----------------------------------------------------------------------------- ------------------------------------------------------------------------------ -- This file is part of 'Finite Field Arithmetic', aka 'FFA'. -- -- -- -- (C) 2019 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; -- FFA with FFA; use FFA; -- For the intrinsic equality operator on Words use type FFA.Word; -- For RNG: with FFA_RNG; use FFA_RNG; package body FFA_Calc is -- Ensure that requested Peh Dimensions are permissible. Terminate if not. procedure Validate_Peh_Dimensions(Dimensions : in Peh_Dimensions) is begin -- Test if proposed Width is permissible: if not FFA_FZ_Valid_Bitness_P(Dimensions.Width) then Eggog("Requested Invalid FZ Width, " & FFA_Validity_Rule_Doc); end if; -- Warn the operator if an unbounded Peh run has been requested: if Dimensions.Life = 0 then Achtung("WARNING: Life=0 enables UNBOUNDED run time;" & " halting cannot be guaranteed!"); end if; end Validate_Peh_Dimensions; -- Start a Peh Machine with the given Dimensions and Tape; return a Verdict. function Peh_Machine(Dimensions : in Peh_Dimensions; Tape : in Peh_Tapes; RNG : in RNG_Device) return Peh_Verdicts is -- The number of Words required to make a FZ of the given Bitness. Wordness : Indices := Indices(Dimensions.Width / Bitness); -------------------------------------------------------- -- State -- -------------------------------------------------------- -- The Data Stack: subtype Stack_Positions is Natural range 0 .. Dimensions.Height; type Stacks is array(Stack_Positions range <>) of FZ(1 .. Wordness); Stack : Stacks(Stack_Positions'Range); -- Current top of the Data Stack: SP : Stack_Positions := Stack_Positions'First; -- Valid indices into the Tape: subtype Tape_Positions is Peh_Tape_Range range Tape'First .. Tape'Last; -- Position of the CURRENT Op on the Tape: IP : Tape_Positions; -- After an Op, will contain position of NEXT op (if = to IP -> halt) IP_Next : Tape_Positions; -- Types of Entry for the Control Stack: type Call_Types is (Invalid, Subroutines, Loops); -- Control Stack Entries: type Call is record Why : Call_Types := Invalid; -- Which call type? Ret : Tape_Positions; -- The IP we must return to after it end record; -- Control Stack; permits bidirectional motion across the Tape: Control_Stack : array(ControlStack_Range) of Call; -- Current top of the Control Stack: CSP : ControlStack_Range := ControlStack_Range'First; -- A Segment represents a particular section of Tape, for certain uses. type Segment is record -- The Tape Position of the FIRST Symbol on the Segment: L : Tape_Positions := Tape'First; -- Default: start of the Tape. -- The Tape Position of the LAST Symbol on the Segment: R : Tape_Positions := Tape'Last; -- Default: end of the Tape. end record; -- Subtypes of Segment: subtype Sub_Names is Segment; -- Subroutine Names subtype Sub_Bodies is Segment; -- Subroutine Bodies subtype Cutouts is Segment; -- Cutout (see Ch.18 discussion) -- Represents a Subroutine defined on this Tape: type Sub_Def is record Name : Sub_Names; -- Name of the Subroutine. Payload : Sub_Bodies; -- Body of the Subroutine. end record; -- Subroutine Table. Once defined, Subs may not be erased or altered. Subs : array(Subroutine_Table_Range) of Sub_Def; -- Position of the most recently-defined Subroutine in Subs : STP : Subroutine_Table_Range := Subs'First; -- Registers: subtype RegNames is Character range 'g' .. 'z'; type RegTables is array(RegNames range <>) of FZ(1 .. Wordness); -- Ordinary Register Set (accessed if no Cutout, or when ABOVE it) Registers : RegTables(RegNames'Range); -- 'Cutout' Register Set (accessed only if IP is IN or BELOW the Cutout) CO_Registers : RegTables(RegNames'Range); -- Carry/Borrow Flag set by certain arithmetical Ops: Flag : WBool := 0; -- 'Cutout'-segregated Carry/Borrow Flag: CO_Flag : WBool := 0; -- Odometer: Ticks : Natural := 0; -- The current levels of the three types of nestable Block: QuoteLevel : Natural := 0; CommLevel : Natural := 0; CondLevel : Natural := 0; -- The possible Modes of the reader: type Modes is (Normal, SubName, SubBody, PrefixOp); -- Currently-active reader Mode: Mode : Modes := Normal; -- Current levels of nestable Blocks when reading a Subroutine Body: SubQuoteLevel : Natural := 0; SubCommLevel : Natural := 0; SubCondLevel : Natural := 0; -- Scratch for a Subroutine being proposed for lookup or internment: Proposed_Sub : Sub_Def; -- 'Cutout' Tape Segment. (See Ch.18 discussion re: when and how to use.) -- If the Cutout is armed, it stays armed until Peh halts. Cutout_Begun : Boolean := False; Cutout_Armed : Boolean := False; Cutout : Cutouts; -- Prefix for Prefixed Operators PrevC : Character := ' '; -- Current Verdict. We run while 'Mu', Tape remains, and Ticks under max. Verdict : Peh_Verdicts := Mu; -------------------------------------------------------- ------------ -- Cutout -- ------------ -- Find whether Cutout would prohibit move from current IP to the given : function Cutout_Prohibits(Position : in Tape_Positions) return Boolean is begin return Cutout_Armed and IP > Cutout.R and Position < Cutout.L; end Cutout_Prohibits; -- Find whether given a Tape Position lies inside an armed Cutout: function In_Cutout(Position : in Tape_Positions) return Boolean is begin return Cutout_Armed and Position in Cutout.L .. Cutout.R; end In_Cutout; -- Determine whether to use the Cutout Registers at the current position: function Use_CO_Registers return Boolean is begin -- If we are either BELOW or INSIDE armed Cutout : we use only the -- CO_Registers alternative register file. Otherwise: use Registers. return Cutout_Armed and IP <= Cutout.R; end Use_CO_Registers; ---------- -- Zaps -- ---------- -- Zero the Data Stack and reset the SP: procedure Zap_Data_Stack is begin -- Clear the Data Stack: for i in Stack'Range loop FFA_FZ_Clear(Stack(i)); end loop; -- Set SP to bottom: SP := Stack_Positions'First; end Zap_Data_Stack; -- Zero all Registers (Ordinary set) : procedure Zap_Ordinary_Registers is begin for r in RegNames'Range loop FFA_FZ_Clear(Registers(r)); end loop; end Zap_Ordinary_Registers; -- Zero all Registers (Cutout set) : procedure Zap_Cutout_Registers is begin for r in RegNames'Range loop FFA_FZ_Clear(CO_Registers(r)); end loop; end Zap_Cutout_Registers; -- Zero all Registers in the currently-active Register Set: procedure Zap_Registers is begin if Use_CO_Registers then Zap_Cutout_Registers; else Zap_Ordinary_Registers; end if; end Zap_Registers; -- Zero the currently-active Overflow Flag: procedure Zap_Flag is begin if Use_CO_Registers then CO_Flag := 0; else Flag := 0; end if; end Zap_Flag; -- NO effect on Blocks, Control Stack, Tape, Verdict, Cutout, Subroutines procedure Zap_Master is begin Zap_Data_Stack; Zap_Registers; Zap_Flag; end Zap_Master; ----------- -- Eggog -- ----------- -- Report a fatal error condition at the current Symbol. -- On Unixlikes, this will also end the process and return control to OS. procedure E(S : in String) is begin Zap_Master; -- Jettison all resettable state! Eggog("FATAL: Tick:" & Natural'Image(Ticks) & ", IP:" & Tape_Positions'Image(IP) & ", Symbol: '" & Tape(IP) & "'" & " : " & S); end E; ----------- -- Walls -- ----------- -- Determine whether we are currently at the last Symbol on the Tape: function Last_Tape_Symbol return Boolean is begin return IP = Tape_Positions'Last; end Last_Tape_Symbol; -- Certain Ops are NOT permitted to occur as the final Op on a Tape: function Next_IP_On_Tape return Tape_Positions is begin -- Check if we are in fact on the last Symbol of the Tape: if Last_Tape_Symbol then E("This Op requires a succeeding Tape Position, " & "but it is at the end of the Tape!"); end if; -- ... Otherwise, return the immediate successor Tape Position: return IP + 1; end Next_IP_On_Tape; -- Determine whether we have reached the given limit of Life: function Exhausted_Life return Boolean is -- If Life = 0, we are in "immortal" mode. Otherwise mortal: MustDie : Boolean := (Dimensions.Life /= 0) and (Ticks = Dimensions.Life); begin if MustDie then Achtung("WARNING: Exhausted Life (" & Natural'Image(Ticks) & " ticks )"); end if; return MustDie; end Exhausted_Life; ---------------- -- Data Stack -- ---------------- -- Determine whether the Data Stack is Not Empty: function Data_Stack_Not_Empty return Boolean is begin return SP /= Stack'First; end Data_Stack_Not_Empty; -- Raise the SP up by one: 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 Data Stack: procedure Drop is begin FFA_FZ_Clear(Stack(SP)); SP := SP - 1; end Drop; -- Check whether the Data Stack has the necessary N items: procedure Want(N : in Positive) is begin if SP < N then E("Stack Underflow!"); end if; end Want; --------- -- I/O -- --------- -- Slide a new hex digit into the FZ on top of the Data 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; ------------------ -- Debug Traces -- ------------------ -- Print the bounds of a Tape Segment for Debug: procedure Print_Segment(S : in Segment) is begin Write_String("(" & Tape_Positions'Image(S.L) & "," & Tape_Positions'Image(S.R) & " )"); end Print_Segment; -- Print a Debug Trace (used in 'QD') : procedure Print_Trace is begin -- For clarity in cases where the Tape has already produced output: Write_Newline; -- Print Data Stack Trace: Write_String("Data Stack:"); Write_Newline; for i in reverse Stack'First + 1 .. SP loop Write_String(" " & Stack_Positions'Image(i) & " : "); Print_FZ(Stack(i)); end loop; -- Print Control Stack Trace: Write_String("Control Stack:"); Write_Newline; for i in reverse Control_Stack'First + 1 .. CSP loop Write_String(" " & ControlStack_Range'Image(i) & " :"); Write_String(" Return IP:" & Stack_Positions'Image(Control_Stack(i).Ret)); Write_String(" Call Type: "); case Control_Stack(i).Why is when Subroutines => Write_String("Subroutine"); when Loops => Write_String("Loop"); when others => Write_String("INVALID"); end case; Write_Newline; end loop; -- Print All Registers: Write_String("Registers:"); Write_Newline; -- We will not print the Cutout Register Set unless it is active: for r in RegNames'Range loop if Use_CO_Registers then -- If the Cutout Register Set is currently active: Write_String(" (C)" & r & " : "); Print_FZ(CO_Registers(r)); else -- If the Ordinary Register Set is currently active: Write_String(" " & r & " : "); Print_FZ(Registers(r)); end if; end loop; -- Print Subroutine Table: Write_String("Subroutines:"); Write_Newline; -- Walk the Subroutine Table from first to last valid entry: for i in Subs'First + 1 .. STP loop declare -- The current Sub in the Subroutine Table being examined: S : Sub_Def := Subs(i); -- The Name of the current Sub: S_Name : String := String(Tape(S.Name.L .. S.Name.R)); begin Write_String(" " & Subroutine_Table_Range'Image(i) & " : '" & S_Name & "' "); Print_Segment(S.Payload); if Cutout_Armed then -- Indicate whether Sub is uncallable here because of Cutout: if Cutout_Prohibits(S.Payload.L) then Write_String(" (Guarded)"); -- Indicate whether Sub lies INSIDE the Cutout: elsif In_Cutout(S.Payload.R) then Write_String(" (Cutout)"); end if; end if; Write_Newline; end; end loop; Write_String("Cutout: "); -- Print Cutout bounds, if Cutout is armed: if Cutout_Armed then Write_String("Armed: "); Print_Segment(Cutout); else Write_String("NONE"); end if; Write_Newline; -- Print active Overflow-Flag, then Ticks and IP: if Use_CO_Registers then Write_String("Flag (CO) :" & WBool'Image(CO_Flag)); else Write_String("Flag :" & WBool'Image(Flag)); end if; Write_Newline; Write_String("Ticks :" & Natural'Image(Ticks)); Write_Newline; Write_String("IP :" & Tape_Positions'Image(IP)); Write_Newline; end Print_Trace; ------------------- -- Control Stack -- ------------------- -- Determine whether the Control Stack is Not Empty: function Control_Stack_Not_Empty return Boolean is begin return CSP /= Control_Stack'First; end Control_Stack_Not_Empty; -- Construct a Call and push it to the Control Stack: procedure Control_Push(Call_Type : in Call_Types; Return_IP : in Tape_Positions) is begin -- First, test for Overflow of Control Stack: if CSP = Control_Stack'Last then E("Control Stack Overflow!"); end if; -- Push a Call with given parameters to the Control Stack: CSP := CSP + 1; Control_Stack(CSP) := (Why => Call_Type, Ret => Return_IP); end Control_Push; -- Pop an IP from the Control Stack, and verify expected Call Type: function Control_Pop(Expected_Type : in Call_Types) return Tape_Positions is C : Call; begin -- First, test for Underflow of Control Stack: if CSP = Control_Stack'First then E("Control Stack Underflow!"); end if; -- Pop from Control Stack: C := Control_Stack(CSP); Control_Stack(CSP).Why := Invalid; CSP := CSP - 1; -- Now, see whether it was NOT the expected type. If so, eggog: if C.Why /= Expected_Type then declare CT : constant array(Call_Types) of String(1 .. 10) := (" INVALID ", "Subroutine", "Loop state"); begin E("Currently in a " & CT(C.Why) & "; but this Op exits a " & CT(Expected_Type) & " !"); end; end if; -- ... The Call was of the expected type, so return it: return C.Ret; end Control_Pop; ----------------- -- Subroutines -- ----------------- -- Find Subroutine with supplied Name in Subroutine Table, if it exists: function Lookup_Subroutine(Name : in Sub_Names) return Subroutine_Table_Range is -- Number of Symbols in the Name of the current Proposed Subroutine: Sub_Name_Length : Positive := 1 + Name.R - Name.L; begin -- Enforce minimum Subroutine Name length: if Sub_Name_Length < Subr_Min_Name_Length then E("Proposed Name is" & Positive'Image(Sub_Name_Length) & " Symbols long, but the shortest permitted Name length is" & Positive'Image(Subr_Min_Name_Length) & " !"); end if; -- Walk the Subroutine Table from first to last valid entry: for i in Subs'First + 1 .. STP loop declare -- The current Sub in the Subroutine Table being examined: S : Sub_Def := Subs(i); -- Number of Symbols in the Name of S: S_Name_Length : Positive := 1 + S.Name.R - S.Name.L; begin -- If the lengths of the Names match: if Sub_Name_Length = S_Name_Length then -- If the two Names are actually equal: if Tape(Name.L .. Name.R) = Tape(S.Name.L .. S.Name.R) then return i; -- Return the table index of the located Sub end if; end if; end; end loop; -- Name was not found in Subroutine Table; return the zero position: return Subs'First; end Lookup_Subroutine; -- Attempt to intern the given Subroutine into the Subroutines Table: procedure Intern_Subroutine(Sub : in Sub_Def) is -- Position of the current Proposed Sub in Sub Table: Index : Subroutine_Table_Range := Lookup_Subroutine(Sub.Name); -- To DEFINE a Sub, it must NOT have existed in Sub Table. -- Name of the Proposed Sub (for eggogs) : S_Name : String := String(Tape(Sub.Name.L .. Sub.Name.R)); begin -- If a Sub with this Name already exists, eggog: if Index /= Subs'First then E("Attempted to redefine Subroutine '" & S_Name & "' !"); end if; -- Definitions are prohibited inside Loops or Sub calls: if Control_Stack_Not_Empty then E("Attempted to define Subroutine '" & S_Name & "' while inside a Loop or Subroutine!"); end if; -- If the Subroutine Table is full, eggog: if STP = Subs'Last then E("Cannot define the Subroutine '" & S_Name & ": the Subroutine Table is Full!"); end if; -- Finally, intern the Proposed Subroutine into the Sub Table: STP := STP + 1; Subs(STP) := Sub; end Intern_Subroutine; -- Invoke a given Subroutine: procedure Invoke_Subroutine(Sub : in Sub_Def) is begin -- Push the Call to Control Stack: Control_Push(Call_Type => Subroutines, Return_IP => Next_IP_On_Tape); -- Next instruction will be the first Symbol of the Sub's Body: IP_Next := Sub.Payload.L; end Invoke_Subroutine; -- Attempt to invoke a Subroutine with the supplied name: procedure Invoke_Named_Subroutine(Name : in Sub_Names) is -- Position of the current Proposed Sub in Sub Table: Index : Subroutine_Table_Range := Lookup_Subroutine(Name); -- To invoke a Sub, it MUST exist in the Sub Table. -- Name of the Proposed Sub (for eggogs) : S_Name : String := String(Tape(Name.L .. Name.R)); begin -- If no defined Subroutine has this Name, eggog: if Index = Subs'First then E("Invoked Undefined Subroutine '" & S_Name & "' !"); end if; -- Otherwise, proceed to the invocation: declare -- The Sub Table Entry we successfully looked up: Sub : Sub_Def := Subs(Index); begin -- Recursion is prohibited in Peh Tapes. Detect it: if IP in Sub.Payload.L .. Sub.Payload.R then E("Recursive invocation in Subroutine '" & S_Name & "' is prohibited!"); end if; -- Prohibit Subroutines whose definitions end AFTER the current IP: if IP < Sub.Payload.R then E("Cannot invoke Subroutine '" & S_Name & "' before the position where it is defined!"); end if; -- Proceed to invoke the Subroutine: Invoke_Subroutine(Sub); end; end Invoke_Named_Subroutine; -- Invoke the nearest Subroutine defined to the LEFT of the current IP: procedure Invoke_Left_Subroutine is -- Position of the Subroutine to be invoked (Subs'First if none) Index : Subroutine_Table_Range := Subs'First; begin -- Find the nearest invocable Sub (i.e. to the LEFT of current IP) : -- Walk starting from the LAST Sub in Subs, down to the FIRST: for i in reverse Subs'First + 1 .. STP loop -- If a Sub's definition ended PRIOR TO the current IP: if Subs(i).Payload.R < IP then -- Save that Sub's table index: Index := i; -- If we found a Sub that met the condition, stop walking: exit when Index /= Subs'First; end if; end loop; -- If no Subs have been defined prior to current IP, then eggog: if Index = Subs'First then E("No Subroutines were defined prior to this position!"); end if; -- Proceed to invoke the selected Sub: Invoke_Subroutine(Subs(Index)); end Invoke_Left_Subroutine; --------- -- Peh -- --------- -- For all Ops which entail Division: 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; ------------------------------------------------------------------------ -- Execute a Normal Op procedure Op_Normal(C : in Character) is -- Over/underflow output from certain ops F : Word; begin case C is ------------ -- Blocks -- ------------ -- Enter Comment Block: Symbols will be ignored until matching ')' when '(' => CommLevel := 1; -- Exit a Comment Block (but if we're here, we aren't in one!) when ')' => E("Mismatched close-comment parenthesis !"); -- Enter a Quote Block: Symbols will print until matching ']' when '[' => QuoteLevel := 1; -- Exit a Quote Block (but if we're here, we aren't in one!) when ']' => E("Mismatched close-quote bracket !"); -- Enter a Conditional branch: when '{' => Want(1); if FFA_FZ_ZeroP(Stack(SP)) = 1 then -- Enter a 'taken' branch. -- All subsequent Symbols will be ignored until matching '}'. 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')); ------------------------- -- Fetch from Register -- ------------------------- when 'g' .. 'z' => -- Put value of Register on stack Push; if Use_CO_Registers then Stack(SP) := CO_Registers(C); -- use Cutout Register set else Stack(SP) := Registers(C); -- use ordinary set end if; ------------------ -- 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); -- If we are in the Cutout, write the CO_Flag instead of Flag: if Use_CO_Registers then CO_Flag := FFA_Word_NZeroP(F); else Flag := FFA_Word_NZeroP(F); end if; Drop; -- Add when '+' => Want(2); FFA_FZ_Add(X => Stack(SP - 1), Y => Stack(SP), Sum => Stack(SP - 1), Overflow => F); -- If we are in the Cutout, write the CO_Flag instead of Flag: if Use_CO_Registers then CO_Flag := FFA_Word_NZeroP(F); else Flag := FFA_Word_NZeroP(F); end if; 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)); -- 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)); -- Greatest Common Divisor (GCD) when 'G' => Want(2); -- Note that GCD(0,0) is not factually zero, or unique. -- But it is permissible to define it as zero. -- (See Ch. 15 discussion.) FFA_FZ_Greatest_Common_Divisor(X => Stack(SP - 1), Y => Stack(SP), Result => Stack(SP - 1)); Drop; ----------------- -- 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; -- If we are in the Cutout, read CO_Flag instead of Flag: if Use_CO_Registers then FFA_WBool_To_FZ(CO_Flag, Stack(SP)); else FFA_WBool_To_FZ(Flag, Stack(SP)); end if; -- Print the FZ on the top of the stack when '#' => Want(1); Print_FZ(Stack(SP)); Drop; -- Put the Peh Program Version on the stack, -- followed by FFA Program Version. when 'V' => Push; Push; -- Peh Version: FFA_FZ_Clear(Stack(SP - 1)); FFA_FZ_Set_Head(Stack(SP - 1), Word(Peh_K_Version)); -- FFA Version: FFA_FZ_Clear(Stack(SP)); FFA_FZ_Set_Head(Stack(SP), Word(FFA_K_Version)); -- Constant-Time Miller-Rabin Test on N using the given Witness. -- Witness will be used as-is if it conforms to the valid range, -- i.e. 2 <= Witness <= N - 2; else will be transformed into a -- valid Witness via modular arithmetic. -- Outputs ONE if N WAS FOUND composite; ZERO if NOT FOUND. -- Handles degenerate cases of N that M-R per se cannot eat: -- N=0, N=1: ALWAYS 'FOUND COMPOS.'; 2, 3 - ALWAYS 'NOT FOUND'. -- If N is Even and not equal to 2, N is ALWAYS 'FOUND COMPOS.' -- For ALL other N, the output is equal to that of the M-R test. -- At most 1/4 of all possible Witnesses will be 'liars' for -- a particular composite N , i.e. fail to attest to its -- compositivity. when 'P' => Want(2); declare MR_Result : WBool := FFA_FZ_MR_Composite_On_Witness(N => Stack(SP - 1), Witness => Stack(SP)); begin FFA_WBool_To_FZ(MR_Result, Stack(SP - 1)); end; Drop; -------------- -- Prefixes -- -------------- when 'Q' -- 'Quit...' | 'Z' -- 'Zap...' | 'L' -- 'Left...' | 'R' -- 'Right...' | 'M' -- 'Modular...' | '$' -- Pop top of Stack into the following Register... => -- Set the Prefixed Op Mode. Next Symbol is treated as prefixed: Mode := PrefixOp; ----------- -- Loops -- ----------- -- Begin Loop: Push IP (i.e. of THIS Op) to Control Stack. when ':' => Control_Push(Call_Type => Loops, Return_IP => IP); -- Conditional End Loop: Pop top of Stack, and... -- ... if ZERO: simply discard the top of the Control Stack. -- ... if NONZERO: pop top of Control Stack and make it next IP. when ',' => Want(1); declare Loop_Position : Tape_Positions := Control_Pop(Loops); Trigger : WBool := FFA_FZ_NZeroP(Stack(SP)); begin -- If Trigger is active, re-enter the Loop: if Trigger = 1 then IP_Next := Loop_Position; end if; end; -- ... otherwise, continue normally. Drop; ----------------- -- Subroutines -- ----------------- -- Return from a Subroutine: when ';' => -- Next instruction will be at the saved Return Position: IP_Next := Control_Pop(Subroutines); -- Indicate the start of a Subroutine Name, e.g. @SubName -- ... if DEFINING a NEW Subroutine: is followed by @body; -- ... if INVOKING EXISTING Subroutine: is followed by ! when '@' => -- Save the NEXT IP as the first Symbol of the proposed Name: Proposed_Sub.Name.L := Next_IP_On_Tape; -- Enter the Name mode: Mode := SubName; -- We will remain in Name mode until we see a @ or ! . -- '!' invokes a previously-defined Subroutine: -- ... If found after @Name was given, the syntax is: @SubName! -- ... If found in THIS context, with no @Name , then invokes -- the nearest Subroutine defined to the LEFT of this IP. -- NO Sub defined to the RIGHT of the current IP may be invoked. when '!' => Invoke_Left_Subroutine; --------------------------------------------------------- -- Reserved Ops, i.e. ones we have not defined yet: -- --------------------------------------------------------- when 'H' | 'I' | 'J' | 'K' | 'N' | 'T' | 'X' | 'Y' => E("This Operator is not defined yet: " & C); --------------------------------------------------------- ---------- -- NOPs -- ---------- -- Unprintables and spaces DO NOTHING. -- (However: they occupy space, consume Life, clear Prefix.) when others => null; end case; end Op_Normal; ------------------------------------------------------------------------ -- Execute a Prefixed Op procedure Op_Prefixed(Prefix : in Character; O : in Character) is -- Report an attempt to execute an undefined Prefix Op: procedure Undefined_Prefix_Op is begin E("Undefined Prefix Op: '" & Prefix & O & "'"); end Undefined_Prefix_Op; begin -- Which Prefix Op? case Prefix is --------------------------------------------------------- -- Quit... (See Ch. 17 discussion) when 'Q' => -- .. Quit how? case O is -- ... with a 'Yes' Verdict: when 'Y' => -- Prohibited from within a loop or Subroutine: if Control_Stack_Not_Empty then E("Attempted to proclaim a 'Yes' Verdict" & " inside a Loop or Subroutine!"); end if; Verdict := Yes; -- ... with a 'No' Verdict: when 'N' => Verdict := No; -- ... with a 'Mu' Verdict: (permitted, but discouraged) when 'M' => IP_Next := IP; -- Force a 'Mu' Termination -- ... with Debug Trace, and a 'Mu' Verdict: when 'D' => Print_Trace; IP_Next := IP; -- Force a 'Mu' Termination -- ... with an explicit Tape-triggered fatal EGGOG! -- The 'QE' curtain call is intended strictly to signal -- catastrophic (e.g. iron) failure from within a Tape -- program ('cosmic ray' scenario) where a ~hardwired -- mechanism~ of any kind appears to have done something -- unexpected; or to abort on a failed test of the RNG; -- or similar hard-stop scenarios, where either physical -- iron, or basic FFA routine must be said to have failed, -- and the continued use of the system itself - dangerous. -- The use of 'QE' for any other purpose is discouraged; -- please do not use it to indicate failed decryption etc. when 'E' => -- Hard-stop with this eggog: E("Tape-triggered CATASTROPHIC ERROR! " & "Your iron and/or your build of Peh, " & "may be defective! Please consult " & "the author of this Tape."); -- ... Unknown (Eggog): when others => Undefined_Prefix_Op; end case; --------------------------------------------------------- -- Zap... when 'Z' => -- .. Zap what? case O is -- ... Registers: when 'R' => -- If in Cutout, will zap only Cutout set of regs Zap_Registers; -- ... Data Stack: when 'D' => Zap_Data_Stack; -- ... Overflow Flag (if in Cutout, zaps CO_Flag) : when 'F' => Zap_Flag; -- ... All Zappable State: when 'A' => Zap_Master; when others => Undefined_Prefix_Op; end case; --------------------------------------------------------- -- Write into Register... when '$' => -- Eggog if operator gave us a garbage Register name: if O not in RegNames then E("There is no Register '" & O & "' !"); end if; -- Selected Register exists; move top FZ on stack into it: Want(1); if Use_CO_Registers then CO_Registers(O) := Stack(SP); -- use Cutout Register set else Registers(O) := Stack(SP); -- use ordinary set end if; Drop; --------------------------------------------------------- -- 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!"); -- ... 'Cutout' : -- Mark the LEFT SIDE of the 'Cutout' Tape segment; -- The Tape IN OR PRIOR to it will retain the ability to -- move directly into points PRIOR to THIS position -- on the Tape (i.e. where THIS Op had executed). -- Ops on Tape AFTER 'RC' mark can move INTO Cutout, -- but NOT directly into any position PRIOR to it. -- If 'LC' is executed, a 'RC' MUST occur before Tape end. -- FATAL if a 'LC' or 'RC' Op had previously executed. when 'C' => -- Eggog if we have ALREADY begun the Cutout somewhere: if Cutout_Begun then E("'LC' Op may only execute ONCE on a Tape!"); end if; -- Cutout defs are prohibited inside loops or Sub calls: if Control_Stack_Not_Empty then E("Attempted to execute 'LC' (Left-Cutout)" & " inside a Loop or Subroutine!"); end if; -- Set the START of the Cutout, and mark it 'begun': Cutout_Begun := True; Cutout.L := IP; -- ... Unknown (Eggog): when others => Undefined_Prefix_Op; 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!"); -- 'Right-Multiply', give only lower half of the product XY when '*' => Want(2); FFA_FZ_Low_Multiply(X => Stack(SP - 1), Y => Stack(SP), XY => Stack(SP - 1)); Drop; -- ... 'Cutout' : -- Mark the RIGHT SIDE of the 'Cutout' Tape segment that -- began with 'LC', and permanently arms the Cutout. -- After THIS position, no IP_Next may be set which -- directly transfers control to a point PRIOR to 'LC'. -- FATAL if no 'LC' had executed to mark the LEFT SIDE. when 'C' => -- Eggog if we never marked the beginning with 'LC': if not Cutout_Begun then E("'RC' Op found, but no there was no prior 'LC' !"); end if; -- Eggog if we have already armed the Cutout: if Cutout_Armed then E("'RC' Op found, but the Cutout is already armed!"); end if; -- Cutout defs are prohibited inside loops or Sub calls: if Control_Stack_Not_Empty then E("Attempted to execute 'RC' (Right-Cutout)" & " inside a Loop or Subroutine!"); end if; -- Otherwise proceed to complete and arm the Cutout: Cutout.R := IP; Cutout_Armed := True; -- ... Unknown (Eggog): when others => Undefined_Prefix_Op; end case; --------------------------------------------------------- -- Modular... when 'M' => -- Which M-op? case O is -- ... Multiplication (Conventional) : 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; -- ... Squaring (Conventional) : when 'S' => Want(2); MustNotZero(Stack(SP)); FFA_FZ_Modular_Square(X => Stack(SP - 1), Modulus => Stack(SP), Product => Stack(SP - 1)); Drop; -- ... Exponentiation (Barrettronic) : 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 (Eggog): when others => Undefined_Prefix_Op; end case; --------------------------------------------------------- -- ... Unknown: (impossible per mechanics, but must handle case) when others => E("Undefined Prefix: " & Prefix); end case; end Op_Prefixed; ------------------------------------------------------------------------ -- Process a character in a proposed Subroutine Name: procedure SubName_Symbol(C : in Character) is begin case C is -- Attempt to INVOKE the named Subroutine: when '!' => -- Detect attempt to invoke a Sub with no Name: if IP = Proposed_Sub.Name.L then E("Attempted to invoke a nameless Subroutine!"); end if; -- Exit the Sub Name mode and enter Normal mode: Mode := Normal; -- Attempt to invoke the subroutine: Invoke_Named_Subroutine(Proposed_Sub.Name); -- Attempt to read a body for a Subroutine Definition: when '@' => -- Detect attempt to define a Sub with no Name: if IP = Proposed_Sub.Name.L then E("Attempted to define a nameless Subroutine!"); end if; -- Save NEXT IP as the beginning of the proposed Body: Proposed_Sub.Payload.L := Next_IP_On_Tape; -- Exit the Name mode and enter Sub Body mode: Mode := SubBody; -- Any permissible Symbol in a Subroutine Name: when '0' .. '9' | 'A' .. 'Z' | 'a' .. 'z' | '-' | '_' => -- Save IP as the potential end of the proposed Sub Name: Proposed_Sub.Name.R := IP; when others => E("Symbol '" & C & "' is prohibited in a Subroutine Name !"); end case; end SubName_Symbol; ------------------------------------------------------------------------ -- Process a character in a proposed Subroutine Body: procedure SubBody_Symbol(C : in Character) is -- Name of Proposed Subroutine (for eggogs) : Name : String := String(Tape(Proposed_Sub.Name.L .. Proposed_Sub.Name.R)); begin case C is -- Subroutine Terminator: when ';' => -- Only takes effect if NOT in a Comment or Quote Block: if SubCommLevel = 0 and SubQuoteLevel = 0 then if SubCondLevel /= 0 then E("Conditional Return in Subroutine: '" & Name & "' is Prohibited!" & " (Please check for unbalanced '{'.)'"); end if; -- Now, Sub-Comm, Quote, and Cond levels are 0. -- The ';' becomes last Symbol of the new Sub's Body. -- Test for attempt to define a Sub with a null Body: if IP = Proposed_Sub.Payload.L then E("Null Body in Subroutine: '" & Name & "' is prohibited!"); end if; -- Intern this new Sub definition: Proposed_Sub.Payload.R := IP; -- Exit the Sub Body mode and enter Normal mode: Mode := Normal; -- Attempt to intern the Proposed Subroutine: Intern_Subroutine(Proposed_Sub); end if; -- Begin-Comment inside a Subroutine Body: when '(' => SubCommLevel := SubCommLevel + 1; -- End-Comment inside a Subroutine Body: when ')' => -- If cannot drop Sub Comment level: if SubCommLevel = 0 then E("Unbalanced ')' in Body of Subroutine: '" & Name & "' !"); end if; SubCommLevel := SubCommLevel - 1; -- Begin-Quote inside a Subroutine Body: when '[' => -- Ignore if Commented: if SubCommLevel = 0 then SubQuoteLevel := SubQuoteLevel + 1; end if; -- End-Quote inside a Subroutine Body: when ']' => -- Ignore if Commented: if SubCommLevel = 0 then -- If cannot drop Sub Quote level: if SubQuoteLevel = 0 then E("Unbalanced ']' in Body of Subroutine: '" & Name & "' !"); end if; SubQuoteLevel := SubQuoteLevel - 1; end if; -- Begin-Conditional inside a Subroutine Body: when '{' => -- Ignore if Commented or Quoted: if SubCommLevel = 0 and SubQuoteLevel = 0 then SubCondLevel := SubCondLevel + 1; end if; -- End-Conditional inside a Subroutine Body: when '}' => -- Ignore if Commented or Quoted: if SubCommLevel = 0 and SubQuoteLevel = 0 then -- If cannot drop Sub Conditional level: if SubCondLevel = 0 then E("Unbalanced '}' in Body of Subroutine: '" & Name & "' !"); end if; SubCondLevel := SubCondLevel - 1; end if; -- All other Symbols have no special effect in Sub Body : when others => null; -- Stay in Body mode until we see the ';'. end case; end SubBody_Symbol; ------------------------------------------------------------------------ -- All Peh Symbols begin their processing here : procedure Op(C : in Character) is begin -- See whether we are inside a 'Block' : -- ... 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; else --- ... we are not inside a 'Block' : case Mode is --- ... a character in a proposed Subroutine Name: when SubName => SubName_Symbol(C); --- ... a character in a proposed Subroutine Body: when SubBody => SubBody_Symbol(C); --- ... the second character of a Prefixed Op: when PrefixOp => -- Drop prefix-op hammer, until another prefix-op cocks it: Mode := Normal; -- Dispatch this op, where prefix is the preceding character Op_Prefixed(Prefix => PrevC, O => C); -- This is a Normal Op... when Normal => -- ... so proceed with the normal rules: Op_Normal(C); -- Save the current Symbol as a possible prefix: PrevC := C; end case; end if; end Op; ------------------------------------------------------------------------ ----------------------------- -- Start of Tape Execution -- ----------------------------- begin -- Reset all resettable state: Zap_Master; Zap_Cutout_Registers; -- Execution begins with the first Op on the Tape: IP := Tape_Positions'First; loop -- If current Op is NOT the last Op on the Tape: if not Last_Tape_Symbol then -- ... then default successor of the current Op is the next one: IP_Next := IP + 1; else -- ... but if no 'next' Op exists, or quit-with-Mu, we stay put: IP_Next := IP; -- ... this will trigger an exit from the loop. end if; -- Advance Odometer for every Op (incl. prefixes, in comments, etc) : Ticks := Ticks + 1; -- Execute the Op at the current IP: Op(Tape(IP)); -- Halt when... exit when Verdict /= Mu or -- Got a Verdict, or... IP_Next = IP or -- Reached the end of the Tape, or... Exhausted_Life; -- Exhausted Life. -- If the Cutout has been armed on this Tape, then enforce it: if Cutout_Prohibits(IP_Next) then E("Attempted movement to IP:" & Tape_Positions'Image(IP_Next) & " violates the Cutout!"); end if; -- We did not halt yet, so select the IP of the next Op to fetch: IP := IP_Next; end loop; -- At this point, the Tape has halted. ------------------------------------------------------------------ -- Termination in a Mode other than 'Normal' triggers a Eggog Verdict: case Mode is -- Unclosed Subroutine Name at Tape's End: when SubName => E("The Subroutine Name at IP:" & Tape_Positions'Image(Proposed_Sub.Name.L) & " is Unterminated!"); -- Unclosed Subroutine Body at Tape's End: when SubBody => E("The Body of Subroutine: '" & String(Tape(Proposed_Sub.Name.L .. Proposed_Sub.Name.R)) & "' is Unterminated!"); -- Incomplete Prefix Op at Tape's End: when PrefixOp => E("Prefix Op: '" & PrevC & "' is Unterminated at End of Tape!"); -- This is the expected Mode at Tape's End: when Normal => null; end case; -- Unclosed Cutout triggers a Eggog Verdict: if Cutout_Begun and not Cutout_Armed then E("The Cutout declaration 'LC' at IP:" & Tape_Positions'Image(Cutout.L) & " is Unterminated!"); end if; ------------------------------------------------------------------ -- The following types of Unclosed Blocks trigger a Warning: if CommLevel > 0 then Achtung("WARNING: Tape terminated with an unclosed Comment!"); end if; if QuoteLevel > 0 then Achtung("WARNING: Tape terminated with an unclosed Quote!"); end if; if CondLevel > 0 then Achtung("WARNING: Tape terminated with an unclosed Conditional!"); end if; ------------------------------------------------------------------ -- Non-empty stacks, after Tape has halted, also trigger a Warning: -- Warn operator if we terminated with a non-empty Control Stack. -- This situation ought to be considered poor style in a Peh Tape; -- for clarity, Verdicts should be returned from a place near -- the visually-apparent end of a Tape. However, this is not mandatory. if Control_Stack_Not_Empty then Achtung("WARNING: Tape terminated inside a Loop or Subroutine!"); end if; -- Warn operator if we terminated with a non-empty Data Stack: if Data_Stack_Not_Empty then Achtung("WARNING: Tape terminated with a non-empty Data Stack!"); end if; ------------------------------------------------------------------ -- We're done with the Tape and any Warnings, so clear the state: Zap_Master; Zap_Cutout_Registers; -- Return the Verdict: return Verdict; end Peh_Machine; end FFA_Calc;