Finite Field Arithmetic

ffa_calc.adb


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