ffa_ch19_peh_tuning_and

raw
ffa_ch18_subrouti...    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_ch18_subrouti...   82       -- Types of Entry for the Control Stack:
ffa_ch18_subrouti...   83       type Call_Types is (Invalid, Subroutines, Loops);
ffa_ch18_subrouti...   84       
ffa_ch18_subrouti...   85       -- Control Stack Entries:
ffa_ch18_subrouti...   86       type Call is
ffa_ch18_subrouti...   87          record
ffa_ch18_subrouti...   88             Why : Call_Types := Invalid; -- Which call type?
ffa_ch18_subrouti...   89             Ret : Tape_Positions;        -- The IP we must return to after it
ffa_ch18_subrouti...   90          end record;
ffa_ch18_subrouti...   91       
ffa_ch17_peh.kv        92       -- Control Stack; permits bidirectional motion across the Tape:
ffa_ch18_subrouti...   93       Control_Stack : array(ControlStack_Range) of Call;
ffa_ch4_ffacalc.kv     94       
ffa_ch17_peh.kv        95       -- Current top of the Control Stack:
ffa_ch17_peh.kv        96       CSP           : ControlStack_Range := ControlStack_Range'First;
ffa_ch17_peh.kv        97       
ffa_ch18_subrouti...   98       -- A Segment represents a particular section of Tape, for certain uses.
ffa_ch18_subrouti...   99       type Segment is
ffa_ch18_subrouti...  100          record
ffa_ch18_subrouti...  101             -- The Tape Position of the FIRST Symbol on the Segment:
ffa_ch18_subrouti...  102             L : Tape_Positions := Tape'First; -- Default: start of the Tape.
ffa_ch18_subrouti...  103             
ffa_ch18_subrouti...  104             -- The Tape Position of the LAST Symbol on the Segment:
ffa_ch18_subrouti...  105             R : Tape_Positions := Tape'Last;  -- Default: end of the Tape.
ffa_ch18_subrouti...  106          end record;
ffa_ch18_subrouti...  107       
ffa_ch18_subrouti...  108       -- Subtypes of Segment:
ffa_ch18_subrouti...  109       subtype Sub_Names  is Segment; -- Subroutine Names
ffa_ch18_subrouti...  110       subtype Sub_Bodies is Segment; -- Subroutine Bodies
ffa_ch18_subrouti...  111       subtype Cutouts    is Segment; -- Cutout (see Ch.18 discussion)
ffa_ch18_subrouti...  112       
ffa_ch18_subrouti...  113       -- Represents a Subroutine defined on this Tape:
ffa_ch18_subrouti...  114       type Sub_Def is
ffa_ch18_subrouti...  115          record
ffa_ch18_subrouti...  116             Name    : Sub_Names;  -- Name of the Subroutine.
ffa_ch18_subrouti...  117             Payload : Sub_Bodies; -- Body of the Subroutine.
ffa_ch18_subrouti...  118          end record;
ffa_ch18_subrouti...  119       
ffa_ch18_subrouti...  120       -- Subroutine Table. Once defined, Subs may not be erased or altered.
ffa_ch18_subrouti...  121       Subs          : array(Subroutine_Table_Range) of Sub_Def;
ffa_ch18_subrouti...  122       
ffa_ch18_subrouti...  123       -- Position of the most recently-defined Subroutine in Subs :
ffa_ch18_subrouti...  124       STP           : Subroutine_Table_Range := Subs'First;
ffa_ch18_subrouti...  125       
ffa_ch17_peh.kv       126       -- Registers:
ffa_ch17_peh.kv       127       subtype RegNames is Character range 'g' .. 'z';
ffa_ch17_peh.kv       128       type RegTables is array(RegNames range <>) of FZ(1 .. Wordness);
ffa_ch18_subrouti...  129       
ffa_ch18_subrouti...  130       -- Ordinary Register Set (accessed if no Cutout, or when ABOVE it)
ffa_ch17_peh.kv       131       Registers     : RegTables(RegNames'Range);
ffa_ch4_ffacalc.kv    132       
ffa_ch18_subrouti...  133       -- 'Cutout' Register Set (accessed only if IP is IN or BELOW the Cutout)
ffa_ch18_subrouti...  134       CO_Registers  : RegTables(RegNames'Range);
ffa_ch18_subrouti...  135       
ffa_ch18_subrouti...  136       -- Carry/Borrow Flag set by certain arithmetical Ops:
ffa_ch17_peh.kv       137       Flag          : WBool        := 0;
ffa_ch4_ffacalc.kv    138       
ffa_ch19_peh_tuni...  139       -- 'Cutout'-segregated Carry/Borrow Flag:
ffa_ch19_peh_tuni...  140       CO_Flag       : WBool        := 0;
ffa_ch19_peh_tuni...  141       
ffa_ch4_ffacalc.kv    142       -- Odometer:
ffa_ch17_peh.kv       143       Ticks         : Natural      := 0;
ffa_ch4_ffacalc.kv    144       
ffa_ch18_subrouti...  145       -- The current levels of the three types of nestable Block:
ffa_ch17_peh.kv       146       QuoteLevel    : Natural      := 0;
ffa_ch17_peh.kv       147       CommLevel     : Natural      := 0;
ffa_ch17_peh.kv       148       CondLevel     : Natural      := 0;
ffa_ch13_measure_...  149       
ffa_ch19_peh_tuni...  150       -- The possible Modes of the reader:
ffa_ch19_peh_tuni...  151       type Modes is (Normal, SubName, SubBody, PrefixOp);
ffa_ch18_subrouti...  152       
ffa_ch19_peh_tuni...  153       -- Currently-active reader Mode:
ffa_ch19_peh_tuni...  154       Mode          : Modes        := Normal;
ffa_ch18_subrouti...  155       
ffa_ch18_subrouti...  156       -- Current levels of nestable Blocks when reading a Subroutine Body:
ffa_ch18_subrouti...  157       SubQuoteLevel : Natural      := 0;
ffa_ch18_subrouti...  158       SubCommLevel  : Natural      := 0;
ffa_ch18_subrouti...  159       SubCondLevel  : Natural      := 0;
ffa_ch18_subrouti...  160       
ffa_ch18_subrouti...  161       -- Scratch for a Subroutine being proposed for lookup or internment:
ffa_ch18_subrouti...  162       Proposed_Sub  : Sub_Def;
ffa_ch18_subrouti...  163       
ffa_ch18_subrouti...  164       -- 'Cutout' Tape Segment. (See Ch.18 discussion re: when and how to use.)
ffa_ch18_subrouti...  165       -- If the Cutout is armed, it stays armed until Peh halts.
ffa_ch18_subrouti...  166       Cutout_Begun  : Boolean      := False;
ffa_ch18_subrouti...  167       Cutout_Armed  : Boolean      := False;
ffa_ch18_subrouti...  168       Cutout        : Cutouts;
ffa_ch18_subrouti...  169       
ffa_ch19_peh_tuni...  170       -- Prefix for Prefixed Operators
ffa_ch17_peh.kv       171       PrevC         : Character    := ' ';
ffa_ch13_measure_...  172       
ffa_ch18_subrouti...  173       -- Current Verdict. We run while 'Mu', Tape remains, and Ticks under max.
ffa_ch17_peh.kv       174       Verdict       : Peh_Verdicts := Mu;
ffa_ch4_ffacalc.kv    175       --------------------------------------------------------
ffa_ch4_ffacalc.kv    176       
ffa_ch4_ffacalc.kv    177       
ffa_ch18_subrouti...  178       ------------
ffa_ch18_subrouti...  179       -- Cutout --
ffa_ch18_subrouti...  180       ------------
ffa_ch18_subrouti...  181       
ffa_ch18_subrouti...  182       -- Find whether Cutout would prohibit move from current IP to the given :
ffa_ch18_subrouti...  183       function Cutout_Prohibits(Position : in Tape_Positions) return Boolean is
ffa_ch17_peh.kv       184       begin
ffa_ch18_subrouti...  185          return Cutout_Armed and IP > Cutout.R and Position < Cutout.L;
ffa_ch18_subrouti...  186       end Cutout_Prohibits;
ffa_ch18_subrouti...  187       
ffa_ch18_subrouti...  188       
ffa_ch18_subrouti...  189       -- Find whether given a Tape Position lies inside an armed Cutout:
ffa_ch18_subrouti...  190       function In_Cutout(Position : in Tape_Positions) return Boolean is
ffa_ch18_subrouti...  191       begin
ffa_ch18_subrouti...  192          return Cutout_Armed and Position in Cutout.L .. Cutout.R;
ffa_ch18_subrouti...  193       end In_Cutout;
ffa_ch18_subrouti...  194       
ffa_ch18_subrouti...  195       
ffa_ch18_subrouti...  196       -- Determine whether to use the Cutout Registers at the current position:
ffa_ch18_subrouti...  197       function Use_CO_Registers return Boolean is
ffa_ch18_subrouti...  198       begin
ffa_ch18_subrouti...  199          -- If we are either BELOW or INSIDE armed Cutout : we use only the
ffa_ch18_subrouti...  200          -- CO_Registers alternative register file. Otherwise: use Registers.
ffa_ch18_subrouti...  201          return Cutout_Armed and IP <= Cutout.R;
ffa_ch18_subrouti...  202       end Use_CO_Registers;
ffa_ch18_subrouti...  203       
ffa_ch17_peh.kv       204       
ffa_ch18_subrouti...  205       ----------
ffa_ch18_subrouti...  206       -- Zaps --
ffa_ch18_subrouti...  207       ----------
ffa_ch17_peh.kv       208       
ffa_ch18_subrouti...  209       -- Zero the Data Stack and reset the SP:
ffa_ch18_subrouti...  210       procedure Zap_Data_Stack is
ffa_ch4_ffacalc.kv    211       begin
ffa_ch17_peh.kv       212          -- Clear the Data Stack:
ffa_ch4_ffacalc.kv    213          for i in Stack'Range loop
ffa_ch11_tuning_a...  214             FFA_FZ_Clear(Stack(i));
ffa_ch4_ffacalc.kv    215          end loop;
ffa_ch17_peh.kv       216          -- Set SP to bottom:
ffa_ch18_subrouti...  217          SP := Stack_Positions'First;
ffa_ch18_subrouti...  218       end Zap_Data_Stack;
ffa_ch18_subrouti...  219       
ffa_ch18_subrouti...  220       
ffa_ch18_subrouti...  221       -- Zero all Registers (Ordinary set) :
ffa_ch18_subrouti...  222       procedure Zap_Ordinary_Registers is
ffa_ch18_subrouti...  223       begin
ffa_ch17_peh.kv       224          for r in RegNames'Range loop
ffa_ch17_peh.kv       225             FFA_FZ_Clear(Registers(r));
ffa_ch17_peh.kv       226          end loop;
ffa_ch18_subrouti...  227       end Zap_Ordinary_Registers;
ffa_ch18_subrouti...  228       
ffa_ch18_subrouti...  229       
ffa_ch18_subrouti...  230       -- Zero all Registers (Cutout set) :
ffa_ch18_subrouti...  231       procedure Zap_Cutout_Registers is
ffa_ch18_subrouti...  232       begin
ffa_ch18_subrouti...  233          for r in RegNames'Range loop
ffa_ch18_subrouti...  234             FFA_FZ_Clear(CO_Registers(r));
ffa_ch18_subrouti...  235          end loop;
ffa_ch18_subrouti...  236       end Zap_Cutout_Registers;
ffa_ch18_subrouti...  237       
ffa_ch18_subrouti...  238       
ffa_ch18_subrouti...  239       -- Zero all Registers in the currently-active Register Set:
ffa_ch18_subrouti...  240       procedure Zap_Registers is
ffa_ch18_subrouti...  241       begin
ffa_ch18_subrouti...  242          if Use_CO_Registers then
ffa_ch18_subrouti...  243             Zap_Cutout_Registers;
ffa_ch18_subrouti...  244          else
ffa_ch18_subrouti...  245             Zap_Ordinary_Registers;
ffa_ch18_subrouti...  246          end if;
ffa_ch18_subrouti...  247       end Zap_Registers;
ffa_ch18_subrouti...  248 
ffa_ch18_subrouti...  249       
ffa_ch19_peh_tuni...  250       -- Zero the currently-active Overflow Flag:
ffa_ch18_subrouti...  251       procedure Zap_Flag is
ffa_ch18_subrouti...  252       begin
ffa_ch19_peh_tuni...  253          if Use_CO_Registers then
ffa_ch19_peh_tuni...  254             CO_Flag := 0;
ffa_ch19_peh_tuni...  255          else
ffa_ch19_peh_tuni...  256             Flag    := 0;
ffa_ch19_peh_tuni...  257          end if;
ffa_ch18_subrouti...  258       end Zap_Flag;
ffa_ch18_subrouti...  259       
ffa_ch18_subrouti...  260       
ffa_ch18_subrouti...  261       -- NO effect on Blocks, Control Stack, Tape, Verdict, Cutout, Subroutines
ffa_ch18_subrouti...  262       procedure Zap_Master is
ffa_ch18_subrouti...  263       begin
ffa_ch18_subrouti...  264          Zap_Data_Stack;
ffa_ch18_subrouti...  265          Zap_Registers;
ffa_ch18_subrouti...  266          Zap_Flag;
ffa_ch18_subrouti...  267       end Zap_Master;
ffa_ch4_ffacalc.kv    268       
ffa_ch4_ffacalc.kv    269       
ffa_ch18_subrouti...  270       -----------
ffa_ch18_subrouti...  271       -- Eggog --
ffa_ch18_subrouti...  272       -----------
ffa_ch18_subrouti...  273       
ffa_ch18_subrouti...  274       -- Report a fatal error condition at the current Symbol.
ffa_ch17_peh.kv       275       -- On Unixlikes, this will also end the process and return control to OS.
ffa_ch4_ffacalc.kv    276       procedure E(S : in String) is
ffa_ch4_ffacalc.kv    277       begin
ffa_ch18_subrouti...  278          Zap_Master; -- Jettison all resettable state!
ffa_ch17_peh.kv       279          Eggog("FATAL: Tick:" & Natural'Image(Ticks) &
ffa_ch18_subrouti...  280                  ", IP:" & Tape_Positions'Image(IP) & 
ffa_ch18_subrouti...  281                  ", Symbol: '" & Tape(IP) & "'" & " : " & S);
ffa_ch4_ffacalc.kv    282       end E;
ffa_ch4_ffacalc.kv    283       
ffa_ch4_ffacalc.kv    284       
ffa_ch18_subrouti...  285       -----------
ffa_ch18_subrouti...  286       -- Walls --
ffa_ch18_subrouti...  287       -----------
ffa_ch17_peh.kv       288       
ffa_ch18_subrouti...  289       -- Determine whether we are currently at the last Symbol on the Tape:
ffa_ch18_subrouti...  290       function Last_Tape_Symbol return Boolean is
ffa_ch17_peh.kv       291       begin
ffa_ch18_subrouti...  292          return IP = Tape_Positions'Last;
ffa_ch18_subrouti...  293       end Last_Tape_Symbol;
ffa_ch18_subrouti...  294       
ffa_ch18_subrouti...  295       
ffa_ch18_subrouti...  296       -- Certain Ops are NOT permitted to occur as the final Op on a Tape:
ffa_ch18_subrouti...  297       function Next_IP_On_Tape return Tape_Positions is
ffa_ch18_subrouti...  298       begin
ffa_ch18_subrouti...  299          -- Check if we are in fact on the last Symbol of the Tape:
ffa_ch18_subrouti...  300          if Last_Tape_Symbol then
ffa_ch18_subrouti...  301             E("This Op requires a succeeding Tape Position, "
ffa_ch18_subrouti...  302              & "but it is at the end of the Tape!");
ffa_ch17_peh.kv       303          end if;
ffa_ch18_subrouti...  304          -- ... Otherwise, return the immediate successor Tape Position:
ffa_ch18_subrouti...  305          return IP + 1;
ffa_ch18_subrouti...  306       end Next_IP_On_Tape;
ffa_ch17_peh.kv       307       
ffa_ch17_peh.kv       308       
ffa_ch18_subrouti...  309       -- Determine whether we have reached the given limit of Life:
ffa_ch18_subrouti...  310       function Exhausted_Life return Boolean is
ffa_ch18_subrouti...  311          -- If Life = 0, we are in "immortal" mode. Otherwise mortal:
ffa_ch18_subrouti...  312          MustDie : Boolean := 
ffa_ch18_subrouti...  313            (Dimensions.Life /= 0) and (Ticks = Dimensions.Life);
ffa_ch17_peh.kv       314       begin
ffa_ch18_subrouti...  315          if MustDie then
ffa_ch18_subrouti...  316             Achtung("WARNING: Exhausted Life ("
ffa_ch18_subrouti...  317                       & Natural'Image(Ticks) & " ticks )");
ffa_ch17_peh.kv       318          end if;
ffa_ch18_subrouti...  319          return MustDie;
ffa_ch18_subrouti...  320       end Exhausted_Life;
ffa_ch17_peh.kv       321       
ffa_ch17_peh.kv       322       
ffa_ch17_peh.kv       323       ----------------
ffa_ch17_peh.kv       324       -- Data Stack --
ffa_ch17_peh.kv       325       ----------------
ffa_ch17_peh.kv       326       
ffa_ch18_subrouti...  327       -- Determine whether the Data Stack is Not Empty:
ffa_ch18_subrouti...  328       function Data_Stack_Not_Empty return Boolean is
ffa_ch18_subrouti...  329       begin
ffa_ch18_subrouti...  330          return SP /= Stack'First;
ffa_ch18_subrouti...  331       end Data_Stack_Not_Empty;
ffa_ch18_subrouti...  332       
ffa_ch18_subrouti...  333       
ffa_ch18_subrouti...  334       -- Raise the SP up by one:
ffa_ch4_ffacalc.kv    335       procedure Push is
ffa_ch4_ffacalc.kv    336       begin
ffa_ch4_ffacalc.kv    337          if SP = Stack_Positions'Last then
ffa_ch4_ffacalc.kv    338             E("Stack Overflow!");
ffa_ch4_ffacalc.kv    339          else
ffa_ch4_ffacalc.kv    340             SP := SP + 1;
ffa_ch4_ffacalc.kv    341          end if;
ffa_ch4_ffacalc.kv    342       end Push;
ffa_ch4_ffacalc.kv    343       
ffa_ch4_ffacalc.kv    344       
ffa_ch18_subrouti...  345       -- Discard the Top of the Data Stack:
ffa_ch4_ffacalc.kv    346       procedure Drop is
ffa_ch4_ffacalc.kv    347       begin
ffa_ch11_tuning_a...  348          FFA_FZ_Clear(Stack(SP));
ffa_ch4_ffacalc.kv    349          SP := SP - 1;
ffa_ch4_ffacalc.kv    350       end Drop;
ffa_ch4_ffacalc.kv    351       
ffa_ch4_ffacalc.kv    352       
ffa_ch18_subrouti...  353       -- Check whether the Data Stack has the necessary N items:
ffa_ch4_ffacalc.kv    354       procedure Want(N : in Positive) is
ffa_ch4_ffacalc.kv    355       begin
ffa_ch4_ffacalc.kv    356          if SP < N then
ffa_ch4_ffacalc.kv    357             E("Stack Underflow!");
ffa_ch4_ffacalc.kv    358          end if;
ffa_ch4_ffacalc.kv    359       end Want;
ffa_ch4_ffacalc.kv    360       
ffa_ch4_ffacalc.kv    361       
ffa_ch18_subrouti...  362       ---------
ffa_ch18_subrouti...  363       -- I/O --
ffa_ch18_subrouti...  364       ---------
ffa_ch5_egypt.kv      365       
ffa_ch18_subrouti...  366       -- Slide a new hex digit into the FZ on top of the Data Stack
ffa_ch11_tuning_a...  367       procedure Ins_Hex_Digit(Digit : in Nibble) is
ffa_ch11_tuning_a...  368          Overflow : WBool := 0;
ffa_ch4_ffacalc.kv    369       begin
ffa_ch11_tuning_a...  370          
ffa_ch11_tuning_a...  371          -- Insert the given nibble, and detect any overflow:
ffa_ch11_tuning_a...  372          FFA_FZ_Insert_Bottom_Nibble(N        => Stack(SP),
ffa_ch11_tuning_a...  373                                      D        => Digit,
ffa_ch11_tuning_a...  374                                      Overflow => Overflow);
ffa_ch4_ffacalc.kv    375          
ffa_ch4_ffacalc.kv    376          -- Constants which exceed the Width are forbidden:
ffa_ch11_tuning_a...  377          if Overflow = 1 then
ffa_ch4_ffacalc.kv    378             E("Constant Exceeds Bitness!");
ffa_ch4_ffacalc.kv    379          end if;
ffa_ch4_ffacalc.kv    380          
ffa_ch4_ffacalc.kv    381       end;
ffa_ch4_ffacalc.kv    382       
ffa_ch4_ffacalc.kv    383       
ffa_ch11_tuning_a...  384       -- Emit an ASCII representation of N to the terminal
ffa_ch11_tuning_a...  385       procedure Print_FZ(N : in FZ) is
ffa_ch11_tuning_a...  386          S : String(1 .. FFA_FZ_ASCII_Length(N)); -- Mandatorily, exact size
ffa_ch11_tuning_a...  387       begin
ffa_ch11_tuning_a...  388          FFA_FZ_To_Hex_String(N, S); -- Convert N to ASCII hex
ffa_ch11_tuning_a...  389          Write_String(S);            -- Print the result to stdout
ffa_ch11_tuning_a...  390          Write_Newline;              -- Print newline, for clarity.
ffa_ch11_tuning_a...  391       end Print_FZ;
ffa_ch11_tuning_a...  392       
ffa_ch11_tuning_a...  393       
ffa_ch18_subrouti...  394       ------------------
ffa_ch18_subrouti...  395       -- Debug Traces --
ffa_ch18_subrouti...  396       ------------------
ffa_ch18_subrouti...  397       
ffa_ch18_subrouti...  398       -- Print the bounds of a Tape Segment for Debug:
ffa_ch18_subrouti...  399       procedure Print_Segment(S : in Segment) is
ffa_ch18_subrouti...  400       begin
ffa_ch18_subrouti...  401          Write_String("(" & Tape_Positions'Image(S.L) &
ffa_ch18_subrouti...  402                         "," & Tape_Positions'Image(S.R) & " )");
ffa_ch18_subrouti...  403       end Print_Segment;
ffa_ch18_subrouti...  404       
ffa_ch18_subrouti...  405       
ffa_ch18_subrouti...  406       -- Print a Debug Trace (used in 'QD') :
ffa_ch17_peh.kv       407       procedure Print_Trace is
ffa_ch13_measure_...  408       begin
ffa_ch18_subrouti...  409          -- For clarity in cases where the Tape has already produced output:
ffa_ch18_subrouti...  410          Write_Newline;
ffa_ch18_subrouti...  411          
ffa_ch17_peh.kv       412          -- Print Data Stack Trace:
ffa_ch17_peh.kv       413          Write_String("Data Stack:");
ffa_ch17_peh.kv       414          Write_Newline;
ffa_ch17_peh.kv       415          for i in reverse Stack'First + 1 .. SP loop
ffa_ch17_peh.kv       416             Write_String("   " & Stack_Positions'Image(i) & " : ");
ffa_ch17_peh.kv       417             Print_FZ(Stack(i));
ffa_ch17_peh.kv       418          end loop;
ffa_ch17_peh.kv       419          
ffa_ch17_peh.kv       420          -- Print Control Stack Trace:
ffa_ch17_peh.kv       421          Write_String("Control Stack:");
ffa_ch17_peh.kv       422          Write_Newline;
ffa_ch17_peh.kv       423          for i in reverse Control_Stack'First + 1 .. CSP loop
ffa_ch18_subrouti...  424             Write_String("   " & ControlStack_Range'Image(i) & " :");
ffa_ch18_subrouti...  425             Write_String(" Return IP:"
ffa_ch18_subrouti...  426                            & Stack_Positions'Image(Control_Stack(i).Ret));
ffa_ch18_subrouti...  427             Write_String(" Call Type: ");
ffa_ch18_subrouti...  428             case Control_Stack(i).Why is
ffa_ch18_subrouti...  429                when Subroutines =>
ffa_ch18_subrouti...  430                   Write_String("Subroutine");
ffa_ch18_subrouti...  431                when Loops =>
ffa_ch18_subrouti...  432                   Write_String("Loop");
ffa_ch18_subrouti...  433                when others =>
ffa_ch18_subrouti...  434                   Write_String("INVALID");
ffa_ch18_subrouti...  435             end case;
ffa_ch17_peh.kv       436             Write_Newline;
ffa_ch17_peh.kv       437          end loop;
ffa_ch17_peh.kv       438          
ffa_ch17_peh.kv       439          -- Print All Registers:
ffa_ch17_peh.kv       440          Write_String("Registers:");
ffa_ch17_peh.kv       441          Write_Newline;
ffa_ch18_subrouti...  442          -- We will not print the Cutout Register Set unless it is active:
ffa_ch17_peh.kv       443          for r in RegNames'Range loop
ffa_ch18_subrouti...  444             if Use_CO_Registers then
ffa_ch18_subrouti...  445                -- If the Cutout Register Set is currently active:
ffa_ch18_subrouti...  446                Write_String(" (C)" & r & " : ");
ffa_ch18_subrouti...  447                Print_FZ(CO_Registers(r));
ffa_ch18_subrouti...  448             else
ffa_ch18_subrouti...  449                -- If the Ordinary Register Set is currently active:
ffa_ch18_subrouti...  450                Write_String("    " & r & " : ");
ffa_ch18_subrouti...  451                Print_FZ(Registers(r));
ffa_ch18_subrouti...  452             end if;
ffa_ch17_peh.kv       453          end loop;
ffa_ch17_peh.kv       454          
ffa_ch18_subrouti...  455          -- Print Subroutine Table:
ffa_ch18_subrouti...  456          Write_String("Subroutines:");
ffa_ch18_subrouti...  457          Write_Newline;
ffa_ch18_subrouti...  458          -- Walk the Subroutine Table from first to last valid entry:
ffa_ch18_subrouti...  459          for i in Subs'First + 1 .. STP loop
ffa_ch18_subrouti...  460             declare
ffa_ch18_subrouti...  461                -- The current Sub in the Subroutine Table being examined:
ffa_ch18_subrouti...  462                S      : Sub_Def := Subs(i);
ffa_ch18_subrouti...  463                -- The Name of the current Sub:
ffa_ch18_subrouti...  464                S_Name : String  := String(Tape(S.Name.L .. S.Name.R));
ffa_ch18_subrouti...  465             begin
ffa_ch18_subrouti...  466                Write_String("   " & Subroutine_Table_Range'Image(i)
ffa_ch18_subrouti...  467                               & " : '" & S_Name & "' ");
ffa_ch18_subrouti...  468                Print_Segment(S.Payload);
ffa_ch18_subrouti...  469                if Cutout_Armed then
ffa_ch18_subrouti...  470                   -- Indicate whether Sub is uncallable here because of Cutout:
ffa_ch18_subrouti...  471                   if Cutout_Prohibits(S.Payload.L) then
ffa_ch18_subrouti...  472                      Write_String(" (Guarded)");
ffa_ch18_subrouti...  473                   -- Indicate whether Sub lies INSIDE the Cutout:
ffa_ch18_subrouti...  474                   elsif In_Cutout(S.Payload.R) then
ffa_ch18_subrouti...  475                      Write_String(" (Cutout)");
ffa_ch18_subrouti...  476                   end if;
ffa_ch18_subrouti...  477                end if;
ffa_ch18_subrouti...  478                Write_Newline;
ffa_ch18_subrouti...  479             end;
ffa_ch18_subrouti...  480          end loop;
ffa_ch18_subrouti...  481          
ffa_ch18_subrouti...  482          Write_String("Cutout: ");
ffa_ch18_subrouti...  483          -- Print Cutout bounds, if Cutout is armed:
ffa_ch18_subrouti...  484          if Cutout_Armed then
ffa_ch18_subrouti...  485             Write_String("Armed: ");
ffa_ch18_subrouti...  486             Print_Segment(Cutout);
ffa_ch18_subrouti...  487          else
ffa_ch18_subrouti...  488             Write_String("NONE");
ffa_ch18_subrouti...  489          end if;
ffa_ch18_subrouti...  490          Write_Newline;
ffa_ch18_subrouti...  491          
ffa_ch19_peh_tuni...  492          -- Print active Overflow-Flag, then Ticks and IP:
ffa_ch19_peh_tuni...  493          
ffa_ch19_peh_tuni...  494          if Use_CO_Registers then
ffa_ch19_peh_tuni...  495             Write_String("Flag (CO) :" & WBool'Image(CO_Flag));
ffa_ch19_peh_tuni...  496          else
ffa_ch19_peh_tuni...  497             Write_String("Flag      :" & WBool'Image(Flag));
ffa_ch19_peh_tuni...  498          end if;
ffa_ch19_peh_tuni...  499          
ffa_ch18_subrouti...  500          Write_Newline;
ffa_ch19_peh_tuni...  501          Write_String("Ticks     :" & Natural'Image(Ticks));
ffa_ch17_peh.kv       502          Write_Newline;
ffa_ch19_peh_tuni...  503          Write_String("IP        :" & Tape_Positions'Image(IP));
ffa_ch17_peh.kv       504          Write_Newline;
ffa_ch17_peh.kv       505       end Print_Trace;
ffa_ch13_measure_...  506       
ffa_ch13_measure_...  507       
ffa_ch18_subrouti...  508       -------------------
ffa_ch18_subrouti...  509       -- Control Stack --
ffa_ch18_subrouti...  510       -------------------
ffa_ch18_subrouti...  511       
ffa_ch18_subrouti...  512       -- Determine whether the Control Stack is Not Empty:
ffa_ch18_subrouti...  513       function Control_Stack_Not_Empty return Boolean is
ffa_ch18_subrouti...  514       begin
ffa_ch18_subrouti...  515          return CSP /= Control_Stack'First;
ffa_ch18_subrouti...  516       end Control_Stack_Not_Empty;
ffa_ch18_subrouti...  517       
ffa_ch18_subrouti...  518       
ffa_ch18_subrouti...  519       -- Construct a Call and push it to the Control Stack:
ffa_ch18_subrouti...  520       procedure Control_Push(Call_Type : in Call_Types;
ffa_ch18_subrouti...  521                              Return_IP : in Tape_Positions) is
ffa_ch18_subrouti...  522       begin
ffa_ch18_subrouti...  523          -- First, test for Overflow of Control Stack:
ffa_ch18_subrouti...  524          if CSP = Control_Stack'Last then
ffa_ch18_subrouti...  525             E("Control Stack Overflow!");
ffa_ch18_subrouti...  526          end if;
ffa_ch18_subrouti...  527          -- Push a Call with given parameters to the Control Stack:
ffa_ch18_subrouti...  528          CSP                := CSP + 1;
ffa_ch18_subrouti...  529          Control_Stack(CSP) := (Why => Call_Type, Ret => Return_IP);
ffa_ch18_subrouti...  530       end Control_Push;
ffa_ch18_subrouti...  531       
ffa_ch18_subrouti...  532       
ffa_ch18_subrouti...  533       -- Pop an IP from the Control Stack, and verify expected Call Type:
ffa_ch18_subrouti...  534       function Control_Pop(Expected_Type : in Call_Types)
ffa_ch18_subrouti...  535                           return Tape_Positions is
ffa_ch18_subrouti...  536          C : Call;
ffa_ch18_subrouti...  537       begin
ffa_ch18_subrouti...  538          -- First, test for Underflow of Control Stack:
ffa_ch18_subrouti...  539          if CSP = Control_Stack'First then
ffa_ch18_subrouti...  540             E("Control Stack Underflow!");
ffa_ch18_subrouti...  541          end if;
ffa_ch18_subrouti...  542          -- Pop from Control Stack:
ffa_ch18_subrouti...  543          C                      := Control_Stack(CSP);
ffa_ch18_subrouti...  544          Control_Stack(CSP).Why := Invalid;
ffa_ch18_subrouti...  545          CSP                    := CSP - 1;
ffa_ch18_subrouti...  546          -- Now, see whether it was NOT the expected type. If so, eggog:
ffa_ch18_subrouti...  547          if C.Why /= Expected_Type then
ffa_ch18_subrouti...  548             declare
ffa_ch18_subrouti...  549                CT : constant array(Call_Types) of String(1 .. 10)
ffa_ch18_subrouti...  550                  := (" INVALID  ", "Subroutine", "Loop state");
ffa_ch18_subrouti...  551             begin
ffa_ch18_subrouti...  552                E("Currently in a " & CT(C.Why) & "; but this Op exits a "
ffa_ch18_subrouti...  553                    & CT(Expected_Type) & " !");
ffa_ch18_subrouti...  554             end;
ffa_ch18_subrouti...  555          end if;
ffa_ch18_subrouti...  556          -- ... The Call was of the expected type, so return it:
ffa_ch18_subrouti...  557          return C.Ret;
ffa_ch18_subrouti...  558       end Control_Pop;
ffa_ch18_subrouti...  559       
ffa_ch18_subrouti...  560       
ffa_ch18_subrouti...  561       -----------------
ffa_ch18_subrouti...  562       -- Subroutines --
ffa_ch18_subrouti...  563       -----------------
ffa_ch18_subrouti...  564       
ffa_ch18_subrouti...  565       -- Find Subroutine with supplied Name in Subroutine Table, if it exists:
ffa_ch18_subrouti...  566       function Lookup_Subroutine(Name : in Sub_Names)
ffa_ch18_subrouti...  567                                 return Subroutine_Table_Range is
ffa_ch18_subrouti...  568          -- Number of Symbols in the Name of the current Proposed Subroutine:
ffa_ch18_subrouti...  569          Sub_Name_Length : Positive := 1 + Name.R - Name.L;
ffa_ch18_subrouti...  570       begin
ffa_ch18_subrouti...  571          -- Enforce minimum Subroutine Name length:
ffa_ch18_subrouti...  572          if Sub_Name_Length < Subr_Min_Name_Length then
ffa_ch18_subrouti...  573             E("Proposed Name is" & Positive'Image(Sub_Name_Length) &
ffa_ch18_subrouti...  574                 " Symbols long, but the shortest permitted Name length is" &
ffa_ch18_subrouti...  575                 Positive'Image(Subr_Min_Name_Length) & " !");
ffa_ch18_subrouti...  576          end if;
ffa_ch18_subrouti...  577          -- Walk the Subroutine Table from first to last valid entry:
ffa_ch18_subrouti...  578          for i in Subs'First + 1 .. STP loop
ffa_ch18_subrouti...  579             declare
ffa_ch18_subrouti...  580                -- The current Sub in the Subroutine Table being examined:
ffa_ch18_subrouti...  581                S             : Sub_Def := Subs(i);
ffa_ch18_subrouti...  582                -- Number of Symbols in the Name of S:
ffa_ch18_subrouti...  583                S_Name_Length : Positive := 1 + S.Name.R - S.Name.L;
ffa_ch18_subrouti...  584             begin
ffa_ch18_subrouti...  585                -- If the lengths of the Names match:
ffa_ch18_subrouti...  586                if Sub_Name_Length = S_Name_Length then
ffa_ch18_subrouti...  587                   -- If the two Names are actually equal:
ffa_ch18_subrouti...  588                   if Tape(Name.L .. Name.R) = Tape(S.Name.L .. S.Name.R) then
ffa_ch18_subrouti...  589                      return i; -- Return the table index of the located Sub
ffa_ch18_subrouti...  590                   end if;
ffa_ch18_subrouti...  591                end if;
ffa_ch18_subrouti...  592             end;
ffa_ch18_subrouti...  593          end loop;
ffa_ch18_subrouti...  594          -- Name was not found in Subroutine Table; return the zero position:
ffa_ch18_subrouti...  595          return Subs'First;
ffa_ch18_subrouti...  596       end Lookup_Subroutine;
ffa_ch18_subrouti...  597       
ffa_ch18_subrouti...  598       
ffa_ch18_subrouti...  599       -- Attempt to intern the given Subroutine into the Subroutines Table:
ffa_ch18_subrouti...  600       procedure Intern_Subroutine(Sub : in Sub_Def) is
ffa_ch18_subrouti...  601          -- Position of the current Proposed Sub in Sub Table:
ffa_ch18_subrouti...  602          Index  : Subroutine_Table_Range := Lookup_Subroutine(Sub.Name);
ffa_ch18_subrouti...  603          -- To DEFINE a Sub, it must NOT have existed in Sub Table.
ffa_ch18_subrouti...  604          
ffa_ch18_subrouti...  605          -- Name of the Proposed Sub (for eggogs) :
ffa_ch18_subrouti...  606          S_Name : String := String(Tape(Sub.Name.L .. Sub.Name.R));
ffa_ch18_subrouti...  607       begin
ffa_ch18_subrouti...  608          -- If a Sub with this Name already exists, eggog:
ffa_ch18_subrouti...  609          if Index /= Subs'First then
ffa_ch18_subrouti...  610             E("Attempted to redefine Subroutine '" & S_Name & "' !");
ffa_ch18_subrouti...  611          end if;
ffa_ch18_subrouti...  612          -- Definitions are prohibited inside Loops or Sub calls:
ffa_ch18_subrouti...  613          if Control_Stack_Not_Empty then
ffa_ch18_subrouti...  614             E("Attempted to define Subroutine '" 
ffa_ch18_subrouti...  615                 & S_Name & "' while inside a Loop or Subroutine!");
ffa_ch18_subrouti...  616          end if;
ffa_ch18_subrouti...  617          -- If the Subroutine Table is full, eggog:
ffa_ch18_subrouti...  618          if STP = Subs'Last then
ffa_ch18_subrouti...  619             E("Cannot define the Subroutine '" & S_Name
ffa_ch18_subrouti...  620                 & ": the Subroutine Table is Full!");
ffa_ch18_subrouti...  621          end if;
ffa_ch18_subrouti...  622          -- Finally, intern the Proposed Subroutine into the Sub Table:
ffa_ch18_subrouti...  623          STP       := STP + 1;
ffa_ch18_subrouti...  624          Subs(STP) := Sub;
ffa_ch18_subrouti...  625       end Intern_Subroutine;
ffa_ch18_subrouti...  626       
ffa_ch18_subrouti...  627       
ffa_ch18_subrouti...  628       -- Invoke a given Subroutine:
ffa_ch18_subrouti...  629       procedure Invoke_Subroutine(Sub : in Sub_Def) is
ffa_ch18_subrouti...  630       begin
ffa_ch18_subrouti...  631          -- Push the Call to Control Stack:
ffa_ch18_subrouti...  632          Control_Push(Call_Type => Subroutines, Return_IP => Next_IP_On_Tape);
ffa_ch18_subrouti...  633          -- Next instruction will be the first Symbol of the Sub's Body:
ffa_ch18_subrouti...  634          IP_Next := Sub.Payload.L;
ffa_ch18_subrouti...  635       end Invoke_Subroutine;
ffa_ch18_subrouti...  636       
ffa_ch18_subrouti...  637       
ffa_ch18_subrouti...  638       -- Attempt to invoke a Subroutine with the supplied name:
ffa_ch18_subrouti...  639       procedure Invoke_Named_Subroutine(Name : in Sub_Names) is
ffa_ch18_subrouti...  640          -- Position of the current Proposed Sub in Sub Table:
ffa_ch18_subrouti...  641          Index  : Subroutine_Table_Range := Lookup_Subroutine(Name);
ffa_ch18_subrouti...  642          -- To invoke a Sub, it MUST exist in the Sub Table.
ffa_ch18_subrouti...  643          
ffa_ch18_subrouti...  644          -- Name of the Proposed Sub (for eggogs) :
ffa_ch18_subrouti...  645          S_Name : String := String(Tape(Name.L .. Name.R));
ffa_ch18_subrouti...  646       begin
ffa_ch18_subrouti...  647          -- If no defined Subroutine has this Name, eggog:
ffa_ch18_subrouti...  648          if Index = Subs'First then
ffa_ch18_subrouti...  649             E("Invoked Undefined Subroutine '" & S_Name & "' !");
ffa_ch18_subrouti...  650          end if;
ffa_ch18_subrouti...  651          -- Otherwise, proceed to the invocation:
ffa_ch18_subrouti...  652          declare
ffa_ch18_subrouti...  653             -- The Sub Table Entry we successfully looked up:
ffa_ch18_subrouti...  654             Sub : Sub_Def := Subs(Index);
ffa_ch18_subrouti...  655          begin
ffa_ch18_subrouti...  656             -- Recursion is prohibited in Peh Tapes. Detect it:
ffa_ch18_subrouti...  657             if IP in Sub.Payload.L .. Sub.Payload.R then
ffa_ch18_subrouti...  658                E("Recursive invocation in Subroutine '" 
ffa_ch18_subrouti...  659                    & S_Name & "' is prohibited!");
ffa_ch18_subrouti...  660             end if;
ffa_ch18_subrouti...  661             -- Prohibit Subroutines whose definitions end AFTER the current IP:
ffa_ch18_subrouti...  662             if IP < Sub.Payload.R then
ffa_ch18_subrouti...  663                E("Cannot invoke Subroutine '" & S_Name &
ffa_ch18_subrouti...  664                    "' before the position where it is defined!");
ffa_ch18_subrouti...  665             end if;
ffa_ch18_subrouti...  666             -- Proceed to invoke the Subroutine:
ffa_ch18_subrouti...  667             Invoke_Subroutine(Sub);
ffa_ch18_subrouti...  668          end;
ffa_ch18_subrouti...  669       end Invoke_Named_Subroutine;
ffa_ch18_subrouti...  670       
ffa_ch18_subrouti...  671       
ffa_ch18_subrouti...  672       -- Invoke the nearest Subroutine defined to the LEFT of the current IP:
ffa_ch18_subrouti...  673       procedure Invoke_Left_Subroutine is
ffa_ch18_subrouti...  674          -- Position of the Subroutine to be invoked (Subs'First if none)
ffa_ch18_subrouti...  675          Index : Subroutine_Table_Range := Subs'First;
ffa_ch18_subrouti...  676       begin
ffa_ch18_subrouti...  677          -- Find the nearest invocable Sub (i.e. to the LEFT of current IP) :
ffa_ch18_subrouti...  678          -- Walk starting from the LAST Sub in Subs, down to the FIRST:
ffa_ch18_subrouti...  679          for i in reverse Subs'First + 1 .. STP loop
ffa_ch18_subrouti...  680             -- If a Sub's definition ended PRIOR TO the current IP:
ffa_ch18_subrouti...  681             if Subs(i).Payload.R < IP then
ffa_ch18_subrouti...  682                -- Save that Sub's table index:
ffa_ch18_subrouti...  683                Index := i;
ffa_ch18_subrouti...  684                -- If we found a Sub that met the condition, stop walking:
ffa_ch18_subrouti...  685                exit when Index /= Subs'First;
ffa_ch18_subrouti...  686             end if;
ffa_ch18_subrouti...  687          end loop;
ffa_ch18_subrouti...  688          -- If no Subs have been defined prior to current IP, then eggog:
ffa_ch18_subrouti...  689          if Index = Subs'First then
ffa_ch18_subrouti...  690             E("No Subroutines were defined prior to this position!");
ffa_ch18_subrouti...  691          end if;
ffa_ch18_subrouti...  692          -- Proceed to invoke the selected Sub:
ffa_ch18_subrouti...  693          Invoke_Subroutine(Subs(Index));
ffa_ch18_subrouti...  694       end Invoke_Left_Subroutine;
ffa_ch18_subrouti...  695       
ffa_ch18_subrouti...  696       
ffa_ch18_subrouti...  697       ---------
ffa_ch18_subrouti...  698       -- Peh --
ffa_ch18_subrouti...  699       ---------
ffa_ch18_subrouti...  700       
ffa_ch18_subrouti...  701       -- For all Ops which entail Division: ensure that a Divisor is not zero:
ffa_ch18_subrouti...  702       procedure MustNotZero(D : in FZ) is
ffa_ch18_subrouti...  703       begin
ffa_ch18_subrouti...  704          if FFA_FZ_ZeroP(D) = 1 then
ffa_ch18_subrouti...  705             E("Division by Zero!");
ffa_ch18_subrouti...  706          end if;
ffa_ch18_subrouti...  707       end MustNotZero;
ffa_ch18_subrouti...  708       
ffa_ch18_subrouti...  709       ------------------------------------------------------------------------
ffa_ch18_subrouti...  710       
ffa_ch4_ffacalc.kv    711       -- Execute a Normal Op
ffa_ch4_ffacalc.kv    712       procedure Op_Normal(C : in Character) is
ffa_ch4_ffacalc.kv    713          
ffa_ch4_ffacalc.kv    714          -- Over/underflow output from certain ops
ffa_ch4_ffacalc.kv    715          F : Word;
ffa_ch18_subrouti...  716 
ffa_ch4_ffacalc.kv    717       begin
ffa_ch4_ffacalc.kv    718          
ffa_ch4_ffacalc.kv    719          case C is
ffa_ch4_ffacalc.kv    720             
ffa_ch18_subrouti...  721             ------------
ffa_ch18_subrouti...  722             -- Blocks --
ffa_ch18_subrouti...  723             ------------
ffa_ch18_subrouti...  724             
ffa_ch18_subrouti...  725             -- Enter Comment Block: Symbols will be ignored until matching ')'
ffa_ch4_ffacalc.kv    726             when '(' =>
ffa_ch4_ffacalc.kv    727                CommLevel := 1;
ffa_ch4_ffacalc.kv    728                
ffa_ch18_subrouti...  729                -- Exit a Comment Block (but if we're here, we aren't in one!)
ffa_ch4_ffacalc.kv    730             when ')' =>
ffa_ch4_ffacalc.kv    731                E("Mismatched close-comment parenthesis !");
ffa_ch4_ffacalc.kv    732                
ffa_ch18_subrouti...  733                -- Enter a Quote Block: Symbols will print until matching ']'
ffa_ch4_ffacalc.kv    734             when '[' =>
ffa_ch4_ffacalc.kv    735                QuoteLevel := 1;
ffa_ch4_ffacalc.kv    736                
ffa_ch18_subrouti...  737                -- Exit a Quote Block (but if we're here, we aren't in one!)
ffa_ch4_ffacalc.kv    738             when ']' =>
ffa_ch4_ffacalc.kv    739                E("Mismatched close-quote bracket !");
ffa_ch4_ffacalc.kv    740                
ffa_ch18_subrouti...  741                -- Enter a Conditional branch:
ffa_ch4_ffacalc.kv    742             when '{' =>
ffa_ch4_ffacalc.kv    743                Want(1);
ffa_ch11_tuning_a...  744                if FFA_FZ_ZeroP(Stack(SP)) = 1 then
ffa_ch18_subrouti...  745                   -- Enter a 'taken' branch.
ffa_ch18_subrouti...  746                   -- All subsequent Symbols will be ignored until matching '}'.
ffa_ch4_ffacalc.kv    747                   CondLevel := 1;
ffa_ch4_ffacalc.kv    748                end if;
ffa_ch4_ffacalc.kv    749                Drop;
ffa_ch4_ffacalc.kv    750                
ffa_ch4_ffacalc.kv    751                -- Exit from a ~non-taken~ Conditional branch:
ffa_ch18_subrouti...  752                -- ... we push a 0, to suppress the 'else' clause:
ffa_ch4_ffacalc.kv    753             when '}' =>
ffa_ch4_ffacalc.kv    754                Push;
ffa_ch11_tuning_a...  755                FFA_WBool_To_FZ(0, Stack(SP));
ffa_ch4_ffacalc.kv    756                
ffa_ch4_ffacalc.kv    757                ----------------
ffa_ch4_ffacalc.kv    758                -- Immediates --
ffa_ch4_ffacalc.kv    759                ----------------
ffa_ch4_ffacalc.kv    760                
ffa_ch4_ffacalc.kv    761                -- These operate on the FZ ~currently~ at top of the stack;
ffa_ch4_ffacalc.kv    762                -- and this means that the stack may NOT be empty.
ffa_ch4_ffacalc.kv    763                
ffa_ch4_ffacalc.kv    764             when '0' .. '9' =>
ffa_ch4_ffacalc.kv    765                Want(1);
ffa_ch11_tuning_a...  766                Ins_Hex_Digit(Character'Pos(C) - Character'Pos('0'));
ffa_ch4_ffacalc.kv    767                
ffa_ch4_ffacalc.kv    768             when 'A' .. 'F' =>
ffa_ch4_ffacalc.kv    769                Want(1);
ffa_ch11_tuning_a...  770                Ins_Hex_Digit(10 + Character'Pos(C) - Character'Pos('A'));
ffa_ch4_ffacalc.kv    771                
ffa_ch4_ffacalc.kv    772             when 'a' .. 'f' =>
ffa_ch4_ffacalc.kv    773                Want(1);
ffa_ch11_tuning_a...  774                Ins_Hex_Digit(10 + Character'Pos(C) - Character'Pos('a'));
ffa_ch4_ffacalc.kv    775                
ffa_ch17_peh.kv       776                -------------------------
ffa_ch17_peh.kv       777                -- Fetch from Register --
ffa_ch17_peh.kv       778                -------------------------
ffa_ch17_peh.kv       779             when 'g' .. 'z' =>
ffa_ch18_subrouti...  780                -- Put value of Register on stack
ffa_ch17_peh.kv       781                Push;
ffa_ch18_subrouti...  782                if Use_CO_Registers then
ffa_ch18_subrouti...  783                   Stack(SP) := CO_Registers(C); -- use Cutout Register set
ffa_ch18_subrouti...  784                else
ffa_ch18_subrouti...  785                   Stack(SP) := Registers(C);    -- use ordinary set
ffa_ch18_subrouti...  786                end if;
ffa_ch17_peh.kv       787                
ffa_ch4_ffacalc.kv    788                ------------------
ffa_ch4_ffacalc.kv    789                -- Stack Motion --
ffa_ch4_ffacalc.kv    790                ------------------
ffa_ch4_ffacalc.kv    791                
ffa_ch4_ffacalc.kv    792                -- Push a 0 onto the stack
ffa_ch4_ffacalc.kv    793             when '.' =>
ffa_ch4_ffacalc.kv    794                Push;
ffa_ch11_tuning_a...  795                FFA_FZ_Clear(Stack(SP));
ffa_ch4_ffacalc.kv    796                
ffa_ch4_ffacalc.kv    797                -- Dup
ffa_ch4_ffacalc.kv    798             when '"' =>
ffa_ch4_ffacalc.kv    799                Want(1);
ffa_ch4_ffacalc.kv    800                Push;
ffa_ch4_ffacalc.kv    801                Stack(SP) := Stack(SP - 1);
ffa_ch4_ffacalc.kv    802                
ffa_ch4_ffacalc.kv    803                -- Drop
ffa_ch4_ffacalc.kv    804             when '_' =>
ffa_ch4_ffacalc.kv    805                Want(1);
ffa_ch4_ffacalc.kv    806                Drop;
ffa_ch4_ffacalc.kv    807                
ffa_ch4_ffacalc.kv    808                -- Swap
ffa_ch4_ffacalc.kv    809             when ''' =>
ffa_ch4_ffacalc.kv    810                Want(2);
ffa_ch11_tuning_a...  811                FFA_FZ_Swap(Stack(SP), Stack(SP - 1));
ffa_ch4_ffacalc.kv    812                
ffa_ch4_ffacalc.kv    813                -- Over
ffa_ch4_ffacalc.kv    814             when '`' =>
ffa_ch4_ffacalc.kv    815                Want(2);
ffa_ch4_ffacalc.kv    816                Push;
ffa_ch4_ffacalc.kv    817                Stack(SP) := Stack(SP - 2);
ffa_ch4_ffacalc.kv    818                
ffa_ch4_ffacalc.kv    819                ----------------
ffa_ch4_ffacalc.kv    820                -- Predicates --
ffa_ch4_ffacalc.kv    821                ----------------
ffa_ch4_ffacalc.kv    822                
ffa_ch4_ffacalc.kv    823                -- Equality
ffa_ch4_ffacalc.kv    824             when '=' =>
ffa_ch4_ffacalc.kv    825                Want(2);
ffa_ch11_tuning_a...  826                FFA_WBool_To_FZ(FFA_FZ_EqP(X => Stack(SP),
ffa_ch11_tuning_a...  827                                           Y => Stack(SP - 1)),
ffa_ch11_tuning_a...  828                                Stack(SP - 1));
ffa_ch4_ffacalc.kv    829                Drop;
ffa_ch4_ffacalc.kv    830                
ffa_ch4_ffacalc.kv    831                -- Less-Than
ffa_ch4_ffacalc.kv    832             when '<' =>
ffa_ch4_ffacalc.kv    833                Want(2);
ffa_ch11_tuning_a...  834                FFA_WBool_To_FZ(FFA_FZ_LessThanP(X => Stack(SP - 1),
ffa_ch11_tuning_a...  835                                                 Y => Stack(SP)),
ffa_ch11_tuning_a...  836                                Stack(SP - 1));
ffa_ch4_ffacalc.kv    837                Drop;
ffa_ch4_ffacalc.kv    838                
ffa_ch4_ffacalc.kv    839                -- Greater-Than
ffa_ch4_ffacalc.kv    840             when '>' =>
ffa_ch4_ffacalc.kv    841                Want(2);
ffa_ch11_tuning_a...  842                FFA_WBool_To_FZ(FFA_FZ_GreaterThanP(X => Stack(SP - 1),
ffa_ch11_tuning_a...  843                                                    Y => Stack(SP)),
ffa_ch11_tuning_a...  844                                Stack(SP - 1));
ffa_ch4_ffacalc.kv    845                Drop;
ffa_ch4_ffacalc.kv    846                
ffa_ch4_ffacalc.kv    847                ----------------
ffa_ch4_ffacalc.kv    848                -- Arithmetic --
ffa_ch4_ffacalc.kv    849                ----------------
ffa_ch4_ffacalc.kv    850                
ffa_ch4_ffacalc.kv    851                -- Subtract
ffa_ch4_ffacalc.kv    852             when '-' =>
ffa_ch4_ffacalc.kv    853                Want(2);
ffa_ch11_tuning_a...  854                FFA_FZ_Subtract(X          => Stack(SP - 1),
ffa_ch11_tuning_a...  855                                Y          => Stack(SP),
ffa_ch11_tuning_a...  856                                Difference => Stack(SP - 1),
ffa_ch11_tuning_a...  857                                Underflow  => F);
ffa_ch19_peh_tuni...  858                
ffa_ch19_peh_tuni...  859                -- If we are in the Cutout, write the CO_Flag instead of Flag:
ffa_ch19_peh_tuni...  860                if Use_CO_Registers then
ffa_ch19_peh_tuni...  861                   CO_Flag := FFA_Word_NZeroP(F);
ffa_ch19_peh_tuni...  862                else
ffa_ch19_peh_tuni...  863                   Flag    := FFA_Word_NZeroP(F);
ffa_ch19_peh_tuni...  864                end if;
ffa_ch4_ffacalc.kv    865                Drop;
ffa_ch4_ffacalc.kv    866                
ffa_ch4_ffacalc.kv    867                -- Add
ffa_ch4_ffacalc.kv    868             when '+' =>
ffa_ch4_ffacalc.kv    869                Want(2);
ffa_ch11_tuning_a...  870                FFA_FZ_Add(X        => Stack(SP - 1),
ffa_ch11_tuning_a...  871                           Y        => Stack(SP),
ffa_ch11_tuning_a...  872                           Sum      => Stack(SP - 1),
ffa_ch11_tuning_a...  873                           Overflow => F);
ffa_ch19_peh_tuni...  874                
ffa_ch19_peh_tuni...  875                -- If we are in the Cutout, write the CO_Flag instead of Flag:
ffa_ch19_peh_tuni...  876                if Use_CO_Registers then
ffa_ch19_peh_tuni...  877                   CO_Flag := FFA_Word_NZeroP(F);
ffa_ch19_peh_tuni...  878                else
ffa_ch19_peh_tuni...  879                   Flag    := FFA_Word_NZeroP(F);
ffa_ch19_peh_tuni...  880                end if;
ffa_ch4_ffacalc.kv    881                Drop;
ffa_ch4_ffacalc.kv    882                
ffa_ch5_egypt.kv      883                -- Divide and give Quotient and Remainder
ffa_ch5_egypt.kv      884             when '\' =>
ffa_ch5_egypt.kv      885                Want(2);
ffa_ch5_egypt.kv      886                MustNotZero(Stack(SP));
ffa_ch11_tuning_a...  887                FFA_FZ_IDiv(Dividend  => Stack(SP - 1),
ffa_ch11_tuning_a...  888                            Divisor   => Stack(SP),
ffa_ch11_tuning_a...  889                            Quotient  => Stack(SP - 1),
ffa_ch11_tuning_a...  890                            Remainder => Stack(SP));
ffa_ch5_egypt.kv      891                
ffa_ch5_egypt.kv      892                -- Divide and give Quotient only
ffa_ch5_egypt.kv      893             when '/' =>
ffa_ch5_egypt.kv      894                Want(2);
ffa_ch5_egypt.kv      895                MustNotZero(Stack(SP));
ffa_ch11_tuning_a...  896                FFA_FZ_Div(Dividend  => Stack(SP - 1),
ffa_ch11_tuning_a...  897                           Divisor   => Stack(SP),
ffa_ch11_tuning_a...  898                           Quotient  => Stack(SP - 1));
ffa_ch5_egypt.kv      899                Drop;
ffa_ch5_egypt.kv      900                
ffa_ch5_egypt.kv      901                -- Divide and give Remainder only
ffa_ch5_egypt.kv      902             when '%' =>
ffa_ch5_egypt.kv      903                Want(2);
ffa_ch5_egypt.kv      904                MustNotZero(Stack(SP));
ffa_ch11_tuning_a...  905                FFA_FZ_Mod(Dividend  => Stack(SP - 1),
ffa_ch11_tuning_a...  906                           Divisor   => Stack(SP),
ffa_ch11_tuning_a...  907                           Remainder => Stack(SP - 1));
ffa_ch5_egypt.kv      908                Drop;
ffa_ch5_egypt.kv      909                
ffa_ch5_egypt.kv      910                -- Multiply, give bottom and top halves
ffa_ch5_egypt.kv      911             when '*' =>
ffa_ch5_egypt.kv      912                Want(2);
ffa_ch11_tuning_a...  913                FFA_FZ_Multiply(X     => Stack(SP - 1),
ffa_ch11_tuning_a...  914                                Y     => Stack(SP),
ffa_ch11_tuning_a...  915                                XY_Lo => Stack(SP - 1),
ffa_ch11_tuning_a...  916                                XY_Hi => Stack(SP));
ffa_ch5_egypt.kv      917                
ffa_ch15_gcd.kv       918                -- Square, give bottom and top halves
ffa_ch15_gcd.kv       919             when 'S' =>
ffa_ch15_gcd.kv       920                Want(1);
ffa_ch15_gcd.kv       921                Push;
ffa_ch15_gcd.kv       922                FFA_FZ_Square(X     => Stack(SP - 1),
ffa_ch15_gcd.kv       923                              XX_Lo => Stack(SP - 1),
ffa_ch15_gcd.kv       924                              XX_Hi => Stack(SP));
ffa_ch15_gcd.kv       925                
ffa_ch15_gcd.kv       926                -- Greatest Common Divisor (GCD)
ffa_ch15_gcd.kv       927             when 'G' =>
ffa_ch15_gcd.kv       928                Want(2);
ffa_ch15_gcd.kv       929                
ffa_ch15_gcd.kv       930                -- Note that GCD(0,0) is not factually zero, or unique.
ffa_ch15_gcd.kv       931                -- But it is permissible to define it as zero.
ffa_ch15_gcd.kv       932                -- (See Ch. 15 discussion.)
ffa_ch15_gcd.kv       933                
ffa_ch15_gcd.kv       934                FFA_FZ_Greatest_Common_Divisor(X      => Stack(SP - 1),
ffa_ch15_gcd.kv       935                                               Y      => Stack(SP),
ffa_ch15_gcd.kv       936                                               Result => Stack(SP - 1));
ffa_ch15_gcd.kv       937                Drop;
ffa_ch15_gcd.kv       938                
ffa_ch4_ffacalc.kv    939                -----------------
ffa_ch4_ffacalc.kv    940                -- Bitwise Ops --
ffa_ch4_ffacalc.kv    941                -----------------
ffa_ch4_ffacalc.kv    942                
ffa_ch4_ffacalc.kv    943                -- Bitwise-And
ffa_ch4_ffacalc.kv    944             when '&' =>
ffa_ch4_ffacalc.kv    945                Want(2);
ffa_ch11_tuning_a...  946                FFA_FZ_And(X      => Stack(SP - 1),
ffa_ch11_tuning_a...  947                           Y      => Stack(SP),
ffa_ch11_tuning_a...  948                           Result => Stack(SP - 1));
ffa_ch4_ffacalc.kv    949                Drop;
ffa_ch4_ffacalc.kv    950                
ffa_ch4_ffacalc.kv    951                -- Bitwise-Or
ffa_ch4_ffacalc.kv    952             when '|' =>
ffa_ch4_ffacalc.kv    953                Want(2);
ffa_ch11_tuning_a...  954                FFA_FZ_Or(X      => Stack(SP - 1),
ffa_ch11_tuning_a...  955                          Y      => Stack(SP),
ffa_ch11_tuning_a...  956                          Result => Stack(SP - 1));
ffa_ch4_ffacalc.kv    957                Drop;
ffa_ch4_ffacalc.kv    958                
ffa_ch4_ffacalc.kv    959                -- Bitwise-Xor
ffa_ch4_ffacalc.kv    960             when '^' =>
ffa_ch4_ffacalc.kv    961                Want(2);
ffa_ch11_tuning_a...  962                FFA_FZ_Xor(X      => Stack(SP - 1),
ffa_ch11_tuning_a...  963                           Y      => Stack(SP),
ffa_ch11_tuning_a...  964                           Result => Stack(SP - 1));
ffa_ch4_ffacalc.kv    965                Drop;
ffa_ch4_ffacalc.kv    966                
ffa_ch4_ffacalc.kv    967                -- Bitwise-Not (1s-Complement)
ffa_ch4_ffacalc.kv    968             when '~' =>
ffa_ch4_ffacalc.kv    969                Want(1);
ffa_ch11_tuning_a...  970                FFA_FZ_Not(Stack(SP), Stack(SP));
ffa_ch4_ffacalc.kv    971                
ffa_ch4_ffacalc.kv    972                -----------
ffa_ch4_ffacalc.kv    973                -- Other --
ffa_ch4_ffacalc.kv    974                -----------
ffa_ch4_ffacalc.kv    975                
ffa_ch8_randomism.kv  976                -- Push a FZ of RNGolade onto the stack
ffa_ch8_randomism.kv  977             when '?' =>
ffa_ch8_randomism.kv  978                Push;
ffa_ch11_tuning_a...  979                FFA_FZ_Clear(Stack(SP));
ffa_ch8_randomism.kv  980                FZ_Random(RNG, Stack(SP));
ffa_ch8_randomism.kv  981                
ffa_ch4_ffacalc.kv    982                -- mUx
ffa_ch4_ffacalc.kv    983             when 'U' =>
ffa_ch4_ffacalc.kv    984                Want(3);
ffa_ch11_tuning_a...  985                FFA_FZ_Mux(X      => Stack(SP - 2),
ffa_ch11_tuning_a...  986                           Y      => Stack(SP - 1),
ffa_ch11_tuning_a...  987                           Result => Stack(SP - 2),
ffa_ch11_tuning_a...  988                           Sel    => FFA_FZ_NZeroP(Stack(SP)));
ffa_ch4_ffacalc.kv    989                Drop;
ffa_ch4_ffacalc.kv    990                Drop;
ffa_ch4_ffacalc.kv    991                
ffa_ch13_measure_...  992                -- Find the position of eldest nonzero bit, if any exist
ffa_ch13_measure_...  993             when 'W' =>
ffa_ch13_measure_...  994                Want(1);
ffa_ch13_measure_...  995                declare
ffa_ch13_measure_...  996                   -- Find the measure ( 0 if no 1s, or 1 .. FZBitness )
ffa_ch14_barrett.kv   997                   Measure : FZBit_Index := FFA_FZ_Measure(Stack(SP));
ffa_ch14_barrett.kv   998                begin
ffa_ch13_measure_...  999                   -- Put on top of stack
ffa_ch13_measure_... 1000                   FFA_FZ_Clear(Stack(SP));
ffa_ch14_barrett.kv  1001                   FFA_FZ_Set_Head(Stack(SP), Word(Measure));
ffa_ch13_measure_... 1002                end;
ffa_ch13_measure_... 1003                
ffa_ch4_ffacalc.kv   1004                -- Put the Overflow flag on the stack
ffa_ch4_ffacalc.kv   1005             when 'O' =>
ffa_ch4_ffacalc.kv   1006                Push;
ffa_ch19_peh_tuni... 1007                -- If we are in the Cutout, read CO_Flag instead of Flag:
ffa_ch19_peh_tuni... 1008                if Use_CO_Registers then
ffa_ch19_peh_tuni... 1009                   FFA_WBool_To_FZ(CO_Flag, Stack(SP));
ffa_ch19_peh_tuni... 1010                else
ffa_ch19_peh_tuni... 1011                   FFA_WBool_To_FZ(Flag,    Stack(SP));
ffa_ch19_peh_tuni... 1012                end if;
ffa_ch4_ffacalc.kv   1013                
ffa_ch4_ffacalc.kv   1014                -- Print the FZ on the top of the stack
ffa_ch4_ffacalc.kv   1015             when '#' =>
ffa_ch4_ffacalc.kv   1016                Want(1);
ffa_ch11_tuning_a... 1017                Print_FZ(Stack(SP));
ffa_ch4_ffacalc.kv   1018                Drop;
ffa_ch4_ffacalc.kv   1019                
ffa_ch17_peh.kv      1020                -- Put the Peh Program Version on the stack,
ffa_ch14_barrett.kv  1021                -- followed by FFA Program Version.
ffa_ch14_barrett.kv  1022             when 'V' =>
ffa_ch14_barrett.kv  1023                Push;
ffa_ch14_barrett.kv  1024                Push;
ffa_ch17_peh.kv      1025                -- Peh Version:
ffa_ch14_barrett.kv  1026                FFA_FZ_Clear(Stack(SP - 1));
ffa_ch17_peh.kv      1027                FFA_FZ_Set_Head(Stack(SP - 1), Word(Peh_K_Version));
ffa_ch14_barrett.kv  1028                -- FFA Version:
ffa_ch14_barrett.kv  1029                FFA_FZ_Clear(Stack(SP));
ffa_ch14_barrett.kv  1030                FFA_FZ_Set_Head(Stack(SP), Word(FFA_K_Version));
ffa_ch14_barrett.kv  1031                
ffa_ch16_miller_r... 1032                -- Constant-Time Miller-Rabin Test on N using the given Witness.
ffa_ch16_miller_r... 1033                -- Witness will be used as-is if it conforms to the valid range,
ffa_ch16_miller_r... 1034                -- i.e. 2 <= Witness <= N - 2; else will be transformed into a
ffa_ch16_miller_r... 1035                -- valid Witness via modular arithmetic.
ffa_ch16_miller_r... 1036                -- Outputs ONE if N WAS FOUND composite; ZERO if NOT FOUND.
ffa_ch16_miller_r... 1037                -- Handles degenerate cases of N that M-R per se cannot eat:
ffa_ch16_miller_r... 1038                -- N=0, N=1: ALWAYS 'FOUND COMPOS.'; 2, 3 - ALWAYS 'NOT FOUND'.
ffa_ch16_miller_r... 1039                -- If N is Even and not equal to 2, N is ALWAYS 'FOUND COMPOS.'
ffa_ch16_miller_r... 1040                -- For ALL other N, the output is equal to that of the M-R test.
ffa_ch16_miller_r... 1041                -- At most 1/4 of all possible Witnesses will be 'liars' for
ffa_ch16_miller_r... 1042                -- a particular composite N , i.e. fail to attest to its
ffa_ch16_miller_r... 1043                -- compositivity.
ffa_ch16_miller_r... 1044             when 'P' =>
ffa_ch16_miller_r... 1045                Want(2);
ffa_ch16_miller_r... 1046                declare
ffa_ch16_miller_r... 1047                   MR_Result : WBool := 
ffa_ch16_miller_r... 1048                     FFA_FZ_MR_Composite_On_Witness(N       => Stack(SP - 1),
ffa_ch16_miller_r... 1049                                                    Witness => Stack(SP));
ffa_ch16_miller_r... 1050                begin
ffa_ch16_miller_r... 1051                   FFA_WBool_To_FZ(MR_Result, Stack(SP - 1));
ffa_ch16_miller_r... 1052                end;
ffa_ch16_miller_r... 1053                Drop;
ffa_ch16_miller_r... 1054                
ffa_ch13_measure_... 1055                --------------
ffa_ch13_measure_... 1056                -- Prefixes --
ffa_ch13_measure_... 1057                --------------
ffa_ch13_measure_... 1058                
ffa_ch17_peh.kv      1059             when
ffa_ch17_peh.kv      1060               'Q' -- 'Quit...'
ffa_ch17_peh.kv      1061               |
ffa_ch18_subrouti... 1062               'Z' -- 'Zap...'
ffa_ch18_subrouti... 1063               |
ffa_ch17_peh.kv      1064               'L' -- 'Left...'
ffa_ch17_peh.kv      1065               |
ffa_ch17_peh.kv      1066               'R' -- 'Right...'
ffa_ch17_peh.kv      1067               |
ffa_ch17_peh.kv      1068               'M' -- 'Modular...'
ffa_ch17_peh.kv      1069               |
ffa_ch17_peh.kv      1070               '$' -- Pop top of Stack into the following Register...
ffa_ch17_peh.kv      1071               =>
ffa_ch19_peh_tuni... 1072                -- Set the Prefixed Op Mode. Next Symbol is treated as prefixed:
ffa_ch19_peh_tuni... 1073                Mode := PrefixOp;
ffa_ch17_peh.kv      1074                
ffa_ch18_subrouti... 1075                -----------
ffa_ch18_subrouti... 1076                -- Loops --
ffa_ch18_subrouti... 1077                -----------
ffa_ch17_peh.kv      1078                
ffa_ch18_subrouti... 1079                -- Begin Loop: Push IP (i.e. of THIS Op) to Control Stack.
ffa_ch17_peh.kv      1080             when ':' =>
ffa_ch18_subrouti... 1081                Control_Push(Call_Type => Loops, Return_IP => IP);
ffa_ch17_peh.kv      1082                
ffa_ch18_subrouti... 1083                -- Conditional End Loop: Pop top of Stack, and...
ffa_ch17_peh.kv      1084                -- ... if ZERO:    simply discard the top of the Control Stack.
ffa_ch17_peh.kv      1085                -- ... if NONZERO: pop top of Control Stack and make it next IP.
ffa_ch17_peh.kv      1086             when ',' =>
ffa_ch17_peh.kv      1087                Want(1);
ffa_ch17_peh.kv      1088                declare
ffa_ch18_subrouti... 1089                   Loop_Position : Tape_Positions := Control_Pop(Loops);
ffa_ch18_subrouti... 1090                   Trigger       : WBool          := FFA_FZ_NZeroP(Stack(SP));
ffa_ch17_peh.kv      1091                begin
ffa_ch18_subrouti... 1092                   -- If Trigger is active, re-enter the Loop:
ffa_ch18_subrouti... 1093                   if Trigger = 1 then
ffa_ch18_subrouti... 1094                      IP_Next := Loop_Position;
ffa_ch17_peh.kv      1095                   end if;
ffa_ch17_peh.kv      1096                end;
ffa_ch18_subrouti... 1097                -- ... otherwise, continue normally.
ffa_ch17_peh.kv      1098                Drop;
ffa_ch13_measure_... 1099                
ffa_ch18_subrouti... 1100                -----------------
ffa_ch18_subrouti... 1101                -- Subroutines --
ffa_ch18_subrouti... 1102                -----------------
ffa_ch18_subrouti... 1103                
ffa_ch18_subrouti... 1104                -- Return from a Subroutine:
ffa_ch17_peh.kv      1105             when ';' =>
ffa_ch18_subrouti... 1106                -- Next instruction will be at the saved Return Position:
ffa_ch18_subrouti... 1107                IP_Next := Control_Pop(Subroutines);
ffa_ch18_subrouti... 1108                
ffa_ch18_subrouti... 1109                -- Indicate the start of a Subroutine Name, e.g. @SubName
ffa_ch18_subrouti... 1110                -- ... if DEFINING  a NEW   Subroutine: is followed by @body;
ffa_ch18_subrouti... 1111                -- ... if INVOKING EXISTING Subroutine: is followed by !
ffa_ch18_subrouti... 1112             when '@' =>
ffa_ch18_subrouti... 1113                -- Save the NEXT IP as the first Symbol of the proposed Name:
ffa_ch18_subrouti... 1114                Proposed_Sub.Name.L := Next_IP_On_Tape;
ffa_ch18_subrouti... 1115                -- Enter the Name mode:
ffa_ch19_peh_tuni... 1116                Mode                := SubName;
ffa_ch18_subrouti... 1117                -- We will remain in Name mode until we see a @ or ! .
ffa_ch18_subrouti... 1118                
ffa_ch18_subrouti... 1119                -- '!' invokes a previously-defined Subroutine:
ffa_ch18_subrouti... 1120                -- ... If found after @Name was given, the syntax is: @SubName!
ffa_ch18_subrouti... 1121                -- ... If found in THIS context, with no @Name , then invokes
ffa_ch18_subrouti... 1122                --     the nearest Subroutine defined to the LEFT of this IP.
ffa_ch18_subrouti... 1123                -- NO Sub defined to the RIGHT of the current IP may be invoked.
ffa_ch18_subrouti... 1124             when '!' =>
ffa_ch18_subrouti... 1125                Invoke_Left_Subroutine;
ffa_ch13_measure_... 1126                
ffa_ch13_measure_... 1127                ---------------------------------------------------------
ffa_ch17_peh.kv      1128                -- Reserved Ops, i.e. ones we have not defined yet:    --
ffa_ch13_measure_... 1129                ---------------------------------------------------------
ffa_ch18_subrouti... 1130             when 'H' | 'I' | 'J' | 'K' | 'N' | 'T' | 'X' | 'Y' =>
ffa_ch13_measure_... 1131                
ffa_ch13_measure_... 1132                E("This Operator is not defined yet: " & C);
ffa_ch12_karatsub... 1133                ---------------------------------------------------------
ffa_ch12_karatsub... 1134                
ffa_ch4_ffacalc.kv   1135                ----------
ffa_ch4_ffacalc.kv   1136                -- NOPs --
ffa_ch4_ffacalc.kv   1137                ----------
ffa_ch4_ffacalc.kv   1138                
ffa_ch18_subrouti... 1139                -- Unprintables and spaces DO NOTHING.
ffa_ch18_subrouti... 1140                -- (However: they occupy space, consume Life, clear Prefix.)
ffa_ch4_ffacalc.kv   1141             when others =>
ffa_ch4_ffacalc.kv   1142                null;
ffa_ch4_ffacalc.kv   1143                
ffa_ch4_ffacalc.kv   1144          end case;
ffa_ch4_ffacalc.kv   1145          
ffa_ch4_ffacalc.kv   1146       end Op_Normal;
ffa_ch4_ffacalc.kv   1147       
ffa_ch18_subrouti... 1148       ------------------------------------------------------------------------
ffa_ch4_ffacalc.kv   1149       
ffa_ch13_measure_... 1150       -- Execute a Prefixed Op
ffa_ch13_measure_... 1151       procedure Op_Prefixed(Prefix : in Character;
ffa_ch13_measure_... 1152                             O      : in Character) is
ffa_ch17_peh.kv      1153          
ffa_ch17_peh.kv      1154          -- Report an attempt to execute an undefined Prefix Op:
ffa_ch17_peh.kv      1155          procedure Undefined_Prefix_Op is
ffa_ch17_peh.kv      1156          begin
ffa_ch18_subrouti... 1157             E("Undefined Prefix Op: '" & Prefix & O & "'");
ffa_ch17_peh.kv      1158          end Undefined_Prefix_Op;
ffa_ch17_peh.kv      1159          
ffa_ch13_measure_... 1160       begin
ffa_ch13_measure_... 1161          
ffa_ch17_peh.kv      1162          -- Which Prefix Op?
ffa_ch13_measure_... 1163          case Prefix is
ffa_ch13_measure_... 1164             
ffa_ch13_measure_... 1165             ---------------------------------------------------------
ffa_ch18_subrouti... 1166             -- Quit... (See Ch. 17 discussion)
ffa_ch17_peh.kv      1167             when 'Q' =>
ffa_ch17_peh.kv      1168                
ffa_ch17_peh.kv      1169                -- .. Quit how?
ffa_ch17_peh.kv      1170                case O is
ffa_ch17_peh.kv      1171                   
ffa_ch17_peh.kv      1172                   -- ... with a 'Yes' Verdict:
ffa_ch17_peh.kv      1173                   when 'Y' =>
ffa_ch18_subrouti... 1174                      -- Prohibited from within a loop or Subroutine:
ffa_ch18_subrouti... 1175                      if Control_Stack_Not_Empty then
ffa_ch18_subrouti... 1176                         E("Attempted to proclaim a 'Yes' Verdict" &
ffa_ch18_subrouti... 1177                             " inside a Loop or Subroutine!");
ffa_ch18_subrouti... 1178                      end if;
ffa_ch17_peh.kv      1179                      Verdict := Yes;
ffa_ch17_peh.kv      1180                      
ffa_ch17_peh.kv      1181                   -- ... with a 'No' Verdict:
ffa_ch17_peh.kv      1182                   when 'N' =>
ffa_ch17_peh.kv      1183                      Verdict := No;
ffa_ch17_peh.kv      1184                      
ffa_ch17_peh.kv      1185                   -- ... with a 'Mu' Verdict: (permitted, but discouraged)
ffa_ch17_peh.kv      1186                   when 'M' =>
ffa_ch17_peh.kv      1187                      IP_Next := IP; -- Force a 'Mu' Termination
ffa_ch17_peh.kv      1188                      
ffa_ch17_peh.kv      1189                   -- ... with Debug Trace, and a 'Mu' Verdict:
ffa_ch17_peh.kv      1190                   when 'D' =>
ffa_ch17_peh.kv      1191                      Print_Trace;
ffa_ch17_peh.kv      1192                      IP_Next := IP; -- Force a 'Mu' Termination
ffa_ch17_peh.kv      1193                      
ffa_ch17_peh.kv      1194                      -- ... with an explicit Tape-triggered fatal EGGOG!
ffa_ch17_peh.kv      1195                      -- The 'QE' curtain call is intended strictly to signal
ffa_ch17_peh.kv      1196                      -- catastrophic (e.g. iron) failure from within a Tape
ffa_ch17_peh.kv      1197                      -- program ('cosmic ray' scenario) where a ~hardwired
ffa_ch17_peh.kv      1198                      -- mechanism~ of any kind appears to have done something
ffa_ch17_peh.kv      1199                      -- unexpected; or to abort on a failed test of the RNG;
ffa_ch17_peh.kv      1200                      -- or similar hard-stop scenarios, where either physical
ffa_ch17_peh.kv      1201                      -- iron, or basic FFA routine must be said to have failed,
ffa_ch17_peh.kv      1202                      -- and the continued use of the system itself - dangerous.
ffa_ch17_peh.kv      1203                      -- The use of 'QE' for any other purpose is discouraged;
ffa_ch17_peh.kv      1204                      -- please do not use it to indicate failed decryption etc.
ffa_ch17_peh.kv      1205                   when 'E' =>
ffa_ch17_peh.kv      1206                      -- Hard-stop with this eggog:
ffa_ch17_peh.kv      1207                      E("Tape-triggered CATASTROPHIC ERROR! " &
ffa_ch17_peh.kv      1208                          "Your iron and/or your build of Peh, " &
ffa_ch17_peh.kv      1209                          "may be defective! Please consult " & 
ffa_ch17_peh.kv      1210                          "the author of this Tape.");
ffa_ch17_peh.kv      1211                      
ffa_ch17_peh.kv      1212                      -- ... Unknown (Eggog):
ffa_ch17_peh.kv      1213                   when others =>
ffa_ch17_peh.kv      1214                      Undefined_Prefix_Op;
ffa_ch17_peh.kv      1215                      
ffa_ch17_peh.kv      1216                end case;
ffa_ch17_peh.kv      1217                
ffa_ch17_peh.kv      1218             ---------------------------------------------------------
ffa_ch18_subrouti... 1219             -- Zap...
ffa_ch18_subrouti... 1220             when 'Z' =>
ffa_ch18_subrouti... 1221                
ffa_ch18_subrouti... 1222                -- .. Zap what?
ffa_ch18_subrouti... 1223                case O is
ffa_ch18_subrouti... 1224                   
ffa_ch18_subrouti... 1225                   -- ... Registers:
ffa_ch18_subrouti... 1226                   when 'R' =>
ffa_ch18_subrouti... 1227                      -- If in Cutout, will zap only Cutout set of regs
ffa_ch18_subrouti... 1228                      Zap_Registers;
ffa_ch18_subrouti... 1229                      
ffa_ch18_subrouti... 1230                   -- ... Data Stack:
ffa_ch18_subrouti... 1231                   when 'D' =>
ffa_ch18_subrouti... 1232                      Zap_Data_Stack;
ffa_ch18_subrouti... 1233                      
ffa_ch19_peh_tuni... 1234                   -- ... Overflow Flag (if in Cutout, zaps CO_Flag) :
ffa_ch18_subrouti... 1235                   when 'F' =>
ffa_ch18_subrouti... 1236                      Zap_Flag;
ffa_ch18_subrouti... 1237                      
ffa_ch18_subrouti... 1238                   -- ... All Zappable State:
ffa_ch18_subrouti... 1239                   when 'A' =>
ffa_ch18_subrouti... 1240                      Zap_Master;
ffa_ch18_subrouti... 1241                      
ffa_ch18_subrouti... 1242                   when others =>
ffa_ch18_subrouti... 1243                      Undefined_Prefix_Op;
ffa_ch18_subrouti... 1244                      
ffa_ch18_subrouti... 1245                end case;
ffa_ch18_subrouti... 1246                
ffa_ch18_subrouti... 1247             ---------------------------------------------------------
ffa_ch17_peh.kv      1248             -- Write into Register...
ffa_ch17_peh.kv      1249             when '$' =>
ffa_ch17_peh.kv      1250                
ffa_ch17_peh.kv      1251                -- Eggog if operator gave us a garbage Register name:
ffa_ch17_peh.kv      1252                if O not in RegNames then
ffa_ch17_peh.kv      1253                   E("There is no Register '" & O & "' !");
ffa_ch17_peh.kv      1254                end if;
ffa_ch17_peh.kv      1255                
ffa_ch17_peh.kv      1256                -- Selected Register exists; move top FZ on stack into it:
ffa_ch17_peh.kv      1257                Want(1);
ffa_ch18_subrouti... 1258                if Use_CO_Registers then
ffa_ch18_subrouti... 1259                   CO_Registers(O) := Stack(SP); -- use Cutout Register set
ffa_ch18_subrouti... 1260                else
ffa_ch18_subrouti... 1261                   Registers(O)    := Stack(SP); -- use ordinary set
ffa_ch18_subrouti... 1262                end if;
ffa_ch17_peh.kv      1263                Drop;
ffa_ch17_peh.kv      1264             
ffa_ch17_peh.kv      1265             ---------------------------------------------------------
ffa_ch13_measure_... 1266             -- Left...
ffa_ch13_measure_... 1267             when 'L' =>
ffa_ch13_measure_... 1268                
ffa_ch13_measure_... 1269                -- Which L-op?
ffa_ch13_measure_... 1270                case O is
ffa_ch13_measure_... 1271                   
ffa_ch13_measure_... 1272                   -- ... Shift  :
ffa_ch13_measure_... 1273                   when 'S' =>
ffa_ch13_measure_... 1274                      Want(2);
ffa_ch13_measure_... 1275                      declare
ffa_ch13_measure_... 1276                         -- Number of bit positions to shift by:
ffa_ch13_measure_... 1277                         ShiftCount : FZBit_Index
ffa_ch13_measure_... 1278                           := FZBit_Index(FFA_FZ_Get_Head(Stack(SP)));
ffa_ch13_measure_... 1279                      begin
ffa_ch13_measure_... 1280                         FFA_FZ_Quiet_ShiftLeft(N        => Stack(SP - 1),
ffa_ch13_measure_... 1281                                                ShiftedN => Stack(SP - 1),
ffa_ch13_measure_... 1282                                                Count    => ShiftCount);
ffa_ch13_measure_... 1283                      end;
ffa_ch13_measure_... 1284                      Drop;
ffa_ch13_measure_... 1285                      
ffa_ch13_measure_... 1286                   -- ... Rotate :
ffa_ch13_measure_... 1287                   when 'R' =>
ffa_ch13_measure_... 1288                      E("Left-Rotate not yet defined!");
ffa_ch13_measure_... 1289                      
ffa_ch18_subrouti... 1290                   -- ... 'Cutout' :
ffa_ch18_subrouti... 1291                   -- Mark the LEFT SIDE of the 'Cutout' Tape segment;
ffa_ch18_subrouti... 1292                   -- The Tape IN OR PRIOR to it will retain the ability to
ffa_ch18_subrouti... 1293                   -- move directly into points PRIOR to THIS position
ffa_ch18_subrouti... 1294                   -- on the Tape (i.e. where THIS Op had executed).
ffa_ch18_subrouti... 1295                   -- Ops on Tape AFTER 'RC' mark can move INTO Cutout,
ffa_ch18_subrouti... 1296                   -- but NOT directly into any position PRIOR to it.
ffa_ch18_subrouti... 1297                   -- If 'LC' is executed, a 'RC' MUST occur before Tape end.
ffa_ch18_subrouti... 1298                   -- FATAL if a 'LC' or 'RC' Op had previously executed.
ffa_ch18_subrouti... 1299                   when 'C' =>
ffa_ch18_subrouti... 1300                      -- Eggog if we have ALREADY begun the Cutout somewhere:
ffa_ch18_subrouti... 1301                      if Cutout_Begun then
ffa_ch18_subrouti... 1302                         E("'LC' Op may only execute ONCE on a Tape!");
ffa_ch18_subrouti... 1303                      end if;
ffa_ch18_subrouti... 1304                      -- Cutout defs are prohibited inside loops or Sub calls:
ffa_ch18_subrouti... 1305                      if Control_Stack_Not_Empty then
ffa_ch18_subrouti... 1306                         E("Attempted to execute 'LC' (Left-Cutout)" &
ffa_ch18_subrouti... 1307                             " inside a Loop or Subroutine!");
ffa_ch18_subrouti... 1308                      end if;
ffa_ch18_subrouti... 1309                      -- Set the START of the Cutout, and mark it 'begun':
ffa_ch18_subrouti... 1310                      Cutout_Begun := True;
ffa_ch18_subrouti... 1311                      Cutout.L     := IP;
ffa_ch18_subrouti... 1312                      
ffa_ch17_peh.kv      1313                   -- ... Unknown (Eggog):
ffa_ch13_measure_... 1314                   when others =>
ffa_ch17_peh.kv      1315                      Undefined_Prefix_Op;
ffa_ch13_measure_... 1316                      
ffa_ch13_measure_... 1317                end case;
ffa_ch13_measure_... 1318             ---------------------------------------------------------
ffa_ch13_measure_... 1319             -- Right...
ffa_ch13_measure_... 1320             when 'R' =>
ffa_ch13_measure_... 1321                
ffa_ch13_measure_... 1322                -- Which R-op?
ffa_ch13_measure_... 1323                case O is
ffa_ch13_measure_... 1324                   
ffa_ch13_measure_... 1325                   -- ... Shift:
ffa_ch13_measure_... 1326                   when 'S' =>
ffa_ch13_measure_... 1327                      Want(2);
ffa_ch13_measure_... 1328                      declare
ffa_ch13_measure_... 1329                         -- Number of bit positions to shift by:
ffa_ch13_measure_... 1330                         ShiftCount : FZBit_Index
ffa_ch13_measure_... 1331                           := FZBit_Index(FFA_FZ_Get_Head(Stack(SP)));
ffa_ch13_measure_... 1332                      begin
ffa_ch13_measure_... 1333                         FFA_FZ_Quiet_ShiftRight(N        => Stack(SP - 1),
ffa_ch13_measure_... 1334                                                 ShiftedN => Stack(SP - 1),
ffa_ch13_measure_... 1335                                                 Count    => ShiftCount);
ffa_ch13_measure_... 1336                      end;
ffa_ch13_measure_... 1337                      Drop;
ffa_ch13_measure_... 1338                      
ffa_ch13_measure_... 1339                   -- ... Rotate:
ffa_ch13_measure_... 1340                   when 'R' =>
ffa_ch13_measure_... 1341                      E("Right-Rotate not yet defined!");
ffa_ch13_measure_... 1342                      
ffa_ch15_gcd.kv      1343                   -- 'Right-Multiply', give only lower half of the product XY
ffa_ch15_gcd.kv      1344                   when '*' =>
ffa_ch15_gcd.kv      1345                      Want(2);
ffa_ch15_gcd.kv      1346                      FFA_FZ_Low_Multiply(X  => Stack(SP - 1),
ffa_ch15_gcd.kv      1347                                          Y  => Stack(SP),
ffa_ch15_gcd.kv      1348                                          XY => Stack(SP - 1));
ffa_ch15_gcd.kv      1349                      Drop;
ffa_ch15_gcd.kv      1350                      
ffa_ch18_subrouti... 1351                   -- ... 'Cutout' :
ffa_ch18_subrouti... 1352                   -- Mark the RIGHT SIDE of the 'Cutout' Tape segment that
ffa_ch18_subrouti... 1353                   -- began with 'LC', and permanently arms the Cutout.
ffa_ch18_subrouti... 1354                   -- After THIS position, no IP_Next may be set which
ffa_ch18_subrouti... 1355                   -- directly transfers control to a point PRIOR to 'LC'.
ffa_ch18_subrouti... 1356                   -- FATAL if no 'LC' had executed to mark the LEFT SIDE.
ffa_ch18_subrouti... 1357                   when 'C' =>
ffa_ch18_subrouti... 1358                      -- Eggog if we never marked the beginning with 'LC':
ffa_ch18_subrouti... 1359                      if not Cutout_Begun then
ffa_ch18_subrouti... 1360                         E("'RC' Op found, but no there was no prior 'LC' !");
ffa_ch18_subrouti... 1361                      end if;
ffa_ch18_subrouti... 1362                      -- Eggog if we have already armed the Cutout:
ffa_ch18_subrouti... 1363                      if Cutout_Armed then
ffa_ch18_subrouti... 1364                         E("'RC' Op found, but the Cutout is already armed!");
ffa_ch18_subrouti... 1365                      end if;
ffa_ch18_subrouti... 1366                      -- Cutout defs are prohibited inside loops or Sub calls:
ffa_ch18_subrouti... 1367                      if Control_Stack_Not_Empty then
ffa_ch18_subrouti... 1368                         E("Attempted to execute 'RC' (Right-Cutout)" &
ffa_ch18_subrouti... 1369                             " inside a Loop or Subroutine!");
ffa_ch18_subrouti... 1370                      end if;
ffa_ch18_subrouti... 1371                      -- Otherwise proceed to complete and arm the Cutout:
ffa_ch18_subrouti... 1372                      Cutout.R     := IP;
ffa_ch18_subrouti... 1373                      Cutout_Armed := True;
ffa_ch18_subrouti... 1374                      
ffa_ch17_peh.kv      1375                   -- ... Unknown (Eggog):
ffa_ch13_measure_... 1376                   when others =>
ffa_ch17_peh.kv      1377                      Undefined_Prefix_Op;
ffa_ch13_measure_... 1378                      
ffa_ch13_measure_... 1379                end case;
ffa_ch13_measure_... 1380             ---------------------------------------------------------
ffa_ch15_gcd.kv      1381             -- Modular...
ffa_ch13_measure_... 1382             when 'M' =>
ffa_ch13_measure_... 1383                
ffa_ch13_measure_... 1384                -- Which M-op?
ffa_ch13_measure_... 1385                case O is
ffa_ch13_measure_... 1386                   
ffa_ch15_gcd.kv      1387                   -- ... Multiplication (Conventional) :
ffa_ch13_measure_... 1388                   when '*' =>
ffa_ch13_measure_... 1389                      Want(3);
ffa_ch13_measure_... 1390                      MustNotZero(Stack(SP));
ffa_ch13_measure_... 1391                      FFA_FZ_Modular_Multiply(X       => Stack(SP - 2),
ffa_ch13_measure_... 1392                                              Y       => Stack(SP - 1),
ffa_ch13_measure_... 1393                                              Modulus => Stack(SP),
ffa_ch13_measure_... 1394                                              Product => Stack(SP - 2));
ffa_ch13_measure_... 1395                      Drop;
ffa_ch13_measure_... 1396                      Drop;
ffa_ch13_measure_... 1397                      
ffa_ch15_gcd.kv      1398                   -- ... Squaring (Conventional) :
ffa_ch15_gcd.kv      1399                   when 'S' =>
ffa_ch15_gcd.kv      1400                      Want(2);
ffa_ch15_gcd.kv      1401                      MustNotZero(Stack(SP));
ffa_ch15_gcd.kv      1402                      FFA_FZ_Modular_Square(X       => Stack(SP - 1),
ffa_ch15_gcd.kv      1403                                            Modulus => Stack(SP),
ffa_ch15_gcd.kv      1404                                            Product => Stack(SP - 1));
ffa_ch15_gcd.kv      1405                      Drop;
ffa_ch15_gcd.kv      1406                      
ffa_ch15_gcd.kv      1407                   -- ... Exponentiation (Barrettronic) :
ffa_ch13_measure_... 1408                   when 'X' =>
ffa_ch13_measure_... 1409                      Want(3);
ffa_ch13_measure_... 1410                      MustNotZero(Stack(SP));
ffa_ch13_measure_... 1411                      FFA_FZ_Modular_Exponentiate(Base     => Stack(SP - 2),
ffa_ch13_measure_... 1412                                                  Exponent => Stack(SP - 1),
ffa_ch13_measure_... 1413                                                  Modulus  => Stack(SP),
ffa_ch13_measure_... 1414                                                  Result   => Stack(SP - 2));
ffa_ch13_measure_... 1415                      Drop;
ffa_ch13_measure_... 1416                      Drop;
ffa_ch13_measure_... 1417                      
ffa_ch17_peh.kv      1418                   -- ... Unknown (Eggog):
ffa_ch13_measure_... 1419                   when others =>
ffa_ch17_peh.kv      1420                      Undefined_Prefix_Op;
ffa_ch13_measure_... 1421                      
ffa_ch13_measure_... 1422                end case;
ffa_ch13_measure_... 1423             ---------------------------------------------------------
ffa_ch13_measure_... 1424             -- ... Unknown: (impossible per mechanics, but must handle case)
ffa_ch13_measure_... 1425             when others =>
ffa_ch13_measure_... 1426                E("Undefined Prefix: " & Prefix);
ffa_ch13_measure_... 1427                
ffa_ch13_measure_... 1428          end case;
ffa_ch13_measure_... 1429          
ffa_ch13_measure_... 1430       end Op_Prefixed;
ffa_ch13_measure_... 1431       
ffa_ch18_subrouti... 1432       ------------------------------------------------------------------------
ffa_ch13_measure_... 1433       
ffa_ch19_peh_tuni... 1434       -- Process a character in a proposed Subroutine Name:
ffa_ch19_peh_tuni... 1435       procedure SubName_Symbol(C : in Character) is
ffa_ch19_peh_tuni... 1436       begin
ffa_ch19_peh_tuni... 1437          case C is
ffa_ch19_peh_tuni... 1438             -- Attempt to INVOKE the named Subroutine:
ffa_ch19_peh_tuni... 1439             when '!' =>
ffa_ch19_peh_tuni... 1440                -- Detect attempt to invoke a Sub with no Name:
ffa_ch19_peh_tuni... 1441                if IP = Proposed_Sub.Name.L then
ffa_ch19_peh_tuni... 1442                   E("Attempted to invoke a nameless Subroutine!");
ffa_ch19_peh_tuni... 1443                end if;
ffa_ch19_peh_tuni... 1444                -- Exit the Sub Name mode and enter Normal mode:
ffa_ch19_peh_tuni... 1445                Mode := Normal;
ffa_ch19_peh_tuni... 1446                -- Attempt to invoke the subroutine:
ffa_ch19_peh_tuni... 1447                Invoke_Named_Subroutine(Proposed_Sub.Name);
ffa_ch19_peh_tuni... 1448                
ffa_ch19_peh_tuni... 1449                -- Attempt to read a body for a Subroutine Definition:
ffa_ch19_peh_tuni... 1450             when '@' =>
ffa_ch19_peh_tuni... 1451                -- Detect attempt to define a Sub with no Name:
ffa_ch19_peh_tuni... 1452                if IP = Proposed_Sub.Name.L then
ffa_ch19_peh_tuni... 1453                   E("Attempted to define a nameless Subroutine!");
ffa_ch19_peh_tuni... 1454                end if;
ffa_ch19_peh_tuni... 1455                -- Save NEXT IP as the beginning of the proposed Body:
ffa_ch19_peh_tuni... 1456                Proposed_Sub.Payload.L := Next_IP_On_Tape;
ffa_ch19_peh_tuni... 1457                -- Exit the Name mode and enter Sub Body mode:
ffa_ch19_peh_tuni... 1458                Mode                   := SubBody;
ffa_ch19_peh_tuni... 1459                
ffa_ch19_peh_tuni... 1460                -- Any permissible Symbol in a Subroutine Name:
ffa_ch19_peh_tuni... 1461             when '0' .. '9' | 'A' .. 'Z' | 'a' .. 'z' | '-' | '_'  =>
ffa_ch19_peh_tuni... 1462                -- Save IP as the potential end of the proposed Sub Name:
ffa_ch19_peh_tuni... 1463                Proposed_Sub.Name.R    := IP;
ffa_ch19_peh_tuni... 1464                
ffa_ch19_peh_tuni... 1465             when others =>
ffa_ch19_peh_tuni... 1466                E("Symbol '" & C & "' is prohibited in a Subroutine Name !");
ffa_ch19_peh_tuni... 1467          end case;
ffa_ch19_peh_tuni... 1468       end SubName_Symbol;
ffa_ch19_peh_tuni... 1469       
ffa_ch19_peh_tuni... 1470       ------------------------------------------------------------------------
ffa_ch19_peh_tuni... 1471       
ffa_ch19_peh_tuni... 1472       -- Process a character in a proposed Subroutine Body:
ffa_ch19_peh_tuni... 1473       procedure SubBody_Symbol(C : in Character) is
ffa_ch19_peh_tuni... 1474          
ffa_ch19_peh_tuni... 1475          -- Name of Proposed Subroutine (for eggogs) :
ffa_ch19_peh_tuni... 1476          Name : String
ffa_ch19_peh_tuni... 1477            := String(Tape(Proposed_Sub.Name.L .. Proposed_Sub.Name.R));
ffa_ch19_peh_tuni... 1478          
ffa_ch19_peh_tuni... 1479       begin
ffa_ch19_peh_tuni... 1480          case C is
ffa_ch19_peh_tuni... 1481             -- Subroutine Terminator:
ffa_ch19_peh_tuni... 1482             when ';' =>
ffa_ch19_peh_tuni... 1483                -- Only takes effect if NOT in a Comment or Quote Block:
ffa_ch19_peh_tuni... 1484                if SubCommLevel = 0 and SubQuoteLevel = 0 then
ffa_ch19_peh_tuni... 1485                   if SubCondLevel /= 0 then
ffa_ch19_peh_tuni... 1486                      E("Conditional Return in Subroutine: '"
ffa_ch19_peh_tuni... 1487                          & Name & "' is Prohibited!" &
ffa_ch19_peh_tuni... 1488                          " (Please check for unbalanced '{'.)'");
ffa_ch19_peh_tuni... 1489                   end if;
ffa_ch19_peh_tuni... 1490                   -- Now, Sub-Comm, Quote, and Cond levels are 0.
ffa_ch19_peh_tuni... 1491                   -- The ';' becomes last Symbol of the new Sub's Body.
ffa_ch19_peh_tuni... 1492                   -- Test for attempt to define a Sub with a null Body:
ffa_ch19_peh_tuni... 1493                   if IP = Proposed_Sub.Payload.L then
ffa_ch19_peh_tuni... 1494                      E("Null Body in Subroutine: '" & Name 
ffa_ch19_peh_tuni... 1495                          & "' is prohibited!");
ffa_ch19_peh_tuni... 1496                   end if;
ffa_ch19_peh_tuni... 1497                   -- Intern this new Sub definition:
ffa_ch19_peh_tuni... 1498                   Proposed_Sub.Payload.R := IP;
ffa_ch19_peh_tuni... 1499                   -- Exit the Sub Body mode and enter Normal mode:
ffa_ch19_peh_tuni... 1500                   Mode                   := Normal;
ffa_ch19_peh_tuni... 1501                   -- Attempt to intern the Proposed Subroutine:
ffa_ch19_peh_tuni... 1502                   Intern_Subroutine(Proposed_Sub);
ffa_ch19_peh_tuni... 1503                end if;
ffa_ch19_peh_tuni... 1504                
ffa_ch19_peh_tuni... 1505                -- Begin-Comment inside a Subroutine Body:
ffa_ch19_peh_tuni... 1506             when '(' =>
ffa_ch19_peh_tuni... 1507                SubCommLevel := SubCommLevel + 1;
ffa_ch19_peh_tuni... 1508                
ffa_ch19_peh_tuni... 1509                -- End-Comment inside a Subroutine Body:
ffa_ch19_peh_tuni... 1510             when ')' =>
ffa_ch19_peh_tuni... 1511                -- If cannot drop Sub Comment level:
ffa_ch19_peh_tuni... 1512                if SubCommLevel = 0 then
ffa_ch19_peh_tuni... 1513                   E("Unbalanced ')' in Body of Subroutine: '"
ffa_ch19_peh_tuni... 1514                       & Name & "' !");
ffa_ch19_peh_tuni... 1515                end if;
ffa_ch19_peh_tuni... 1516                SubCommLevel := SubCommLevel - 1;
ffa_ch19_peh_tuni... 1517                
ffa_ch19_peh_tuni... 1518                -- Begin-Quote inside a Subroutine Body:
ffa_ch19_peh_tuni... 1519             when '[' =>
ffa_ch19_peh_tuni... 1520                -- Ignore if Commented:
ffa_ch19_peh_tuni... 1521                if SubCommLevel = 0 then
ffa_ch19_peh_tuni... 1522                   SubQuoteLevel := SubQuoteLevel + 1;
ffa_ch19_peh_tuni... 1523                end if;
ffa_ch19_peh_tuni... 1524                
ffa_ch19_peh_tuni... 1525                -- End-Quote inside a Subroutine Body:
ffa_ch19_peh_tuni... 1526             when ']' =>
ffa_ch19_peh_tuni... 1527                -- Ignore if Commented:
ffa_ch19_peh_tuni... 1528                if SubCommLevel = 0 then
ffa_ch19_peh_tuni... 1529                   -- If cannot drop Sub Quote level:
ffa_ch19_peh_tuni... 1530                   if SubQuoteLevel = 0 then
ffa_ch19_peh_tuni... 1531                      E("Unbalanced ']' in Body of Subroutine: '"
ffa_ch19_peh_tuni... 1532                          & Name & "' !");
ffa_ch19_peh_tuni... 1533                   end if;
ffa_ch19_peh_tuni... 1534                   SubQuoteLevel := SubQuoteLevel - 1;
ffa_ch19_peh_tuni... 1535                end if;
ffa_ch19_peh_tuni... 1536                
ffa_ch19_peh_tuni... 1537                -- Begin-Conditional inside a Subroutine Body:
ffa_ch19_peh_tuni... 1538             when '{' =>
ffa_ch19_peh_tuni... 1539                -- Ignore if Commented or Quoted:
ffa_ch19_peh_tuni... 1540                if SubCommLevel = 0 and SubQuoteLevel = 0 then
ffa_ch19_peh_tuni... 1541                   SubCondLevel := SubCondLevel + 1;
ffa_ch19_peh_tuni... 1542                end if;
ffa_ch19_peh_tuni... 1543                
ffa_ch19_peh_tuni... 1544                -- End-Conditional inside a Subroutine Body:
ffa_ch19_peh_tuni... 1545             when '}' =>
ffa_ch19_peh_tuni... 1546                -- Ignore if Commented or Quoted:
ffa_ch19_peh_tuni... 1547                if SubCommLevel = 0 and SubQuoteLevel = 0 then
ffa_ch19_peh_tuni... 1548                   -- If cannot drop Sub Conditional level:
ffa_ch19_peh_tuni... 1549                   if SubCondLevel = 0 then
ffa_ch19_peh_tuni... 1550                      E("Unbalanced '}' in Body of Subroutine: '"
ffa_ch19_peh_tuni... 1551                          & Name & "' !");
ffa_ch19_peh_tuni... 1552                   end if;
ffa_ch19_peh_tuni... 1553                   SubCondLevel := SubCondLevel - 1;
ffa_ch19_peh_tuni... 1554                end if;
ffa_ch19_peh_tuni... 1555                
ffa_ch19_peh_tuni... 1556                -- All other Symbols have no special effect in Sub Body :
ffa_ch19_peh_tuni... 1557             when others =>
ffa_ch19_peh_tuni... 1558                null; -- Stay in Body mode until we see the ';'.
ffa_ch19_peh_tuni... 1559          end case;
ffa_ch19_peh_tuni... 1560       end SubBody_Symbol;
ffa_ch19_peh_tuni... 1561       
ffa_ch19_peh_tuni... 1562       
ffa_ch19_peh_tuni... 1563       ------------------------------------------------------------------------
ffa_ch19_peh_tuni... 1564       
ffa_ch19_peh_tuni... 1565       -- All Peh Symbols begin their processing here :
ffa_ch4_ffacalc.kv   1566       procedure Op(C : in Character) is
ffa_ch4_ffacalc.kv   1567       begin
ffa_ch18_subrouti... 1568          
ffa_ch18_subrouti... 1569          -- See whether we are inside a 'Block' :
ffa_ch4_ffacalc.kv   1570          
ffa_ch4_ffacalc.kv   1571          -- ... in a Comment block:
ffa_ch4_ffacalc.kv   1572          if CommLevel > 0 then
ffa_ch4_ffacalc.kv   1573             case C is
ffa_ch4_ffacalc.kv   1574                when ')' =>  -- Drop a nesting level:
ffa_ch4_ffacalc.kv   1575                   CommLevel := CommLevel - 1;
ffa_ch4_ffacalc.kv   1576                when '(' =>  -- Add a nesting level:
ffa_ch4_ffacalc.kv   1577                   CommLevel := CommLevel + 1;
ffa_ch4_ffacalc.kv   1578                when others =>
ffa_ch4_ffacalc.kv   1579                   null; -- Other symbols have no effect at all
ffa_ch4_ffacalc.kv   1580             end case;
ffa_ch4_ffacalc.kv   1581             
ffa_ch4_ffacalc.kv   1582             -- ... in a Quote block:
ffa_ch4_ffacalc.kv   1583          elsif QuoteLevel > 0 then
ffa_ch4_ffacalc.kv   1584             case C is
ffa_ch4_ffacalc.kv   1585                when ']' =>   -- Drop a nesting level:
ffa_ch4_ffacalc.kv   1586                   QuoteLevel := QuoteLevel - 1;
ffa_ch4_ffacalc.kv   1587                when '[' =>   -- Add a nesting level:
ffa_ch4_ffacalc.kv   1588                   QuoteLevel := QuoteLevel + 1;
ffa_ch4_ffacalc.kv   1589                when others =>
ffa_ch4_ffacalc.kv   1590                   null; -- Other symbols have no effect on the level
ffa_ch4_ffacalc.kv   1591             end case;
ffa_ch4_ffacalc.kv   1592             
ffa_ch4_ffacalc.kv   1593             -- If we aren't the mode-exiting ']', print current symbol:
ffa_ch4_ffacalc.kv   1594             if QuoteLevel > 0 then
ffa_ch4_ffacalc.kv   1595                Write_Char(C);
ffa_ch4_ffacalc.kv   1596             end if;
ffa_ch4_ffacalc.kv   1597             
ffa_ch4_ffacalc.kv   1598             --- ... in a ~taken~ Conditional branch:
ffa_ch4_ffacalc.kv   1599          elsif CondLevel > 0 then
ffa_ch4_ffacalc.kv   1600             case C is
ffa_ch4_ffacalc.kv   1601                when '}' =>   -- Drop a nesting level:
ffa_ch4_ffacalc.kv   1602                   CondLevel := CondLevel - 1;
ffa_ch4_ffacalc.kv   1603                   
ffa_ch4_ffacalc.kv   1604                   -- If we exited the Conditional as a result,
ffa_ch4_ffacalc.kv   1605                   -- we push a 1 to trigger the possible 'else' clause:
ffa_ch4_ffacalc.kv   1606                   if CondLevel = 0 then
ffa_ch4_ffacalc.kv   1607                      Push;
ffa_ch11_tuning_a... 1608                      FFA_WBool_To_FZ(1, Stack(SP));
ffa_ch4_ffacalc.kv   1609                   end if;
ffa_ch4_ffacalc.kv   1610                   
ffa_ch4_ffacalc.kv   1611                when '{' =>   -- Add a nesting level:
ffa_ch4_ffacalc.kv   1612                   CondLevel := CondLevel + 1;
ffa_ch18_subrouti... 1613                   
ffa_ch4_ffacalc.kv   1614                when others =>
ffa_ch4_ffacalc.kv   1615                   null; -- Other symbols have no effect on the level
ffa_ch4_ffacalc.kv   1616             end case;
ffa_ch13_measure_... 1617             
ffa_ch19_peh_tuni... 1618          else
ffa_ch19_peh_tuni... 1619             --- ... we are not inside a 'Block' :
ffa_ch19_peh_tuni... 1620             
ffa_ch19_peh_tuni... 1621             case Mode is
ffa_ch18_subrouti... 1622                
ffa_ch19_peh_tuni... 1623                --- ... a character in a proposed Subroutine Name:
ffa_ch19_peh_tuni... 1624                when SubName =>
ffa_ch19_peh_tuni... 1625                   SubName_Symbol(C);
ffa_ch18_subrouti... 1626                   
ffa_ch19_peh_tuni... 1627                --- ... a character in a proposed Subroutine Body:
ffa_ch19_peh_tuni... 1628                when SubBody =>
ffa_ch19_peh_tuni... 1629                   SubBody_Symbol(C);
ffa_ch18_subrouti... 1630                   
ffa_ch19_peh_tuni... 1631                --- ... the second character of a Prefixed Op:
ffa_ch19_peh_tuni... 1632                when PrefixOp =>
ffa_ch19_peh_tuni... 1633                   -- Drop prefix-op hammer, until another prefix-op cocks it:
ffa_ch19_peh_tuni... 1634                   Mode := Normal;
ffa_ch19_peh_tuni... 1635             
ffa_ch19_peh_tuni... 1636                   -- Dispatch this op, where prefix is the preceding character
ffa_ch19_peh_tuni... 1637                   Op_Prefixed(Prefix => PrevC, O => C);
ffa_ch19_peh_tuni... 1638                   
ffa_ch19_peh_tuni... 1639                -- This is a Normal Op...
ffa_ch19_peh_tuni... 1640                when Normal =>
ffa_ch19_peh_tuni... 1641                   -- ... so proceed with the normal rules:
ffa_ch19_peh_tuni... 1642                   Op_Normal(C);
ffa_ch19_peh_tuni... 1643                   
ffa_ch19_peh_tuni... 1644                   -- Save the current Symbol as a possible prefix:
ffa_ch19_peh_tuni... 1645                   PrevC := C;
ffa_ch18_subrouti... 1646                   
ffa_ch18_subrouti... 1647             end case;
ffa_ch18_subrouti... 1648             
ffa_ch4_ffacalc.kv   1649          end if;
ffa_ch4_ffacalc.kv   1650       end Op;
ffa_ch4_ffacalc.kv   1651       
ffa_ch19_peh_tuni... 1652       ------------------------------------------------------------------------
ffa_ch19_peh_tuni... 1653       
ffa_ch18_subrouti... 1654       -----------------------------
ffa_ch18_subrouti... 1655       -- Start of Tape Execution --
ffa_ch18_subrouti... 1656       -----------------------------
ffa_ch18_subrouti... 1657       
ffa_ch4_ffacalc.kv   1658    begin
ffa_ch17_peh.kv      1659       -- Reset all resettable state:
ffa_ch18_subrouti... 1660       Zap_Master;
ffa_ch18_subrouti... 1661       Zap_Cutout_Registers;
ffa_ch17_peh.kv      1662       
ffa_ch17_peh.kv      1663       -- Execution begins with the first Op on the Tape:
ffa_ch17_peh.kv      1664       IP := Tape_Positions'First;
ffa_ch17_peh.kv      1665       
ffa_ch4_ffacalc.kv   1666       loop
ffa_ch17_peh.kv      1667          
ffa_ch17_peh.kv      1668          -- If current Op is NOT the last Op on the Tape:
ffa_ch18_subrouti... 1669          if not Last_Tape_Symbol then
ffa_ch17_peh.kv      1670             
ffa_ch17_peh.kv      1671             -- ... then default successor of the current Op is the next one:
ffa_ch17_peh.kv      1672             IP_Next := IP + 1;
ffa_ch17_peh.kv      1673             
ffa_ch4_ffacalc.kv   1674          else
ffa_ch17_peh.kv      1675             
ffa_ch17_peh.kv      1676             -- ... but if no 'next' Op exists, or quit-with-Mu, we stay put:
ffa_ch17_peh.kv      1677             IP_Next := IP; -- ... this will trigger an exit from the loop.
ffa_ch17_peh.kv      1678             
ffa_ch4_ffacalc.kv   1679          end if;
ffa_ch17_peh.kv      1680          
ffa_ch17_peh.kv      1681          -- Advance Odometer for every Op (incl. prefixes, in comments, etc) :
ffa_ch17_peh.kv      1682          Ticks := Ticks + 1;
ffa_ch17_peh.kv      1683          
ffa_ch17_peh.kv      1684          -- Execute the Op at the current IP:
ffa_ch17_peh.kv      1685          Op(Tape(IP));
ffa_ch17_peh.kv      1686          
ffa_ch17_peh.kv      1687          -- Halt when...
ffa_ch17_peh.kv      1688          exit when
ffa_ch17_peh.kv      1689            Verdict /= Mu or -- Got a Verdict, or...
ffa_ch17_peh.kv      1690            IP_Next  = IP or -- Reached the end of the Tape, or...
ffa_ch17_peh.kv      1691            Exhausted_Life;  -- Exhausted Life.
ffa_ch17_peh.kv      1692          
ffa_ch18_subrouti... 1693          -- If the Cutout has been armed on this Tape, then enforce it:
ffa_ch18_subrouti... 1694          if Cutout_Prohibits(IP_Next) then
ffa_ch18_subrouti... 1695             E("Attempted movement to IP:" & Tape_Positions'Image(IP_Next) &
ffa_ch18_subrouti... 1696                 " violates the Cutout!");
ffa_ch18_subrouti... 1697          end if;
ffa_ch18_subrouti... 1698          
ffa_ch17_peh.kv      1699          -- We did not halt yet, so select the IP of the next Op to fetch:
ffa_ch17_peh.kv      1700          IP := IP_Next;
ffa_ch17_peh.kv      1701          
ffa_ch4_ffacalc.kv   1702       end loop;
ffa_ch17_peh.kv      1703       
ffa_ch18_subrouti... 1704       -- At this point, the Tape has halted.
ffa_ch18_subrouti... 1705       
ffa_ch18_subrouti... 1706       ------------------------------------------------------------------
ffa_ch19_peh_tuni... 1707       -- Termination in a Mode other than 'Normal' triggers a Eggog Verdict:
ffa_ch18_subrouti... 1708       
ffa_ch19_peh_tuni... 1709       case Mode is
ffa_ch19_peh_tuni... 1710          
ffa_ch19_peh_tuni... 1711          -- Unclosed Subroutine Name at Tape's End:
ffa_ch19_peh_tuni... 1712          when SubName =>
ffa_ch19_peh_tuni... 1713             E("The Subroutine Name at IP:"
ffa_ch19_peh_tuni... 1714                 & Tape_Positions'Image(Proposed_Sub.Name.L)
ffa_ch19_peh_tuni... 1715                 & " is Unterminated!");
ffa_ch19_peh_tuni... 1716             
ffa_ch19_peh_tuni... 1717          -- Unclosed Subroutine Body at Tape's End:
ffa_ch19_peh_tuni... 1718          when SubBody =>
ffa_ch19_peh_tuni... 1719             E("The Body of Subroutine: '" 
ffa_ch19_peh_tuni... 1720                 & String(Tape(Proposed_Sub.Name.L .. Proposed_Sub.Name.R)) 
ffa_ch19_peh_tuni... 1721                 & "' is Unterminated!");
ffa_ch19_peh_tuni... 1722             
ffa_ch19_peh_tuni... 1723          -- Incomplete Prefix Op at Tape's End:
ffa_ch19_peh_tuni... 1724          when PrefixOp =>
ffa_ch19_peh_tuni... 1725             E("Prefix Op: '" & PrevC & "' is Unterminated at End of Tape!");
ffa_ch19_peh_tuni... 1726             
ffa_ch19_peh_tuni... 1727          -- This is the expected Mode at Tape's End:
ffa_ch19_peh_tuni... 1728          when Normal =>
ffa_ch19_peh_tuni... 1729             null;
ffa_ch19_peh_tuni... 1730             
ffa_ch19_peh_tuni... 1731       end case;
ffa_ch18_subrouti... 1732       
ffa_ch19_peh_tuni... 1733       -- Unclosed Cutout triggers a Eggog Verdict:
ffa_ch18_subrouti... 1734       if Cutout_Begun and not Cutout_Armed then
ffa_ch18_subrouti... 1735          E("The Cutout declaration 'LC' at IP:"
ffa_ch18_subrouti... 1736              & Tape_Positions'Image(Cutout.L) & " is Unterminated!");
ffa_ch18_subrouti... 1737       end if;
ffa_ch18_subrouti... 1738       
ffa_ch18_subrouti... 1739       ------------------------------------------------------------------
ffa_ch18_subrouti... 1740       -- The following types of Unclosed Blocks trigger a Warning:
ffa_ch18_subrouti... 1741       
ffa_ch17_peh.kv      1742       if CommLevel > 0 then
ffa_ch17_peh.kv      1743          Achtung("WARNING: Tape terminated with an unclosed Comment!");
ffa_ch17_peh.kv      1744       end if;
ffa_ch17_peh.kv      1745       
ffa_ch17_peh.kv      1746       if QuoteLevel > 0 then
ffa_ch17_peh.kv      1747          Achtung("WARNING: Tape terminated with an unclosed Quote!");
ffa_ch17_peh.kv      1748       end if;
ffa_ch17_peh.kv      1749       
ffa_ch17_peh.kv      1750       if CondLevel > 0 then
ffa_ch17_peh.kv      1751          Achtung("WARNING: Tape terminated with an unclosed Conditional!");
ffa_ch17_peh.kv      1752       end if;
ffa_ch17_peh.kv      1753       
ffa_ch18_subrouti... 1754       ------------------------------------------------------------------
ffa_ch18_subrouti... 1755       -- Non-empty stacks, after Tape has halted, also trigger a Warning:
ffa_ch18_subrouti... 1756       
ffa_ch17_peh.kv      1757       -- Warn operator if we terminated with a non-empty Control Stack.
ffa_ch17_peh.kv      1758       -- This situation ought to be considered poor style in a Peh Tape;
ffa_ch17_peh.kv      1759       -- for clarity, Verdicts should be returned from a place near
ffa_ch17_peh.kv      1760       -- the visually-apparent end of a Tape. However, this is not mandatory.
ffa_ch18_subrouti... 1761       if Control_Stack_Not_Empty then
ffa_ch18_subrouti... 1762          Achtung("WARNING: Tape terminated inside a Loop or Subroutine!");
ffa_ch17_peh.kv      1763       end if;
ffa_ch17_peh.kv      1764       
ffa_ch18_subrouti... 1765       -- Warn operator if we terminated with a non-empty Data Stack:
ffa_ch18_subrouti... 1766       if Data_Stack_Not_Empty then
ffa_ch18_subrouti... 1767          Achtung("WARNING: Tape terminated with a non-empty Data Stack!");
ffa_ch18_subrouti... 1768       end if;
ffa_ch18_subrouti... 1769       
ffa_ch18_subrouti... 1770       ------------------------------------------------------------------
ffa_ch18_subrouti... 1771       
ffa_ch18_subrouti... 1772       -- We're done with the Tape and any Warnings, so clear the state:
ffa_ch18_subrouti... 1773       Zap_Master;
ffa_ch18_subrouti... 1774       Zap_Cutout_Registers;
ffa_ch17_peh.kv      1775       
ffa_ch17_peh.kv      1776       -- Return the Verdict:
ffa_ch17_peh.kv      1777       return Verdict;
ffa_ch17_peh.kv      1778       
ffa_ch17_peh.kv      1779    end Peh_Machine;
ffa_ch4_ffacalc.kv   1780    
ffa_ch4_ffacalc.kv   1781 end FFA_Calc;