------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- This file is part of 'Finite Field Arithmetic', aka 'FFA'. -- -- -- -- (C) 2017 Stanislav Datskovskiy ( www.loper-os.org ) -- -- http://wot.deedbot.org/17215D118B7239507FAFED98B98228A001ABFFC7.html -- -- -- -- You do not have, nor can you ever acquire the right to use, copy or -- -- distribute this software ; Should you use this software for any purpose, -- -- or copy and distribute it to anyone or in any manner, you are breaking -- -- the laws of whatever soi-disant jurisdiction, and you promise to -- -- continue doing so for the indefinite future. In any case, please -- -- always : read and understand any software ; verify any PGP signatures -- -- that you use - for any purpose. -- -- -- -- See also http://trilema.com/2015/a-new-software-licensing-paradigm . -- ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- Basics with OS; use OS; with CmdLine; use CmdLine; -- FFA with FZ_Lim; use FZ_Lim; with Words; use Words; with W_Pred; use W_Pred; with FZ_Type; use FZ_Type; with FZ_Basic; use FZ_Basic; with FZ_Arith; use FZ_Arith; with FZ_Cmp; use FZ_Cmp; with FZ_Pred; use FZ_Pred; with FZ_BitOp; use FZ_BitOp; with FZ_Shift; use FZ_Shift; with FZ_Divis; use FZ_Divis; with FZ_Mul; use FZ_Mul; with FZ_ModEx; use FZ_ModEx; -- For Output with FFA_IO; use FFA_IO; -- For RNG: with FFA_RNG; use FFA_RNG; procedure FFA_Calc is Width : Positive; -- Desired FFA Width Height : Positive; -- Desired Height of Stack RNG : RNG_Device; -- The active RNG device. begin if Arg_Count < 3 or Arg_Count > 4 then Eggog("Usage: ./ffa_calc WIDTH HEIGHT [/dev/rng]"); end if; declare Arg1 : CmdLineArg; Arg2 : CmdLineArg; begin -- Get commandline args: Get_Argument(1, Arg1); -- First arg Get_Argument(2, Arg2); -- Second arg if Arg_Count = 4 then -- RNG was specified: declare Arg3 : CmdLineArg; begin Get_Argument(3, Arg3); -- Third arg (optional) -- Ada.Sequential_IO chokes on paths with trailing whitespace! -- So we have to give it a trimmed path. But we can't use -- Ada.Strings.Fixed.Trim, because it suffers from -- SecondaryStackism-syphilis. Instead we are stuck doing this: Init_RNG(RNG, Arg3(Arg3'First .. Len_Arg(3))); end; else -- RNG was NOT specified: Init_RNG(RNG); -- Use the machine default then end if; -- Parse into Positives: Width := Positive'Value(Arg1); Height := Positive'Value(Arg2); exception when others => Eggog("Invalid arguments!"); end; -- Test if proposed Width is permissible: if not FZ_Valid_Bitness_P(Width) then Eggog("Invalid Width: " & FZ_Validity_Rule_Doc); end if; -- The Calculator itself: declare -- The number of Words required to make a FZ of the given Bitness. Wordness : Indices := Indices(Width / Bitness); -------------------------------------------------------- -- State -- -------------------------------------------------------- -- The Stack: subtype Stack_Positions is Natural range 0 .. Height; type Stacks is array(Stack_Positions range <>) of FZ(1 .. Wordness); Stack : Stacks(Stack_Positions'Range); -- Stack Pointer: SP : Stack_Positions := Stack_Positions'First; -- Carry/Borrow Flag: Flag : WBool := 0; -- Odometer: Pos : Natural := 0; -- The current levels of the three types of nestedness: QuoteLevel : Natural := 0; CommLevel : Natural := 0; CondLevel : Natural := 0; -------------------------------------------------------- -- Clear the stack and set SP to bottom. procedure Zap is begin -- Clear the stack for i in Stack'Range loop FZ_Clear(Stack(i)); end loop; -- Set SP to bottom SP := Stack_Positions'First; -- Clear Overflow flag Flag := 0; end Zap; -- Report a fatal error condition at the current symbol procedure E(S : in String) is begin Eggog("Pos:" & Natural'Image(Pos) & ": " & S); end E; -- Move SP up procedure Push is begin if SP = Stack_Positions'Last then E("Stack Overflow!"); else SP := SP + 1; end if; end Push; -- Discard the top of the stack procedure Drop is begin FZ_Clear(Stack(SP)); SP := SP - 1; end Drop; -- Check if stack has the necessary N items procedure Want(N : in Positive) is begin if SP < N then E("Stack Underflow!"); end if; end Want; -- Ensure that a divisor is not zero procedure MustNotZero(D : in FZ) is begin if FZ_ZeroP(D) = 1 then E("Division by Zero!"); end if; end MustNotZero; -- Slide a new hex digit into the FZ on top of stack procedure Ins_Hex_Digit(N : in out FZ; D : in Nibble) is Overflow : Word := 0; begin -- Make room in this FZ for one additional hex digit FZ_ShiftLeft_O(N => N, ShiftedN => N, Count => 4, Overflow => Overflow); -- Constants which exceed the Width are forbidden: if W_NZeroP(Overflow) = 1 then E("Constant Exceeds Bitness!"); end if; -- Set the new digit FZ_Or_W(N, D); end; -- Execute a Normal Op procedure Op_Normal(C : in Character) is -- Over/underflow output from certain ops F : Word; begin case C is -------------- -- Stickies -- -------------- -- Enter Commented when '(' => CommLevel := 1; -- Exit Commented (but we aren't in it!) when ')' => E("Mismatched close-comment parenthesis !"); -- Enter Quoted when '[' => QuoteLevel := 1; -- Exit Quoted (but we aren't in it!) when ']' => E("Mismatched close-quote bracket !"); -- Enter a ~taken~ Conditional branch: when '{' => Want(1); if FZ_ZeroP(Stack(SP)) = 1 then CondLevel := 1; end if; Drop; -- Exit from a ~non-taken~ Conditional branch: -- ... we push a 0, to suppress the 'else' clause when '}' => Push; WBool_To_FZ(0, Stack(SP)); ---------------- -- Immediates -- ---------------- -- These operate on the FZ ~currently~ at top of the stack; -- and this means that the stack may NOT be empty. when '0' .. '9' => Want(1); Ins_Hex_Digit(Stack(SP), Character'Pos(C) - Character'Pos('0')); when 'A' .. 'F' => Want(1); Ins_Hex_Digit(Stack(SP), 10 + Character'Pos(C) - Character'Pos('A')); when 'a' .. 'f' => Want(1); Ins_Hex_Digit(Stack(SP), 10 + Character'Pos(C) - Character'Pos('a')); ------------------ -- Stack Motion -- ------------------ -- Push a 0 onto the stack when '.' => Push; FZ_Clear(Stack(SP)); -- Dup when '"' => Want(1); Push; Stack(SP) := Stack(SP - 1); -- Drop when '_' => Want(1); Drop; -- Swap when ''' => Want(2); FZ_Swap(Stack(SP), Stack(SP - 1)); -- Over when '`' => Want(2); Push; Stack(SP) := Stack(SP - 2); ---------------- -- Predicates -- ---------------- -- Equality when '=' => Want(2); WBool_To_FZ(FZ_Eqp(X => Stack(SP), Y => Stack(SP - 1)), Stack(SP - 1)); Drop; -- Less-Than when '<' => Want(2); WBool_To_FZ(FZ_LessThanP(X => Stack(SP - 1), Y => Stack(SP)), Stack(SP - 1)); Drop; -- Greater-Than when '>' => Want(2); WBool_To_FZ(FZ_GreaterThanP(X => Stack(SP - 1), Y => Stack(SP)), Stack(SP - 1)); Drop; ---------------- -- Arithmetic -- ---------------- -- Subtract when '-' => Want(2); FZ_Sub(X => Stack(SP - 1), Y => Stack(SP), Difference => Stack(SP - 1), Underflow => F); Flag := W_NZeroP(F); Drop; -- Add when '+' => Want(2); FZ_Add(X => Stack(SP - 1), Y => Stack(SP), Sum => Stack(SP - 1), Overflow => F); Flag := W_NZeroP(F); Drop; -- Divide and give Quotient and Remainder when '\' => Want(2); MustNotZero(Stack(SP)); FZ_IDiv(Dividend => Stack(SP - 1), Divisor => Stack(SP), Quotient => Stack(SP - 1), Remainder => Stack(SP)); -- Divide and give Quotient only when '/' => Want(2); MustNotZero(Stack(SP)); FZ_Div(Dividend => Stack(SP - 1), Divisor => Stack(SP), Quotient => Stack(SP - 1)); Drop; -- Divide and give Remainder only when '%' => Want(2); MustNotZero(Stack(SP)); FZ_Mod(Dividend => Stack(SP - 1), Divisor => Stack(SP), Remainder => Stack(SP - 1)); Drop; -- Multiply, give bottom and top halves when '*' => Want(2); FZ_Mult(X => Stack(SP - 1), Y => Stack(SP), XY_Lo => Stack(SP - 1), XY_Hi => Stack(SP)); -- Modular Multiplication when 'M' => Want(3); MustNotZero(Stack(SP)); FZ_Mod_Mul(X => Stack(SP - 2), Y => Stack(SP - 1), Modulus => Stack(SP), Product => Stack(SP - 2)); Drop; Drop; -- Modular Exponentiation when 'X' => Want(3); MustNotZero(Stack(SP)); FZ_Mod_Exp(Base => Stack(SP - 2), Exponent => Stack(SP - 1), Modulus => Stack(SP), Result => Stack(SP - 2)); Drop; Drop; ----------------- -- Bitwise Ops -- ----------------- -- Bitwise-And when '&' => Want(2); FZ_And(X => Stack(SP - 1), Y => Stack(SP), Result => Stack(SP - 1)); Drop; -- Bitwise-Or when '|' => Want(2); FZ_Or(X => Stack(SP - 1), Y => Stack(SP), Result => Stack(SP - 1)); Drop; -- Bitwise-Xor when '^' => Want(2); FZ_Xor(X => Stack(SP - 1), Y => Stack(SP), Result => Stack(SP - 1)); Drop; -- Bitwise-Not (1s-Complement) when '~' => Want(1); FZ_Not(Stack(SP), Stack(SP)); ----------- -- Other -- ----------- -- Push a FZ of RNGolade onto the stack when '?' => Push; FZ_Clear(Stack(SP)); FZ_Random(RNG, Stack(SP)); -- mUx when 'U' => Want(3); FZ_Mux(X => Stack(SP - 2), Y => Stack(SP - 1), Result => Stack(SP - 2), Sel => FZ_NZeroP(Stack(SP))); Drop; Drop; -- Put the Overflow flag on the stack when 'O' => Push; WBool_To_FZ(Flag, Stack(SP)); -- Print the FZ on the top of the stack when '#' => Want(1); Dump(Stack(SP)); Drop; -- Zap (reset) when 'Z' => Zap; -- Quit with Stack Trace when 'Q' => for I in reverse Stack'First + 1 .. SP loop Dump(Stack(I)); end loop; Quit(0); ---------- -- NOPs -- ---------- -- Ops we have not yet spoken of -- do nothing when others => null; end case; end Op_Normal; -- Process a Symbol procedure Op(C : in Character) is begin -- First, see whether we are in a state of nestedness: -- ... in a Comment block: if CommLevel > 0 then case C is when ')' => -- Drop a nesting level: CommLevel := CommLevel - 1; when '(' => -- Add a nesting level: CommLevel := CommLevel + 1; when others => null; -- Other symbols have no effect at all end case; -- ... in a Quote block: elsif QuoteLevel > 0 then case C is when ']' => -- Drop a nesting level: QuoteLevel := QuoteLevel - 1; when '[' => -- Add a nesting level: QuoteLevel := QuoteLevel + 1; when others => null; -- Other symbols have no effect on the level end case; -- If we aren't the mode-exiting ']', print current symbol: if QuoteLevel > 0 then Write_Char(C); end if; --- ... in a ~taken~ Conditional branch: elsif CondLevel > 0 then case C is when '}' => -- Drop a nesting level: CondLevel := CondLevel - 1; -- If we exited the Conditional as a result, -- we push a 1 to trigger the possible 'else' clause: if CondLevel = 0 then Push; WBool_To_FZ(1, Stack(SP)); end if; when '{' => -- Add a nesting level: CondLevel := CondLevel + 1; when others => null; -- Other symbols have no effect on the level end case; else -- This is a Normal Op, so proceed with the normal rules. Op_Normal(C); end if; end Op; -- Current Character C : Character; begin -- Reset the Calculator Zap; -- Process characters until EOF: loop if Read_Char(C) then -- Execute Op: Op(C); -- Advance Odometer Pos := Pos + 1; else Zap; Quit(0); -- if EOF, we're done end if; end loop; end; end FFA_Calc;