ffa_ch4_ffacalc.kv

raw
ffa_ch4_ffacalc.kv      1 ------------------------------------------------------------------------------
ffa_ch4_ffacalc.kv      2 ------------------------------------------------------------------------------
ffa_ch4_ffacalc.kv      3 -- This file is part of 'Finite Field Arithmetic', aka 'FFA'.               --
ffa_ch4_ffacalc.kv      4 --                                                                          --
ffa_ch4_ffacalc.kv      5 -- (C) 2017 Stanislav Datskovskiy ( www.loper-os.org )                      --
ffa_ch4_ffacalc.kv      6 -- http://wot.deedbot.org/17215D118B7239507FAFED98B98228A001ABFFC7.html     --
ffa_ch4_ffacalc.kv      7 --                                                                          --
ffa_ch4_ffacalc.kv      8 -- You do not have, nor can you ever acquire the right to use, copy or      --
ffa_ch4_ffacalc.kv      9 -- distribute this software ; Should you use this software for any purpose, --
ffa_ch4_ffacalc.kv     10 -- or copy and distribute it to anyone or in any manner, you are breaking   --
ffa_ch4_ffacalc.kv     11 -- the laws of whatever soi-disant jurisdiction, and you promise to         --
ffa_ch4_ffacalc.kv     12 -- continue doing so for the indefinite future. In any case, please         --
ffa_ch4_ffacalc.kv     13 -- always : read and understand any software ; verify any PGP signatures    --
ffa_ch4_ffacalc.kv     14 -- that you use - for any purpose.                                          --
ffa_ch4_ffacalc.kv     15 --                                                                          --
ffa_ch4_ffacalc.kv     16 -- See also http://trilema.com/2015/a-new-software-licensing-paradigm .     --
ffa_ch4_ffacalc.kv     17 ------------------------------------------------------------------------------
ffa_ch4_ffacalc.kv     18 ------------------------------------------------------------------------------
ffa_ch4_ffacalc.kv     19 
ffa_ch4_ffacalc.kv     20 -- Basics
ffa_ch4_ffacalc.kv     21 with OS;          use OS;
ffa_ch4_ffacalc.kv     22 with CmdLine;     use CmdLine;
ffa_ch4_ffacalc.kv     23 
ffa_ch4_ffacalc.kv     24 -- FFA
ffa_ch4_ffacalc.kv     25 with FZ_Lim;   use FZ_Lim;
ffa_ch4_ffacalc.kv     26 with Words;    use Words;
ffa_ch4_ffacalc.kv     27 with W_Pred;   use W_Pred;
ffa_ch4_ffacalc.kv     28 with FZ_Type;  use FZ_Type;
ffa_ch4_ffacalc.kv     29 with FZ_Basic; use FZ_Basic;
ffa_ch4_ffacalc.kv     30 with FZ_Arith; use FZ_Arith;
ffa_ch4_ffacalc.kv     31 with FZ_Cmp;   use FZ_Cmp;
ffa_ch4_ffacalc.kv     32 with FZ_Pred;  use FZ_Pred;
ffa_ch4_ffacalc.kv     33 with FZ_BitOp; use FZ_BitOp;
ffa_ch4_ffacalc.kv     34 with FZ_Shift; use FZ_Shift;
ffa_ch4_ffacalc.kv     35 
ffa_ch4_ffacalc.kv     36 -- For Output
ffa_ch4_ffacalc.kv     37 with FFA_IO;   use FFA_IO;
ffa_ch4_ffacalc.kv     38 
ffa_ch4_ffacalc.kv     39 
ffa_ch4_ffacalc.kv     40 procedure FFA_Calc is
ffa_ch4_ffacalc.kv     41    
ffa_ch4_ffacalc.kv     42    Width  : Positive; -- Desired FFA Width
ffa_ch4_ffacalc.kv     43    Height : Positive; -- Desired Height of Stack
ffa_ch4_ffacalc.kv     44    
ffa_ch4_ffacalc.kv     45 begin
ffa_ch4_ffacalc.kv     46    if Arg_Count /= 3 then
ffa_ch4_ffacalc.kv     47       Eggog("Usage: ./ffa_calc WIDTH HEIGHT");
ffa_ch4_ffacalc.kv     48    end if;
ffa_ch4_ffacalc.kv     49    
ffa_ch4_ffacalc.kv     50    declare
ffa_ch4_ffacalc.kv     51       Arg1 : CmdLineArg;
ffa_ch4_ffacalc.kv     52       Arg2 : CmdLineArg;
ffa_ch4_ffacalc.kv     53    begin
ffa_ch4_ffacalc.kv     54       -- Get commandline args:
ffa_ch4_ffacalc.kv     55       Get_Argument(1, Arg1); -- First arg
ffa_ch4_ffacalc.kv     56       Get_Argument(2, Arg2); -- Second arg
ffa_ch4_ffacalc.kv     57       
ffa_ch4_ffacalc.kv     58       -- Parse into Positives:
ffa_ch4_ffacalc.kv     59       Width  := Positive'Value(Arg1);
ffa_ch4_ffacalc.kv     60       Height := Positive'Value(Arg2);
ffa_ch4_ffacalc.kv     61    exception
ffa_ch4_ffacalc.kv     62       when others =>
ffa_ch4_ffacalc.kv     63          Eggog("Invalid arguments!");
ffa_ch4_ffacalc.kv     64    end;
ffa_ch4_ffacalc.kv     65    
ffa_ch4_ffacalc.kv     66    -- Test if proposed Width is permissible:
ffa_ch4_ffacalc.kv     67    if not FZ_Valid_Bitness_P(Width) then
ffa_ch4_ffacalc.kv     68       Eggog("Invalid Width: " & FZ_Validity_Rule_Doc);
ffa_ch4_ffacalc.kv     69    end if;
ffa_ch4_ffacalc.kv     70    
ffa_ch4_ffacalc.kv     71    -- The Calculator itself:
ffa_ch4_ffacalc.kv     72    declare
ffa_ch4_ffacalc.kv     73       
ffa_ch4_ffacalc.kv     74       -- The number of Words required to make a FZ of the given Bitness.
ffa_ch4_ffacalc.kv     75       Wordness : Indices := Indices(Width / Bitness);
ffa_ch4_ffacalc.kv     76       
ffa_ch4_ffacalc.kv     77       --------------------------------------------------------
ffa_ch4_ffacalc.kv     78       -- State --
ffa_ch4_ffacalc.kv     79       --------------------------------------------------------
ffa_ch4_ffacalc.kv     80       -- The Stack:
ffa_ch4_ffacalc.kv     81       subtype Stack_Positions is Natural range 0 .. Height;
ffa_ch4_ffacalc.kv     82       type Stacks is array(Stack_Positions range <>) of FZ(1 .. Wordness);
ffa_ch4_ffacalc.kv     83       Stack      : Stacks(Stack_Positions'Range);
ffa_ch4_ffacalc.kv     84       
ffa_ch4_ffacalc.kv     85       -- Stack Pointer:
ffa_ch4_ffacalc.kv     86       SP         : Stack_Positions := Stack_Positions'First;
ffa_ch4_ffacalc.kv     87       
ffa_ch4_ffacalc.kv     88       -- Carry/Borrow Flag:
ffa_ch4_ffacalc.kv     89       Flag       : WBool   := 0;
ffa_ch4_ffacalc.kv     90       
ffa_ch4_ffacalc.kv     91       -- Odometer:
ffa_ch4_ffacalc.kv     92       Pos        : Natural := 0;
ffa_ch4_ffacalc.kv     93       
ffa_ch4_ffacalc.kv     94       -- The current levels of the three types of nestedness:
ffa_ch4_ffacalc.kv     95       QuoteLevel : Natural := 0;
ffa_ch4_ffacalc.kv     96       CommLevel  : Natural := 0;
ffa_ch4_ffacalc.kv     97       CondLevel  : Natural := 0;
ffa_ch4_ffacalc.kv     98       --------------------------------------------------------
ffa_ch4_ffacalc.kv     99       
ffa_ch4_ffacalc.kv    100       
ffa_ch4_ffacalc.kv    101       -- Clear the stack and set SP to bottom.
ffa_ch4_ffacalc.kv    102       procedure Zap is
ffa_ch4_ffacalc.kv    103       begin
ffa_ch4_ffacalc.kv    104          -- Clear the stack
ffa_ch4_ffacalc.kv    105          for i in Stack'Range loop
ffa_ch4_ffacalc.kv    106             FZ_Clear(Stack(i));
ffa_ch4_ffacalc.kv    107          end loop;
ffa_ch4_ffacalc.kv    108          -- Set SP to bottom
ffa_ch4_ffacalc.kv    109          SP   := Stack_Positions'First;
ffa_ch4_ffacalc.kv    110          -- Clear Overflow flag
ffa_ch4_ffacalc.kv    111          Flag := 0;
ffa_ch4_ffacalc.kv    112       end Zap;
ffa_ch4_ffacalc.kv    113       
ffa_ch4_ffacalc.kv    114       
ffa_ch4_ffacalc.kv    115       -- Report a fatal error condition at the current symbol
ffa_ch4_ffacalc.kv    116       procedure E(S : in String) is
ffa_ch4_ffacalc.kv    117       begin
ffa_ch4_ffacalc.kv    118          Eggog("Pos:" & Natural'Image(Pos) & ": " & S);
ffa_ch4_ffacalc.kv    119       end E;
ffa_ch4_ffacalc.kv    120       
ffa_ch4_ffacalc.kv    121       
ffa_ch4_ffacalc.kv    122       -- Move SP up
ffa_ch4_ffacalc.kv    123       procedure Push is
ffa_ch4_ffacalc.kv    124       begin
ffa_ch4_ffacalc.kv    125          if SP = Stack_Positions'Last then
ffa_ch4_ffacalc.kv    126             E("Stack Overflow!");
ffa_ch4_ffacalc.kv    127          else
ffa_ch4_ffacalc.kv    128             SP := SP + 1;
ffa_ch4_ffacalc.kv    129          end if;
ffa_ch4_ffacalc.kv    130       end Push;
ffa_ch4_ffacalc.kv    131       
ffa_ch4_ffacalc.kv    132       
ffa_ch4_ffacalc.kv    133       -- Discard the top of the stack
ffa_ch4_ffacalc.kv    134       procedure Drop is
ffa_ch4_ffacalc.kv    135       begin
ffa_ch4_ffacalc.kv    136          FZ_Clear(Stack(SP));
ffa_ch4_ffacalc.kv    137          SP := SP - 1;
ffa_ch4_ffacalc.kv    138       end Drop;
ffa_ch4_ffacalc.kv    139       
ffa_ch4_ffacalc.kv    140       
ffa_ch4_ffacalc.kv    141       -- Check if stack has the necessary N items
ffa_ch4_ffacalc.kv    142       procedure Want(N : in Positive) is
ffa_ch4_ffacalc.kv    143       begin
ffa_ch4_ffacalc.kv    144          if SP < N then
ffa_ch4_ffacalc.kv    145             E("Stack Underflow!");
ffa_ch4_ffacalc.kv    146          end if;
ffa_ch4_ffacalc.kv    147       end Want;
ffa_ch4_ffacalc.kv    148       
ffa_ch4_ffacalc.kv    149       
ffa_ch4_ffacalc.kv    150       -- Slide a new hex digit into the FZ on top of stack
ffa_ch4_ffacalc.kv    151       procedure Ins_Hex_Digit(N : in out FZ;
ffa_ch4_ffacalc.kv    152                               D : in Nibble) is
ffa_ch4_ffacalc.kv    153          Overflow : Word := 0;
ffa_ch4_ffacalc.kv    154       begin
ffa_ch4_ffacalc.kv    155          -- Make room in this FZ for one additional hex digit
ffa_ch4_ffacalc.kv    156          FZ_ShiftLeft_O(N        => N,
ffa_ch4_ffacalc.kv    157                         ShiftedN => N,
ffa_ch4_ffacalc.kv    158                         Count    => 4,
ffa_ch4_ffacalc.kv    159                         Overflow => Overflow);
ffa_ch4_ffacalc.kv    160          
ffa_ch4_ffacalc.kv    161          -- Constants which exceed the Width are forbidden:
ffa_ch4_ffacalc.kv    162          if W_NZeroP(Overflow) = 1 then
ffa_ch4_ffacalc.kv    163             E("Constant Exceeds Bitness!");
ffa_ch4_ffacalc.kv    164          end if;
ffa_ch4_ffacalc.kv    165          
ffa_ch4_ffacalc.kv    166          -- Set the new digit
ffa_ch4_ffacalc.kv    167          FZ_Or_W(N, D);
ffa_ch4_ffacalc.kv    168       end;
ffa_ch4_ffacalc.kv    169       
ffa_ch4_ffacalc.kv    170       
ffa_ch4_ffacalc.kv    171       -- Execute a Normal Op
ffa_ch4_ffacalc.kv    172       procedure Op_Normal(C : in Character) is
ffa_ch4_ffacalc.kv    173          
ffa_ch4_ffacalc.kv    174          -- Over/underflow output from certain ops
ffa_ch4_ffacalc.kv    175          F : Word;
ffa_ch4_ffacalc.kv    176          
ffa_ch4_ffacalc.kv    177       begin
ffa_ch4_ffacalc.kv    178          
ffa_ch4_ffacalc.kv    179          case C is
ffa_ch4_ffacalc.kv    180             
ffa_ch4_ffacalc.kv    181             --------------
ffa_ch4_ffacalc.kv    182             -- Stickies --
ffa_ch4_ffacalc.kv    183             --------------
ffa_ch4_ffacalc.kv    184             -- Enter Commented
ffa_ch4_ffacalc.kv    185             when '(' =>
ffa_ch4_ffacalc.kv    186                CommLevel := 1;
ffa_ch4_ffacalc.kv    187                
ffa_ch4_ffacalc.kv    188                -- Exit Commented (but we aren't in it!)
ffa_ch4_ffacalc.kv    189             when ')' =>
ffa_ch4_ffacalc.kv    190                E("Mismatched close-comment parenthesis !");
ffa_ch4_ffacalc.kv    191                
ffa_ch4_ffacalc.kv    192                -- Enter Quoted
ffa_ch4_ffacalc.kv    193             when '[' =>
ffa_ch4_ffacalc.kv    194                QuoteLevel := 1;
ffa_ch4_ffacalc.kv    195                
ffa_ch4_ffacalc.kv    196                -- Exit Quoted (but we aren't in it!)
ffa_ch4_ffacalc.kv    197             when ']' =>
ffa_ch4_ffacalc.kv    198                E("Mismatched close-quote bracket !");
ffa_ch4_ffacalc.kv    199                
ffa_ch4_ffacalc.kv    200                -- Enter a ~taken~ Conditional branch:
ffa_ch4_ffacalc.kv    201             when '{' =>
ffa_ch4_ffacalc.kv    202                Want(1);
ffa_ch4_ffacalc.kv    203                if FZ_ZeroP(Stack(SP)) = 1 then
ffa_ch4_ffacalc.kv    204                   CondLevel := 1;
ffa_ch4_ffacalc.kv    205                end if;
ffa_ch4_ffacalc.kv    206                Drop;
ffa_ch4_ffacalc.kv    207                
ffa_ch4_ffacalc.kv    208                -- Exit from a ~non-taken~ Conditional branch:
ffa_ch4_ffacalc.kv    209                -- ... we push a 0, to suppress the 'else' clause
ffa_ch4_ffacalc.kv    210             when '}' =>
ffa_ch4_ffacalc.kv    211                Push;
ffa_ch4_ffacalc.kv    212                WBool_To_FZ(0, Stack(SP));
ffa_ch4_ffacalc.kv    213                
ffa_ch4_ffacalc.kv    214                ----------------
ffa_ch4_ffacalc.kv    215                -- Immediates --
ffa_ch4_ffacalc.kv    216                ----------------
ffa_ch4_ffacalc.kv    217                
ffa_ch4_ffacalc.kv    218                -- These operate on the FZ ~currently~ at top of the stack;
ffa_ch4_ffacalc.kv    219                -- and this means that the stack may NOT be empty.
ffa_ch4_ffacalc.kv    220                
ffa_ch4_ffacalc.kv    221             when '0' .. '9' =>
ffa_ch4_ffacalc.kv    222                Want(1);
ffa_ch4_ffacalc.kv    223                Ins_Hex_Digit(Stack(SP),
ffa_ch4_ffacalc.kv    224                              Character'Pos(C) - Character'Pos('0'));
ffa_ch4_ffacalc.kv    225                
ffa_ch4_ffacalc.kv    226             when 'A' .. 'F' =>
ffa_ch4_ffacalc.kv    227                Want(1);
ffa_ch4_ffacalc.kv    228                Ins_Hex_Digit(Stack(SP),
ffa_ch4_ffacalc.kv    229                              10 + Character'Pos(C) - Character'Pos('A'));
ffa_ch4_ffacalc.kv    230                
ffa_ch4_ffacalc.kv    231             when 'a' .. 'f' =>
ffa_ch4_ffacalc.kv    232                Want(1);
ffa_ch4_ffacalc.kv    233                Ins_Hex_Digit(Stack(SP),
ffa_ch4_ffacalc.kv    234                              10 + Character'Pos(C) - Character'Pos('a'));
ffa_ch4_ffacalc.kv    235                
ffa_ch4_ffacalc.kv    236                ------------------
ffa_ch4_ffacalc.kv    237                -- Stack Motion --
ffa_ch4_ffacalc.kv    238                ------------------
ffa_ch4_ffacalc.kv    239                
ffa_ch4_ffacalc.kv    240                -- Push a 0 onto the stack
ffa_ch4_ffacalc.kv    241             when '.' =>
ffa_ch4_ffacalc.kv    242                Push;
ffa_ch4_ffacalc.kv    243                FZ_Clear(Stack(SP));
ffa_ch4_ffacalc.kv    244                
ffa_ch4_ffacalc.kv    245                -- Dup
ffa_ch4_ffacalc.kv    246             when '"' =>
ffa_ch4_ffacalc.kv    247                Want(1);
ffa_ch4_ffacalc.kv    248                Push;
ffa_ch4_ffacalc.kv    249                Stack(SP) := Stack(SP - 1);
ffa_ch4_ffacalc.kv    250                
ffa_ch4_ffacalc.kv    251                -- Drop
ffa_ch4_ffacalc.kv    252             when '_' =>
ffa_ch4_ffacalc.kv    253                Want(1);
ffa_ch4_ffacalc.kv    254                Drop;
ffa_ch4_ffacalc.kv    255                
ffa_ch4_ffacalc.kv    256                -- Swap
ffa_ch4_ffacalc.kv    257             when ''' =>
ffa_ch4_ffacalc.kv    258                Want(2);
ffa_ch4_ffacalc.kv    259                FZ_Swap(Stack(SP), Stack(SP - 1));
ffa_ch4_ffacalc.kv    260                
ffa_ch4_ffacalc.kv    261                -- Over
ffa_ch4_ffacalc.kv    262             when '`' =>
ffa_ch4_ffacalc.kv    263                Want(2);
ffa_ch4_ffacalc.kv    264                Push;
ffa_ch4_ffacalc.kv    265                Stack(SP) := Stack(SP - 2);
ffa_ch4_ffacalc.kv    266                
ffa_ch4_ffacalc.kv    267                ----------------
ffa_ch4_ffacalc.kv    268                -- Predicates --
ffa_ch4_ffacalc.kv    269                ----------------
ffa_ch4_ffacalc.kv    270                
ffa_ch4_ffacalc.kv    271                -- Equality
ffa_ch4_ffacalc.kv    272             when '=' =>
ffa_ch4_ffacalc.kv    273                Want(2);
ffa_ch4_ffacalc.kv    274                WBool_To_FZ(FZ_Eqp(X => Stack(SP),
ffa_ch4_ffacalc.kv    275                                   Y => Stack(SP - 1)),
ffa_ch4_ffacalc.kv    276                            Stack(SP - 1));
ffa_ch4_ffacalc.kv    277                Drop;
ffa_ch4_ffacalc.kv    278                
ffa_ch4_ffacalc.kv    279                -- Less-Than
ffa_ch4_ffacalc.kv    280             when '<' =>
ffa_ch4_ffacalc.kv    281                Want(2);
ffa_ch4_ffacalc.kv    282                WBool_To_FZ(FZ_LessThanP(X => Stack(SP - 1),
ffa_ch4_ffacalc.kv    283                                         Y => Stack(SP)),
ffa_ch4_ffacalc.kv    284                            Stack(SP - 1));
ffa_ch4_ffacalc.kv    285                Drop;
ffa_ch4_ffacalc.kv    286                
ffa_ch4_ffacalc.kv    287                -- Greater-Than
ffa_ch4_ffacalc.kv    288             when '>' =>
ffa_ch4_ffacalc.kv    289                Want(2);
ffa_ch4_ffacalc.kv    290                WBool_To_FZ(FZ_GreaterThanP(X => Stack(SP - 1),
ffa_ch4_ffacalc.kv    291                                            Y => Stack(SP)),
ffa_ch4_ffacalc.kv    292                            Stack(SP - 1));
ffa_ch4_ffacalc.kv    293                Drop;
ffa_ch4_ffacalc.kv    294                
ffa_ch4_ffacalc.kv    295                ----------------
ffa_ch4_ffacalc.kv    296                -- Arithmetic --
ffa_ch4_ffacalc.kv    297                ----------------
ffa_ch4_ffacalc.kv    298                
ffa_ch4_ffacalc.kv    299                -- Subtract
ffa_ch4_ffacalc.kv    300             when '-' =>
ffa_ch4_ffacalc.kv    301                Want(2);
ffa_ch4_ffacalc.kv    302                FZ_Sub(X          => Stack(SP - 1),
ffa_ch4_ffacalc.kv    303                       Y          => Stack(SP),
ffa_ch4_ffacalc.kv    304                       Difference => Stack(SP - 1),
ffa_ch4_ffacalc.kv    305                       Underflow  => F);
ffa_ch4_ffacalc.kv    306                Flag := W_NZeroP(F);
ffa_ch4_ffacalc.kv    307                Drop;
ffa_ch4_ffacalc.kv    308                
ffa_ch4_ffacalc.kv    309                -- Add
ffa_ch4_ffacalc.kv    310             when '+' =>
ffa_ch4_ffacalc.kv    311                Want(2);
ffa_ch4_ffacalc.kv    312                FZ_Add(X        => Stack(SP - 1),
ffa_ch4_ffacalc.kv    313                       Y        => Stack(SP),
ffa_ch4_ffacalc.kv    314                       Sum      => Stack(SP - 1),
ffa_ch4_ffacalc.kv    315                       Overflow => F);
ffa_ch4_ffacalc.kv    316                Flag := W_NZeroP(F);
ffa_ch4_ffacalc.kv    317                Drop;
ffa_ch4_ffacalc.kv    318                
ffa_ch4_ffacalc.kv    319                -----------------
ffa_ch4_ffacalc.kv    320                -- Bitwise Ops --
ffa_ch4_ffacalc.kv    321                -----------------
ffa_ch4_ffacalc.kv    322                
ffa_ch4_ffacalc.kv    323                -- Bitwise-And
ffa_ch4_ffacalc.kv    324             when '&' =>
ffa_ch4_ffacalc.kv    325                Want(2);
ffa_ch4_ffacalc.kv    326                FZ_And(X      => Stack(SP - 1),
ffa_ch4_ffacalc.kv    327                       Y      => Stack(SP),
ffa_ch4_ffacalc.kv    328                       Result => Stack(SP - 1));
ffa_ch4_ffacalc.kv    329                Drop;
ffa_ch4_ffacalc.kv    330                
ffa_ch4_ffacalc.kv    331                -- Bitwise-Or
ffa_ch4_ffacalc.kv    332             when '|' =>
ffa_ch4_ffacalc.kv    333                Want(2);
ffa_ch4_ffacalc.kv    334                FZ_Or(X      => Stack(SP - 1),
ffa_ch4_ffacalc.kv    335                      Y      => Stack(SP),
ffa_ch4_ffacalc.kv    336                      Result => Stack(SP - 1));
ffa_ch4_ffacalc.kv    337                Drop;
ffa_ch4_ffacalc.kv    338                
ffa_ch4_ffacalc.kv    339                -- Bitwise-Xor
ffa_ch4_ffacalc.kv    340             when '^' =>
ffa_ch4_ffacalc.kv    341                Want(2);
ffa_ch4_ffacalc.kv    342                FZ_Xor(X      => Stack(SP - 1),
ffa_ch4_ffacalc.kv    343                       Y      => Stack(SP),
ffa_ch4_ffacalc.kv    344                       Result => Stack(SP - 1));
ffa_ch4_ffacalc.kv    345                Drop;
ffa_ch4_ffacalc.kv    346                
ffa_ch4_ffacalc.kv    347                -- Bitwise-Not (1s-Complement)
ffa_ch4_ffacalc.kv    348             when '~' =>
ffa_ch4_ffacalc.kv    349                Want(1);
ffa_ch4_ffacalc.kv    350                FZ_Not(Stack(SP), Stack(SP));
ffa_ch4_ffacalc.kv    351                
ffa_ch4_ffacalc.kv    352                -----------
ffa_ch4_ffacalc.kv    353                -- Other --
ffa_ch4_ffacalc.kv    354                -----------
ffa_ch4_ffacalc.kv    355                
ffa_ch4_ffacalc.kv    356                -- mUx
ffa_ch4_ffacalc.kv    357             when 'U' =>
ffa_ch4_ffacalc.kv    358                Want(3);
ffa_ch4_ffacalc.kv    359                FZ_Mux(X      => Stack(SP - 2),
ffa_ch4_ffacalc.kv    360                       Y      => Stack(SP - 1),
ffa_ch4_ffacalc.kv    361                       Result => Stack(SP - 2),
ffa_ch4_ffacalc.kv    362                       Sel    => FZ_NZeroP(Stack(SP)));
ffa_ch4_ffacalc.kv    363                Drop;
ffa_ch4_ffacalc.kv    364                Drop;
ffa_ch4_ffacalc.kv    365                
ffa_ch4_ffacalc.kv    366                -- Put the Overflow flag on the stack
ffa_ch4_ffacalc.kv    367             when 'O' =>
ffa_ch4_ffacalc.kv    368                Push;
ffa_ch4_ffacalc.kv    369                WBool_To_FZ(Flag, Stack(SP));
ffa_ch4_ffacalc.kv    370                
ffa_ch4_ffacalc.kv    371                -- Print the FZ on the top of the stack
ffa_ch4_ffacalc.kv    372             when '#' =>
ffa_ch4_ffacalc.kv    373                Want(1);
ffa_ch4_ffacalc.kv    374                Dump(Stack(SP));
ffa_ch4_ffacalc.kv    375                Drop;
ffa_ch4_ffacalc.kv    376                
ffa_ch4_ffacalc.kv    377                -- Zap (reset)
ffa_ch4_ffacalc.kv    378             when 'Z' =>
ffa_ch4_ffacalc.kv    379                Zap;
ffa_ch4_ffacalc.kv    380                
ffa_ch4_ffacalc.kv    381                -- Quit with Stack Trace
ffa_ch4_ffacalc.kv    382             when 'Q' =>
ffa_ch4_ffacalc.kv    383                for I in reverse Stack'First + 1 .. SP loop
ffa_ch4_ffacalc.kv    384                   Dump(Stack(I));
ffa_ch4_ffacalc.kv    385                end loop;
ffa_ch4_ffacalc.kv    386                Quit(0);
ffa_ch4_ffacalc.kv    387                
ffa_ch4_ffacalc.kv    388                ----------
ffa_ch4_ffacalc.kv    389                -- NOPs --
ffa_ch4_ffacalc.kv    390                ----------
ffa_ch4_ffacalc.kv    391                
ffa_ch4_ffacalc.kv    392                -- Ops we have not yet spoken of -- do nothing
ffa_ch4_ffacalc.kv    393             when others =>
ffa_ch4_ffacalc.kv    394                null;
ffa_ch4_ffacalc.kv    395                
ffa_ch4_ffacalc.kv    396          end case;
ffa_ch4_ffacalc.kv    397          
ffa_ch4_ffacalc.kv    398       end Op_Normal;
ffa_ch4_ffacalc.kv    399       
ffa_ch4_ffacalc.kv    400       
ffa_ch4_ffacalc.kv    401       -- Process a Symbol
ffa_ch4_ffacalc.kv    402       procedure Op(C : in Character) is
ffa_ch4_ffacalc.kv    403       begin
ffa_ch4_ffacalc.kv    404          -- First, see whether we are in a state of nestedness:
ffa_ch4_ffacalc.kv    405          
ffa_ch4_ffacalc.kv    406          -- ... in a Comment block:
ffa_ch4_ffacalc.kv    407          if CommLevel > 0 then
ffa_ch4_ffacalc.kv    408             case C is
ffa_ch4_ffacalc.kv    409                when ')' =>  -- Drop a nesting level:
ffa_ch4_ffacalc.kv    410                   CommLevel := CommLevel - 1;
ffa_ch4_ffacalc.kv    411                when '(' =>  -- Add a nesting level:
ffa_ch4_ffacalc.kv    412                   CommLevel := CommLevel + 1;
ffa_ch4_ffacalc.kv    413                when others =>
ffa_ch4_ffacalc.kv    414                   null; -- Other symbols have no effect at all
ffa_ch4_ffacalc.kv    415             end case;
ffa_ch4_ffacalc.kv    416             
ffa_ch4_ffacalc.kv    417             -- ... in a Quote block:
ffa_ch4_ffacalc.kv    418          elsif QuoteLevel > 0 then
ffa_ch4_ffacalc.kv    419             case C is
ffa_ch4_ffacalc.kv    420                when ']' =>   -- Drop a nesting level:
ffa_ch4_ffacalc.kv    421                   QuoteLevel := QuoteLevel - 1;
ffa_ch4_ffacalc.kv    422                when '[' =>   -- Add a nesting level:
ffa_ch4_ffacalc.kv    423                   QuoteLevel := QuoteLevel + 1;
ffa_ch4_ffacalc.kv    424                when others =>
ffa_ch4_ffacalc.kv    425                   null; -- Other symbols have no effect on the level
ffa_ch4_ffacalc.kv    426             end case;
ffa_ch4_ffacalc.kv    427             
ffa_ch4_ffacalc.kv    428             -- If we aren't the mode-exiting ']', print current symbol:
ffa_ch4_ffacalc.kv    429             if QuoteLevel > 0 then
ffa_ch4_ffacalc.kv    430                Write_Char(C);
ffa_ch4_ffacalc.kv    431             end if;
ffa_ch4_ffacalc.kv    432             
ffa_ch4_ffacalc.kv    433             --- ... in a ~taken~ Conditional branch:
ffa_ch4_ffacalc.kv    434          elsif CondLevel > 0 then
ffa_ch4_ffacalc.kv    435             case C is
ffa_ch4_ffacalc.kv    436                when '}' =>   -- Drop a nesting level:
ffa_ch4_ffacalc.kv    437                   CondLevel := CondLevel - 1;
ffa_ch4_ffacalc.kv    438                   
ffa_ch4_ffacalc.kv    439                   -- If we exited the Conditional as a result,
ffa_ch4_ffacalc.kv    440                   -- we push a 1 to trigger the possible 'else' clause:
ffa_ch4_ffacalc.kv    441                   if CondLevel = 0 then
ffa_ch4_ffacalc.kv    442                      Push;
ffa_ch4_ffacalc.kv    443                      WBool_To_FZ(1, Stack(SP));
ffa_ch4_ffacalc.kv    444                   end if;
ffa_ch4_ffacalc.kv    445                   
ffa_ch4_ffacalc.kv    446                when '{' =>   -- Add a nesting level:
ffa_ch4_ffacalc.kv    447                   CondLevel := CondLevel + 1;
ffa_ch4_ffacalc.kv    448                when others =>
ffa_ch4_ffacalc.kv    449                   null; -- Other symbols have no effect on the level
ffa_ch4_ffacalc.kv    450             end case;
ffa_ch4_ffacalc.kv    451          else
ffa_ch4_ffacalc.kv    452             -- This is a Normal Op, so proceed with the normal rules.
ffa_ch4_ffacalc.kv    453             Op_Normal(C);
ffa_ch4_ffacalc.kv    454          end if;
ffa_ch4_ffacalc.kv    455          
ffa_ch4_ffacalc.kv    456       end Op;
ffa_ch4_ffacalc.kv    457       
ffa_ch4_ffacalc.kv    458       
ffa_ch4_ffacalc.kv    459       -- Current Character
ffa_ch4_ffacalc.kv    460       C : Character;
ffa_ch4_ffacalc.kv    461       
ffa_ch4_ffacalc.kv    462    begin
ffa_ch4_ffacalc.kv    463       -- Reset the Calculator      
ffa_ch4_ffacalc.kv    464       Zap;
ffa_ch4_ffacalc.kv    465       -- Process characters until EOF:
ffa_ch4_ffacalc.kv    466       loop
ffa_ch4_ffacalc.kv    467          if Read_Char(C) then
ffa_ch4_ffacalc.kv    468             -- Execute Op:
ffa_ch4_ffacalc.kv    469             Op(C);
ffa_ch4_ffacalc.kv    470             -- Advance Odometer
ffa_ch4_ffacalc.kv    471             Pos := Pos + 1;
ffa_ch4_ffacalc.kv    472          else
ffa_ch4_ffacalc.kv    473             Zap;
ffa_ch4_ffacalc.kv    474             Quit(0); -- if EOF, we're done
ffa_ch4_ffacalc.kv    475          end if;
ffa_ch4_ffacalc.kv    476       end loop;
ffa_ch4_ffacalc.kv    477    end;
ffa_ch4_ffacalc.kv    478    
ffa_ch4_ffacalc.kv    479 end FFA_Calc;