------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- 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; -- Control Stack; permits bidirectional motion across the Tape: Control_Stack : array(ControlStack_Range) of Tape_Positions := (others => Tape_Positions'First); -- Current top of the Control Stack: CSP : ControlStack_Range := ControlStack_Range'First; -- Registers: subtype RegNames is Character range 'g' .. 'z'; type RegTables is array(RegNames range <>) of FZ(1 .. Wordness); Registers : RegTables(RegNames'Range); -- Carry/Borrow Flag: Flag : WBool := 0; -- Odometer: Ticks : 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; -- Current Verdict. We run while 'Mu', tape remains, and Ticks under max. Verdict : Peh_Verdicts := Mu; -------------------------------------------------------- -- 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; -- Clear all state, other than blocks, Control Stack, Tape and Verdict: procedure Zap 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; -- Clear all Registers: for r in RegNames'Range loop FFA_FZ_Clear(Registers(r)); end loop; -- Clear Overflow flag: Flag := 0; -- Clear prefix: HavePrefix := False; PrevC := ' '; end Zap; -- 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; -- Jettison all resettable state! Eggog("FATAL: Tick:" & Natural'Image(Ticks) & " IP:" & Tape_Positions'Image(IP) & " : " & S); end E; ------------------- -- Control Stack -- ------------------- -- Push a given Tape Position to the Control Stack: procedure Control_Push(Position : 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 given Tape Position to Control Stack: CSP := CSP + 1; Control_Stack(CSP) := Position; end Control_Push; -- Pop a Tape Position from the Control Stack: function Control_Pop return Tape_Positions is Position : Tape_Positions; begin -- First, test for Underflow of Control Stack: if CSP = Control_Stack'First then E("Control Stack Underflow!"); end if; -- Pop a Tape Position from Control Stack: Position := Control_Stack(CSP); Control_Stack(CSP) := Tape_Positions'First; CSP := CSP - 1; return Position; end Control_Pop; ---------------- -- Data Stack -- ---------------- -- 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; -- Print a Debug Trace (used in 'QD') procedure Print_Trace is begin -- 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) & " :" & Tape_Positions'Image(Control_Stack(i))); Write_Newline; end loop; -- Print All Registers: Write_String("Registers:"); Write_Newline; for r in RegNames'Range loop Write_String(" " & r & " : "); Print_FZ(Registers(r)); end loop; -- Print Ticks and IP: Write_String("Ticks :" & Natural'Image(Ticks)); Write_Newline; Write_String("IP :" & Tape_Positions'Image(IP)); Write_Newline; end Print_Trace; -- 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')); ------------------------- -- Fetch from Register -- ------------------------- when 'g' .. 'z' => Push; Stack(SP) := Registers(C); -- Put value of Register on stack ------------------ -- 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)); -- 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; 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 all resettables) when 'Z' => Zap; -- 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...' | 'L' -- 'Left...' | 'R' -- 'Right...' | 'M' -- 'Modular...' | '$' -- Pop top of Stack into the following Register... => HavePrefix := True; ------------------- -- Control Stack -- ------------------- -- Push current IP (i.e. of THIS Op) to Control Stack. when ':' => Control_Push(IP); -- Conditional Return: 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 Position : Tape_Positions := Control_Pop; begin if FFA_FZ_NZeroP(Stack(SP)) = 1 then IP_Next := Position; end if; end; Drop; -- UNconditional Return: Control Stack top popped into IP_Next. when ';' => IP_Next := Control_Pop; --------------------------------------------------------- -- 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: 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... when 'Q' => -- .. Quit how? case O is -- ... with a 'Yes' Verdict: when 'Y' => 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; --------------------------------------------------------- -- 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); Registers(O) := Stack(SP); 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!"); -- ... 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; -- ... 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 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; -- In all cases, save the current symbol as possible prefix: PrevC := C; end Op; begin -- Reset all resettable state: Zap; -- 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 IP /= Tape_Positions'Last 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. -- We did not halt yet, so select the IP of the next Op to fetch: IP := IP_Next; end loop; -- Warn operator about any unclosed blocks: 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; -- 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 CSP /= Control_Stack'First then Achtung("WARNING: Tape terminated with a non-empty Control Stack!"); end if; -- We're done with the Tape, so clear the state: Zap; -- Return the Verdict: return Verdict; end Peh_Machine; end FFA_Calc;