File : ffa_calc.adb


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