File : ffa_calc.adb


   1 ------------------------------------------------------------------------------
   2 ------------------------------------------------------------------------------
   3 -- This file is part of 'Finite Field Arithmetic', aka 'FFA'.               --
   4 --                                                                          --
   5 -- (C) 2018 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 with CmdLine;  use CmdLine;
  24 
  25 -- FFA
  26 with FFA;      use FFA;
  27 
  28 -- For the intrinsic equality operator on Words
  29 use type FFA.Word;
  30 
  31 -- For RNG:
  32 with FFA_RNG;  use FFA_RNG;
  33 
  34 
  35 procedure FFA_Calc is
  36    
  37    Width   : Positive;   -- Desired FFA Width
  38    Height  : Positive;   -- Desired Height of Stack
  39    RNG     : RNG_Device; -- The active RNG device.
  40    
  41 begin
  42    if Arg_Count < 3 or Arg_Count > 4 then
  43       Eggog("Usage: ./ffa_calc WIDTH HEIGHT [/dev/rng]");
  44    end if;
  45    
  46    declare
  47       Arg1 : CmdLineArg;
  48       Arg2 : CmdLineArg;
  49    begin
  50       -- Get commandline args:
  51       Get_Argument(1, Arg1); -- First arg
  52       Get_Argument(2, Arg2); -- Second arg
  53       
  54       if Arg_Count = 4 then
  55          -- RNG was specified:
  56          declare
  57             Arg3 : CmdLineArg;
  58          begin
  59             Get_Argument(3, Arg3); -- Third arg (optional)
  60             
  61             -- Ada.Sequential_IO chokes on paths with trailing whitespace!
  62             -- So we have to give it a trimmed path. But we can't use
  63             -- Ada.Strings.Fixed.Trim, because it suffers from
  64             -- SecondaryStackism-syphilis. Instead we are stuck doing this:
  65             Init_RNG(RNG, Arg3(Arg3'First .. Len_Arg(3)));
  66          end;
  67       else
  68          -- RNG was NOT specified:
  69          Init_RNG(RNG); -- Use the machine default then
  70       end if;
  71       
  72       -- Parse into Positives:
  73       Width  := Positive'Value(Arg1);
  74       Height := Positive'Value(Arg2);
  75    exception
  76       when others =>
  77          Eggog("Invalid arguments!");
  78    end;
  79    
  80    -- Test if proposed Width is permissible:
  81    if not FFA_FZ_Valid_Bitness_P(Width) then
  82       Eggog("Invalid Width: " & FFA_Validity_Rule_Doc);
  83    end if;
  84    
  85    -- The Calculator itself:
  86    declare
  87       
  88       -- The number of Words required to make a FZ of the given Bitness.
  89       Wordness : Indices := Indices(Width / Bitness);
  90       
  91       --------------------------------------------------------
  92       -- State --
  93       --------------------------------------------------------
  94       -- The Stack:
  95       subtype Stack_Positions is Natural range 0 .. Height;
  96       type Stacks is array(Stack_Positions range <>) of FZ(1 .. Wordness);
  97       Stack      : Stacks(Stack_Positions'Range);
  98       
  99       -- Stack Pointer:
 100       SP         : Stack_Positions := Stack_Positions'First;
 101       
 102       -- Carry/Borrow Flag:
 103       Flag       : WBool   := 0;
 104       
 105       -- Odometer:
 106       Pos        : Natural := 0;
 107       
 108       -- The current levels of the three types of nestedness:
 109       QuoteLevel : Natural := 0;
 110       CommLevel  : Natural := 0;
 111       CondLevel  : Natural := 0;
 112       
 113       -- Prefixed Operators
 114       PrevC      : Character := ' ';
 115       HavePrefix : Boolean   := False;
 116       
 117       --------------------------------------------------------
 118       
 119       
 120       -- Clear the stack and set SP to bottom.
 121       procedure Zap is
 122       begin
 123          -- Clear the stack
 124          for i in Stack'Range loop
 125             FFA_FZ_Clear(Stack(i));
 126          end loop;
 127          -- Set SP to bottom
 128          SP   := Stack_Positions'First;
 129          -- Clear Overflow flag
 130          Flag := 0;
 131          -- Clear prefix
 132          HavePrefix := False;
 133          PrevC      := ' ';
 134       end Zap;
 135       
 136       
 137       -- Report a fatal error condition at the current symbol
 138       procedure E(S : in String) is
 139       begin
 140          Eggog("Pos:" & Natural'Image(Pos) & ": " & S);
 141       end E;
 142       
 143       
 144       -- Move SP up
 145       procedure Push is
 146       begin
 147          if SP = Stack_Positions'Last then
 148             E("Stack Overflow!");
 149          else
 150             SP := SP + 1;
 151          end if;
 152       end Push;
 153       
 154       
 155       -- Discard the top of the stack
 156       procedure Drop is
 157       begin
 158          FFA_FZ_Clear(Stack(SP));
 159          SP := SP - 1;
 160       end Drop;
 161       
 162       
 163       -- Check if stack has the necessary N items
 164       procedure Want(N : in Positive) is
 165       begin
 166          if SP < N then
 167             E("Stack Underflow!");
 168          end if;
 169       end Want;
 170       
 171       
 172       -- Ensure that a divisor is not zero
 173       procedure MustNotZero(D : in FZ) is
 174       begin
 175          if FFA_FZ_ZeroP(D) = 1 then
 176             E("Division by Zero!");
 177          end if;
 178       end MustNotZero;
 179       
 180       
 181       -- Slide a new hex digit into the FZ on top of stack
 182       procedure Ins_Hex_Digit(Digit : in Nibble) is
 183          Overflow : WBool := 0;
 184       begin
 185          
 186          -- Insert the given nibble, and detect any overflow:
 187          FFA_FZ_Insert_Bottom_Nibble(N        => Stack(SP),
 188                                      D        => Digit,
 189                                      Overflow => Overflow);
 190          
 191          -- Constants which exceed the Width are forbidden:
 192          if Overflow = 1 then
 193             E("Constant Exceeds Bitness!");
 194          end if;
 195          
 196       end;
 197       
 198       
 199       -- Emit an ASCII representation of N to the terminal
 200       procedure Print_FZ(N : in FZ) is
 201          S : String(1 .. FFA_FZ_ASCII_Length(N)); -- Mandatorily, exact size
 202       begin
 203          FFA_FZ_To_Hex_String(N, S); -- Convert N to ASCII hex
 204          Write_String(S);            -- Print the result to stdout
 205          Write_Newline;              -- Print newline, for clarity.
 206       end Print_FZ;
 207       
 208       
 209       -- Denote that the given op is a prefix
 210       procedure IsPrefix is
 211       begin
 212          HavePrefix := True;
 213       end IsPrefix;
 214       
 215       
 216       -- Execute a Normal Op
 217       procedure Op_Normal(C : in Character) is
 218          
 219          -- Over/underflow output from certain ops
 220          F : Word;
 221          
 222       begin
 223          
 224          case C is
 225             
 226             --------------
 227             -- Stickies --
 228             --------------
 229             -- Enter Commented
 230             when '(' =>
 231                CommLevel := 1;
 232                
 233                -- Exit Commented (but we aren't in it!)
 234             when ')' =>
 235                E("Mismatched close-comment parenthesis !");
 236                
 237                -- Enter Quoted
 238             when '[' =>
 239                QuoteLevel := 1;
 240                
 241                -- Exit Quoted (but we aren't in it!)
 242             when ']' =>
 243                E("Mismatched close-quote bracket !");
 244                
 245                -- Enter a ~taken~ Conditional branch:
 246             when '{' =>
 247                Want(1);
 248                if FFA_FZ_ZeroP(Stack(SP)) = 1 then
 249                   CondLevel := 1;
 250                end if;
 251                Drop;
 252                
 253                -- Exit from a ~non-taken~ Conditional branch:
 254                -- ... we push a 0, to suppress the 'else' clause
 255             when '}' =>
 256                Push;
 257                FFA_WBool_To_FZ(0, Stack(SP));
 258                
 259                ----------------
 260                -- Immediates --
 261                ----------------
 262                
 263                -- These operate on the FZ ~currently~ at top of the stack;
 264                -- and this means that the stack may NOT be empty.
 265                
 266             when '0' .. '9' =>
 267                Want(1);
 268                Ins_Hex_Digit(Character'Pos(C) - Character'Pos('0'));
 269                
 270             when 'A' .. 'F' =>
 271                Want(1);
 272                Ins_Hex_Digit(10 + Character'Pos(C) - Character'Pos('A'));
 273                
 274             when 'a' .. 'f' =>
 275                Want(1);
 276                Ins_Hex_Digit(10 + Character'Pos(C) - Character'Pos('a'));
 277                
 278                ------------------
 279                -- Stack Motion --
 280                ------------------
 281                
 282                -- Push a 0 onto the stack
 283             when '.' =>
 284                Push;
 285                FFA_FZ_Clear(Stack(SP));
 286                
 287                -- Dup
 288             when '"' =>
 289                Want(1);
 290                Push;
 291                Stack(SP) := Stack(SP - 1);
 292                
 293                -- Drop
 294             when '_' =>
 295                Want(1);
 296                Drop;
 297                
 298                -- Swap
 299             when ''' =>
 300                Want(2);
 301                FFA_FZ_Swap(Stack(SP), Stack(SP - 1));
 302                
 303                -- Over
 304             when '`' =>
 305                Want(2);
 306                Push;
 307                Stack(SP) := Stack(SP - 2);
 308                
 309                ----------------
 310                -- Predicates --
 311                ----------------
 312                
 313                -- Equality
 314             when '=' =>
 315                Want(2);
 316                FFA_WBool_To_FZ(FFA_FZ_EqP(X => Stack(SP),
 317                                           Y => Stack(SP - 1)),
 318                                Stack(SP - 1));
 319                Drop;
 320                
 321                -- Less-Than
 322             when '<' =>
 323                Want(2);
 324                FFA_WBool_To_FZ(FFA_FZ_LessThanP(X => Stack(SP - 1),
 325                                                 Y => Stack(SP)),
 326                                Stack(SP - 1));
 327                Drop;
 328                
 329                -- Greater-Than
 330             when '>' =>
 331                Want(2);
 332                FFA_WBool_To_FZ(FFA_FZ_GreaterThanP(X => Stack(SP - 1),
 333                                                    Y => Stack(SP)),
 334                                Stack(SP - 1));
 335                Drop;
 336                
 337                ----------------
 338                -- Arithmetic --
 339                ----------------
 340                
 341                -- Subtract
 342             when '-' =>
 343                Want(2);
 344                FFA_FZ_Subtract(X          => Stack(SP - 1),
 345                                Y          => Stack(SP),
 346                                Difference => Stack(SP - 1),
 347                                Underflow  => F);
 348                Flag := FFA_Word_NZeroP(F);
 349                Drop;
 350                
 351                -- Add
 352             when '+' =>
 353                Want(2);
 354                FFA_FZ_Add(X        => Stack(SP - 1),
 355                           Y        => Stack(SP),
 356                           Sum      => Stack(SP - 1),
 357                           Overflow => F);
 358                Flag := FFA_Word_NZeroP(F);
 359                Drop;
 360                
 361                -- Divide and give Quotient and Remainder
 362             when '\' =>
 363                Want(2);
 364                MustNotZero(Stack(SP));
 365                FFA_FZ_IDiv(Dividend  => Stack(SP - 1),
 366                            Divisor   => Stack(SP),
 367                            Quotient  => Stack(SP - 1),
 368                            Remainder => Stack(SP));
 369                
 370                -- Divide and give Quotient only
 371             when '/' =>
 372                Want(2);
 373                MustNotZero(Stack(SP));
 374                FFA_FZ_Div(Dividend  => Stack(SP - 1),
 375                           Divisor   => Stack(SP),
 376                           Quotient  => Stack(SP - 1));
 377                Drop;
 378                
 379                -- Divide and give Remainder only
 380             when '%' =>
 381                Want(2);
 382                MustNotZero(Stack(SP));
 383                FFA_FZ_Mod(Dividend  => Stack(SP - 1),
 384                           Divisor   => Stack(SP),
 385                           Remainder => Stack(SP - 1));
 386                Drop;
 387                
 388                -- Multiply, give bottom and top halves
 389             when '*' =>
 390                Want(2);
 391                FFA_FZ_Multiply(X     => Stack(SP - 1),
 392                                Y     => Stack(SP),
 393                                XY_Lo => Stack(SP - 1),
 394                                XY_Hi => Stack(SP));
 395                
 396                -----------------
 397                -- Bitwise Ops --
 398                -----------------
 399                
 400                -- Bitwise-And
 401             when '&' =>
 402                Want(2);
 403                FFA_FZ_And(X      => Stack(SP - 1),
 404                           Y      => Stack(SP),
 405                           Result => Stack(SP - 1));
 406                Drop;
 407                
 408                -- Bitwise-Or
 409             when '|' =>
 410                Want(2);
 411                FFA_FZ_Or(X      => Stack(SP - 1),
 412                          Y      => Stack(SP),
 413                          Result => Stack(SP - 1));
 414                Drop;
 415                
 416                -- Bitwise-Xor
 417             when '^' =>
 418                Want(2);
 419                FFA_FZ_Xor(X      => Stack(SP - 1),
 420                           Y      => Stack(SP),
 421                           Result => Stack(SP - 1));
 422                Drop;
 423                
 424                -- Bitwise-Not (1s-Complement)
 425             when '~' =>
 426                Want(1);
 427                FFA_FZ_Not(Stack(SP), Stack(SP));
 428                
 429                -----------
 430                -- Other --
 431                -----------
 432                
 433                -- Push a FZ of RNGolade onto the stack
 434             when '?' =>
 435                Push;
 436                FFA_FZ_Clear(Stack(SP));
 437                FZ_Random(RNG, Stack(SP));
 438                
 439                -- mUx
 440             when 'U' =>
 441                Want(3);
 442                FFA_FZ_Mux(X      => Stack(SP - 2),
 443                           Y      => Stack(SP - 1),
 444                           Result => Stack(SP - 2),
 445                           Sel    => FFA_FZ_NZeroP(Stack(SP)));
 446                Drop;
 447                Drop;
 448                
 449                -- Find the position of eldest nonzero bit, if any exist
 450             when 'W' =>
 451                Want(1);
 452                declare
 453                   -- Find the measure ( 0 if no 1s, or 1 .. FZBitness )
 454                   Measure : FZBit_Index := FFA_FZ_Measure(Stack(SP));
 455                begin
 456                   -- Put on top of stack
 457                   FFA_FZ_Clear(Stack(SP));
 458                   FFA_FZ_Set_Head(Stack(SP), Word(Measure));
 459                end;
 460                
 461                -- Put the Overflow flag on the stack
 462             when 'O' =>
 463                Push;
 464                FFA_WBool_To_FZ(Flag, Stack(SP));
 465                
 466                -- Print the FZ on the top of the stack
 467             when '#' =>
 468                Want(1);
 469                Print_FZ(Stack(SP));
 470                Drop;
 471                
 472                -- Zap (reset)
 473             when 'Z' =>
 474                Zap;
 475                
 476                -- Quit with Stack Trace
 477             when 'Q' =>
 478                for I in reverse Stack'First + 1 .. SP loop
 479                   Print_FZ(Stack(I));
 480                end loop;
 481                Quit(0);
 482                
 483                -- Put the FFACalc Program Version on the stack,
 484                -- followed by FFA Program Version.
 485             when 'V' =>
 486                Push;
 487                Push;
 488                -- FFACalc Version:
 489                FFA_FZ_Clear(Stack(SP - 1));
 490                FFA_FZ_Set_Head(Stack(SP - 1), Word(FFACalc_K_Version));
 491                -- FFA Version:
 492                FFA_FZ_Clear(Stack(SP));
 493                FFA_FZ_Set_Head(Stack(SP), Word(FFA_K_Version));
 494                
 495                -- Square, give bottom and top halves
 496             when 'S' =>
 497                Want(1);
 498                Push;
 499                FFA_FZ_Square(X     => Stack(SP - 1),
 500                              XX_Lo => Stack(SP - 1),
 501                              XX_Hi => Stack(SP));
 502                
 503                --------------
 504                -- Prefixes --
 505                --------------
 506                
 507                -- 'Left...'    :
 508             when 'L' =>
 509                IsPrefix;
 510                
 511                -- 'Right...'   :
 512             when 'R' =>
 513                IsPrefix;
 514                
 515                -- 'Modular...' :
 516             when 'M' =>
 517                IsPrefix;
 518                
 519                ---------------------------------------------------------
 520                -- Reserved Ops, i.e. ones we have not defined yet:   --
 521                ---------------------------------------------------------
 522             when '!' | '@' | '$' | ':' | ';' | ',' |
 523                  'G' | 'H' | 'I' | 'J' | 'K' | 'N' |
 524                  'P' | 'T' | 'X' | 'Y' =>
 525                
 526                E("This Operator is not defined yet: " & C);
 527                ---------------------------------------------------------
 528                
 529                ----------
 530                -- NOPs --
 531                ----------
 532                
 533                -- Unprintables and spaces DO NOTHING:
 534             when others =>
 535                null;
 536                
 537          end case;
 538          
 539       end Op_Normal;
 540       
 541       
 542       -- Execute a Prefixed Op
 543       procedure Op_Prefixed(Prefix : in Character;
 544                             O      : in Character) is
 545       begin
 546          
 547          -- The Prefixed Op:
 548          case Prefix is
 549             
 550             ---------------------------------------------------------
 551             -- Left...
 552             when 'L' =>
 553                
 554                -- Which L-op?
 555                case O is
 556                   
 557                   -- ... Shift  :
 558                   when 'S' =>
 559                      Want(2);
 560                      declare
 561                         -- Number of bit positions to shift by:
 562                         ShiftCount : FZBit_Index
 563                           := FZBit_Index(FFA_FZ_Get_Head(Stack(SP)));
 564                      begin
 565                         FFA_FZ_Quiet_ShiftLeft(N        => Stack(SP - 1),
 566                                                ShiftedN => Stack(SP - 1),
 567                                                Count    => ShiftCount);
 568                      end;
 569                      Drop;
 570                      
 571                   -- ... Rotate :
 572                   when 'R' =>
 573                      E("Left-Rotate not yet defined!");
 574                      
 575                   -- ... Unknown:
 576                   when others =>
 577                      E("Undefined Op: L" & O);
 578                      
 579                end case;
 580             ---------------------------------------------------------
 581             -- Right...
 582             when 'R' =>
 583                
 584                -- Which R-op?
 585                case O is
 586                   
 587                   -- ... Shift:
 588                   when 'S' =>
 589                      Want(2);
 590                      declare
 591                         -- Number of bit positions to shift by:
 592                         ShiftCount : FZBit_Index
 593                           := FZBit_Index(FFA_FZ_Get_Head(Stack(SP)));
 594                      begin
 595                         FFA_FZ_Quiet_ShiftRight(N        => Stack(SP - 1),
 596                                                 ShiftedN => Stack(SP - 1),
 597                                                 Count    => ShiftCount);
 598                      end;
 599                      Drop;
 600                      
 601                   -- ... Rotate:
 602                   when 'R' =>
 603                      E("Right-Rotate not yet defined!");
 604                      
 605                   -- ... Unknown:
 606                   when others =>
 607                      E("Undefined Op: R" & O);
 608                      
 609                end case;
 610             ---------------------------------------------------------
 611             -- Modular...   
 612             when 'M' =>
 613                
 614                -- Which M-op?
 615                case O is
 616                   
 617                   -- ... Multiplication :
 618                   when '*' =>
 619                      Want(3);
 620                      MustNotZero(Stack(SP));
 621                      FFA_FZ_Modular_Multiply(X       => Stack(SP - 2),
 622                                              Y       => Stack(SP - 1),
 623                                              Modulus => Stack(SP),
 624                                              Product => Stack(SP - 2));
 625                      Drop;
 626                      Drop;
 627                      
 628                   -- ... Exponentiation :
 629                   when 'X' =>
 630                      Want(3);
 631                      MustNotZero(Stack(SP));
 632                      FFA_FZ_Modular_Exponentiate(Base     => Stack(SP - 2),
 633                                                  Exponent => Stack(SP - 1),
 634                                                  Modulus  => Stack(SP),
 635                                                  Result   => Stack(SP - 2));
 636                      Drop;
 637                      Drop;
 638                      
 639                   -- ... Unknown:
 640                   when others =>
 641                      E("Undefined Op: M" & O);
 642                      
 643                end case;
 644             ---------------------------------------------------------
 645             -- ... Unknown: (impossible per mechanics, but must handle case)
 646             when others =>
 647                E("Undefined Prefix: " & Prefix);
 648                
 649          end case;
 650          
 651       end Op_Prefixed;
 652       
 653       
 654       -- Process a Symbol
 655       procedure Op(C : in Character) is
 656       begin
 657          -- First, see whether we are in a state of nestedness:
 658          
 659          -- ... in a Comment block:
 660          if CommLevel > 0 then
 661             case C is
 662                when ')' =>  -- Drop a nesting level:
 663                   CommLevel := CommLevel - 1;
 664                when '(' =>  -- Add a nesting level:
 665                   CommLevel := CommLevel + 1;
 666                when others =>
 667                   null; -- Other symbols have no effect at all
 668             end case;
 669             
 670             -- ... in a Quote block:
 671          elsif QuoteLevel > 0 then
 672             case C is
 673                when ']' =>   -- Drop a nesting level:
 674                   QuoteLevel := QuoteLevel - 1;
 675                when '[' =>   -- Add a nesting level:
 676                   QuoteLevel := QuoteLevel + 1;
 677                when others =>
 678                   null; -- Other symbols have no effect on the level
 679             end case;
 680             
 681             -- If we aren't the mode-exiting ']', print current symbol:
 682             if QuoteLevel > 0 then
 683                Write_Char(C);
 684             end if;
 685             
 686             --- ... in a ~taken~ Conditional branch:
 687          elsif CondLevel > 0 then
 688             case C is
 689                when '}' =>   -- Drop a nesting level:
 690                   CondLevel := CondLevel - 1;
 691                   
 692                   -- If we exited the Conditional as a result,
 693                   -- we push a 1 to trigger the possible 'else' clause:
 694                   if CondLevel = 0 then
 695                      Push;
 696                      FFA_WBool_To_FZ(1, Stack(SP));
 697                   end if;
 698                   
 699                when '{' =>   -- Add a nesting level:
 700                   CondLevel := CondLevel + 1;
 701                when others =>
 702                   null; -- Other symbols have no effect on the level
 703             end case;
 704             
 705             --- ... if in a prefixed op:
 706          elsif HavePrefix then
 707             
 708             -- Drop the prefix-op hammer, until another prefix-op cocks it
 709             HavePrefix := False;
 710             
 711             -- Dispatch this op, where prefix is the preceding character
 712             Op_Prefixed(Prefix => PrevC, O => C);
 713             
 714          else
 715             -- This is a Normal Op, so proceed with the normal rules.
 716             Op_Normal(C);
 717          end if;
 718          
 719       end Op;
 720       
 721       
 722       -- Current Character
 723       C : Character;
 724       
 725    begin
 726       -- Reset the Calculator      
 727       Zap;
 728       -- Process characters until EOF:
 729       loop
 730          if Read_Char(C) then
 731             -- Execute Op:
 732             Op(C);
 733             -- Advance Odometer
 734             Pos := Pos + 1;
 735             -- Save the op for use in prefixed ops
 736             PrevC := C;
 737          else
 738             Zap;
 739             Quit(0); -- if EOF, we're done
 740          end if;
 741       end loop;
 742    end;
 743    
 744 end FFA_Calc;