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