------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- This file is part of 'Finite Field Arithmetic', aka 'FFA'. -- -- -- -- (C) 2018 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 Version; use Version; with OS; use OS; with CmdLine; use CmdLine; -- FFA with FFA; use FFA; -- For the intrinsic equality operator on Words use type FFA.Word; -- 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 FFA_FZ_Valid_Bitness_P(Width) then Eggog("Invalid Width: " & FFA_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; -- Prefixed Operators PrevC : Character := ' '; HavePrefix : Boolean := False; -------------------------------------------------------- -- Clear the stack and set SP to bottom. procedure Zap is begin -- Clear the stack for i in Stack'Range loop FFA_FZ_Clear(Stack(i)); end loop; -- Set SP to bottom SP := Stack_Positions'First; -- Clear Overflow flag Flag := 0; -- Clear prefix HavePrefix := False; PrevC := ' '; 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 FFA_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 FFA_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(Digit : in Nibble) is Overflow : WBool := 0; begin -- Insert the given nibble, and detect any overflow: FFA_FZ_Insert_Bottom_Nibble(N => Stack(SP), D => Digit, Overflow => Overflow); -- Constants which exceed the Width are forbidden: if Overflow = 1 then E("Constant Exceeds Bitness!"); end if; end; -- Emit an ASCII representation of N to the terminal procedure Print_FZ(N : in FZ) is S : String(1 .. FFA_FZ_ASCII_Length(N)); -- Mandatorily, exact size begin FFA_FZ_To_Hex_String(N, S); -- Convert N to ASCII hex Write_String(S); -- Print the result to stdout Write_Newline; -- Print newline, for clarity. end Print_FZ; -- Denote that the given op is a prefix procedure IsPrefix is begin HavePrefix := True; end IsPrefix; -- 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 FFA_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; FFA_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(Character'Pos(C) - Character'Pos('0')); when 'A' .. 'F' => Want(1); Ins_Hex_Digit(10 + Character'Pos(C) - Character'Pos('A')); when 'a' .. 'f' => Want(1); Ins_Hex_Digit(10 + Character'Pos(C) - Character'Pos('a')); ------------------ -- Stack Motion -- ------------------ -- Push a 0 onto the stack when '.' => Push; FFA_FZ_Clear(Stack(SP)); -- Dup when '"' => Want(1); Push; Stack(SP) := Stack(SP - 1); -- Drop when '_' => Want(1); Drop; -- Swap when ''' => Want(2); FFA_FZ_Swap(Stack(SP), Stack(SP - 1)); -- Over when '`' => Want(2); Push; Stack(SP) := Stack(SP - 2); ---------------- -- Predicates -- ---------------- -- Equality when '=' => Want(2); FFA_WBool_To_FZ(FFA_FZ_EqP(X => Stack(SP), Y => Stack(SP - 1)), Stack(SP - 1)); Drop; -- Less-Than when '<' => Want(2); FFA_WBool_To_FZ(FFA_FZ_LessThanP(X => Stack(SP - 1), Y => Stack(SP)), Stack(SP - 1)); Drop; -- Greater-Than when '>' => Want(2); FFA_WBool_To_FZ(FFA_FZ_GreaterThanP(X => Stack(SP - 1), Y => Stack(SP)), Stack(SP - 1)); Drop; ---------------- -- Arithmetic -- ---------------- -- Subtract when '-' => Want(2); FFA_FZ_Subtract(X => Stack(SP - 1), Y => Stack(SP), Difference => Stack(SP - 1), Underflow => F); Flag := FFA_Word_NZeroP(F); Drop; -- Add when '+' => Want(2); FFA_FZ_Add(X => Stack(SP - 1), Y => Stack(SP), Sum => Stack(SP - 1), Overflow => F); Flag := FFA_Word_NZeroP(F); Drop; -- Divide and give Quotient and Remainder when '\' => Want(2); MustNotZero(Stack(SP)); FFA_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)); FFA_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)); FFA_FZ_Mod(Dividend => Stack(SP - 1), Divisor => Stack(SP), Remainder => Stack(SP - 1)); Drop; -- Multiply, give bottom and top halves when '*' => Want(2); FFA_FZ_Multiply(X => Stack(SP - 1), Y => Stack(SP), XY_Lo => Stack(SP - 1), XY_Hi => Stack(SP)); ----------------- -- Bitwise Ops -- ----------------- -- Bitwise-And when '&' => Want(2); FFA_FZ_And(X => Stack(SP - 1), Y => Stack(SP), Result => Stack(SP - 1)); Drop; -- Bitwise-Or when '|' => Want(2); FFA_FZ_Or(X => Stack(SP - 1), Y => Stack(SP), Result => Stack(SP - 1)); Drop; -- Bitwise-Xor when '^' => Want(2); FFA_FZ_Xor(X => Stack(SP - 1), Y => Stack(SP), Result => Stack(SP - 1)); Drop; -- Bitwise-Not (1s-Complement) when '~' => Want(1); FFA_FZ_Not(Stack(SP), Stack(SP)); ----------- -- Other -- ----------- -- Push a FZ of RNGolade onto the stack when '?' => Push; FFA_FZ_Clear(Stack(SP)); FZ_Random(RNG, Stack(SP)); -- mUx when 'U' => Want(3); FFA_FZ_Mux(X => Stack(SP - 2), Y => Stack(SP - 1), Result => Stack(SP - 2), Sel => FFA_FZ_NZeroP(Stack(SP))); Drop; Drop; -- Find the position of eldest nonzero bit, if any exist when 'W' => Want(1); declare -- Find the measure ( 0 if no 1s, or 1 .. FZBitness ) Measure : FZBit_Index := FFA_FZ_Measure(Stack(SP)); begin -- Put on top of stack FFA_FZ_Clear(Stack(SP)); FFA_FZ_Set_Head(Stack(SP), Word(Measure)); end; -- Put the Overflow flag on the stack when 'O' => Push; FFA_WBool_To_FZ(Flag, Stack(SP)); -- Print the FZ on the top of the stack when '#' => Want(1); Print_FZ(Stack(SP)); Drop; -- Zap (reset) when 'Z' => Zap; -- Quit with Stack Trace when 'Q' => for I in reverse Stack'First + 1 .. SP loop Print_FZ(Stack(I)); end loop; Quit(0); -- Put the FFACalc Program Version on the stack, -- followed by FFA Program Version. when 'V' => Push; Push; -- FFACalc Version: FFA_FZ_Clear(Stack(SP - 1)); FFA_FZ_Set_Head(Stack(SP - 1), Word(FFACalc_K_Version)); -- FFA Version: FFA_FZ_Clear(Stack(SP)); FFA_FZ_Set_Head(Stack(SP), Word(FFA_K_Version)); -- Square, give bottom and top halves when 'S' => Want(1); Push; FFA_FZ_Square(X => Stack(SP - 1), XX_Lo => Stack(SP - 1), XX_Hi => Stack(SP)); -------------- -- Prefixes -- -------------- -- 'Left...' : when 'L' => IsPrefix; -- 'Right...' : when 'R' => IsPrefix; -- 'Modular...' : when 'M' => IsPrefix; --------------------------------------------------------- -- Reserved Ops, i.e. ones we have not defined yet: -- --------------------------------------------------------- when '!' | '@' | '$' | ':' | ';' | ',' | 'G' | 'H' | 'I' | 'J' | 'K' | 'N' | 'P' | 'T' | 'X' | 'Y' => E("This Operator is not defined yet: " & C); --------------------------------------------------------- ---------- -- NOPs -- ---------- -- Unprintables and spaces DO NOTHING: when others => null; end case; end Op_Normal; -- Execute a Prefixed Op procedure Op_Prefixed(Prefix : in Character; O : in Character) is begin -- The Prefixed Op: case Prefix is --------------------------------------------------------- -- Left... when 'L' => -- Which L-op? case O is -- ... Shift : when 'S' => Want(2); declare -- Number of bit positions to shift by: ShiftCount : FZBit_Index := FZBit_Index(FFA_FZ_Get_Head(Stack(SP))); begin FFA_FZ_Quiet_ShiftLeft(N => Stack(SP - 1), ShiftedN => Stack(SP - 1), Count => ShiftCount); end; Drop; -- ... Rotate : when 'R' => E("Left-Rotate not yet defined!"); -- ... Unknown: when others => E("Undefined Op: L" & O); end case; --------------------------------------------------------- -- Right... when 'R' => -- Which R-op? case O is -- ... Shift: when 'S' => Want(2); declare -- Number of bit positions to shift by: ShiftCount : FZBit_Index := FZBit_Index(FFA_FZ_Get_Head(Stack(SP))); begin FFA_FZ_Quiet_ShiftRight(N => Stack(SP - 1), ShiftedN => Stack(SP - 1), Count => ShiftCount); end; Drop; -- ... Rotate: when 'R' => E("Right-Rotate not yet defined!"); -- ... Unknown: when others => E("Undefined Op: R" & O); end case; --------------------------------------------------------- -- Modular... when 'M' => -- Which M-op? case O is -- ... Multiplication : when '*' => Want(3); MustNotZero(Stack(SP)); FFA_FZ_Modular_Multiply(X => Stack(SP - 2), Y => Stack(SP - 1), Modulus => Stack(SP), Product => Stack(SP - 2)); Drop; Drop; -- ... Exponentiation : when 'X' => Want(3); MustNotZero(Stack(SP)); FFA_FZ_Modular_Exponentiate(Base => Stack(SP - 2), Exponent => Stack(SP - 1), Modulus => Stack(SP), Result => Stack(SP - 2)); Drop; Drop; -- ... Unknown: when others => E("Undefined Op: M" & O); end case; --------------------------------------------------------- -- ... Unknown: (impossible per mechanics, but must handle case) when others => E("Undefined Prefix: " & Prefix); end case; end Op_Prefixed; -- 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; FFA_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; --- ... if in a prefixed op: elsif HavePrefix then -- Drop the prefix-op hammer, until another prefix-op cocks it HavePrefix := False; -- Dispatch this op, where prefix is the preceding character Op_Prefixed(Prefix => PrevC, O => C); 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; -- Save the op for use in prefixed ops PrevC := C; else Zap; Quit(0); -- if EOF, we're done end if; end loop; end; end FFA_Calc;