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_ch15_gcd.kv 5 -- (C) 2019 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_ch14_barrett.kv 21 with Version; use Version;
ffa_ch8_randomism.kv 22 with OS; use OS;
ffa_ch4_ffacalc.kv 23
ffa_ch4_ffacalc.kv 24 -- FFA
ffa_ch11_tuning_a... 25 with FFA; use FFA;
ffa_ch4_ffacalc.kv 26
ffa_ch11_tuning_a... 27 -- For the intrinsic equality operator on Words
ffa_ch11_tuning_a... 28 use type FFA.Word;
ffa_ch4_ffacalc.kv 29
ffa_ch8_randomism.kv 30 -- For RNG:
ffa_ch8_randomism.kv 31 with FFA_RNG; use FFA_RNG;
ffa_ch8_randomism.kv 32
ffa_ch8_randomism.kv 33
ffa_ch17_peh.kv 34 package body FFA_Calc is
ffa_ch4_ffacalc.kv 35
ffa_ch17_peh.kv 36 -- Ensure that requested Peh Dimensions are permissible. Terminate if not.
ffa_ch17_peh.kv 37 procedure Validate_Peh_Dimensions(Dimensions : in Peh_Dimensions) is
ffa_ch4_ffacalc.kv 38 begin
ffa_ch17_peh.kv 39
ffa_ch17_peh.kv 40 -- Test if proposed Width is permissible:
ffa_ch17_peh.kv 41 if not FFA_FZ_Valid_Bitness_P(Dimensions.Width) then
ffa_ch17_peh.kv 42 Eggog("Requested Invalid FZ Width, " & FFA_Validity_Rule_Doc);
ffa_ch17_peh.kv 43 end if;
ffa_ch17_peh.kv 44
ffa_ch17_peh.kv 45 -- Warn the operator if an unbounded Peh run has been requested:
ffa_ch17_peh.kv 46 if Dimensions.Life = 0 then
ffa_ch17_peh.kv 47 Achtung("WARNING: Life=0 enables UNBOUNDED run time;" &
ffa_ch17_peh.kv 48 " halting cannot be guaranteed!");
ffa_ch8_randomism.kv 49 end if;
ffa_ch8_randomism.kv 50
ffa_ch17_peh.kv 51 end Validate_Peh_Dimensions;
ffa_ch4_ffacalc.kv 52
ffa_ch4_ffacalc.kv 53
ffa_ch17_peh.kv 54 -- Start a Peh Machine with the given Dimensions and Tape; return a Verdict.
ffa_ch17_peh.kv 55 function Peh_Machine(Dimensions : in Peh_Dimensions;
ffa_ch17_peh.kv 56 Tape : in Peh_Tapes;
ffa_ch17_peh.kv 57 RNG : in RNG_Device) return Peh_Verdicts is
ffa_ch4_ffacalc.kv 58
ffa_ch4_ffacalc.kv 59 -- The number of Words required to make a FZ of the given Bitness.
ffa_ch17_peh.kv 60 Wordness : Indices := Indices(Dimensions.Width / Bitness);
ffa_ch4_ffacalc.kv 61
ffa_ch4_ffacalc.kv 62 --------------------------------------------------------
ffa_ch4_ffacalc.kv 63 -- State --
ffa_ch4_ffacalc.kv 64 --------------------------------------------------------
ffa_ch17_peh.kv 65 -- The Data Stack:
ffa_ch17_peh.kv 66 subtype Stack_Positions is Natural range 0 .. Dimensions.Height;
ffa_ch4_ffacalc.kv 67 type Stacks is array(Stack_Positions range <>) of FZ(1 .. Wordness);
ffa_ch17_peh.kv 68 Stack : Stacks(Stack_Positions'Range);
ffa_ch17_peh.kv 69
ffa_ch17_peh.kv 70 -- Current top of the Data Stack:
ffa_ch17_peh.kv 71 SP : Stack_Positions := Stack_Positions'First;
ffa_ch17_peh.kv 72
ffa_ch17_peh.kv 73 -- Valid indices into the Tape:
ffa_ch17_peh.kv 74 subtype Tape_Positions is Peh_Tape_Range range Tape'First .. Tape'Last;
ffa_ch17_peh.kv 75
ffa_ch17_peh.kv 76 -- Position of the CURRENT Op on the Tape:
ffa_ch17_peh.kv 77 IP : Tape_Positions;
ffa_ch17_peh.kv 78
ffa_ch17_peh.kv 79 -- After an Op, will contain position of NEXT op (if = to IP -> halt)
ffa_ch17_peh.kv 80 IP_Next : Tape_Positions;
ffa_ch17_peh.kv 81
ffa_ch17_peh.kv 82 -- Control Stack; permits bidirectional motion across the Tape:
ffa_ch17_peh.kv 83 Control_Stack : array(ControlStack_Range) of Tape_Positions
ffa_ch17_peh.kv 84 := (others => Tape_Positions'First);
ffa_ch4_ffacalc.kv 85
ffa_ch17_peh.kv 86 -- Current top of the Control Stack:
ffa_ch17_peh.kv 87 CSP : ControlStack_Range := ControlStack_Range'First;
ffa_ch17_peh.kv 88
ffa_ch17_peh.kv 89 -- Registers:
ffa_ch17_peh.kv 90 subtype RegNames is Character range 'g' .. 'z';
ffa_ch17_peh.kv 91 type RegTables is array(RegNames range <>) of FZ(1 .. Wordness);
ffa_ch17_peh.kv 92 Registers : RegTables(RegNames'Range);
ffa_ch4_ffacalc.kv 93
ffa_ch4_ffacalc.kv 94 -- Carry/Borrow Flag:
ffa_ch17_peh.kv 95 Flag : WBool := 0;
ffa_ch4_ffacalc.kv 96
ffa_ch4_ffacalc.kv 97 -- Odometer:
ffa_ch17_peh.kv 98 Ticks : Natural := 0;
ffa_ch4_ffacalc.kv 99
ffa_ch4_ffacalc.kv 100 -- The current levels of the three types of nestedness:
ffa_ch17_peh.kv 101 QuoteLevel : Natural := 0;
ffa_ch17_peh.kv 102 CommLevel : Natural := 0;
ffa_ch17_peh.kv 103 CondLevel : Natural := 0;
ffa_ch13_measure_... 104
ffa_ch13_measure_... 105 -- Prefixed Operators
ffa_ch17_peh.kv 106 PrevC : Character := ' ';
ffa_ch17_peh.kv 107 HavePrefix : Boolean := False;
ffa_ch13_measure_... 108
ffa_ch17_peh.kv 109 -- Current Verdict. We run while 'Mu', tape remains, and Ticks under max.
ffa_ch17_peh.kv 110 Verdict : Peh_Verdicts := Mu;
ffa_ch4_ffacalc.kv 111 --------------------------------------------------------
ffa_ch4_ffacalc.kv 112
ffa_ch4_ffacalc.kv 113
ffa_ch17_peh.kv 114 -- Determine whether we have reached the given limit of Life:
ffa_ch17_peh.kv 115 function Exhausted_Life return Boolean is
ffa_ch17_peh.kv 116 -- If Life = 0, we are in "immortal" mode. Otherwise mortal:
ffa_ch17_peh.kv 117 MustDie : Boolean :=
ffa_ch17_peh.kv 118 (Dimensions.Life /= 0) and (Ticks = Dimensions.Life);
ffa_ch17_peh.kv 119 begin
ffa_ch17_peh.kv 120 if MustDie then
ffa_ch17_peh.kv 121 Achtung("WARNING: Exhausted Life ("
ffa_ch17_peh.kv 122 & Natural'Image(Ticks) & " ticks )");
ffa_ch17_peh.kv 123 end if;
ffa_ch17_peh.kv 124 return MustDie;
ffa_ch17_peh.kv 125 end Exhausted_Life;
ffa_ch17_peh.kv 126
ffa_ch17_peh.kv 127
ffa_ch17_peh.kv 128 -- Clear all state, other than blocks, Control Stack, Tape and Verdict:
ffa_ch4_ffacalc.kv 129 procedure Zap is
ffa_ch4_ffacalc.kv 130 begin
ffa_ch17_peh.kv 131 -- Clear the Data Stack:
ffa_ch4_ffacalc.kv 132 for i in Stack'Range loop
ffa_ch11_tuning_a... 133 FFA_FZ_Clear(Stack(i));
ffa_ch4_ffacalc.kv 134 end loop;
ffa_ch17_peh.kv 135 -- Set SP to bottom:
ffa_ch17_peh.kv 136 SP := Stack_Positions'First;
ffa_ch17_peh.kv 137 -- Clear all Registers:
ffa_ch17_peh.kv 138 for r in RegNames'Range loop
ffa_ch17_peh.kv 139 FFA_FZ_Clear(Registers(r));
ffa_ch17_peh.kv 140 end loop;
ffa_ch17_peh.kv 141 -- Clear Overflow flag:
ffa_ch17_peh.kv 142 Flag := 0;
ffa_ch17_peh.kv 143 -- Clear prefix:
ffa_ch17_peh.kv 144 HavePrefix := False;
ffa_ch17_peh.kv 145 PrevC := ' ';
ffa_ch4_ffacalc.kv 146 end Zap;
ffa_ch4_ffacalc.kv 147
ffa_ch4_ffacalc.kv 148
ffa_ch17_peh.kv 149 -- Report a fatal error condition at the current symbol.
ffa_ch17_peh.kv 150 -- On Unixlikes, this will also end the process and return control to OS.
ffa_ch4_ffacalc.kv 151 procedure E(S : in String) is
ffa_ch4_ffacalc.kv 152 begin
ffa_ch17_peh.kv 153 Zap; -- Jettison all resettable state!
ffa_ch17_peh.kv 154 Eggog("FATAL: Tick:" & Natural'Image(Ticks) &
ffa_ch17_peh.kv 155 " IP:" & Tape_Positions'Image(IP) & " : " & S);
ffa_ch4_ffacalc.kv 156 end E;
ffa_ch4_ffacalc.kv 157
ffa_ch4_ffacalc.kv 158
ffa_ch17_peh.kv 159 -------------------
ffa_ch17_peh.kv 160 -- Control Stack --
ffa_ch17_peh.kv 161 -------------------
ffa_ch17_peh.kv 162
ffa_ch17_peh.kv 163 -- Push a given Tape Position to the Control Stack:
ffa_ch17_peh.kv 164 procedure Control_Push(Position : in Tape_Positions) is
ffa_ch17_peh.kv 165 begin
ffa_ch17_peh.kv 166 -- First, test for Overflow of Control Stack:
ffa_ch17_peh.kv 167 if CSP = Control_Stack'Last then
ffa_ch17_peh.kv 168 E("Control Stack Overflow!");
ffa_ch17_peh.kv 169 end if;
ffa_ch17_peh.kv 170
ffa_ch17_peh.kv 171 -- Push given Tape Position to Control Stack:
ffa_ch17_peh.kv 172 CSP := CSP + 1;
ffa_ch17_peh.kv 173 Control_Stack(CSP) := Position;
ffa_ch17_peh.kv 174 end Control_Push;
ffa_ch17_peh.kv 175
ffa_ch17_peh.kv 176
ffa_ch17_peh.kv 177 -- Pop a Tape Position from the Control Stack:
ffa_ch17_peh.kv 178 function Control_Pop return Tape_Positions is
ffa_ch17_peh.kv 179 Position : Tape_Positions;
ffa_ch17_peh.kv 180 begin
ffa_ch17_peh.kv 181 -- First, test for Underflow of Control Stack:
ffa_ch17_peh.kv 182 if CSP = Control_Stack'First then
ffa_ch17_peh.kv 183 E("Control Stack Underflow!");
ffa_ch17_peh.kv 184 end if;
ffa_ch17_peh.kv 185
ffa_ch17_peh.kv 186 -- Pop a Tape Position from Control Stack:
ffa_ch17_peh.kv 187 Position := Control_Stack(CSP);
ffa_ch17_peh.kv 188 Control_Stack(CSP) := Tape_Positions'First;
ffa_ch17_peh.kv 189 CSP := CSP - 1;
ffa_ch17_peh.kv 190 return Position;
ffa_ch17_peh.kv 191 end Control_Pop;
ffa_ch17_peh.kv 192
ffa_ch17_peh.kv 193
ffa_ch17_peh.kv 194 ----------------
ffa_ch17_peh.kv 195 -- Data Stack --
ffa_ch17_peh.kv 196 ----------------
ffa_ch17_peh.kv 197
ffa_ch4_ffacalc.kv 198 -- Move SP up
ffa_ch4_ffacalc.kv 199 procedure Push is
ffa_ch4_ffacalc.kv 200 begin
ffa_ch4_ffacalc.kv 201 if SP = Stack_Positions'Last then
ffa_ch4_ffacalc.kv 202 E("Stack Overflow!");
ffa_ch4_ffacalc.kv 203 else
ffa_ch4_ffacalc.kv 204 SP := SP + 1;
ffa_ch4_ffacalc.kv 205 end if;
ffa_ch4_ffacalc.kv 206 end Push;
ffa_ch4_ffacalc.kv 207
ffa_ch4_ffacalc.kv 208
ffa_ch4_ffacalc.kv 209 -- Discard the top of the stack
ffa_ch4_ffacalc.kv 210 procedure Drop is
ffa_ch4_ffacalc.kv 211 begin
ffa_ch11_tuning_a... 212 FFA_FZ_Clear(Stack(SP));
ffa_ch4_ffacalc.kv 213 SP := SP - 1;
ffa_ch4_ffacalc.kv 214 end Drop;
ffa_ch4_ffacalc.kv 215
ffa_ch4_ffacalc.kv 216
ffa_ch4_ffacalc.kv 217 -- Check if stack has the necessary N items
ffa_ch4_ffacalc.kv 218 procedure Want(N : in Positive) is
ffa_ch4_ffacalc.kv 219 begin
ffa_ch4_ffacalc.kv 220 if SP < N then
ffa_ch4_ffacalc.kv 221 E("Stack Underflow!");
ffa_ch4_ffacalc.kv 222 end if;
ffa_ch4_ffacalc.kv 223 end Want;
ffa_ch4_ffacalc.kv 224
ffa_ch4_ffacalc.kv 225
ffa_ch5_egypt.kv 226 -- Ensure that a divisor is not zero
ffa_ch5_egypt.kv 227 procedure MustNotZero(D : in FZ) is
ffa_ch5_egypt.kv 228 begin
ffa_ch11_tuning_a... 229 if FFA_FZ_ZeroP(D) = 1 then
ffa_ch5_egypt.kv 230 E("Division by Zero!");
ffa_ch5_egypt.kv 231 end if;
ffa_ch5_egypt.kv 232 end MustNotZero;
ffa_ch5_egypt.kv 233
ffa_ch5_egypt.kv 234
ffa_ch4_ffacalc.kv 235 -- Slide a new hex digit into the FZ on top of stack
ffa_ch11_tuning_a... 236 procedure Ins_Hex_Digit(Digit : in Nibble) is
ffa_ch11_tuning_a... 237 Overflow : WBool := 0;
ffa_ch4_ffacalc.kv 238 begin
ffa_ch11_tuning_a... 239
ffa_ch11_tuning_a... 240 -- Insert the given nibble, and detect any overflow:
ffa_ch11_tuning_a... 241 FFA_FZ_Insert_Bottom_Nibble(N => Stack(SP),
ffa_ch11_tuning_a... 242 D => Digit,
ffa_ch11_tuning_a... 243 Overflow => Overflow);
ffa_ch4_ffacalc.kv 244
ffa_ch4_ffacalc.kv 245 -- Constants which exceed the Width are forbidden:
ffa_ch11_tuning_a... 246 if Overflow = 1 then
ffa_ch4_ffacalc.kv 247 E("Constant Exceeds Bitness!");
ffa_ch4_ffacalc.kv 248 end if;
ffa_ch4_ffacalc.kv 249
ffa_ch4_ffacalc.kv 250 end;
ffa_ch4_ffacalc.kv 251
ffa_ch4_ffacalc.kv 252
ffa_ch11_tuning_a... 253 -- Emit an ASCII representation of N to the terminal
ffa_ch11_tuning_a... 254 procedure Print_FZ(N : in FZ) is
ffa_ch11_tuning_a... 255 S : String(1 .. FFA_FZ_ASCII_Length(N)); -- Mandatorily, exact size
ffa_ch11_tuning_a... 256 begin
ffa_ch11_tuning_a... 257 FFA_FZ_To_Hex_String(N, S); -- Convert N to ASCII hex
ffa_ch11_tuning_a... 258 Write_String(S); -- Print the result to stdout
ffa_ch11_tuning_a... 259 Write_Newline; -- Print newline, for clarity.
ffa_ch11_tuning_a... 260 end Print_FZ;
ffa_ch11_tuning_a... 261
ffa_ch11_tuning_a... 262
ffa_ch17_peh.kv 263 -- Print a Debug Trace (used in 'QD')
ffa_ch17_peh.kv 264 procedure Print_Trace is
ffa_ch13_measure_... 265 begin
ffa_ch17_peh.kv 266 -- Print Data Stack Trace:
ffa_ch17_peh.kv 267 Write_String("Data Stack:");
ffa_ch17_peh.kv 268 Write_Newline;
ffa_ch17_peh.kv 269 for i in reverse Stack'First + 1 .. SP loop
ffa_ch17_peh.kv 270 Write_String(" " & Stack_Positions'Image(i) & " : ");
ffa_ch17_peh.kv 271 Print_FZ(Stack(i));
ffa_ch17_peh.kv 272 end loop;
ffa_ch17_peh.kv 273
ffa_ch17_peh.kv 274 -- Print Control Stack Trace:
ffa_ch17_peh.kv 275 Write_String("Control Stack:");
ffa_ch17_peh.kv 276 Write_Newline;
ffa_ch17_peh.kv 277 for i in reverse Control_Stack'First + 1 .. CSP loop
ffa_ch17_peh.kv 278 Write_String(" " & ControlStack_Range'Image(i) & " :"
ffa_ch17_peh.kv 279 & Tape_Positions'Image(Control_Stack(i)));
ffa_ch17_peh.kv 280 Write_Newline;
ffa_ch17_peh.kv 281 end loop;
ffa_ch17_peh.kv 282
ffa_ch17_peh.kv 283 -- Print All Registers:
ffa_ch17_peh.kv 284 Write_String("Registers:");
ffa_ch17_peh.kv 285 Write_Newline;
ffa_ch17_peh.kv 286 for r in RegNames'Range loop
ffa_ch17_peh.kv 287 Write_String(" " & r & " : ");
ffa_ch17_peh.kv 288 Print_FZ(Registers(r));
ffa_ch17_peh.kv 289 end loop;
ffa_ch17_peh.kv 290
ffa_ch17_peh.kv 291 -- Print Ticks and IP:
ffa_ch17_peh.kv 292 Write_String("Ticks :" & Natural'Image(Ticks));
ffa_ch17_peh.kv 293 Write_Newline;
ffa_ch17_peh.kv 294 Write_String("IP :" & Tape_Positions'Image(IP));
ffa_ch17_peh.kv 295 Write_Newline;
ffa_ch17_peh.kv 296 end Print_Trace;
ffa_ch13_measure_... 297
ffa_ch13_measure_... 298
ffa_ch4_ffacalc.kv 299 -- Execute a Normal Op
ffa_ch4_ffacalc.kv 300 procedure Op_Normal(C : in Character) is
ffa_ch4_ffacalc.kv 301
ffa_ch4_ffacalc.kv 302 -- Over/underflow output from certain ops
ffa_ch4_ffacalc.kv 303 F : Word;
ffa_ch4_ffacalc.kv 304
ffa_ch4_ffacalc.kv 305 begin
ffa_ch4_ffacalc.kv 306
ffa_ch4_ffacalc.kv 307 case C is
ffa_ch4_ffacalc.kv 308
ffa_ch4_ffacalc.kv 309 --------------
ffa_ch4_ffacalc.kv 310 -- Stickies --
ffa_ch4_ffacalc.kv 311 --------------
ffa_ch4_ffacalc.kv 312 -- Enter Commented
ffa_ch4_ffacalc.kv 313 when '(' =>
ffa_ch4_ffacalc.kv 314 CommLevel := 1;
ffa_ch4_ffacalc.kv 315
ffa_ch4_ffacalc.kv 316 -- Exit Commented (but we aren't in it!)
ffa_ch4_ffacalc.kv 317 when ')' =>
ffa_ch4_ffacalc.kv 318 E("Mismatched close-comment parenthesis !");
ffa_ch4_ffacalc.kv 319
ffa_ch4_ffacalc.kv 320 -- Enter Quoted
ffa_ch4_ffacalc.kv 321 when '[' =>
ffa_ch4_ffacalc.kv 322 QuoteLevel := 1;
ffa_ch4_ffacalc.kv 323
ffa_ch4_ffacalc.kv 324 -- Exit Quoted (but we aren't in it!)
ffa_ch4_ffacalc.kv 325 when ']' =>
ffa_ch4_ffacalc.kv 326 E("Mismatched close-quote bracket !");
ffa_ch4_ffacalc.kv 327
ffa_ch4_ffacalc.kv 328 -- Enter a ~taken~ Conditional branch:
ffa_ch4_ffacalc.kv 329 when '{' =>
ffa_ch4_ffacalc.kv 330 Want(1);
ffa_ch11_tuning_a... 331 if FFA_FZ_ZeroP(Stack(SP)) = 1 then
ffa_ch4_ffacalc.kv 332 CondLevel := 1;
ffa_ch4_ffacalc.kv 333 end if;
ffa_ch4_ffacalc.kv 334 Drop;
ffa_ch4_ffacalc.kv 335
ffa_ch4_ffacalc.kv 336 -- Exit from a ~non-taken~ Conditional branch:
ffa_ch4_ffacalc.kv 337 -- ... we push a 0, to suppress the 'else' clause
ffa_ch4_ffacalc.kv 338 when '}' =>
ffa_ch4_ffacalc.kv 339 Push;
ffa_ch11_tuning_a... 340 FFA_WBool_To_FZ(0, Stack(SP));
ffa_ch4_ffacalc.kv 341
ffa_ch4_ffacalc.kv 342 ----------------
ffa_ch4_ffacalc.kv 343 -- Immediates --
ffa_ch4_ffacalc.kv 344 ----------------
ffa_ch4_ffacalc.kv 345
ffa_ch4_ffacalc.kv 346 -- These operate on the FZ ~currently~ at top of the stack;
ffa_ch4_ffacalc.kv 347 -- and this means that the stack may NOT be empty.
ffa_ch4_ffacalc.kv 348
ffa_ch4_ffacalc.kv 349 when '0' .. '9' =>
ffa_ch4_ffacalc.kv 350 Want(1);
ffa_ch11_tuning_a... 351 Ins_Hex_Digit(Character'Pos(C) - Character'Pos('0'));
ffa_ch4_ffacalc.kv 352
ffa_ch4_ffacalc.kv 353 when 'A' .. 'F' =>
ffa_ch4_ffacalc.kv 354 Want(1);
ffa_ch11_tuning_a... 355 Ins_Hex_Digit(10 + Character'Pos(C) - Character'Pos('A'));
ffa_ch4_ffacalc.kv 356
ffa_ch4_ffacalc.kv 357 when 'a' .. 'f' =>
ffa_ch4_ffacalc.kv 358 Want(1);
ffa_ch11_tuning_a... 359 Ins_Hex_Digit(10 + Character'Pos(C) - Character'Pos('a'));
ffa_ch4_ffacalc.kv 360
ffa_ch17_peh.kv 361 -------------------------
ffa_ch17_peh.kv 362 -- Fetch from Register --
ffa_ch17_peh.kv 363 -------------------------
ffa_ch17_peh.kv 364 when 'g' .. 'z' =>
ffa_ch17_peh.kv 365 Push;
ffa_ch17_peh.kv 366 Stack(SP) := Registers(C); -- Put value of Register on stack
ffa_ch17_peh.kv 367
ffa_ch4_ffacalc.kv 368 ------------------
ffa_ch4_ffacalc.kv 369 -- Stack Motion --
ffa_ch4_ffacalc.kv 370 ------------------
ffa_ch4_ffacalc.kv 371
ffa_ch4_ffacalc.kv 372 -- Push a 0 onto the stack
ffa_ch4_ffacalc.kv 373 when '.' =>
ffa_ch4_ffacalc.kv 374 Push;
ffa_ch11_tuning_a... 375 FFA_FZ_Clear(Stack(SP));
ffa_ch4_ffacalc.kv 376
ffa_ch4_ffacalc.kv 377 -- Dup
ffa_ch4_ffacalc.kv 378 when '"' =>
ffa_ch4_ffacalc.kv 379 Want(1);
ffa_ch4_ffacalc.kv 380 Push;
ffa_ch4_ffacalc.kv 381 Stack(SP) := Stack(SP - 1);
ffa_ch4_ffacalc.kv 382
ffa_ch4_ffacalc.kv 383 -- Drop
ffa_ch4_ffacalc.kv 384 when '_' =>
ffa_ch4_ffacalc.kv 385 Want(1);
ffa_ch4_ffacalc.kv 386 Drop;
ffa_ch4_ffacalc.kv 387
ffa_ch4_ffacalc.kv 388 -- Swap
ffa_ch4_ffacalc.kv 389 when ''' =>
ffa_ch4_ffacalc.kv 390 Want(2);
ffa_ch11_tuning_a... 391 FFA_FZ_Swap(Stack(SP), Stack(SP - 1));
ffa_ch4_ffacalc.kv 392
ffa_ch4_ffacalc.kv 393 -- Over
ffa_ch4_ffacalc.kv 394 when '`' =>
ffa_ch4_ffacalc.kv 395 Want(2);
ffa_ch4_ffacalc.kv 396 Push;
ffa_ch4_ffacalc.kv 397 Stack(SP) := Stack(SP - 2);
ffa_ch4_ffacalc.kv 398
ffa_ch4_ffacalc.kv 399 ----------------
ffa_ch4_ffacalc.kv 400 -- Predicates --
ffa_ch4_ffacalc.kv 401 ----------------
ffa_ch4_ffacalc.kv 402
ffa_ch4_ffacalc.kv 403 -- Equality
ffa_ch4_ffacalc.kv 404 when '=' =>
ffa_ch4_ffacalc.kv 405 Want(2);
ffa_ch11_tuning_a... 406 FFA_WBool_To_FZ(FFA_FZ_EqP(X => Stack(SP),
ffa_ch11_tuning_a... 407 Y => Stack(SP - 1)),
ffa_ch11_tuning_a... 408 Stack(SP - 1));
ffa_ch4_ffacalc.kv 409 Drop;
ffa_ch4_ffacalc.kv 410
ffa_ch4_ffacalc.kv 411 -- Less-Than
ffa_ch4_ffacalc.kv 412 when '<' =>
ffa_ch4_ffacalc.kv 413 Want(2);
ffa_ch11_tuning_a... 414 FFA_WBool_To_FZ(FFA_FZ_LessThanP(X => Stack(SP - 1),
ffa_ch11_tuning_a... 415 Y => Stack(SP)),
ffa_ch11_tuning_a... 416 Stack(SP - 1));
ffa_ch4_ffacalc.kv 417 Drop;
ffa_ch4_ffacalc.kv 418
ffa_ch4_ffacalc.kv 419 -- Greater-Than
ffa_ch4_ffacalc.kv 420 when '>' =>
ffa_ch4_ffacalc.kv 421 Want(2);
ffa_ch11_tuning_a... 422 FFA_WBool_To_FZ(FFA_FZ_GreaterThanP(X => Stack(SP - 1),
ffa_ch11_tuning_a... 423 Y => Stack(SP)),
ffa_ch11_tuning_a... 424 Stack(SP - 1));
ffa_ch4_ffacalc.kv 425 Drop;
ffa_ch4_ffacalc.kv 426
ffa_ch4_ffacalc.kv 427 ----------------
ffa_ch4_ffacalc.kv 428 -- Arithmetic --
ffa_ch4_ffacalc.kv 429 ----------------
ffa_ch4_ffacalc.kv 430
ffa_ch4_ffacalc.kv 431 -- Subtract
ffa_ch4_ffacalc.kv 432 when '-' =>
ffa_ch4_ffacalc.kv 433 Want(2);
ffa_ch11_tuning_a... 434 FFA_FZ_Subtract(X => Stack(SP - 1),
ffa_ch11_tuning_a... 435 Y => Stack(SP),
ffa_ch11_tuning_a... 436 Difference => Stack(SP - 1),
ffa_ch11_tuning_a... 437 Underflow => F);
ffa_ch11_tuning_a... 438 Flag := FFA_Word_NZeroP(F);
ffa_ch4_ffacalc.kv 439 Drop;
ffa_ch4_ffacalc.kv 440
ffa_ch4_ffacalc.kv 441 -- Add
ffa_ch4_ffacalc.kv 442 when '+' =>
ffa_ch4_ffacalc.kv 443 Want(2);
ffa_ch11_tuning_a... 444 FFA_FZ_Add(X => Stack(SP - 1),
ffa_ch11_tuning_a... 445 Y => Stack(SP),
ffa_ch11_tuning_a... 446 Sum => Stack(SP - 1),
ffa_ch11_tuning_a... 447 Overflow => F);
ffa_ch11_tuning_a... 448 Flag := FFA_Word_NZeroP(F);
ffa_ch4_ffacalc.kv 449 Drop;
ffa_ch4_ffacalc.kv 450
ffa_ch5_egypt.kv 451 -- Divide and give Quotient and Remainder
ffa_ch5_egypt.kv 452 when '\' =>
ffa_ch5_egypt.kv 453 Want(2);
ffa_ch5_egypt.kv 454 MustNotZero(Stack(SP));
ffa_ch11_tuning_a... 455 FFA_FZ_IDiv(Dividend => Stack(SP - 1),
ffa_ch11_tuning_a... 456 Divisor => Stack(SP),
ffa_ch11_tuning_a... 457 Quotient => Stack(SP - 1),
ffa_ch11_tuning_a... 458 Remainder => Stack(SP));
ffa_ch5_egypt.kv 459
ffa_ch5_egypt.kv 460 -- Divide and give Quotient only
ffa_ch5_egypt.kv 461 when '/' =>
ffa_ch5_egypt.kv 462 Want(2);
ffa_ch5_egypt.kv 463 MustNotZero(Stack(SP));
ffa_ch11_tuning_a... 464 FFA_FZ_Div(Dividend => Stack(SP - 1),
ffa_ch11_tuning_a... 465 Divisor => Stack(SP),
ffa_ch11_tuning_a... 466 Quotient => Stack(SP - 1));
ffa_ch5_egypt.kv 467 Drop;
ffa_ch5_egypt.kv 468
ffa_ch5_egypt.kv 469 -- Divide and give Remainder only
ffa_ch5_egypt.kv 470 when '%' =>
ffa_ch5_egypt.kv 471 Want(2);
ffa_ch5_egypt.kv 472 MustNotZero(Stack(SP));
ffa_ch11_tuning_a... 473 FFA_FZ_Mod(Dividend => Stack(SP - 1),
ffa_ch11_tuning_a... 474 Divisor => Stack(SP),
ffa_ch11_tuning_a... 475 Remainder => Stack(SP - 1));
ffa_ch5_egypt.kv 476 Drop;
ffa_ch5_egypt.kv 477
ffa_ch5_egypt.kv 478 -- Multiply, give bottom and top halves
ffa_ch5_egypt.kv 479 when '*' =>
ffa_ch5_egypt.kv 480 Want(2);
ffa_ch11_tuning_a... 481 FFA_FZ_Multiply(X => Stack(SP - 1),
ffa_ch11_tuning_a... 482 Y => Stack(SP),
ffa_ch11_tuning_a... 483 XY_Lo => Stack(SP - 1),
ffa_ch11_tuning_a... 484 XY_Hi => Stack(SP));
ffa_ch5_egypt.kv 485
ffa_ch15_gcd.kv 486 -- Square, give bottom and top halves
ffa_ch15_gcd.kv 487 when 'S' =>
ffa_ch15_gcd.kv 488 Want(1);
ffa_ch15_gcd.kv 489 Push;
ffa_ch15_gcd.kv 490 FFA_FZ_Square(X => Stack(SP - 1),
ffa_ch15_gcd.kv 491 XX_Lo => Stack(SP - 1),
ffa_ch15_gcd.kv 492 XX_Hi => Stack(SP));
ffa_ch15_gcd.kv 493
ffa_ch15_gcd.kv 494 -- Greatest Common Divisor (GCD)
ffa_ch15_gcd.kv 495 when 'G' =>
ffa_ch15_gcd.kv 496 Want(2);
ffa_ch15_gcd.kv 497
ffa_ch15_gcd.kv 498 -- Note that GCD(0,0) is not factually zero, or unique.
ffa_ch15_gcd.kv 499 -- But it is permissible to define it as zero.
ffa_ch15_gcd.kv 500 -- (See Ch. 15 discussion.)
ffa_ch15_gcd.kv 501
ffa_ch15_gcd.kv 502 FFA_FZ_Greatest_Common_Divisor(X => Stack(SP - 1),
ffa_ch15_gcd.kv 503 Y => Stack(SP),
ffa_ch15_gcd.kv 504 Result => Stack(SP - 1));
ffa_ch15_gcd.kv 505 Drop;
ffa_ch15_gcd.kv 506
ffa_ch4_ffacalc.kv 507 -----------------
ffa_ch4_ffacalc.kv 508 -- Bitwise Ops --
ffa_ch4_ffacalc.kv 509 -----------------
ffa_ch4_ffacalc.kv 510
ffa_ch4_ffacalc.kv 511 -- Bitwise-And
ffa_ch4_ffacalc.kv 512 when '&' =>
ffa_ch4_ffacalc.kv 513 Want(2);
ffa_ch11_tuning_a... 514 FFA_FZ_And(X => Stack(SP - 1),
ffa_ch11_tuning_a... 515 Y => Stack(SP),
ffa_ch11_tuning_a... 516 Result => Stack(SP - 1));
ffa_ch4_ffacalc.kv 517 Drop;
ffa_ch4_ffacalc.kv 518
ffa_ch4_ffacalc.kv 519 -- Bitwise-Or
ffa_ch4_ffacalc.kv 520 when '|' =>
ffa_ch4_ffacalc.kv 521 Want(2);
ffa_ch11_tuning_a... 522 FFA_FZ_Or(X => Stack(SP - 1),
ffa_ch11_tuning_a... 523 Y => Stack(SP),
ffa_ch11_tuning_a... 524 Result => Stack(SP - 1));
ffa_ch4_ffacalc.kv 525 Drop;
ffa_ch4_ffacalc.kv 526
ffa_ch4_ffacalc.kv 527 -- Bitwise-Xor
ffa_ch4_ffacalc.kv 528 when '^' =>
ffa_ch4_ffacalc.kv 529 Want(2);
ffa_ch11_tuning_a... 530 FFA_FZ_Xor(X => Stack(SP - 1),
ffa_ch11_tuning_a... 531 Y => Stack(SP),
ffa_ch11_tuning_a... 532 Result => Stack(SP - 1));
ffa_ch4_ffacalc.kv 533 Drop;
ffa_ch4_ffacalc.kv 534
ffa_ch4_ffacalc.kv 535 -- Bitwise-Not (1s-Complement)
ffa_ch4_ffacalc.kv 536 when '~' =>
ffa_ch4_ffacalc.kv 537 Want(1);
ffa_ch11_tuning_a... 538 FFA_FZ_Not(Stack(SP), Stack(SP));
ffa_ch4_ffacalc.kv 539
ffa_ch4_ffacalc.kv 540 -----------
ffa_ch4_ffacalc.kv 541 -- Other --
ffa_ch4_ffacalc.kv 542 -----------
ffa_ch4_ffacalc.kv 543
ffa_ch8_randomism.kv 544 -- Push a FZ of RNGolade onto the stack
ffa_ch8_randomism.kv 545 when '?' =>
ffa_ch8_randomism.kv 546 Push;
ffa_ch11_tuning_a... 547 FFA_FZ_Clear(Stack(SP));
ffa_ch8_randomism.kv 548 FZ_Random(RNG, Stack(SP));
ffa_ch8_randomism.kv 549
ffa_ch4_ffacalc.kv 550 -- mUx
ffa_ch4_ffacalc.kv 551 when 'U' =>
ffa_ch4_ffacalc.kv 552 Want(3);
ffa_ch11_tuning_a... 553 FFA_FZ_Mux(X => Stack(SP - 2),
ffa_ch11_tuning_a... 554 Y => Stack(SP - 1),
ffa_ch11_tuning_a... 555 Result => Stack(SP - 2),
ffa_ch11_tuning_a... 556 Sel => FFA_FZ_NZeroP(Stack(SP)));
ffa_ch4_ffacalc.kv 557 Drop;
ffa_ch4_ffacalc.kv 558 Drop;
ffa_ch4_ffacalc.kv 559
ffa_ch13_measure_... 560 -- Find the position of eldest nonzero bit, if any exist
ffa_ch13_measure_... 561 when 'W' =>
ffa_ch13_measure_... 562 Want(1);
ffa_ch13_measure_... 563 declare
ffa_ch13_measure_... 564 -- Find the measure ( 0 if no 1s, or 1 .. FZBitness )
ffa_ch14_barrett.kv 565 Measure : FZBit_Index := FFA_FZ_Measure(Stack(SP));
ffa_ch14_barrett.kv 566 begin
ffa_ch13_measure_... 567 -- Put on top of stack
ffa_ch13_measure_... 568 FFA_FZ_Clear(Stack(SP));
ffa_ch14_barrett.kv 569 FFA_FZ_Set_Head(Stack(SP), Word(Measure));
ffa_ch13_measure_... 570 end;
ffa_ch13_measure_... 571
ffa_ch4_ffacalc.kv 572 -- Put the Overflow flag on the stack
ffa_ch4_ffacalc.kv 573 when 'O' =>
ffa_ch4_ffacalc.kv 574 Push;
ffa_ch11_tuning_a... 575 FFA_WBool_To_FZ(Flag, Stack(SP));
ffa_ch4_ffacalc.kv 576
ffa_ch4_ffacalc.kv 577 -- Print the FZ on the top of the stack
ffa_ch4_ffacalc.kv 578 when '#' =>
ffa_ch4_ffacalc.kv 579 Want(1);
ffa_ch11_tuning_a... 580 Print_FZ(Stack(SP));
ffa_ch4_ffacalc.kv 581 Drop;
ffa_ch4_ffacalc.kv 582
ffa_ch17_peh.kv 583 -- Zap (reset all resettables)
ffa_ch4_ffacalc.kv 584 when 'Z' =>
ffa_ch4_ffacalc.kv 585 Zap;
ffa_ch4_ffacalc.kv 586
ffa_ch17_peh.kv 587 -- Put the Peh Program Version on the stack,
ffa_ch14_barrett.kv 588 -- followed by FFA Program Version.
ffa_ch14_barrett.kv 589 when 'V' =>
ffa_ch14_barrett.kv 590 Push;
ffa_ch14_barrett.kv 591 Push;
ffa_ch17_peh.kv 592 -- Peh Version:
ffa_ch14_barrett.kv 593 FFA_FZ_Clear(Stack(SP - 1));
ffa_ch17_peh.kv 594 FFA_FZ_Set_Head(Stack(SP - 1), Word(Peh_K_Version));
ffa_ch14_barrett.kv 595 -- FFA Version:
ffa_ch14_barrett.kv 596 FFA_FZ_Clear(Stack(SP));
ffa_ch14_barrett.kv 597 FFA_FZ_Set_Head(Stack(SP), Word(FFA_K_Version));
ffa_ch14_barrett.kv 598
ffa_ch16_miller_r... 599 -- Constant-Time Miller-Rabin Test on N using the given Witness.
ffa_ch16_miller_r... 600 -- Witness will be used as-is if it conforms to the valid range,
ffa_ch16_miller_r... 601 -- i.e. 2 <= Witness <= N - 2; else will be transformed into a
ffa_ch16_miller_r... 602 -- valid Witness via modular arithmetic.
ffa_ch16_miller_r... 603 -- Outputs ONE if N WAS FOUND composite; ZERO if NOT FOUND.
ffa_ch16_miller_r... 604 -- Handles degenerate cases of N that M-R per se cannot eat:
ffa_ch16_miller_r... 605 -- N=0, N=1: ALWAYS 'FOUND COMPOS.'; 2, 3 - ALWAYS 'NOT FOUND'.
ffa_ch16_miller_r... 606 -- If N is Even and not equal to 2, N is ALWAYS 'FOUND COMPOS.'
ffa_ch16_miller_r... 607 -- For ALL other N, the output is equal to that of the M-R test.
ffa_ch16_miller_r... 608 -- At most 1/4 of all possible Witnesses will be 'liars' for
ffa_ch16_miller_r... 609 -- a particular composite N , i.e. fail to attest to its
ffa_ch16_miller_r... 610 -- compositivity.
ffa_ch16_miller_r... 611 when 'P' =>
ffa_ch16_miller_r... 612 Want(2);
ffa_ch16_miller_r... 613 declare
ffa_ch16_miller_r... 614 MR_Result : WBool :=
ffa_ch16_miller_r... 615 FFA_FZ_MR_Composite_On_Witness(N => Stack(SP - 1),
ffa_ch16_miller_r... 616 Witness => Stack(SP));
ffa_ch16_miller_r... 617 begin
ffa_ch16_miller_r... 618 FFA_WBool_To_FZ(MR_Result, Stack(SP - 1));
ffa_ch16_miller_r... 619 end;
ffa_ch16_miller_r... 620 Drop;
ffa_ch16_miller_r... 621
ffa_ch13_measure_... 622 --------------
ffa_ch13_measure_... 623 -- Prefixes --
ffa_ch13_measure_... 624 --------------
ffa_ch13_measure_... 625
ffa_ch17_peh.kv 626 when
ffa_ch17_peh.kv 627 'Q' -- 'Quit...'
ffa_ch17_peh.kv 628 |
ffa_ch17_peh.kv 629 'L' -- 'Left...'
ffa_ch17_peh.kv 630 |
ffa_ch17_peh.kv 631 'R' -- 'Right...'
ffa_ch17_peh.kv 632 |
ffa_ch17_peh.kv 633 'M' -- 'Modular...'
ffa_ch17_peh.kv 634 |
ffa_ch17_peh.kv 635 '$' -- Pop top of Stack into the following Register...
ffa_ch17_peh.kv 636 =>
ffa_ch17_peh.kv 637 HavePrefix := True;
ffa_ch17_peh.kv 638
ffa_ch17_peh.kv 639 -------------------
ffa_ch17_peh.kv 640 -- Control Stack --
ffa_ch17_peh.kv 641 -------------------
ffa_ch17_peh.kv 642
ffa_ch17_peh.kv 643 -- Push current IP (i.e. of THIS Op) to Control Stack.
ffa_ch17_peh.kv 644 when ':' =>
ffa_ch17_peh.kv 645 Control_Push(IP);
ffa_ch17_peh.kv 646
ffa_ch17_peh.kv 647 -- Conditional Return: Pop top of Stack, and...
ffa_ch17_peh.kv 648 -- ... if ZERO: simply discard the top of the Control Stack.
ffa_ch17_peh.kv 649 -- ... if NONZERO: pop top of Control Stack and make it next IP.
ffa_ch17_peh.kv 650 when ',' =>
ffa_ch17_peh.kv 651 Want(1);
ffa_ch17_peh.kv 652 declare
ffa_ch17_peh.kv 653 Position : Tape_Positions := Control_Pop;
ffa_ch17_peh.kv 654 begin
ffa_ch17_peh.kv 655 if FFA_FZ_NZeroP(Stack(SP)) = 1 then
ffa_ch17_peh.kv 656 IP_Next := Position;
ffa_ch17_peh.kv 657 end if;
ffa_ch17_peh.kv 658 end;
ffa_ch17_peh.kv 659 Drop;
ffa_ch13_measure_... 660
ffa_ch17_peh.kv 661 -- UNconditional Return: Control Stack top popped into IP_Next.
ffa_ch17_peh.kv 662 when ';' =>
ffa_ch17_peh.kv 663 IP_Next := Control_Pop;
ffa_ch13_measure_... 664
ffa_ch13_measure_... 665 ---------------------------------------------------------
ffa_ch17_peh.kv 666 -- Reserved Ops, i.e. ones we have not defined yet: --
ffa_ch13_measure_... 667 ---------------------------------------------------------
ffa_ch17_peh.kv 668 when '!' | '@' |
ffa_ch17_peh.kv 669 'H' | 'I' | 'J' | 'K' | 'N' | 'T' | 'X' | 'Y' =>
ffa_ch13_measure_... 670
ffa_ch13_measure_... 671 E("This Operator is not defined yet: " & C);
ffa_ch12_karatsub... 672 ---------------------------------------------------------
ffa_ch12_karatsub... 673
ffa_ch4_ffacalc.kv 674 ----------
ffa_ch4_ffacalc.kv 675 -- NOPs --
ffa_ch4_ffacalc.kv 676 ----------
ffa_ch4_ffacalc.kv 677
ffa_ch13_measure_... 678 -- Unprintables and spaces DO NOTHING:
ffa_ch4_ffacalc.kv 679 when others =>
ffa_ch4_ffacalc.kv 680 null;
ffa_ch4_ffacalc.kv 681
ffa_ch4_ffacalc.kv 682 end case;
ffa_ch4_ffacalc.kv 683
ffa_ch4_ffacalc.kv 684 end Op_Normal;
ffa_ch4_ffacalc.kv 685
ffa_ch4_ffacalc.kv 686
ffa_ch13_measure_... 687 -- Execute a Prefixed Op
ffa_ch13_measure_... 688 procedure Op_Prefixed(Prefix : in Character;
ffa_ch13_measure_... 689 O : in Character) is
ffa_ch17_peh.kv 690
ffa_ch17_peh.kv 691 -- Report an attempt to execute an undefined Prefix Op:
ffa_ch17_peh.kv 692 procedure Undefined_Prefix_Op is
ffa_ch17_peh.kv 693 begin
ffa_ch17_peh.kv 694 E("Undefined Prefix Op: " & Prefix & O);
ffa_ch17_peh.kv 695 end Undefined_Prefix_Op;
ffa_ch17_peh.kv 696
ffa_ch13_measure_... 697 begin
ffa_ch13_measure_... 698
ffa_ch17_peh.kv 699 -- Which Prefix Op?
ffa_ch13_measure_... 700 case Prefix is
ffa_ch13_measure_... 701
ffa_ch13_measure_... 702 ---------------------------------------------------------
ffa_ch17_peh.kv 703 -- Quit...
ffa_ch17_peh.kv 704 when 'Q' =>
ffa_ch17_peh.kv 705
ffa_ch17_peh.kv 706 -- .. Quit how?
ffa_ch17_peh.kv 707 case O is
ffa_ch17_peh.kv 708
ffa_ch17_peh.kv 709 -- ... with a 'Yes' Verdict:
ffa_ch17_peh.kv 710 when 'Y' =>
ffa_ch17_peh.kv 711 Verdict := Yes;
ffa_ch17_peh.kv 712
ffa_ch17_peh.kv 713 -- ... with a 'No' Verdict:
ffa_ch17_peh.kv 714 when 'N' =>
ffa_ch17_peh.kv 715 Verdict := No;
ffa_ch17_peh.kv 716
ffa_ch17_peh.kv 717 -- ... with a 'Mu' Verdict: (permitted, but discouraged)
ffa_ch17_peh.kv 718 when 'M' =>
ffa_ch17_peh.kv 719 IP_Next := IP; -- Force a 'Mu' Termination
ffa_ch17_peh.kv 720
ffa_ch17_peh.kv 721 -- ... with Debug Trace, and a 'Mu' Verdict:
ffa_ch17_peh.kv 722 when 'D' =>
ffa_ch17_peh.kv 723 Print_Trace;
ffa_ch17_peh.kv 724 IP_Next := IP; -- Force a 'Mu' Termination
ffa_ch17_peh.kv 725
ffa_ch17_peh.kv 726 -- ... with an explicit Tape-triggered fatal EGGOG!
ffa_ch17_peh.kv 727 -- The 'QE' curtain call is intended strictly to signal
ffa_ch17_peh.kv 728 -- catastrophic (e.g. iron) failure from within a Tape
ffa_ch17_peh.kv 729 -- program ('cosmic ray' scenario) where a ~hardwired
ffa_ch17_peh.kv 730 -- mechanism~ of any kind appears to have done something
ffa_ch17_peh.kv 731 -- unexpected; or to abort on a failed test of the RNG;
ffa_ch17_peh.kv 732 -- or similar hard-stop scenarios, where either physical
ffa_ch17_peh.kv 733 -- iron, or basic FFA routine must be said to have failed,
ffa_ch17_peh.kv 734 -- and the continued use of the system itself - dangerous.
ffa_ch17_peh.kv 735 -- The use of 'QE' for any other purpose is discouraged;
ffa_ch17_peh.kv 736 -- please do not use it to indicate failed decryption etc.
ffa_ch17_peh.kv 737 when 'E' =>
ffa_ch17_peh.kv 738 -- Hard-stop with this eggog:
ffa_ch17_peh.kv 739 E("Tape-triggered CATASTROPHIC ERROR! " &
ffa_ch17_peh.kv 740 "Your iron and/or your build of Peh, " &
ffa_ch17_peh.kv 741 "may be defective! Please consult " &
ffa_ch17_peh.kv 742 "the author of this Tape.");
ffa_ch17_peh.kv 743
ffa_ch17_peh.kv 744 -- ... Unknown (Eggog):
ffa_ch17_peh.kv 745 when others =>
ffa_ch17_peh.kv 746 Undefined_Prefix_Op;
ffa_ch17_peh.kv 747
ffa_ch17_peh.kv 748 end case;
ffa_ch17_peh.kv 749
ffa_ch17_peh.kv 750 ---------------------------------------------------------
ffa_ch17_peh.kv 751 -- Write into Register...
ffa_ch17_peh.kv 752 when '$' =>
ffa_ch17_peh.kv 753
ffa_ch17_peh.kv 754 -- Eggog if operator gave us a garbage Register name:
ffa_ch17_peh.kv 755 if O not in RegNames then
ffa_ch17_peh.kv 756 E("There is no Register '" & O & "' !");
ffa_ch17_peh.kv 757 end if;
ffa_ch17_peh.kv 758
ffa_ch17_peh.kv 759 -- Selected Register exists; move top FZ on stack into it:
ffa_ch17_peh.kv 760 Want(1);
ffa_ch17_peh.kv 761 Registers(O) := Stack(SP);
ffa_ch17_peh.kv 762 Drop;
ffa_ch17_peh.kv 763
ffa_ch17_peh.kv 764 ---------------------------------------------------------
ffa_ch13_measure_... 765 -- Left...
ffa_ch13_measure_... 766 when 'L' =>
ffa_ch13_measure_... 767
ffa_ch13_measure_... 768 -- Which L-op?
ffa_ch13_measure_... 769 case O is
ffa_ch13_measure_... 770
ffa_ch13_measure_... 771 -- ... Shift :
ffa_ch13_measure_... 772 when 'S' =>
ffa_ch13_measure_... 773 Want(2);
ffa_ch13_measure_... 774 declare
ffa_ch13_measure_... 775 -- Number of bit positions to shift by:
ffa_ch13_measure_... 776 ShiftCount : FZBit_Index
ffa_ch13_measure_... 777 := FZBit_Index(FFA_FZ_Get_Head(Stack(SP)));
ffa_ch13_measure_... 778 begin
ffa_ch13_measure_... 779 FFA_FZ_Quiet_ShiftLeft(N => Stack(SP - 1),
ffa_ch13_measure_... 780 ShiftedN => Stack(SP - 1),
ffa_ch13_measure_... 781 Count => ShiftCount);
ffa_ch13_measure_... 782 end;
ffa_ch13_measure_... 783 Drop;
ffa_ch13_measure_... 784
ffa_ch13_measure_... 785 -- ... Rotate :
ffa_ch13_measure_... 786 when 'R' =>
ffa_ch13_measure_... 787 E("Left-Rotate not yet defined!");
ffa_ch13_measure_... 788
ffa_ch17_peh.kv 789 -- ... Unknown (Eggog):
ffa_ch13_measure_... 790 when others =>
ffa_ch17_peh.kv 791 Undefined_Prefix_Op;
ffa_ch13_measure_... 792
ffa_ch13_measure_... 793 end case;
ffa_ch13_measure_... 794 ---------------------------------------------------------
ffa_ch13_measure_... 795 -- Right...
ffa_ch13_measure_... 796 when 'R' =>
ffa_ch13_measure_... 797
ffa_ch13_measure_... 798 -- Which R-op?
ffa_ch13_measure_... 799 case O is
ffa_ch13_measure_... 800
ffa_ch13_measure_... 801 -- ... Shift:
ffa_ch13_measure_... 802 when 'S' =>
ffa_ch13_measure_... 803 Want(2);
ffa_ch13_measure_... 804 declare
ffa_ch13_measure_... 805 -- Number of bit positions to shift by:
ffa_ch13_measure_... 806 ShiftCount : FZBit_Index
ffa_ch13_measure_... 807 := FZBit_Index(FFA_FZ_Get_Head(Stack(SP)));
ffa_ch13_measure_... 808 begin
ffa_ch13_measure_... 809 FFA_FZ_Quiet_ShiftRight(N => Stack(SP - 1),
ffa_ch13_measure_... 810 ShiftedN => Stack(SP - 1),
ffa_ch13_measure_... 811 Count => ShiftCount);
ffa_ch13_measure_... 812 end;
ffa_ch13_measure_... 813 Drop;
ffa_ch13_measure_... 814
ffa_ch13_measure_... 815 -- ... Rotate:
ffa_ch13_measure_... 816 when 'R' =>
ffa_ch13_measure_... 817 E("Right-Rotate not yet defined!");
ffa_ch13_measure_... 818
ffa_ch15_gcd.kv 819 -- 'Right-Multiply', give only lower half of the product XY
ffa_ch15_gcd.kv 820 when '*' =>
ffa_ch15_gcd.kv 821 Want(2);
ffa_ch15_gcd.kv 822 FFA_FZ_Low_Multiply(X => Stack(SP - 1),
ffa_ch15_gcd.kv 823 Y => Stack(SP),
ffa_ch15_gcd.kv 824 XY => Stack(SP - 1));
ffa_ch15_gcd.kv 825 Drop;
ffa_ch15_gcd.kv 826
ffa_ch17_peh.kv 827 -- ... Unknown (Eggog):
ffa_ch13_measure_... 828 when others =>
ffa_ch17_peh.kv 829 Undefined_Prefix_Op;
ffa_ch13_measure_... 830
ffa_ch13_measure_... 831 end case;
ffa_ch13_measure_... 832 ---------------------------------------------------------
ffa_ch15_gcd.kv 833 -- Modular...
ffa_ch13_measure_... 834 when 'M' =>
ffa_ch13_measure_... 835
ffa_ch13_measure_... 836 -- Which M-op?
ffa_ch13_measure_... 837 case O is
ffa_ch13_measure_... 838
ffa_ch15_gcd.kv 839 -- ... Multiplication (Conventional) :
ffa_ch13_measure_... 840 when '*' =>
ffa_ch13_measure_... 841 Want(3);
ffa_ch13_measure_... 842 MustNotZero(Stack(SP));
ffa_ch13_measure_... 843 FFA_FZ_Modular_Multiply(X => Stack(SP - 2),
ffa_ch13_measure_... 844 Y => Stack(SP - 1),
ffa_ch13_measure_... 845 Modulus => Stack(SP),
ffa_ch13_measure_... 846 Product => Stack(SP - 2));
ffa_ch13_measure_... 847 Drop;
ffa_ch13_measure_... 848 Drop;
ffa_ch13_measure_... 849
ffa_ch15_gcd.kv 850 -- ... Squaring (Conventional) :
ffa_ch15_gcd.kv 851 when 'S' =>
ffa_ch15_gcd.kv 852 Want(2);
ffa_ch15_gcd.kv 853 MustNotZero(Stack(SP));
ffa_ch15_gcd.kv 854 FFA_FZ_Modular_Square(X => Stack(SP - 1),
ffa_ch15_gcd.kv 855 Modulus => Stack(SP),
ffa_ch15_gcd.kv 856 Product => Stack(SP - 1));
ffa_ch15_gcd.kv 857 Drop;
ffa_ch15_gcd.kv 858
ffa_ch15_gcd.kv 859 -- ... Exponentiation (Barrettronic) :
ffa_ch13_measure_... 860 when 'X' =>
ffa_ch13_measure_... 861 Want(3);
ffa_ch13_measure_... 862 MustNotZero(Stack(SP));
ffa_ch13_measure_... 863 FFA_FZ_Modular_Exponentiate(Base => Stack(SP - 2),
ffa_ch13_measure_... 864 Exponent => Stack(SP - 1),
ffa_ch13_measure_... 865 Modulus => Stack(SP),
ffa_ch13_measure_... 866 Result => Stack(SP - 2));
ffa_ch13_measure_... 867 Drop;
ffa_ch13_measure_... 868 Drop;
ffa_ch13_measure_... 869
ffa_ch17_peh.kv 870 -- ... Unknown (Eggog):
ffa_ch13_measure_... 871 when others =>
ffa_ch17_peh.kv 872 Undefined_Prefix_Op;
ffa_ch13_measure_... 873
ffa_ch13_measure_... 874 end case;
ffa_ch13_measure_... 875 ---------------------------------------------------------
ffa_ch13_measure_... 876 -- ... Unknown: (impossible per mechanics, but must handle case)
ffa_ch13_measure_... 877 when others =>
ffa_ch13_measure_... 878 E("Undefined Prefix: " & Prefix);
ffa_ch13_measure_... 879
ffa_ch13_measure_... 880 end case;
ffa_ch13_measure_... 881
ffa_ch13_measure_... 882 end Op_Prefixed;
ffa_ch13_measure_... 883
ffa_ch13_measure_... 884
ffa_ch4_ffacalc.kv 885 -- Process a Symbol
ffa_ch4_ffacalc.kv 886 procedure Op(C : in Character) is
ffa_ch4_ffacalc.kv 887 begin
ffa_ch4_ffacalc.kv 888 -- First, see whether we are in a state of nestedness:
ffa_ch4_ffacalc.kv 889
ffa_ch4_ffacalc.kv 890 -- ... in a Comment block:
ffa_ch4_ffacalc.kv 891 if CommLevel > 0 then
ffa_ch4_ffacalc.kv 892 case C is
ffa_ch4_ffacalc.kv 893 when ')' => -- Drop a nesting level:
ffa_ch4_ffacalc.kv 894 CommLevel := CommLevel - 1;
ffa_ch4_ffacalc.kv 895 when '(' => -- Add a nesting level:
ffa_ch4_ffacalc.kv 896 CommLevel := CommLevel + 1;
ffa_ch4_ffacalc.kv 897 when others =>
ffa_ch4_ffacalc.kv 898 null; -- Other symbols have no effect at all
ffa_ch4_ffacalc.kv 899 end case;
ffa_ch4_ffacalc.kv 900
ffa_ch4_ffacalc.kv 901 -- ... in a Quote block:
ffa_ch4_ffacalc.kv 902 elsif QuoteLevel > 0 then
ffa_ch4_ffacalc.kv 903 case C is
ffa_ch4_ffacalc.kv 904 when ']' => -- Drop a nesting level:
ffa_ch4_ffacalc.kv 905 QuoteLevel := QuoteLevel - 1;
ffa_ch4_ffacalc.kv 906 when '[' => -- Add a nesting level:
ffa_ch4_ffacalc.kv 907 QuoteLevel := QuoteLevel + 1;
ffa_ch4_ffacalc.kv 908 when others =>
ffa_ch4_ffacalc.kv 909 null; -- Other symbols have no effect on the level
ffa_ch4_ffacalc.kv 910 end case;
ffa_ch4_ffacalc.kv 911
ffa_ch4_ffacalc.kv 912 -- If we aren't the mode-exiting ']', print current symbol:
ffa_ch4_ffacalc.kv 913 if QuoteLevel > 0 then
ffa_ch4_ffacalc.kv 914 Write_Char(C);
ffa_ch4_ffacalc.kv 915 end if;
ffa_ch4_ffacalc.kv 916
ffa_ch4_ffacalc.kv 917 --- ... in a ~taken~ Conditional branch:
ffa_ch4_ffacalc.kv 918 elsif CondLevel > 0 then
ffa_ch4_ffacalc.kv 919 case C is
ffa_ch4_ffacalc.kv 920 when '}' => -- Drop a nesting level:
ffa_ch4_ffacalc.kv 921 CondLevel := CondLevel - 1;
ffa_ch4_ffacalc.kv 922
ffa_ch4_ffacalc.kv 923 -- If we exited the Conditional as a result,
ffa_ch4_ffacalc.kv 924 -- we push a 1 to trigger the possible 'else' clause:
ffa_ch4_ffacalc.kv 925 if CondLevel = 0 then
ffa_ch4_ffacalc.kv 926 Push;
ffa_ch11_tuning_a... 927 FFA_WBool_To_FZ(1, Stack(SP));
ffa_ch4_ffacalc.kv 928 end if;
ffa_ch4_ffacalc.kv 929
ffa_ch4_ffacalc.kv 930 when '{' => -- Add a nesting level:
ffa_ch4_ffacalc.kv 931 CondLevel := CondLevel + 1;
ffa_ch4_ffacalc.kv 932 when others =>
ffa_ch4_ffacalc.kv 933 null; -- Other symbols have no effect on the level
ffa_ch4_ffacalc.kv 934 end case;
ffa_ch13_measure_... 935
ffa_ch13_measure_... 936 --- ... if in a prefixed op:
ffa_ch13_measure_... 937 elsif HavePrefix then
ffa_ch13_measure_... 938
ffa_ch13_measure_... 939 -- Drop the prefix-op hammer, until another prefix-op cocks it
ffa_ch13_measure_... 940 HavePrefix := False;
ffa_ch13_measure_... 941
ffa_ch13_measure_... 942 -- Dispatch this op, where prefix is the preceding character
ffa_ch13_measure_... 943 Op_Prefixed(Prefix => PrevC, O => C);
ffa_ch13_measure_... 944
ffa_ch4_ffacalc.kv 945 else
ffa_ch4_ffacalc.kv 946 -- This is a Normal Op, so proceed with the normal rules.
ffa_ch4_ffacalc.kv 947 Op_Normal(C);
ffa_ch4_ffacalc.kv 948 end if;
ffa_ch4_ffacalc.kv 949
ffa_ch17_peh.kv 950 -- In all cases, save the current symbol as possible prefix:
ffa_ch17_peh.kv 951 PrevC := C;
ffa_ch17_peh.kv 952
ffa_ch4_ffacalc.kv 953 end Op;
ffa_ch4_ffacalc.kv 954
ffa_ch4_ffacalc.kv 955 begin
ffa_ch17_peh.kv 956 -- Reset all resettable state:
ffa_ch4_ffacalc.kv 957 Zap;
ffa_ch17_peh.kv 958
ffa_ch17_peh.kv 959 -- Execution begins with the first Op on the Tape:
ffa_ch17_peh.kv 960 IP := Tape_Positions'First;
ffa_ch17_peh.kv 961
ffa_ch4_ffacalc.kv 962 loop
ffa_ch17_peh.kv 963
ffa_ch17_peh.kv 964 -- If current Op is NOT the last Op on the Tape:
ffa_ch17_peh.kv 965 if IP /= Tape_Positions'Last then
ffa_ch17_peh.kv 966
ffa_ch17_peh.kv 967 -- ... then default successor of the current Op is the next one:
ffa_ch17_peh.kv 968 IP_Next := IP + 1;
ffa_ch17_peh.kv 969
ffa_ch4_ffacalc.kv 970 else
ffa_ch17_peh.kv 971
ffa_ch17_peh.kv 972 -- ... but if no 'next' Op exists, or quit-with-Mu, we stay put:
ffa_ch17_peh.kv 973 IP_Next := IP; -- ... this will trigger an exit from the loop.
ffa_ch17_peh.kv 974
ffa_ch4_ffacalc.kv 975 end if;
ffa_ch17_peh.kv 976
ffa_ch17_peh.kv 977 -- Advance Odometer for every Op (incl. prefixes, in comments, etc) :
ffa_ch17_peh.kv 978 Ticks := Ticks + 1;
ffa_ch17_peh.kv 979
ffa_ch17_peh.kv 980 -- Execute the Op at the current IP:
ffa_ch17_peh.kv 981 Op(Tape(IP));
ffa_ch17_peh.kv 982
ffa_ch17_peh.kv 983 -- Halt when...
ffa_ch17_peh.kv 984 exit when
ffa_ch17_peh.kv 985 Verdict /= Mu or -- Got a Verdict, or...
ffa_ch17_peh.kv 986 IP_Next = IP or -- Reached the end of the Tape, or...
ffa_ch17_peh.kv 987 Exhausted_Life; -- Exhausted Life.
ffa_ch17_peh.kv 988
ffa_ch17_peh.kv 989 -- We did not halt yet, so select the IP of the next Op to fetch:
ffa_ch17_peh.kv 990 IP := IP_Next;
ffa_ch17_peh.kv 991
ffa_ch4_ffacalc.kv 992 end loop;
ffa_ch17_peh.kv 993
ffa_ch17_peh.kv 994 -- Warn operator about any unclosed blocks:
ffa_ch17_peh.kv 995 if CommLevel > 0 then
ffa_ch17_peh.kv 996 Achtung("WARNING: Tape terminated with an unclosed Comment!");
ffa_ch17_peh.kv 997 end if;
ffa_ch17_peh.kv 998
ffa_ch17_peh.kv 999 if QuoteLevel > 0 then
ffa_ch17_peh.kv 1000 Achtung("WARNING: Tape terminated with an unclosed Quote!");
ffa_ch17_peh.kv 1001 end if;
ffa_ch17_peh.kv 1002
ffa_ch17_peh.kv 1003 if CondLevel > 0 then
ffa_ch17_peh.kv 1004 Achtung("WARNING: Tape terminated with an unclosed Conditional!");
ffa_ch17_peh.kv 1005 end if;
ffa_ch17_peh.kv 1006
ffa_ch17_peh.kv 1007 -- Warn operator if we terminated with a non-empty Control Stack.
ffa_ch17_peh.kv 1008 -- This situation ought to be considered poor style in a Peh Tape;
ffa_ch17_peh.kv 1009 -- for clarity, Verdicts should be returned from a place near
ffa_ch17_peh.kv 1010 -- the visually-apparent end of a Tape. However, this is not mandatory.
ffa_ch17_peh.kv 1011 if CSP /= Control_Stack'First then
ffa_ch17_peh.kv 1012 Achtung("WARNING: Tape terminated with a non-empty Control Stack!");
ffa_ch17_peh.kv 1013 end if;
ffa_ch17_peh.kv 1014
ffa_ch17_peh.kv 1015 -- We're done with the Tape, so clear the state:
ffa_ch17_peh.kv 1016 Zap;
ffa_ch17_peh.kv 1017
ffa_ch17_peh.kv 1018 -- Return the Verdict:
ffa_ch17_peh.kv 1019 return Verdict;
ffa_ch17_peh.kv 1020
ffa_ch17_peh.kv 1021 end Peh_Machine;
ffa_ch4_ffacalc.kv 1022
ffa_ch4_ffacalc.kv 1023 end FFA_Calc;