raw
ffa_ch18_subrouti...    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_ch18_subrouti... 82 -- Types of Entry for the Control Stack:
ffa_ch18_subrouti... 83 type Call_Types is (Invalid, Subroutines, Loops);
ffa_ch18_subrouti... 84
ffa_ch18_subrouti... 85 -- Control Stack Entries:
ffa_ch18_subrouti... 86 type Call is
ffa_ch18_subrouti... 87 record
ffa_ch18_subrouti... 88 Why : Call_Types := Invalid; -- Which call type?
ffa_ch18_subrouti... 89 Ret : Tape_Positions; -- The IP we must return to after it
ffa_ch18_subrouti... 90 end record;
ffa_ch18_subrouti... 91
ffa_ch17_peh.kv 92 -- Control Stack; permits bidirectional motion across the Tape:
ffa_ch18_subrouti... 93 Control_Stack : array(ControlStack_Range) of Call;
ffa_ch4_ffacalc.kv 94
ffa_ch17_peh.kv 95 -- Current top of the Control Stack:
ffa_ch17_peh.kv 96 CSP : ControlStack_Range := ControlStack_Range'First;
ffa_ch17_peh.kv 97
ffa_ch18_subrouti... 98 -- A Segment represents a particular section of Tape, for certain uses.
ffa_ch18_subrouti... 99 type Segment is
ffa_ch18_subrouti... 100 record
ffa_ch18_subrouti... 101 -- The Tape Position of the FIRST Symbol on the Segment:
ffa_ch18_subrouti... 102 L : Tape_Positions := Tape'First; -- Default: start of the Tape.
ffa_ch18_subrouti... 103
ffa_ch18_subrouti... 104 -- The Tape Position of the LAST Symbol on the Segment:
ffa_ch18_subrouti... 105 R : Tape_Positions := Tape'Last; -- Default: end of the Tape.
ffa_ch18_subrouti... 106 end record;
ffa_ch18_subrouti... 107
ffa_ch18_subrouti... 108 -- Subtypes of Segment:
ffa_ch18_subrouti... 109 subtype Sub_Names is Segment; -- Subroutine Names
ffa_ch18_subrouti... 110 subtype Sub_Bodies is Segment; -- Subroutine Bodies
ffa_ch18_subrouti... 111 subtype Cutouts is Segment; -- Cutout (see Ch.18 discussion)
ffa_ch18_subrouti... 112
ffa_ch18_subrouti... 113 -- Represents a Subroutine defined on this Tape:
ffa_ch18_subrouti... 114 type Sub_Def is
ffa_ch18_subrouti... 115 record
ffa_ch18_subrouti... 116 Name : Sub_Names; -- Name of the Subroutine.
ffa_ch18_subrouti... 117 Payload : Sub_Bodies; -- Body of the Subroutine.
ffa_ch18_subrouti... 118 end record;
ffa_ch18_subrouti... 119
ffa_ch18_subrouti... 120 -- Subroutine Table. Once defined, Subs may not be erased or altered.
ffa_ch18_subrouti... 121 Subs : array(Subroutine_Table_Range) of Sub_Def;
ffa_ch18_subrouti... 122
ffa_ch18_subrouti... 123 -- Position of the most recently-defined Subroutine in Subs :
ffa_ch18_subrouti... 124 STP : Subroutine_Table_Range := Subs'First;
ffa_ch18_subrouti... 125
ffa_ch17_peh.kv 126 -- Registers:
ffa_ch17_peh.kv 127 subtype RegNames is Character range 'g' .. 'z';
ffa_ch17_peh.kv 128 type RegTables is array(RegNames range <>) of FZ(1 .. Wordness);
ffa_ch18_subrouti... 129
ffa_ch18_subrouti... 130 -- Ordinary Register Set (accessed if no Cutout, or when ABOVE it)
ffa_ch17_peh.kv 131 Registers : RegTables(RegNames'Range);
ffa_ch4_ffacalc.kv 132
ffa_ch18_subrouti... 133 -- 'Cutout' Register Set (accessed only if IP is IN or BELOW the Cutout)
ffa_ch18_subrouti... 134 CO_Registers : RegTables(RegNames'Range);
ffa_ch18_subrouti... 135
ffa_ch18_subrouti... 136 -- Carry/Borrow Flag set by certain arithmetical Ops:
ffa_ch17_peh.kv 137 Flag : WBool := 0;
ffa_ch4_ffacalc.kv 138
ffa_ch19_peh_tuni... 139 -- 'Cutout'-segregated Carry/Borrow Flag:
ffa_ch19_peh_tuni... 140 CO_Flag : WBool := 0;
ffa_ch19_peh_tuni... 141
ffa_ch4_ffacalc.kv 142 -- Odometer:
ffa_ch17_peh.kv 143 Ticks : Natural := 0;
ffa_ch4_ffacalc.kv 144
ffa_ch18_subrouti... 145 -- The current levels of the three types of nestable Block:
ffa_ch17_peh.kv 146 QuoteLevel : Natural := 0;
ffa_ch17_peh.kv 147 CommLevel : Natural := 0;
ffa_ch17_peh.kv 148 CondLevel : Natural := 0;
ffa_ch13_measure_... 149
ffa_ch19_peh_tuni... 150 -- The possible Modes of the reader:
ffa_ch19_peh_tuni... 151 type Modes is (Normal, SubName, SubBody, PrefixOp);
ffa_ch18_subrouti... 152
ffa_ch19_peh_tuni... 153 -- Currently-active reader Mode:
ffa_ch19_peh_tuni... 154 Mode : Modes := Normal;
ffa_ch18_subrouti... 155
ffa_ch18_subrouti... 156 -- Current levels of nestable Blocks when reading a Subroutine Body:
ffa_ch18_subrouti... 157 SubQuoteLevel : Natural := 0;
ffa_ch18_subrouti... 158 SubCommLevel : Natural := 0;
ffa_ch18_subrouti... 159 SubCondLevel : Natural := 0;
ffa_ch18_subrouti... 160
ffa_ch18_subrouti... 161 -- Scratch for a Subroutine being proposed for lookup or internment:
ffa_ch18_subrouti... 162 Proposed_Sub : Sub_Def;
ffa_ch18_subrouti... 163
ffa_ch18_subrouti... 164 -- 'Cutout' Tape Segment. (See Ch.18 discussion re: when and how to use.)
ffa_ch18_subrouti... 165 -- If the Cutout is armed, it stays armed until Peh halts.
ffa_ch18_subrouti... 166 Cutout_Begun : Boolean := False;
ffa_ch18_subrouti... 167 Cutout_Armed : Boolean := False;
ffa_ch18_subrouti... 168 Cutout : Cutouts;
ffa_ch18_subrouti... 169
ffa_ch19_peh_tuni... 170 -- Prefix for Prefixed Operators
ffa_ch17_peh.kv 171 PrevC : Character := ' ';
ffa_ch13_measure_... 172
ffa_ch18_subrouti... 173 -- Current Verdict. We run while 'Mu', Tape remains, and Ticks under max.
ffa_ch17_peh.kv 174 Verdict : Peh_Verdicts := Mu;
ffa_ch4_ffacalc.kv 175 --------------------------------------------------------
ffa_ch4_ffacalc.kv 176
ffa_ch4_ffacalc.kv 177
ffa_ch18_subrouti... 178 ------------
ffa_ch18_subrouti... 179 -- Cutout --
ffa_ch18_subrouti... 180 ------------
ffa_ch18_subrouti... 181
ffa_ch18_subrouti... 182 -- Find whether Cutout would prohibit move from current IP to the given :
ffa_ch18_subrouti... 183 function Cutout_Prohibits(Position : in Tape_Positions) return Boolean is
ffa_ch17_peh.kv 184 begin
ffa_ch18_subrouti... 185 return Cutout_Armed and IP > Cutout.R and Position < Cutout.L;
ffa_ch18_subrouti... 186 end Cutout_Prohibits;
ffa_ch18_subrouti... 187
ffa_ch18_subrouti... 188
ffa_ch18_subrouti... 189 -- Find whether given a Tape Position lies inside an armed Cutout:
ffa_ch18_subrouti... 190 function In_Cutout(Position : in Tape_Positions) return Boolean is
ffa_ch18_subrouti... 191 begin
ffa_ch18_subrouti... 192 return Cutout_Armed and Position in Cutout.L .. Cutout.R;
ffa_ch18_subrouti... 193 end In_Cutout;
ffa_ch18_subrouti... 194
ffa_ch18_subrouti... 195
ffa_ch18_subrouti... 196 -- Determine whether to use the Cutout Registers at the current position:
ffa_ch18_subrouti... 197 function Use_CO_Registers return Boolean is
ffa_ch18_subrouti... 198 begin
ffa_ch18_subrouti... 199 -- If we are either BELOW or INSIDE armed Cutout : we use only the
ffa_ch18_subrouti... 200 -- CO_Registers alternative register file. Otherwise: use Registers.
ffa_ch18_subrouti... 201 return Cutout_Armed and IP <= Cutout.R;
ffa_ch18_subrouti... 202 end Use_CO_Registers;
ffa_ch18_subrouti... 203
ffa_ch17_peh.kv 204
ffa_ch18_subrouti... 205 ----------
ffa_ch18_subrouti... 206 -- Zaps --
ffa_ch18_subrouti... 207 ----------
ffa_ch17_peh.kv 208
ffa_ch18_subrouti... 209 -- Zero the Data Stack and reset the SP:
ffa_ch18_subrouti... 210 procedure Zap_Data_Stack is
ffa_ch4_ffacalc.kv 211 begin
ffa_ch17_peh.kv 212 -- Clear the Data Stack:
ffa_ch4_ffacalc.kv 213 for i in Stack'Range loop
ffa_ch11_tuning_a... 214 FFA_FZ_Clear(Stack(i));
ffa_ch4_ffacalc.kv 215 end loop;
ffa_ch17_peh.kv 216 -- Set SP to bottom:
ffa_ch18_subrouti... 217 SP := Stack_Positions'First;
ffa_ch18_subrouti... 218 end Zap_Data_Stack;
ffa_ch18_subrouti... 219
ffa_ch18_subrouti... 220
ffa_ch18_subrouti... 221 -- Zero all Registers (Ordinary set) :
ffa_ch18_subrouti... 222 procedure Zap_Ordinary_Registers is
ffa_ch18_subrouti... 223 begin
ffa_ch17_peh.kv 224 for r in RegNames'Range loop
ffa_ch17_peh.kv 225 FFA_FZ_Clear(Registers(r));
ffa_ch17_peh.kv 226 end loop;
ffa_ch18_subrouti... 227 end Zap_Ordinary_Registers;
ffa_ch18_subrouti... 228
ffa_ch18_subrouti... 229
ffa_ch18_subrouti... 230 -- Zero all Registers (Cutout set) :
ffa_ch18_subrouti... 231 procedure Zap_Cutout_Registers is
ffa_ch18_subrouti... 232 begin
ffa_ch18_subrouti... 233 for r in RegNames'Range loop
ffa_ch18_subrouti... 234 FFA_FZ_Clear(CO_Registers(r));
ffa_ch18_subrouti... 235 end loop;
ffa_ch18_subrouti... 236 end Zap_Cutout_Registers;
ffa_ch18_subrouti... 237
ffa_ch18_subrouti... 238
ffa_ch18_subrouti... 239 -- Zero all Registers in the currently-active Register Set:
ffa_ch18_subrouti... 240 procedure Zap_Registers is
ffa_ch18_subrouti... 241 begin
ffa_ch18_subrouti... 242 if Use_CO_Registers then
ffa_ch18_subrouti... 243 Zap_Cutout_Registers;
ffa_ch18_subrouti... 244 else
ffa_ch18_subrouti... 245 Zap_Ordinary_Registers;
ffa_ch18_subrouti... 246 end if;
ffa_ch18_subrouti... 247 end Zap_Registers;
ffa_ch18_subrouti... 248
ffa_ch18_subrouti... 249
ffa_ch19_peh_tuni... 250 -- Zero the currently-active Overflow Flag:
ffa_ch18_subrouti... 251 procedure Zap_Flag is
ffa_ch18_subrouti... 252 begin
ffa_ch19_peh_tuni... 253 if Use_CO_Registers then
ffa_ch19_peh_tuni... 254 CO_Flag := 0;
ffa_ch19_peh_tuni... 255 else
ffa_ch19_peh_tuni... 256 Flag := 0;
ffa_ch19_peh_tuni... 257 end if;
ffa_ch18_subrouti... 258 end Zap_Flag;
ffa_ch18_subrouti... 259
ffa_ch18_subrouti... 260
ffa_ch18_subrouti... 261 -- NO effect on Blocks, Control Stack, Tape, Verdict, Cutout, Subroutines
ffa_ch18_subrouti... 262 procedure Zap_Master is
ffa_ch18_subrouti... 263 begin
ffa_ch18_subrouti... 264 Zap_Data_Stack;
ffa_ch18_subrouti... 265 Zap_Registers;
ffa_ch18_subrouti... 266 Zap_Flag;
ffa_ch18_subrouti... 267 end Zap_Master;
ffa_ch4_ffacalc.kv 268
ffa_ch4_ffacalc.kv 269
ffa_ch18_subrouti... 270 -----------
ffa_ch18_subrouti... 271 -- Eggog --
ffa_ch18_subrouti... 272 -----------
ffa_ch18_subrouti... 273
ffa_ch18_subrouti... 274 -- Report a fatal error condition at the current Symbol.
ffa_ch17_peh.kv 275 -- On Unixlikes, this will also end the process and return control to OS.
ffa_ch4_ffacalc.kv 276 procedure E(S : in String) is
ffa_ch4_ffacalc.kv 277 begin
ffa_ch18_subrouti... 278 Zap_Master; -- Jettison all resettable state!
ffa_ch17_peh.kv 279 Eggog("FATAL: Tick:" & Natural'Image(Ticks) &
ffa_ch18_subrouti... 280 ", IP:" & Tape_Positions'Image(IP) &
ffa_ch18_subrouti... 281 ", Symbol: '" & Tape(IP) & "'" & " : " & S);
ffa_ch4_ffacalc.kv 282 end E;
ffa_ch4_ffacalc.kv 283
ffa_ch4_ffacalc.kv 284
ffa_ch18_subrouti... 285 -----------
ffa_ch18_subrouti... 286 -- Walls --
ffa_ch18_subrouti... 287 -----------
ffa_ch17_peh.kv 288
ffa_ch18_subrouti... 289 -- Determine whether we are currently at the last Symbol on the Tape:
ffa_ch18_subrouti... 290 function Last_Tape_Symbol return Boolean is
ffa_ch17_peh.kv 291 begin
ffa_ch18_subrouti... 292 return IP = Tape_Positions'Last;
ffa_ch18_subrouti... 293 end Last_Tape_Symbol;
ffa_ch18_subrouti... 294
ffa_ch18_subrouti... 295
ffa_ch18_subrouti... 296 -- Certain Ops are NOT permitted to occur as the final Op on a Tape:
ffa_ch18_subrouti... 297 function Next_IP_On_Tape return Tape_Positions is
ffa_ch18_subrouti... 298 begin
ffa_ch18_subrouti... 299 -- Check if we are in fact on the last Symbol of the Tape:
ffa_ch18_subrouti... 300 if Last_Tape_Symbol then
ffa_ch18_subrouti... 301 E("This Op requires a succeeding Tape Position, "
ffa_ch18_subrouti... 302 & "but it is at the end of the Tape!");
ffa_ch17_peh.kv 303 end if;
ffa_ch18_subrouti... 304 -- ... Otherwise, return the immediate successor Tape Position:
ffa_ch18_subrouti... 305 return IP + 1;
ffa_ch18_subrouti... 306 end Next_IP_On_Tape;
ffa_ch17_peh.kv 307
ffa_ch17_peh.kv 308
ffa_ch18_subrouti... 309 -- Determine whether we have reached the given limit of Life:
ffa_ch18_subrouti... 310 function Exhausted_Life return Boolean is
ffa_ch18_subrouti... 311 -- If Life = 0, we are in "immortal" mode. Otherwise mortal:
ffa_ch18_subrouti... 312 MustDie : Boolean :=
ffa_ch18_subrouti... 313 (Dimensions.Life /= 0) and (Ticks = Dimensions.Life);
ffa_ch17_peh.kv 314 begin
ffa_ch18_subrouti... 315 if MustDie then
ffa_ch18_subrouti... 316 Achtung("WARNING: Exhausted Life ("
ffa_ch18_subrouti... 317 & Natural'Image(Ticks) & " ticks )");
ffa_ch17_peh.kv 318 end if;
ffa_ch18_subrouti... 319 return MustDie;
ffa_ch18_subrouti... 320 end Exhausted_Life;
ffa_ch17_peh.kv 321
ffa_ch17_peh.kv 322
ffa_ch17_peh.kv 323 ----------------
ffa_ch17_peh.kv 324 -- Data Stack --
ffa_ch17_peh.kv 325 ----------------
ffa_ch17_peh.kv 326
ffa_ch18_subrouti... 327 -- Determine whether the Data Stack is Not Empty:
ffa_ch18_subrouti... 328 function Data_Stack_Not_Empty return Boolean is
ffa_ch18_subrouti... 329 begin
ffa_ch18_subrouti... 330 return SP /= Stack'First;
ffa_ch18_subrouti... 331 end Data_Stack_Not_Empty;
ffa_ch18_subrouti... 332
ffa_ch18_subrouti... 333
ffa_ch18_subrouti... 334 -- Raise the SP up by one:
ffa_ch4_ffacalc.kv 335 procedure Push is
ffa_ch4_ffacalc.kv 336 begin
ffa_ch4_ffacalc.kv 337 if SP = Stack_Positions'Last then
ffa_ch4_ffacalc.kv 338 E("Stack Overflow!");
ffa_ch4_ffacalc.kv 339 else
ffa_ch4_ffacalc.kv 340 SP := SP + 1;
ffa_ch4_ffacalc.kv 341 end if;
ffa_ch4_ffacalc.kv 342 end Push;
ffa_ch4_ffacalc.kv 343
ffa_ch4_ffacalc.kv 344
ffa_ch18_subrouti... 345 -- Discard the Top of the Data Stack:
ffa_ch4_ffacalc.kv 346 procedure Drop is
ffa_ch4_ffacalc.kv 347 begin
ffa_ch11_tuning_a... 348 FFA_FZ_Clear(Stack(SP));
ffa_ch4_ffacalc.kv 349 SP := SP - 1;
ffa_ch4_ffacalc.kv 350 end Drop;
ffa_ch4_ffacalc.kv 351
ffa_ch4_ffacalc.kv 352
ffa_ch18_subrouti... 353 -- Check whether the Data Stack has the necessary N items:
ffa_ch4_ffacalc.kv 354 procedure Want(N : in Positive) is
ffa_ch4_ffacalc.kv 355 begin
ffa_ch4_ffacalc.kv 356 if SP < N then
ffa_ch4_ffacalc.kv 357 E("Stack Underflow!");
ffa_ch4_ffacalc.kv 358 end if;
ffa_ch4_ffacalc.kv 359 end Want;
ffa_ch4_ffacalc.kv 360
ffa_ch4_ffacalc.kv 361
ffa_ch18_subrouti... 362 ---------
ffa_ch18_subrouti... 363 -- I/O --
ffa_ch18_subrouti... 364 ---------
ffa_ch5_egypt.kv 365
ffa_ch18_subrouti... 366 -- Slide a new hex digit into the FZ on top of the Data Stack
ffa_ch11_tuning_a... 367 procedure Ins_Hex_Digit(Digit : in Nibble) is
ffa_ch11_tuning_a... 368 Overflow : WBool := 0;
ffa_ch4_ffacalc.kv 369 begin
ffa_ch11_tuning_a... 370
ffa_ch11_tuning_a... 371 -- Insert the given nibble, and detect any overflow:
ffa_ch11_tuning_a... 372 FFA_FZ_Insert_Bottom_Nibble(N => Stack(SP),
ffa_ch11_tuning_a... 373 D => Digit,
ffa_ch11_tuning_a... 374 Overflow => Overflow);
ffa_ch4_ffacalc.kv 375
ffa_ch4_ffacalc.kv 376 -- Constants which exceed the Width are forbidden:
ffa_ch11_tuning_a... 377 if Overflow = 1 then
ffa_ch4_ffacalc.kv 378 E("Constant Exceeds Bitness!");
ffa_ch4_ffacalc.kv 379 end if;
ffa_ch4_ffacalc.kv 380
ffa_ch4_ffacalc.kv 381 end;
ffa_ch4_ffacalc.kv 382
ffa_ch4_ffacalc.kv 383
ffa_ch11_tuning_a... 384 -- Emit an ASCII representation of N to the terminal
ffa_ch11_tuning_a... 385 procedure Print_FZ(N : in FZ) is
ffa_ch11_tuning_a... 386 S : String(1 .. FFA_FZ_ASCII_Length(N)); -- Mandatorily, exact size
ffa_ch11_tuning_a... 387 begin
ffa_ch11_tuning_a... 388 FFA_FZ_To_Hex_String(N, S); -- Convert N to ASCII hex
ffa_ch11_tuning_a... 389 Write_String(S); -- Print the result to stdout
ffa_ch11_tuning_a... 390 Write_Newline; -- Print newline, for clarity.
ffa_ch11_tuning_a... 391 end Print_FZ;
ffa_ch11_tuning_a... 392
ffa_ch11_tuning_a... 393
ffa_ch18_subrouti... 394 ------------------
ffa_ch18_subrouti... 395 -- Debug Traces --
ffa_ch18_subrouti... 396 ------------------
ffa_ch18_subrouti... 397
ffa_ch18_subrouti... 398 -- Print the bounds of a Tape Segment for Debug:
ffa_ch18_subrouti... 399 procedure Print_Segment(S : in Segment) is
ffa_ch18_subrouti... 400 begin
ffa_ch18_subrouti... 401 Write_String("(" & Tape_Positions'Image(S.L) &
ffa_ch18_subrouti... 402 "," & Tape_Positions'Image(S.R) & " )");
ffa_ch18_subrouti... 403 end Print_Segment;
ffa_ch18_subrouti... 404
ffa_ch18_subrouti... 405
ffa_ch18_subrouti... 406 -- Print a Debug Trace (used in 'QD') :
ffa_ch17_peh.kv 407 procedure Print_Trace is
ffa_ch13_measure_... 408 begin
ffa_ch18_subrouti... 409 -- For clarity in cases where the Tape has already produced output:
ffa_ch18_subrouti... 410 Write_Newline;
ffa_ch18_subrouti... 411
ffa_ch17_peh.kv 412 -- Print Data Stack Trace:
ffa_ch17_peh.kv 413 Write_String("Data Stack:");
ffa_ch17_peh.kv 414 Write_Newline;
ffa_ch17_peh.kv 415 for i in reverse Stack'First + 1 .. SP loop
ffa_ch17_peh.kv 416 Write_String(" " & Stack_Positions'Image(i) & " : ");
ffa_ch17_peh.kv 417 Print_FZ(Stack(i));
ffa_ch17_peh.kv 418 end loop;
ffa_ch17_peh.kv 419
ffa_ch17_peh.kv 420 -- Print Control Stack Trace:
ffa_ch17_peh.kv 421 Write_String("Control Stack:");
ffa_ch17_peh.kv 422 Write_Newline;
ffa_ch17_peh.kv 423 for i in reverse Control_Stack'First + 1 .. CSP loop
ffa_ch18_subrouti... 424 Write_String(" " & ControlStack_Range'Image(i) & " :");
ffa_ch18_subrouti... 425 Write_String(" Return IP:"
ffa_ch18_subrouti... 426 & Stack_Positions'Image(Control_Stack(i).Ret));
ffa_ch18_subrouti... 427 Write_String(" Call Type: ");
ffa_ch18_subrouti... 428 case Control_Stack(i).Why is
ffa_ch18_subrouti... 429 when Subroutines =>
ffa_ch18_subrouti... 430 Write_String("Subroutine");
ffa_ch18_subrouti... 431 when Loops =>
ffa_ch18_subrouti... 432 Write_String("Loop");
ffa_ch18_subrouti... 433 when others =>
ffa_ch18_subrouti... 434 Write_String("INVALID");
ffa_ch18_subrouti... 435 end case;
ffa_ch17_peh.kv 436 Write_Newline;
ffa_ch17_peh.kv 437 end loop;
ffa_ch17_peh.kv 438
ffa_ch17_peh.kv 439 -- Print All Registers:
ffa_ch17_peh.kv 440 Write_String("Registers:");
ffa_ch17_peh.kv 441 Write_Newline;
ffa_ch18_subrouti... 442 -- We will not print the Cutout Register Set unless it is active:
ffa_ch17_peh.kv 443 for r in RegNames'Range loop
ffa_ch18_subrouti... 444 if Use_CO_Registers then
ffa_ch18_subrouti... 445 -- If the Cutout Register Set is currently active:
ffa_ch18_subrouti... 446 Write_String(" (C)" & r & " : ");
ffa_ch18_subrouti... 447 Print_FZ(CO_Registers(r));
ffa_ch18_subrouti... 448 else
ffa_ch18_subrouti... 449 -- If the Ordinary Register Set is currently active:
ffa_ch18_subrouti... 450 Write_String(" " & r & " : ");
ffa_ch18_subrouti... 451 Print_FZ(Registers(r));
ffa_ch18_subrouti... 452 end if;
ffa_ch17_peh.kv 453 end loop;
ffa_ch17_peh.kv 454
ffa_ch18_subrouti... 455 -- Print Subroutine Table:
ffa_ch18_subrouti... 456 Write_String("Subroutines:");
ffa_ch18_subrouti... 457 Write_Newline;
ffa_ch18_subrouti... 458 -- Walk the Subroutine Table from first to last valid entry:
ffa_ch18_subrouti... 459 for i in Subs'First + 1 .. STP loop
ffa_ch18_subrouti... 460 declare
ffa_ch18_subrouti... 461 -- The current Sub in the Subroutine Table being examined:
ffa_ch18_subrouti... 462 S : Sub_Def := Subs(i);
ffa_ch18_subrouti... 463 -- The Name of the current Sub:
ffa_ch18_subrouti... 464 S_Name : String := String(Tape(S.Name.L .. S.Name.R));
ffa_ch18_subrouti... 465 begin
ffa_ch18_subrouti... 466 Write_String(" " & Subroutine_Table_Range'Image(i)
ffa_ch18_subrouti... 467 & " : '" & S_Name & "' ");
ffa_ch18_subrouti... 468 Print_Segment(S.Payload);
ffa_ch18_subrouti... 469 if Cutout_Armed then
ffa_ch18_subrouti... 470 -- Indicate whether Sub is uncallable here because of Cutout:
ffa_ch18_subrouti... 471 if Cutout_Prohibits(S.Payload.L) then
ffa_ch18_subrouti... 472 Write_String(" (Guarded)");
ffa_ch18_subrouti... 473 -- Indicate whether Sub lies INSIDE the Cutout:
ffa_ch18_subrouti... 474 elsif In_Cutout(S.Payload.R) then
ffa_ch18_subrouti... 475 Write_String(" (Cutout)");
ffa_ch18_subrouti... 476 end if;
ffa_ch18_subrouti... 477 end if;
ffa_ch18_subrouti... 478 Write_Newline;
ffa_ch18_subrouti... 479 end;
ffa_ch18_subrouti... 480 end loop;
ffa_ch18_subrouti... 481
ffa_ch18_subrouti... 482 Write_String("Cutout: ");
ffa_ch18_subrouti... 483 -- Print Cutout bounds, if Cutout is armed:
ffa_ch18_subrouti... 484 if Cutout_Armed then
ffa_ch18_subrouti... 485 Write_String("Armed: ");
ffa_ch18_subrouti... 486 Print_Segment(Cutout);
ffa_ch18_subrouti... 487 else
ffa_ch18_subrouti... 488 Write_String("NONE");
ffa_ch18_subrouti... 489 end if;
ffa_ch18_subrouti... 490 Write_Newline;
ffa_ch18_subrouti... 491
ffa_ch19_peh_tuni... 492 -- Print active Overflow-Flag, then Ticks and IP:
ffa_ch19_peh_tuni... 493
ffa_ch19_peh_tuni... 494 if Use_CO_Registers then
ffa_ch19_peh_tuni... 495 Write_String("Flag (CO) :" & WBool'Image(CO_Flag));
ffa_ch19_peh_tuni... 496 else
ffa_ch19_peh_tuni... 497 Write_String("Flag :" & WBool'Image(Flag));
ffa_ch19_peh_tuni... 498 end if;
ffa_ch19_peh_tuni... 499
ffa_ch18_subrouti... 500 Write_Newline;
ffa_ch19_peh_tuni... 501 Write_String("Ticks :" & Natural'Image(Ticks));
ffa_ch17_peh.kv 502 Write_Newline;
ffa_ch19_peh_tuni... 503 Write_String("IP :" & Tape_Positions'Image(IP));
ffa_ch17_peh.kv 504 Write_Newline;
ffa_ch17_peh.kv 505 end Print_Trace;
ffa_ch13_measure_... 506
ffa_ch13_measure_... 507
ffa_ch18_subrouti... 508 -------------------
ffa_ch18_subrouti... 509 -- Control Stack --
ffa_ch18_subrouti... 510 -------------------
ffa_ch18_subrouti... 511
ffa_ch18_subrouti... 512 -- Determine whether the Control Stack is Not Empty:
ffa_ch18_subrouti... 513 function Control_Stack_Not_Empty return Boolean is
ffa_ch18_subrouti... 514 begin
ffa_ch18_subrouti... 515 return CSP /= Control_Stack'First;
ffa_ch18_subrouti... 516 end Control_Stack_Not_Empty;
ffa_ch18_subrouti... 517
ffa_ch18_subrouti... 518
ffa_ch18_subrouti... 519 -- Construct a Call and push it to the Control Stack:
ffa_ch18_subrouti... 520 procedure Control_Push(Call_Type : in Call_Types;
ffa_ch18_subrouti... 521 Return_IP : in Tape_Positions) is
ffa_ch18_subrouti... 522 begin
ffa_ch18_subrouti... 523 -- First, test for Overflow of Control Stack:
ffa_ch18_subrouti... 524 if CSP = Control_Stack'Last then
ffa_ch18_subrouti... 525 E("Control Stack Overflow!");
ffa_ch18_subrouti... 526 end if;
ffa_ch18_subrouti... 527 -- Push a Call with given parameters to the Control Stack:
ffa_ch18_subrouti... 528 CSP := CSP + 1;
ffa_ch18_subrouti... 529 Control_Stack(CSP) := (Why => Call_Type, Ret => Return_IP);
ffa_ch18_subrouti... 530 end Control_Push;
ffa_ch18_subrouti... 531
ffa_ch18_subrouti... 532
ffa_ch18_subrouti... 533 -- Pop an IP from the Control Stack, and verify expected Call Type:
ffa_ch18_subrouti... 534 function Control_Pop(Expected_Type : in Call_Types)
ffa_ch18_subrouti... 535 return Tape_Positions is
ffa_ch18_subrouti... 536 C : Call;
ffa_ch18_subrouti... 537 begin
ffa_ch18_subrouti... 538 -- First, test for Underflow of Control Stack:
ffa_ch18_subrouti... 539 if CSP = Control_Stack'First then
ffa_ch18_subrouti... 540 E("Control Stack Underflow!");
ffa_ch18_subrouti... 541 end if;
ffa_ch18_subrouti... 542 -- Pop from Control Stack:
ffa_ch18_subrouti... 543 C := Control_Stack(CSP);
ffa_ch18_subrouti... 544 Control_Stack(CSP).Why := Invalid;
ffa_ch18_subrouti... 545 CSP := CSP - 1;
ffa_ch18_subrouti... 546 -- Now, see whether it was NOT the expected type. If so, eggog:
ffa_ch18_subrouti... 547 if C.Why /= Expected_Type then
ffa_ch18_subrouti... 548 declare
ffa_ch18_subrouti... 549 CT : constant array(Call_Types) of String(1 .. 10)
ffa_ch18_subrouti... 550 := (" INVALID ", "Subroutine", "Loop state");
ffa_ch18_subrouti... 551 begin
ffa_ch18_subrouti... 552 E("Currently in a " & CT(C.Why) & "; but this Op exits a "
ffa_ch18_subrouti... 553 & CT(Expected_Type) & " !");
ffa_ch18_subrouti... 554 end;
ffa_ch18_subrouti... 555 end if;
ffa_ch18_subrouti... 556 -- ... The Call was of the expected type, so return it:
ffa_ch18_subrouti... 557 return C.Ret;
ffa_ch18_subrouti... 558 end Control_Pop;
ffa_ch18_subrouti... 559
ffa_ch18_subrouti... 560
ffa_ch18_subrouti... 561 -----------------
ffa_ch18_subrouti... 562 -- Subroutines --
ffa_ch18_subrouti... 563 -----------------
ffa_ch18_subrouti... 564
ffa_ch18_subrouti... 565 -- Find Subroutine with supplied Name in Subroutine Table, if it exists:
ffa_ch18_subrouti... 566 function Lookup_Subroutine(Name : in Sub_Names)
ffa_ch18_subrouti... 567 return Subroutine_Table_Range is
ffa_ch18_subrouti... 568 -- Number of Symbols in the Name of the current Proposed Subroutine:
ffa_ch18_subrouti... 569 Sub_Name_Length : Positive := 1 + Name.R - Name.L;
ffa_ch18_subrouti... 570 begin
ffa_ch18_subrouti... 571 -- Enforce minimum Subroutine Name length:
ffa_ch18_subrouti... 572 if Sub_Name_Length < Subr_Min_Name_Length then
ffa_ch18_subrouti... 573 E("Proposed Name is" & Positive'Image(Sub_Name_Length) &
ffa_ch18_subrouti... 574 " Symbols long, but the shortest permitted Name length is" &
ffa_ch18_subrouti... 575 Positive'Image(Subr_Min_Name_Length) & " !");
ffa_ch18_subrouti... 576 end if;
ffa_ch18_subrouti... 577 -- Walk the Subroutine Table from first to last valid entry:
ffa_ch18_subrouti... 578 for i in Subs'First + 1 .. STP loop
ffa_ch18_subrouti... 579 declare
ffa_ch18_subrouti... 580 -- The current Sub in the Subroutine Table being examined:
ffa_ch18_subrouti... 581 S : Sub_Def := Subs(i);
ffa_ch18_subrouti... 582 -- Number of Symbols in the Name of S:
ffa_ch18_subrouti... 583 S_Name_Length : Positive := 1 + S.Name.R - S.Name.L;
ffa_ch18_subrouti... 584 begin
ffa_ch18_subrouti... 585 -- If the lengths of the Names match:
ffa_ch18_subrouti... 586 if Sub_Name_Length = S_Name_Length then
ffa_ch18_subrouti... 587 -- If the two Names are actually equal:
ffa_ch18_subrouti... 588 if Tape(Name.L .. Name.R) = Tape(S.Name.L .. S.Name.R) then
ffa_ch18_subrouti... 589 return i; -- Return the table index of the located Sub
ffa_ch18_subrouti... 590 end if;
ffa_ch18_subrouti... 591 end if;
ffa_ch18_subrouti... 592 end;
ffa_ch18_subrouti... 593 end loop;
ffa_ch18_subrouti... 594 -- Name was not found in Subroutine Table; return the zero position:
ffa_ch18_subrouti... 595 return Subs'First;
ffa_ch18_subrouti... 596 end Lookup_Subroutine;
ffa_ch18_subrouti... 597
ffa_ch18_subrouti... 598
ffa_ch18_subrouti... 599 -- Attempt to intern the given Subroutine into the Subroutines Table:
ffa_ch18_subrouti... 600 procedure Intern_Subroutine(Sub : in Sub_Def) is
ffa_ch18_subrouti... 601 -- Position of the current Proposed Sub in Sub Table:
ffa_ch18_subrouti... 602 Index : Subroutine_Table_Range := Lookup_Subroutine(Sub.Name);
ffa_ch18_subrouti... 603 -- To DEFINE a Sub, it must NOT have existed in Sub Table.
ffa_ch18_subrouti... 604
ffa_ch18_subrouti... 605 -- Name of the Proposed Sub (for eggogs) :
ffa_ch18_subrouti... 606 S_Name : String := String(Tape(Sub.Name.L .. Sub.Name.R));
ffa_ch18_subrouti... 607 begin
ffa_ch18_subrouti... 608 -- If a Sub with this Name already exists, eggog:
ffa_ch18_subrouti... 609 if Index /= Subs'First then
ffa_ch18_subrouti... 610 E("Attempted to redefine Subroutine '" & S_Name & "' !");
ffa_ch18_subrouti... 611 end if;
ffa_ch18_subrouti... 612 -- Definitions are prohibited inside Loops or Sub calls:
ffa_ch18_subrouti... 613 if Control_Stack_Not_Empty then
ffa_ch18_subrouti... 614 E("Attempted to define Subroutine '"
ffa_ch18_subrouti... 615 & S_Name & "' while inside a Loop or Subroutine!");
ffa_ch18_subrouti... 616 end if;
ffa_ch18_subrouti... 617 -- If the Subroutine Table is full, eggog:
ffa_ch18_subrouti... 618 if STP = Subs'Last then
ffa_ch18_subrouti... 619 E("Cannot define the Subroutine '" & S_Name
ffa_ch18_subrouti... 620 & ": the Subroutine Table is Full!");
ffa_ch18_subrouti... 621 end if;
ffa_ch18_subrouti... 622 -- Finally, intern the Proposed Subroutine into the Sub Table:
ffa_ch18_subrouti... 623 STP := STP + 1;
ffa_ch18_subrouti... 624 Subs(STP) := Sub;
ffa_ch18_subrouti... 625 end Intern_Subroutine;
ffa_ch18_subrouti... 626
ffa_ch18_subrouti... 627
ffa_ch18_subrouti... 628 -- Invoke a given Subroutine:
ffa_ch18_subrouti... 629 procedure Invoke_Subroutine(Sub : in Sub_Def) is
ffa_ch18_subrouti... 630 begin
ffa_ch18_subrouti... 631 -- Push the Call to Control Stack:
ffa_ch18_subrouti... 632 Control_Push(Call_Type => Subroutines, Return_IP => Next_IP_On_Tape);
ffa_ch18_subrouti... 633 -- Next instruction will be the first Symbol of the Sub's Body:
ffa_ch18_subrouti... 634 IP_Next := Sub.Payload.L;
ffa_ch18_subrouti... 635 end Invoke_Subroutine;
ffa_ch18_subrouti... 636
ffa_ch18_subrouti... 637
ffa_ch18_subrouti... 638 -- Attempt to invoke a Subroutine with the supplied name:
ffa_ch18_subrouti... 639 procedure Invoke_Named_Subroutine(Name : in Sub_Names) is
ffa_ch18_subrouti... 640 -- Position of the current Proposed Sub in Sub Table:
ffa_ch18_subrouti... 641 Index : Subroutine_Table_Range := Lookup_Subroutine(Name);
ffa_ch18_subrouti... 642 -- To invoke a Sub, it MUST exist in the Sub Table.
ffa_ch18_subrouti... 643
ffa_ch18_subrouti... 644 -- Name of the Proposed Sub (for eggogs) :
ffa_ch18_subrouti... 645 S_Name : String := String(Tape(Name.L .. Name.R));
ffa_ch18_subrouti... 646 begin
ffa_ch18_subrouti... 647 -- If no defined Subroutine has this Name, eggog:
ffa_ch18_subrouti... 648 if Index = Subs'First then
ffa_ch18_subrouti... 649 E("Invoked Undefined Subroutine '" & S_Name & "' !");
ffa_ch18_subrouti... 650 end if;
ffa_ch18_subrouti... 651 -- Otherwise, proceed to the invocation:
ffa_ch18_subrouti... 652 declare
ffa_ch18_subrouti... 653 -- The Sub Table Entry we successfully looked up:
ffa_ch18_subrouti... 654 Sub : Sub_Def := Subs(Index);
ffa_ch18_subrouti... 655 begin
ffa_ch18_subrouti... 656 -- Recursion is prohibited in Peh Tapes. Detect it:
ffa_ch18_subrouti... 657 if IP in Sub.Payload.L .. Sub.Payload.R then
ffa_ch18_subrouti... 658 E("Recursive invocation in Subroutine '"
ffa_ch18_subrouti... 659 & S_Name & "' is prohibited!");
ffa_ch18_subrouti... 660 end if;
ffa_ch18_subrouti... 661 -- Prohibit Subroutines whose definitions end AFTER the current IP:
ffa_ch18_subrouti... 662 if IP < Sub.Payload.R then
ffa_ch18_subrouti... 663 E("Cannot invoke Subroutine '" & S_Name &
ffa_ch18_subrouti... 664 "' before the position where it is defined!");
ffa_ch18_subrouti... 665 end if;
ffa_ch18_subrouti... 666 -- Proceed to invoke the Subroutine:
ffa_ch18_subrouti... 667 Invoke_Subroutine(Sub);
ffa_ch18_subrouti... 668 end;
ffa_ch18_subrouti... 669 end Invoke_Named_Subroutine;
ffa_ch18_subrouti... 670
ffa_ch18_subrouti... 671
ffa_ch18_subrouti... 672 -- Invoke the nearest Subroutine defined to the LEFT of the current IP:
ffa_ch18_subrouti... 673 procedure Invoke_Left_Subroutine is
ffa_ch18_subrouti... 674 -- Position of the Subroutine to be invoked (Subs'First if none)
ffa_ch18_subrouti... 675 Index : Subroutine_Table_Range := Subs'First;
ffa_ch18_subrouti... 676 begin
ffa_ch18_subrouti... 677 -- Find the nearest invocable Sub (i.e. to the LEFT of current IP) :
ffa_ch18_subrouti... 678 -- Walk starting from the LAST Sub in Subs, down to the FIRST:
ffa_ch18_subrouti... 679 for i in reverse Subs'First + 1 .. STP loop
ffa_ch18_subrouti... 680 -- If a Sub's definition ended PRIOR TO the current IP:
ffa_ch18_subrouti... 681 if Subs(i).Payload.R < IP then
ffa_ch18_subrouti... 682 -- Save that Sub's table index:
ffa_ch18_subrouti... 683 Index := i;
ffa_ch18_subrouti... 684 -- If we found a Sub that met the condition, stop walking:
ffa_ch18_subrouti... 685 exit when Index /= Subs'First;
ffa_ch18_subrouti... 686 end if;
ffa_ch18_subrouti... 687 end loop;
ffa_ch18_subrouti... 688 -- If no Subs have been defined prior to current IP, then eggog:
ffa_ch18_subrouti... 689 if Index = Subs'First then
ffa_ch18_subrouti... 690 E("No Subroutines were defined prior to this position!");
ffa_ch18_subrouti... 691 end if;
ffa_ch18_subrouti... 692 -- Proceed to invoke the selected Sub:
ffa_ch18_subrouti... 693 Invoke_Subroutine(Subs(Index));
ffa_ch18_subrouti... 694 end Invoke_Left_Subroutine;
ffa_ch18_subrouti... 695
ffa_ch18_subrouti... 696
ffa_ch18_subrouti... 697 ---------
ffa_ch18_subrouti... 698 -- Peh --
ffa_ch18_subrouti... 699 ---------
ffa_ch18_subrouti... 700
ffa_ch18_subrouti... 701 -- For all Ops which entail Division: ensure that a Divisor is not zero:
ffa_ch18_subrouti... 702 procedure MustNotZero(D : in FZ) is
ffa_ch18_subrouti... 703 begin
ffa_ch18_subrouti... 704 if FFA_FZ_ZeroP(D) = 1 then
ffa_ch18_subrouti... 705 E("Division by Zero!");
ffa_ch18_subrouti... 706 end if;
ffa_ch18_subrouti... 707 end MustNotZero;
ffa_ch18_subrouti... 708
ffa_ch18_subrouti... 709 ------------------------------------------------------------------------
ffa_ch18_subrouti... 710
ffa_ch4_ffacalc.kv 711 -- Execute a Normal Op
ffa_ch4_ffacalc.kv 712 procedure Op_Normal(C : in Character) is
ffa_ch4_ffacalc.kv 713
ffa_ch4_ffacalc.kv 714 -- Over/underflow output from certain ops
ffa_ch4_ffacalc.kv 715 F : Word;
ffa_ch18_subrouti... 716
ffa_ch4_ffacalc.kv 717 begin
ffa_ch4_ffacalc.kv 718
ffa_ch4_ffacalc.kv 719 case C is
ffa_ch4_ffacalc.kv 720
ffa_ch18_subrouti... 721 ------------
ffa_ch18_subrouti... 722 -- Blocks --
ffa_ch18_subrouti... 723 ------------
ffa_ch18_subrouti... 724
ffa_ch18_subrouti... 725 -- Enter Comment Block: Symbols will be ignored until matching ')'
ffa_ch4_ffacalc.kv 726 when '(' =>
ffa_ch4_ffacalc.kv 727 CommLevel := 1;
ffa_ch4_ffacalc.kv 728
ffa_ch18_subrouti... 729 -- Exit a Comment Block (but if we're here, we aren't in one!)
ffa_ch4_ffacalc.kv 730 when ')' =>
ffa_ch4_ffacalc.kv 731 E("Mismatched close-comment parenthesis !");
ffa_ch4_ffacalc.kv 732
ffa_ch18_subrouti... 733 -- Enter a Quote Block: Symbols will print until matching ']'
ffa_ch4_ffacalc.kv 734 when '[' =>
ffa_ch4_ffacalc.kv 735 QuoteLevel := 1;
ffa_ch4_ffacalc.kv 736
ffa_ch18_subrouti... 737 -- Exit a Quote Block (but if we're here, we aren't in one!)
ffa_ch4_ffacalc.kv 738 when ']' =>
ffa_ch4_ffacalc.kv 739 E("Mismatched close-quote bracket !");
ffa_ch4_ffacalc.kv 740
ffa_ch18_subrouti... 741 -- Enter a Conditional branch:
ffa_ch4_ffacalc.kv 742 when '{' =>
ffa_ch4_ffacalc.kv 743 Want(1);
ffa_ch11_tuning_a... 744 if FFA_FZ_ZeroP(Stack(SP)) = 1 then
ffa_ch18_subrouti... 745 -- Enter a 'taken' branch.
ffa_ch18_subrouti... 746 -- All subsequent Symbols will be ignored until matching '}'.
ffa_ch4_ffacalc.kv 747 CondLevel := 1;
ffa_ch4_ffacalc.kv 748 end if;
ffa_ch4_ffacalc.kv 749 Drop;
ffa_ch4_ffacalc.kv 750
ffa_ch4_ffacalc.kv 751 -- Exit from a ~non-taken~ Conditional branch:
ffa_ch18_subrouti... 752 -- ... we push a 0, to suppress the 'else' clause:
ffa_ch4_ffacalc.kv 753 when '}' =>
ffa_ch4_ffacalc.kv 754 Push;
ffa_ch11_tuning_a... 755 FFA_WBool_To_FZ(0, Stack(SP));
ffa_ch4_ffacalc.kv 756
ffa_ch4_ffacalc.kv 757 ----------------
ffa_ch4_ffacalc.kv 758 -- Immediates --
ffa_ch4_ffacalc.kv 759 ----------------
ffa_ch4_ffacalc.kv 760
ffa_ch4_ffacalc.kv 761 -- These operate on the FZ ~currently~ at top of the stack;
ffa_ch4_ffacalc.kv 762 -- and this means that the stack may NOT be empty.
ffa_ch4_ffacalc.kv 763
ffa_ch4_ffacalc.kv 764 when '0' .. '9' =>
ffa_ch4_ffacalc.kv 765 Want(1);
ffa_ch11_tuning_a... 766 Ins_Hex_Digit(Character'Pos(C) - Character'Pos('0'));
ffa_ch4_ffacalc.kv 767
ffa_ch4_ffacalc.kv 768 when 'A' .. 'F' =>
ffa_ch4_ffacalc.kv 769 Want(1);
ffa_ch11_tuning_a... 770 Ins_Hex_Digit(10 + Character'Pos(C) - Character'Pos('A'));
ffa_ch4_ffacalc.kv 771
ffa_ch4_ffacalc.kv 772 when 'a' .. 'f' =>
ffa_ch4_ffacalc.kv 773 Want(1);
ffa_ch11_tuning_a... 774 Ins_Hex_Digit(10 + Character'Pos(C) - Character'Pos('a'));
ffa_ch4_ffacalc.kv 775
ffa_ch17_peh.kv 776 -------------------------
ffa_ch17_peh.kv 777 -- Fetch from Register --
ffa_ch17_peh.kv 778 -------------------------
ffa_ch17_peh.kv 779 when 'g' .. 'z' =>
ffa_ch18_subrouti... 780 -- Put value of Register on stack
ffa_ch17_peh.kv 781 Push;
ffa_ch18_subrouti... 782 if Use_CO_Registers then
ffa_ch18_subrouti... 783 Stack(SP) := CO_Registers(C); -- use Cutout Register set
ffa_ch18_subrouti... 784 else
ffa_ch18_subrouti... 785 Stack(SP) := Registers(C); -- use ordinary set
ffa_ch18_subrouti... 786 end if;
ffa_ch17_peh.kv 787
ffa_ch4_ffacalc.kv 788 ------------------
ffa_ch4_ffacalc.kv 789 -- Stack Motion --
ffa_ch4_ffacalc.kv 790 ------------------
ffa_ch4_ffacalc.kv 791
ffa_ch4_ffacalc.kv 792 -- Push a 0 onto the stack
ffa_ch4_ffacalc.kv 793 when '.' =>
ffa_ch4_ffacalc.kv 794 Push;
ffa_ch11_tuning_a... 795 FFA_FZ_Clear(Stack(SP));
ffa_ch4_ffacalc.kv 796
ffa_ch4_ffacalc.kv 797 -- Dup
ffa_ch4_ffacalc.kv 798 when '"' =>
ffa_ch4_ffacalc.kv 799 Want(1);
ffa_ch4_ffacalc.kv 800 Push;
ffa_ch4_ffacalc.kv 801 Stack(SP) := Stack(SP - 1);
ffa_ch4_ffacalc.kv 802
ffa_ch4_ffacalc.kv 803 -- Drop
ffa_ch4_ffacalc.kv 804 when '_' =>
ffa_ch4_ffacalc.kv 805 Want(1);
ffa_ch4_ffacalc.kv 806 Drop;
ffa_ch4_ffacalc.kv 807
ffa_ch4_ffacalc.kv 808 -- Swap
ffa_ch4_ffacalc.kv 809 when ''' =>
ffa_ch4_ffacalc.kv 810 Want(2);
ffa_ch11_tuning_a... 811 FFA_FZ_Swap(Stack(SP), Stack(SP - 1));
ffa_ch4_ffacalc.kv 812
ffa_ch4_ffacalc.kv 813 -- Over
ffa_ch4_ffacalc.kv 814 when '`' =>
ffa_ch4_ffacalc.kv 815 Want(2);
ffa_ch4_ffacalc.kv 816 Push;
ffa_ch4_ffacalc.kv 817 Stack(SP) := Stack(SP - 2);
ffa_ch4_ffacalc.kv 818
ffa_ch4_ffacalc.kv 819 ----------------
ffa_ch4_ffacalc.kv 820 -- Predicates --
ffa_ch4_ffacalc.kv 821 ----------------
ffa_ch4_ffacalc.kv 822
ffa_ch4_ffacalc.kv 823 -- Equality
ffa_ch4_ffacalc.kv 824 when '=' =>
ffa_ch4_ffacalc.kv 825 Want(2);
ffa_ch11_tuning_a... 826 FFA_WBool_To_FZ(FFA_FZ_EqP(X => Stack(SP),
ffa_ch11_tuning_a... 827 Y => Stack(SP - 1)),
ffa_ch11_tuning_a... 828 Stack(SP - 1));
ffa_ch4_ffacalc.kv 829 Drop;
ffa_ch4_ffacalc.kv 830
ffa_ch4_ffacalc.kv 831 -- Less-Than
ffa_ch4_ffacalc.kv 832 when '<' =>
ffa_ch4_ffacalc.kv 833 Want(2);
ffa_ch11_tuning_a... 834 FFA_WBool_To_FZ(FFA_FZ_LessThanP(X => Stack(SP - 1),
ffa_ch11_tuning_a... 835 Y => Stack(SP)),
ffa_ch11_tuning_a... 836 Stack(SP - 1));
ffa_ch4_ffacalc.kv 837 Drop;
ffa_ch4_ffacalc.kv 838
ffa_ch4_ffacalc.kv 839 -- Greater-Than
ffa_ch4_ffacalc.kv 840 when '>' =>
ffa_ch4_ffacalc.kv 841 Want(2);
ffa_ch11_tuning_a... 842 FFA_WBool_To_FZ(FFA_FZ_GreaterThanP(X => Stack(SP - 1),
ffa_ch11_tuning_a... 843 Y => Stack(SP)),
ffa_ch11_tuning_a... 844 Stack(SP - 1));
ffa_ch4_ffacalc.kv 845 Drop;
ffa_ch4_ffacalc.kv 846
ffa_ch4_ffacalc.kv 847 ----------------
ffa_ch4_ffacalc.kv 848 -- Arithmetic --
ffa_ch4_ffacalc.kv 849 ----------------
ffa_ch4_ffacalc.kv 850
ffa_ch4_ffacalc.kv 851 -- Subtract
ffa_ch4_ffacalc.kv 852 when '-' =>
ffa_ch4_ffacalc.kv 853 Want(2);
ffa_ch11_tuning_a... 854 FFA_FZ_Subtract(X => Stack(SP - 1),
ffa_ch11_tuning_a... 855 Y => Stack(SP),
ffa_ch11_tuning_a... 856 Difference => Stack(SP - 1),
ffa_ch11_tuning_a... 857 Underflow => F);
ffa_ch19_peh_tuni... 858
ffa_ch19_peh_tuni... 859 -- If we are in the Cutout, write the CO_Flag instead of Flag:
ffa_ch19_peh_tuni... 860 if Use_CO_Registers then
ffa_ch19_peh_tuni... 861 CO_Flag := FFA_Word_NZeroP(F);
ffa_ch19_peh_tuni... 862 else
ffa_ch19_peh_tuni... 863 Flag := FFA_Word_NZeroP(F);
ffa_ch19_peh_tuni... 864 end if;
ffa_ch4_ffacalc.kv 865 Drop;
ffa_ch4_ffacalc.kv 866
ffa_ch4_ffacalc.kv 867 -- Add
ffa_ch4_ffacalc.kv 868 when '+' =>
ffa_ch4_ffacalc.kv 869 Want(2);
ffa_ch11_tuning_a... 870 FFA_FZ_Add(X => Stack(SP - 1),
ffa_ch11_tuning_a... 871 Y => Stack(SP),
ffa_ch11_tuning_a... 872 Sum => Stack(SP - 1),
ffa_ch11_tuning_a... 873 Overflow => F);
ffa_ch19_peh_tuni... 874
ffa_ch19_peh_tuni... 875 -- If we are in the Cutout, write the CO_Flag instead of Flag:
ffa_ch19_peh_tuni... 876 if Use_CO_Registers then
ffa_ch19_peh_tuni... 877 CO_Flag := FFA_Word_NZeroP(F);
ffa_ch19_peh_tuni... 878 else
ffa_ch19_peh_tuni... 879 Flag := FFA_Word_NZeroP(F);
ffa_ch19_peh_tuni... 880 end if;
ffa_ch4_ffacalc.kv 881 Drop;
ffa_ch4_ffacalc.kv 882
ffa_ch5_egypt.kv 883 -- Divide and give Quotient and Remainder
ffa_ch5_egypt.kv 884 when '\' =>
ffa_ch5_egypt.kv 885 Want(2);
ffa_ch5_egypt.kv 886 MustNotZero(Stack(SP));
ffa_ch11_tuning_a... 887 FFA_FZ_IDiv(Dividend => Stack(SP - 1),
ffa_ch11_tuning_a... 888 Divisor => Stack(SP),
ffa_ch11_tuning_a... 889 Quotient => Stack(SP - 1),
ffa_ch11_tuning_a... 890 Remainder => Stack(SP));
ffa_ch5_egypt.kv 891
ffa_ch5_egypt.kv 892 -- Divide and give Quotient only
ffa_ch5_egypt.kv 893 when '/' =>
ffa_ch5_egypt.kv 894 Want(2);
ffa_ch5_egypt.kv 895 MustNotZero(Stack(SP));
ffa_ch11_tuning_a... 896 FFA_FZ_Div(Dividend => Stack(SP - 1),
ffa_ch11_tuning_a... 897 Divisor => Stack(SP),
ffa_ch11_tuning_a... 898 Quotient => Stack(SP - 1));
ffa_ch5_egypt.kv 899 Drop;
ffa_ch5_egypt.kv 900
ffa_ch5_egypt.kv 901 -- Divide and give Remainder only
ffa_ch5_egypt.kv 902 when '%' =>
ffa_ch5_egypt.kv 903 Want(2);
ffa_ch5_egypt.kv 904 MustNotZero(Stack(SP));
ffa_ch11_tuning_a... 905 FFA_FZ_Mod(Dividend => Stack(SP - 1),
ffa_ch11_tuning_a... 906 Divisor => Stack(SP),
ffa_ch11_tuning_a... 907 Remainder => Stack(SP - 1));
ffa_ch5_egypt.kv 908 Drop;
ffa_ch5_egypt.kv 909
ffa_ch5_egypt.kv 910 -- Multiply, give bottom and top halves
ffa_ch5_egypt.kv 911 when '*' =>
ffa_ch5_egypt.kv 912 Want(2);
ffa_ch11_tuning_a... 913 FFA_FZ_Multiply(X => Stack(SP - 1),
ffa_ch11_tuning_a... 914 Y => Stack(SP),
ffa_ch11_tuning_a... 915 XY_Lo => Stack(SP - 1),
ffa_ch11_tuning_a... 916 XY_Hi => Stack(SP));
ffa_ch5_egypt.kv 917
ffa_ch15_gcd.kv 918 -- Square, give bottom and top halves
ffa_ch15_gcd.kv 919 when 'S' =>
ffa_ch15_gcd.kv 920 Want(1);
ffa_ch15_gcd.kv 921 Push;
ffa_ch15_gcd.kv 922 FFA_FZ_Square(X => Stack(SP - 1),
ffa_ch15_gcd.kv 923 XX_Lo => Stack(SP - 1),
ffa_ch15_gcd.kv 924 XX_Hi => Stack(SP));
ffa_ch15_gcd.kv 925
ffa_ch15_gcd.kv 926 -- Greatest Common Divisor (GCD)
ffa_ch15_gcd.kv 927 when 'G' =>
ffa_ch15_gcd.kv 928 Want(2);
ffa_ch15_gcd.kv 929
ffa_ch15_gcd.kv 930 -- Note that GCD(0,0) is not factually zero, or unique.
ffa_ch15_gcd.kv 931 -- But it is permissible to define it as zero.
ffa_ch15_gcd.kv 932 -- (See Ch. 15 discussion.)
ffa_ch15_gcd.kv 933
ffa_ch15_gcd.kv 934 FFA_FZ_Greatest_Common_Divisor(X => Stack(SP - 1),
ffa_ch15_gcd.kv 935 Y => Stack(SP),
ffa_ch15_gcd.kv 936 Result => Stack(SP - 1));
ffa_ch15_gcd.kv 937 Drop;
ffa_ch15_gcd.kv 938
ffa_ch4_ffacalc.kv 939 -----------------
ffa_ch4_ffacalc.kv 940 -- Bitwise Ops --
ffa_ch4_ffacalc.kv 941 -----------------
ffa_ch4_ffacalc.kv 942
ffa_ch4_ffacalc.kv 943 -- Bitwise-And
ffa_ch4_ffacalc.kv 944 when '&' =>
ffa_ch4_ffacalc.kv 945 Want(2);
ffa_ch11_tuning_a... 946 FFA_FZ_And(X => Stack(SP - 1),
ffa_ch11_tuning_a... 947 Y => Stack(SP),
ffa_ch11_tuning_a... 948 Result => Stack(SP - 1));
ffa_ch4_ffacalc.kv 949 Drop;
ffa_ch4_ffacalc.kv 950
ffa_ch4_ffacalc.kv 951 -- Bitwise-Or
ffa_ch4_ffacalc.kv 952 when '|' =>
ffa_ch4_ffacalc.kv 953 Want(2);
ffa_ch11_tuning_a... 954 FFA_FZ_Or(X => Stack(SP - 1),
ffa_ch11_tuning_a... 955 Y => Stack(SP),
ffa_ch11_tuning_a... 956 Result => Stack(SP - 1));
ffa_ch4_ffacalc.kv 957 Drop;
ffa_ch4_ffacalc.kv 958
ffa_ch4_ffacalc.kv 959 -- Bitwise-Xor
ffa_ch4_ffacalc.kv 960 when '^' =>
ffa_ch4_ffacalc.kv 961 Want(2);
ffa_ch11_tuning_a... 962 FFA_FZ_Xor(X => Stack(SP - 1),
ffa_ch11_tuning_a... 963 Y => Stack(SP),
ffa_ch11_tuning_a... 964 Result => Stack(SP - 1));
ffa_ch4_ffacalc.kv 965 Drop;
ffa_ch4_ffacalc.kv 966
ffa_ch4_ffacalc.kv 967 -- Bitwise-Not (1s-Complement)
ffa_ch4_ffacalc.kv 968 when '~' =>
ffa_ch4_ffacalc.kv 969 Want(1);
ffa_ch11_tuning_a... 970 FFA_FZ_Not(Stack(SP), Stack(SP));
ffa_ch4_ffacalc.kv 971
ffa_ch4_ffacalc.kv 972 -----------
ffa_ch4_ffacalc.kv 973 -- Other --
ffa_ch4_ffacalc.kv 974 -----------
ffa_ch4_ffacalc.kv 975
ffa_ch8_randomism.kv 976 -- Push a FZ of RNGolade onto the stack
ffa_ch8_randomism.kv 977 when '?' =>
ffa_ch8_randomism.kv 978 Push;
ffa_ch11_tuning_a... 979 FFA_FZ_Clear(Stack(SP));
ffa_ch8_randomism.kv 980 FZ_Random(RNG, Stack(SP));
ffa_ch8_randomism.kv 981
ffa_ch4_ffacalc.kv 982 -- mUx
ffa_ch4_ffacalc.kv 983 when 'U' =>
ffa_ch4_ffacalc.kv 984 Want(3);
ffa_ch11_tuning_a... 985 FFA_FZ_Mux(X => Stack(SP - 2),
ffa_ch11_tuning_a... 986 Y => Stack(SP - 1),
ffa_ch11_tuning_a... 987 Result => Stack(SP - 2),
ffa_ch11_tuning_a... 988 Sel => FFA_FZ_NZeroP(Stack(SP)));
ffa_ch4_ffacalc.kv 989 Drop;
ffa_ch4_ffacalc.kv 990 Drop;
ffa_ch4_ffacalc.kv 991
ffa_ch13_measure_... 992 -- Find the position of eldest nonzero bit, if any exist
ffa_ch13_measure_... 993 when 'W' =>
ffa_ch13_measure_... 994 Want(1);
ffa_ch13_measure_... 995 declare
ffa_ch13_measure_... 996 -- Find the measure ( 0 if no 1s, or 1 .. FZBitness )
ffa_ch14_barrett.kv 997 Measure : FZBit_Index := FFA_FZ_Measure(Stack(SP));
ffa_ch14_barrett.kv 998 begin
ffa_ch13_measure_... 999 -- Put on top of stack
ffa_ch13_measure_... 1000 FFA_FZ_Clear(Stack(SP));
ffa_ch14_barrett.kv 1001 FFA_FZ_Set_Head(Stack(SP), Word(Measure));
ffa_ch13_measure_... 1002 end;
ffa_ch13_measure_... 1003
ffa_ch4_ffacalc.kv 1004 -- Put the Overflow flag on the stack
ffa_ch4_ffacalc.kv 1005 when 'O' =>
ffa_ch4_ffacalc.kv 1006 Push;
ffa_ch19_peh_tuni... 1007 -- If we are in the Cutout, read CO_Flag instead of Flag:
ffa_ch19_peh_tuni... 1008 if Use_CO_Registers then
ffa_ch19_peh_tuni... 1009 FFA_WBool_To_FZ(CO_Flag, Stack(SP));
ffa_ch19_peh_tuni... 1010 else
ffa_ch19_peh_tuni... 1011 FFA_WBool_To_FZ(Flag, Stack(SP));
ffa_ch19_peh_tuni... 1012 end if;
ffa_ch4_ffacalc.kv 1013
ffa_ch4_ffacalc.kv 1014 -- Print the FZ on the top of the stack
ffa_ch4_ffacalc.kv 1015 when '#' =>
ffa_ch4_ffacalc.kv 1016 Want(1);
ffa_ch11_tuning_a... 1017 Print_FZ(Stack(SP));
ffa_ch4_ffacalc.kv 1018 Drop;
ffa_ch4_ffacalc.kv 1019
ffa_ch17_peh.kv 1020 -- Put the Peh Program Version on the stack,
ffa_ch14_barrett.kv 1021 -- followed by FFA Program Version.
ffa_ch14_barrett.kv 1022 when 'V' =>
ffa_ch14_barrett.kv 1023 Push;
ffa_ch14_barrett.kv 1024 Push;
ffa_ch17_peh.kv 1025 -- Peh Version:
ffa_ch14_barrett.kv 1026 FFA_FZ_Clear(Stack(SP - 1));
ffa_ch17_peh.kv 1027 FFA_FZ_Set_Head(Stack(SP - 1), Word(Peh_K_Version));
ffa_ch14_barrett.kv 1028 -- FFA Version:
ffa_ch14_barrett.kv 1029 FFA_FZ_Clear(Stack(SP));
ffa_ch14_barrett.kv 1030 FFA_FZ_Set_Head(Stack(SP), Word(FFA_K_Version));
ffa_ch14_barrett.kv 1031
ffa_ch16_miller_r... 1032 -- Constant-Time Miller-Rabin Test on N using the given Witness.
ffa_ch16_miller_r... 1033 -- Witness will be used as-is if it conforms to the valid range,
ffa_ch16_miller_r... 1034 -- i.e. 2 <= Witness <= N - 2; else will be transformed into a
ffa_ch16_miller_r... 1035 -- valid Witness via modular arithmetic.
ffa_ch16_miller_r... 1036 -- Outputs ONE if N WAS FOUND composite; ZERO if NOT FOUND.
ffa_ch16_miller_r... 1037 -- Handles degenerate cases of N that M-R per se cannot eat:
ffa_ch16_miller_r... 1038 -- N=0, N=1: ALWAYS 'FOUND COMPOS.'; 2, 3 - ALWAYS 'NOT FOUND'.
ffa_ch16_miller_r... 1039 -- If N is Even and not equal to 2, N is ALWAYS 'FOUND COMPOS.'
ffa_ch16_miller_r... 1040 -- For ALL other N, the output is equal to that of the M-R test.
ffa_ch16_miller_r... 1041 -- At most 1/4 of all possible Witnesses will be 'liars' for
ffa_ch16_miller_r... 1042 -- a particular composite N , i.e. fail to attest to its
ffa_ch16_miller_r... 1043 -- compositivity.
ffa_ch16_miller_r... 1044 when 'P' =>
ffa_ch16_miller_r... 1045 Want(2);
ffa_ch16_miller_r... 1046 declare
ffa_ch16_miller_r... 1047 MR_Result : WBool :=
ffa_ch16_miller_r... 1048 FFA_FZ_MR_Composite_On_Witness(N => Stack(SP - 1),
ffa_ch16_miller_r... 1049 Witness => Stack(SP));
ffa_ch16_miller_r... 1050 begin
ffa_ch16_miller_r... 1051 FFA_WBool_To_FZ(MR_Result, Stack(SP - 1));
ffa_ch16_miller_r... 1052 end;
ffa_ch16_miller_r... 1053 Drop;
ffa_ch16_miller_r... 1054
ffa_ch13_measure_... 1055 --------------
ffa_ch13_measure_... 1056 -- Prefixes --
ffa_ch13_measure_... 1057 --------------
ffa_ch13_measure_... 1058
ffa_ch17_peh.kv 1059 when
ffa_ch17_peh.kv 1060 'Q' -- 'Quit...'
ffa_ch17_peh.kv 1061 |
ffa_ch18_subrouti... 1062 'Z' -- 'Zap...'
ffa_ch18_subrouti... 1063 |
ffa_ch17_peh.kv 1064 'L' -- 'Left...'
ffa_ch17_peh.kv 1065 |
ffa_ch17_peh.kv 1066 'R' -- 'Right...'
ffa_ch17_peh.kv 1067 |
ffa_ch17_peh.kv 1068 'M' -- 'Modular...'
ffa_ch17_peh.kv 1069 |
ffa_ch17_peh.kv 1070 '$' -- Pop top of Stack into the following Register...
ffa_ch17_peh.kv 1071 =>
ffa_ch19_peh_tuni... 1072 -- Set the Prefixed Op Mode. Next Symbol is treated as prefixed:
ffa_ch19_peh_tuni... 1073 Mode := PrefixOp;
ffa_ch17_peh.kv 1074
ffa_ch18_subrouti... 1075 -----------
ffa_ch18_subrouti... 1076 -- Loops --
ffa_ch18_subrouti... 1077 -----------
ffa_ch17_peh.kv 1078
ffa_ch18_subrouti... 1079 -- Begin Loop: Push IP (i.e. of THIS Op) to Control Stack.
ffa_ch17_peh.kv 1080 when ':' =>
ffa_ch18_subrouti... 1081 Control_Push(Call_Type => Loops, Return_IP => IP);
ffa_ch17_peh.kv 1082
ffa_ch18_subrouti... 1083 -- Conditional End Loop: Pop top of Stack, and...
ffa_ch17_peh.kv 1084 -- ... if ZERO: simply discard the top of the Control Stack.
ffa_ch17_peh.kv 1085 -- ... if NONZERO: pop top of Control Stack and make it next IP.
ffa_ch17_peh.kv 1086 when ',' =>
ffa_ch17_peh.kv 1087 Want(1);
ffa_ch17_peh.kv 1088 declare
ffa_ch18_subrouti... 1089 Loop_Position : Tape_Positions := Control_Pop(Loops);
ffa_ch18_subrouti... 1090 Trigger : WBool := FFA_FZ_NZeroP(Stack(SP));
ffa_ch17_peh.kv 1091 begin
ffa_ch18_subrouti... 1092 -- If Trigger is active, re-enter the Loop:
ffa_ch18_subrouti... 1093 if Trigger = 1 then
ffa_ch18_subrouti... 1094 IP_Next := Loop_Position;
ffa_ch17_peh.kv 1095 end if;
ffa_ch17_peh.kv 1096 end;
ffa_ch18_subrouti... 1097 -- ... otherwise, continue normally.
ffa_ch17_peh.kv 1098 Drop;
ffa_ch13_measure_... 1099
ffa_ch18_subrouti... 1100 -----------------
ffa_ch18_subrouti... 1101 -- Subroutines --
ffa_ch18_subrouti... 1102 -----------------
ffa_ch18_subrouti... 1103
ffa_ch18_subrouti... 1104 -- Return from a Subroutine:
ffa_ch17_peh.kv 1105 when ';' =>
ffa_ch18_subrouti... 1106 -- Next instruction will be at the saved Return Position:
ffa_ch18_subrouti... 1107 IP_Next := Control_Pop(Subroutines);
ffa_ch18_subrouti... 1108
ffa_ch18_subrouti... 1109 -- Indicate the start of a Subroutine Name, e.g. @SubName
ffa_ch18_subrouti... 1110 -- ... if DEFINING a NEW Subroutine: is followed by @body;
ffa_ch18_subrouti... 1111 -- ... if INVOKING EXISTING Subroutine: is followed by !
ffa_ch18_subrouti... 1112 when '@' =>
ffa_ch18_subrouti... 1113 -- Save the NEXT IP as the first Symbol of the proposed Name:
ffa_ch18_subrouti... 1114 Proposed_Sub.Name.L := Next_IP_On_Tape;
ffa_ch18_subrouti... 1115 -- Enter the Name mode:
ffa_ch19_peh_tuni... 1116 Mode := SubName;
ffa_ch18_subrouti... 1117 -- We will remain in Name mode until we see a @ or ! .
ffa_ch18_subrouti... 1118
ffa_ch18_subrouti... 1119 -- '!' invokes a previously-defined Subroutine:
ffa_ch18_subrouti... 1120 -- ... If found after @Name was given, the syntax is: @SubName!
ffa_ch18_subrouti... 1121 -- ... If found in THIS context, with no @Name , then invokes
ffa_ch18_subrouti... 1122 -- the nearest Subroutine defined to the LEFT of this IP.
ffa_ch18_subrouti... 1123 -- NO Sub defined to the RIGHT of the current IP may be invoked.
ffa_ch18_subrouti... 1124 when '!' =>
ffa_ch18_subrouti... 1125 Invoke_Left_Subroutine;
ffa_ch13_measure_... 1126
ffa_ch13_measure_... 1127 ---------------------------------------------------------
ffa_ch17_peh.kv 1128 -- Reserved Ops, i.e. ones we have not defined yet: --
ffa_ch13_measure_... 1129 ---------------------------------------------------------
ffa_ch18_subrouti... 1130 when 'H' | 'I' | 'J' | 'K' | 'N' | 'T' | 'X' | 'Y' =>
ffa_ch13_measure_... 1131
ffa_ch13_measure_... 1132 E("This Operator is not defined yet: " & C);
ffa_ch12_karatsub... 1133 ---------------------------------------------------------
ffa_ch12_karatsub... 1134
ffa_ch4_ffacalc.kv 1135 ----------
ffa_ch4_ffacalc.kv 1136 -- NOPs --
ffa_ch4_ffacalc.kv 1137 ----------
ffa_ch4_ffacalc.kv 1138
ffa_ch18_subrouti... 1139 -- Unprintables and spaces DO NOTHING.
ffa_ch18_subrouti... 1140 -- (However: they occupy space, consume Life, clear Prefix.)
ffa_ch4_ffacalc.kv 1141 when others =>
ffa_ch4_ffacalc.kv 1142 null;
ffa_ch4_ffacalc.kv 1143
ffa_ch4_ffacalc.kv 1144 end case;
ffa_ch4_ffacalc.kv 1145
ffa_ch4_ffacalc.kv 1146 end Op_Normal;
ffa_ch4_ffacalc.kv 1147
ffa_ch18_subrouti... 1148 ------------------------------------------------------------------------
ffa_ch4_ffacalc.kv 1149
ffa_ch13_measure_... 1150 -- Execute a Prefixed Op
ffa_ch13_measure_... 1151 procedure Op_Prefixed(Prefix : in Character;
ffa_ch13_measure_... 1152 O : in Character) is
ffa_ch17_peh.kv 1153
ffa_ch17_peh.kv 1154 -- Report an attempt to execute an undefined Prefix Op:
ffa_ch17_peh.kv 1155 procedure Undefined_Prefix_Op is
ffa_ch17_peh.kv 1156 begin
ffa_ch18_subrouti... 1157 E("Undefined Prefix Op: '" & Prefix & O & "'");
ffa_ch17_peh.kv 1158 end Undefined_Prefix_Op;
ffa_ch17_peh.kv 1159
ffa_ch13_measure_... 1160 begin
ffa_ch13_measure_... 1161
ffa_ch17_peh.kv 1162 -- Which Prefix Op?
ffa_ch13_measure_... 1163 case Prefix is
ffa_ch13_measure_... 1164
ffa_ch13_measure_... 1165 ---------------------------------------------------------
ffa_ch18_subrouti... 1166 -- Quit... (See Ch. 17 discussion)
ffa_ch17_peh.kv 1167 when 'Q' =>
ffa_ch17_peh.kv 1168
ffa_ch17_peh.kv 1169 -- .. Quit how?
ffa_ch17_peh.kv 1170 case O is
ffa_ch17_peh.kv 1171
ffa_ch17_peh.kv 1172 -- ... with a 'Yes' Verdict:
ffa_ch17_peh.kv 1173 when 'Y' =>
ffa_ch18_subrouti... 1174 -- Prohibited from within a loop or Subroutine:
ffa_ch18_subrouti... 1175 if Control_Stack_Not_Empty then
ffa_ch18_subrouti... 1176 E("Attempted to proclaim a 'Yes' Verdict" &
ffa_ch18_subrouti... 1177 " inside a Loop or Subroutine!");
ffa_ch18_subrouti... 1178 end if;
ffa_ch17_peh.kv 1179 Verdict := Yes;
ffa_ch17_peh.kv 1180
ffa_ch17_peh.kv 1181 -- ... with a 'No' Verdict:
ffa_ch17_peh.kv 1182 when 'N' =>
ffa_ch17_peh.kv 1183 Verdict := No;
ffa_ch17_peh.kv 1184
ffa_ch17_peh.kv 1185 -- ... with a 'Mu' Verdict: (permitted, but discouraged)
ffa_ch17_peh.kv 1186 when 'M' =>
ffa_ch17_peh.kv 1187 IP_Next := IP; -- Force a 'Mu' Termination
ffa_ch17_peh.kv 1188
ffa_ch17_peh.kv 1189 -- ... with Debug Trace, and a 'Mu' Verdict:
ffa_ch17_peh.kv 1190 when 'D' =>
ffa_ch17_peh.kv 1191 Print_Trace;
ffa_ch17_peh.kv 1192 IP_Next := IP; -- Force a 'Mu' Termination
ffa_ch17_peh.kv 1193
ffa_ch17_peh.kv 1194 -- ... with an explicit Tape-triggered fatal EGGOG!
ffa_ch17_peh.kv 1195 -- The 'QE' curtain call is intended strictly to signal
ffa_ch17_peh.kv 1196 -- catastrophic (e.g. iron) failure from within a Tape
ffa_ch17_peh.kv 1197 -- program ('cosmic ray' scenario) where a ~hardwired
ffa_ch17_peh.kv 1198 -- mechanism~ of any kind appears to have done something
ffa_ch17_peh.kv 1199 -- unexpected; or to abort on a failed test of the RNG;
ffa_ch17_peh.kv 1200 -- or similar hard-stop scenarios, where either physical
ffa_ch17_peh.kv 1201 -- iron, or basic FFA routine must be said to have failed,
ffa_ch17_peh.kv 1202 -- and the continued use of the system itself - dangerous.
ffa_ch17_peh.kv 1203 -- The use of 'QE' for any other purpose is discouraged;
ffa_ch17_peh.kv 1204 -- please do not use it to indicate failed decryption etc.
ffa_ch17_peh.kv 1205 when 'E' =>
ffa_ch17_peh.kv 1206 -- Hard-stop with this eggog:
ffa_ch17_peh.kv 1207 E("Tape-triggered CATASTROPHIC ERROR! " &
ffa_ch17_peh.kv 1208 "Your iron and/or your build of Peh, " &
ffa_ch17_peh.kv 1209 "may be defective! Please consult " &
ffa_ch17_peh.kv 1210 "the author of this Tape.");
ffa_ch17_peh.kv 1211
ffa_ch17_peh.kv 1212 -- ... Unknown (Eggog):
ffa_ch17_peh.kv 1213 when others =>
ffa_ch17_peh.kv 1214 Undefined_Prefix_Op;
ffa_ch17_peh.kv 1215
ffa_ch17_peh.kv 1216 end case;
ffa_ch17_peh.kv 1217
ffa_ch17_peh.kv 1218 ---------------------------------------------------------
ffa_ch18_subrouti... 1219 -- Zap...
ffa_ch18_subrouti... 1220 when 'Z' =>
ffa_ch18_subrouti... 1221
ffa_ch18_subrouti... 1222 -- .. Zap what?
ffa_ch18_subrouti... 1223 case O is
ffa_ch18_subrouti... 1224
ffa_ch18_subrouti... 1225 -- ... Registers:
ffa_ch18_subrouti... 1226 when 'R' =>
ffa_ch18_subrouti... 1227 -- If in Cutout, will zap only Cutout set of regs
ffa_ch18_subrouti... 1228 Zap_Registers;
ffa_ch18_subrouti... 1229
ffa_ch18_subrouti... 1230 -- ... Data Stack:
ffa_ch18_subrouti... 1231 when 'D' =>
ffa_ch18_subrouti... 1232 Zap_Data_Stack;
ffa_ch18_subrouti... 1233
ffa_ch19_peh_tuni... 1234 -- ... Overflow Flag (if in Cutout, zaps CO_Flag) :
ffa_ch18_subrouti... 1235 when 'F' =>
ffa_ch18_subrouti... 1236 Zap_Flag;
ffa_ch18_subrouti... 1237
ffa_ch18_subrouti... 1238 -- ... All Zappable State:
ffa_ch18_subrouti... 1239 when 'A' =>
ffa_ch18_subrouti... 1240 Zap_Master;
ffa_ch18_subrouti... 1241
ffa_ch18_subrouti... 1242 when others =>
ffa_ch18_subrouti... 1243 Undefined_Prefix_Op;
ffa_ch18_subrouti... 1244
ffa_ch18_subrouti... 1245 end case;
ffa_ch18_subrouti... 1246
ffa_ch18_subrouti... 1247 ---------------------------------------------------------
ffa_ch17_peh.kv 1248 -- Write into Register...
ffa_ch17_peh.kv 1249 when '$' =>
ffa_ch17_peh.kv 1250
ffa_ch17_peh.kv 1251 -- Eggog if operator gave us a garbage Register name:
ffa_ch17_peh.kv 1252 if O not in RegNames then
ffa_ch17_peh.kv 1253 E("There is no Register '" & O & "' !");
ffa_ch17_peh.kv 1254 end if;
ffa_ch17_peh.kv 1255
ffa_ch17_peh.kv 1256 -- Selected Register exists; move top FZ on stack into it:
ffa_ch17_peh.kv 1257 Want(1);
ffa_ch18_subrouti... 1258 if Use_CO_Registers then
ffa_ch18_subrouti... 1259 CO_Registers(O) := Stack(SP); -- use Cutout Register set
ffa_ch18_subrouti... 1260 else
ffa_ch18_subrouti... 1261 Registers(O) := Stack(SP); -- use ordinary set
ffa_ch18_subrouti... 1262 end if;
ffa_ch17_peh.kv 1263 Drop;
ffa_ch17_peh.kv 1264
ffa_ch17_peh.kv 1265 ---------------------------------------------------------
ffa_ch13_measure_... 1266 -- Left...
ffa_ch13_measure_... 1267 when 'L' =>
ffa_ch13_measure_... 1268
ffa_ch13_measure_... 1269 -- Which L-op?
ffa_ch13_measure_... 1270 case O is
ffa_ch13_measure_... 1271
ffa_ch13_measure_... 1272 -- ... Shift :
ffa_ch13_measure_... 1273 when 'S' =>
ffa_ch13_measure_... 1274 Want(2);
ffa_ch13_measure_... 1275 declare
ffa_ch13_measure_... 1276 -- Number of bit positions to shift by:
ffa_ch13_measure_... 1277 ShiftCount : FZBit_Index
ffa_ch13_measure_... 1278 := FZBit_Index(FFA_FZ_Get_Head(Stack(SP)));
ffa_ch13_measure_... 1279 begin
ffa_ch13_measure_... 1280 FFA_FZ_Quiet_ShiftLeft(N => Stack(SP - 1),
ffa_ch13_measure_... 1281 ShiftedN => Stack(SP - 1),
ffa_ch13_measure_... 1282 Count => ShiftCount);
ffa_ch13_measure_... 1283 end;
ffa_ch13_measure_... 1284 Drop;
ffa_ch13_measure_... 1285
ffa_ch13_measure_... 1286 -- ... Rotate :
ffa_ch13_measure_... 1287 when 'R' =>
ffa_ch13_measure_... 1288 E("Left-Rotate not yet defined!");
ffa_ch13_measure_... 1289
ffa_ch18_subrouti... 1290 -- ... 'Cutout' :
ffa_ch18_subrouti... 1291 -- Mark the LEFT SIDE of the 'Cutout' Tape segment;
ffa_ch18_subrouti... 1292 -- The Tape IN OR PRIOR to it will retain the ability to
ffa_ch18_subrouti... 1293 -- move directly into points PRIOR to THIS position
ffa_ch18_subrouti... 1294 -- on the Tape (i.e. where THIS Op had executed).
ffa_ch18_subrouti... 1295 -- Ops on Tape AFTER 'RC' mark can move INTO Cutout,
ffa_ch18_subrouti... 1296 -- but NOT directly into any position PRIOR to it.
ffa_ch18_subrouti... 1297 -- If 'LC' is executed, a 'RC' MUST occur before Tape end.
ffa_ch18_subrouti... 1298 -- FATAL if a 'LC' or 'RC' Op had previously executed.
ffa_ch18_subrouti... 1299 when 'C' =>
ffa_ch18_subrouti... 1300 -- Eggog if we have ALREADY begun the Cutout somewhere:
ffa_ch18_subrouti... 1301 if Cutout_Begun then
ffa_ch18_subrouti... 1302 E("'LC' Op may only execute ONCE on a Tape!");
ffa_ch18_subrouti... 1303 end if;
ffa_ch18_subrouti... 1304 -- Cutout defs are prohibited inside loops or Sub calls:
ffa_ch18_subrouti... 1305 if Control_Stack_Not_Empty then
ffa_ch18_subrouti... 1306 E("Attempted to execute 'LC' (Left-Cutout)" &
ffa_ch18_subrouti... 1307 " inside a Loop or Subroutine!");
ffa_ch18_subrouti... 1308 end if;
ffa_ch18_subrouti... 1309 -- Set the START of the Cutout, and mark it 'begun':
ffa_ch18_subrouti... 1310 Cutout_Begun := True;
ffa_ch18_subrouti... 1311 Cutout.L := IP;
ffa_ch18_subrouti... 1312
ffa_ch17_peh.kv 1313 -- ... Unknown (Eggog):
ffa_ch13_measure_... 1314 when others =>
ffa_ch17_peh.kv 1315 Undefined_Prefix_Op;
ffa_ch13_measure_... 1316
ffa_ch13_measure_... 1317 end case;
ffa_ch13_measure_... 1318 ---------------------------------------------------------
ffa_ch13_measure_... 1319 -- Right...
ffa_ch13_measure_... 1320 when 'R' =>
ffa_ch13_measure_... 1321
ffa_ch13_measure_... 1322 -- Which R-op?
ffa_ch13_measure_... 1323 case O is
ffa_ch13_measure_... 1324
ffa_ch13_measure_... 1325 -- ... Shift:
ffa_ch13_measure_... 1326 when 'S' =>
ffa_ch13_measure_... 1327 Want(2);
ffa_ch13_measure_... 1328 declare
ffa_ch13_measure_... 1329 -- Number of bit positions to shift by:
ffa_ch13_measure_... 1330 ShiftCount : FZBit_Index
ffa_ch13_measure_... 1331 := FZBit_Index(FFA_FZ_Get_Head(Stack(SP)));
ffa_ch13_measure_... 1332 begin
ffa_ch13_measure_... 1333 FFA_FZ_Quiet_ShiftRight(N => Stack(SP - 1),
ffa_ch13_measure_... 1334 ShiftedN => Stack(SP - 1),
ffa_ch13_measure_... 1335 Count => ShiftCount);
ffa_ch13_measure_... 1336 end;
ffa_ch13_measure_... 1337 Drop;
ffa_ch13_measure_... 1338
ffa_ch13_measure_... 1339 -- ... Rotate:
ffa_ch13_measure_... 1340 when 'R' =>
ffa_ch13_measure_... 1341 E("Right-Rotate not yet defined!");
ffa_ch13_measure_... 1342
ffa_ch15_gcd.kv 1343 -- 'Right-Multiply', give only lower half of the product XY
ffa_ch15_gcd.kv 1344 when '*' =>
ffa_ch15_gcd.kv 1345 Want(2);
ffa_ch15_gcd.kv 1346 FFA_FZ_Low_Multiply(X => Stack(SP - 1),
ffa_ch15_gcd.kv 1347 Y => Stack(SP),
ffa_ch15_gcd.kv 1348 XY => Stack(SP - 1));
ffa_ch15_gcd.kv 1349 Drop;
ffa_ch15_gcd.kv 1350
ffa_ch18_subrouti... 1351 -- ... 'Cutout' :
ffa_ch18_subrouti... 1352 -- Mark the RIGHT SIDE of the 'Cutout' Tape segment that
ffa_ch18_subrouti... 1353 -- began with 'LC', and permanently arms the Cutout.
ffa_ch18_subrouti... 1354 -- After THIS position, no IP_Next may be set which
ffa_ch18_subrouti... 1355 -- directly transfers control to a point PRIOR to 'LC'.
ffa_ch18_subrouti... 1356 -- FATAL if no 'LC' had executed to mark the LEFT SIDE.
ffa_ch18_subrouti... 1357 when 'C' =>
ffa_ch18_subrouti... 1358 -- Eggog if we never marked the beginning with 'LC':
ffa_ch18_subrouti... 1359 if not Cutout_Begun then
ffa_ch18_subrouti... 1360 E("'RC' Op found, but no there was no prior 'LC' !");
ffa_ch18_subrouti... 1361 end if;
ffa_ch18_subrouti... 1362 -- Eggog if we have already armed the Cutout:
ffa_ch18_subrouti... 1363 if Cutout_Armed then
ffa_ch18_subrouti... 1364 E("'RC' Op found, but the Cutout is already armed!");
ffa_ch18_subrouti... 1365 end if;
ffa_ch18_subrouti... 1366 -- Cutout defs are prohibited inside loops or Sub calls:
ffa_ch18_subrouti... 1367 if Control_Stack_Not_Empty then
ffa_ch18_subrouti... 1368 E("Attempted to execute 'RC' (Right-Cutout)" &
ffa_ch18_subrouti... 1369 " inside a Loop or Subroutine!");
ffa_ch18_subrouti... 1370 end if;
ffa_ch18_subrouti... 1371 -- Otherwise proceed to complete and arm the Cutout:
ffa_ch18_subrouti... 1372 Cutout.R := IP;
ffa_ch18_subrouti... 1373 Cutout_Armed := True;
ffa_ch18_subrouti... 1374
ffa_ch17_peh.kv 1375 -- ... Unknown (Eggog):
ffa_ch13_measure_... 1376 when others =>
ffa_ch17_peh.kv 1377 Undefined_Prefix_Op;
ffa_ch13_measure_... 1378
ffa_ch13_measure_... 1379 end case;
ffa_ch13_measure_... 1380 ---------------------------------------------------------
ffa_ch15_gcd.kv 1381 -- Modular...
ffa_ch13_measure_... 1382 when 'M' =>
ffa_ch13_measure_... 1383
ffa_ch13_measure_... 1384 -- Which M-op?
ffa_ch13_measure_... 1385 case O is
ffa_ch13_measure_... 1386
ffa_ch15_gcd.kv 1387 -- ... Multiplication (Conventional) :
ffa_ch13_measure_... 1388 when '*' =>
ffa_ch13_measure_... 1389 Want(3);
ffa_ch13_measure_... 1390 MustNotZero(Stack(SP));
ffa_ch13_measure_... 1391 FFA_FZ_Modular_Multiply(X => Stack(SP - 2),
ffa_ch13_measure_... 1392 Y => Stack(SP - 1),
ffa_ch13_measure_... 1393 Modulus => Stack(SP),
ffa_ch13_measure_... 1394 Product => Stack(SP - 2));
ffa_ch13_measure_... 1395 Drop;
ffa_ch13_measure_... 1396 Drop;
ffa_ch13_measure_... 1397
ffa_ch15_gcd.kv 1398 -- ... Squaring (Conventional) :
ffa_ch15_gcd.kv 1399 when 'S' =>
ffa_ch15_gcd.kv 1400 Want(2);
ffa_ch15_gcd.kv 1401 MustNotZero(Stack(SP));
ffa_ch15_gcd.kv 1402 FFA_FZ_Modular_Square(X => Stack(SP - 1),
ffa_ch15_gcd.kv 1403 Modulus => Stack(SP),
ffa_ch15_gcd.kv 1404 Product => Stack(SP - 1));
ffa_ch15_gcd.kv 1405 Drop;
ffa_ch15_gcd.kv 1406
ffa_ch15_gcd.kv 1407 -- ... Exponentiation (Barrettronic) :
ffa_ch13_measure_... 1408 when 'X' =>
ffa_ch13_measure_... 1409 Want(3);
ffa_ch13_measure_... 1410 MustNotZero(Stack(SP));
ffa_ch13_measure_... 1411 FFA_FZ_Modular_Exponentiate(Base => Stack(SP - 2),
ffa_ch13_measure_... 1412 Exponent => Stack(SP - 1),
ffa_ch13_measure_... 1413 Modulus => Stack(SP),
ffa_ch13_measure_... 1414 Result => Stack(SP - 2));
ffa_ch13_measure_... 1415 Drop;
ffa_ch13_measure_... 1416 Drop;
ffa_ch13_measure_... 1417
ffa_ch17_peh.kv 1418 -- ... Unknown (Eggog):
ffa_ch13_measure_... 1419 when others =>
ffa_ch17_peh.kv 1420 Undefined_Prefix_Op;
ffa_ch13_measure_... 1421
ffa_ch13_measure_... 1422 end case;
ffa_ch13_measure_... 1423 ---------------------------------------------------------
ffa_ch13_measure_... 1424 -- ... Unknown: (impossible per mechanics, but must handle case)
ffa_ch13_measure_... 1425 when others =>
ffa_ch13_measure_... 1426 E("Undefined Prefix: " & Prefix);
ffa_ch13_measure_... 1427
ffa_ch13_measure_... 1428 end case;
ffa_ch13_measure_... 1429
ffa_ch13_measure_... 1430 end Op_Prefixed;
ffa_ch13_measure_... 1431
ffa_ch18_subrouti... 1432 ------------------------------------------------------------------------
ffa_ch13_measure_... 1433
ffa_ch19_peh_tuni... 1434 -- Process a character in a proposed Subroutine Name:
ffa_ch19_peh_tuni... 1435 procedure SubName_Symbol(C : in Character) is
ffa_ch19_peh_tuni... 1436 begin
ffa_ch19_peh_tuni... 1437 case C is
ffa_ch19_peh_tuni... 1438 -- Attempt to INVOKE the named Subroutine:
ffa_ch19_peh_tuni... 1439 when '!' =>
ffa_ch19_peh_tuni... 1440 -- Detect attempt to invoke a Sub with no Name:
ffa_ch19_peh_tuni... 1441 if IP = Proposed_Sub.Name.L then
ffa_ch19_peh_tuni... 1442 E("Attempted to invoke a nameless Subroutine!");
ffa_ch19_peh_tuni... 1443 end if;
ffa_ch19_peh_tuni... 1444 -- Exit the Sub Name mode and enter Normal mode:
ffa_ch19_peh_tuni... 1445 Mode := Normal;
ffa_ch19_peh_tuni... 1446 -- Attempt to invoke the subroutine:
ffa_ch19_peh_tuni... 1447 Invoke_Named_Subroutine(Proposed_Sub.Name);
ffa_ch19_peh_tuni... 1448
ffa_ch19_peh_tuni... 1449 -- Attempt to read a body for a Subroutine Definition:
ffa_ch19_peh_tuni... 1450 when '@' =>
ffa_ch19_peh_tuni... 1451 -- Detect attempt to define a Sub with no Name:
ffa_ch19_peh_tuni... 1452 if IP = Proposed_Sub.Name.L then
ffa_ch19_peh_tuni... 1453 E("Attempted to define a nameless Subroutine!");
ffa_ch19_peh_tuni... 1454 end if;
ffa_ch19_peh_tuni... 1455 -- Save NEXT IP as the beginning of the proposed Body:
ffa_ch19_peh_tuni... 1456 Proposed_Sub.Payload.L := Next_IP_On_Tape;
ffa_ch19_peh_tuni... 1457 -- Exit the Name mode and enter Sub Body mode:
ffa_ch19_peh_tuni... 1458 Mode := SubBody;
ffa_ch19_peh_tuni... 1459
ffa_ch19_peh_tuni... 1460 -- Any permissible Symbol in a Subroutine Name:
ffa_ch19_peh_tuni... 1461 when '0' .. '9' | 'A' .. 'Z' | 'a' .. 'z' | '-' | '_' =>
ffa_ch19_peh_tuni... 1462 -- Save IP as the potential end of the proposed Sub Name:
ffa_ch19_peh_tuni... 1463 Proposed_Sub.Name.R := IP;
ffa_ch19_peh_tuni... 1464
ffa_ch19_peh_tuni... 1465 when others =>
ffa_ch19_peh_tuni... 1466 E("Symbol '" & C & "' is prohibited in a Subroutine Name !");
ffa_ch19_peh_tuni... 1467 end case;
ffa_ch19_peh_tuni... 1468 end SubName_Symbol;
ffa_ch19_peh_tuni... 1469
ffa_ch19_peh_tuni... 1470 ------------------------------------------------------------------------
ffa_ch19_peh_tuni... 1471
ffa_ch19_peh_tuni... 1472 -- Process a character in a proposed Subroutine Body:
ffa_ch19_peh_tuni... 1473 procedure SubBody_Symbol(C : in Character) is
ffa_ch19_peh_tuni... 1474
ffa_ch19_peh_tuni... 1475 -- Name of Proposed Subroutine (for eggogs) :
ffa_ch19_peh_tuni... 1476 Name : String
ffa_ch19_peh_tuni... 1477 := String(Tape(Proposed_Sub.Name.L .. Proposed_Sub.Name.R));
ffa_ch19_peh_tuni... 1478
ffa_ch19_peh_tuni... 1479 begin
ffa_ch19_peh_tuni... 1480 case C is
ffa_ch19_peh_tuni... 1481 -- Subroutine Terminator:
ffa_ch19_peh_tuni... 1482 when ';' =>
ffa_ch19_peh_tuni... 1483 -- Only takes effect if NOT in a Comment or Quote Block:
ffa_ch19_peh_tuni... 1484 if SubCommLevel = 0 and SubQuoteLevel = 0 then
ffa_ch19_peh_tuni... 1485 if SubCondLevel /= 0 then
ffa_ch19_peh_tuni... 1486 E("Conditional Return in Subroutine: '"
ffa_ch19_peh_tuni... 1487 & Name & "' is Prohibited!" &
ffa_ch19_peh_tuni... 1488 " (Please check for unbalanced '{'.)'");
ffa_ch19_peh_tuni... 1489 end if;
ffa_ch19_peh_tuni... 1490 -- Now, Sub-Comm, Quote, and Cond levels are 0.
ffa_ch19_peh_tuni... 1491 -- The ';' becomes last Symbol of the new Sub's Body.
ffa_ch19_peh_tuni... 1492 -- Test for attempt to define a Sub with a null Body:
ffa_ch19_peh_tuni... 1493 if IP = Proposed_Sub.Payload.L then
ffa_ch19_peh_tuni... 1494 E("Null Body in Subroutine: '" & Name
ffa_ch19_peh_tuni... 1495 & "' is prohibited!");
ffa_ch19_peh_tuni... 1496 end if;
ffa_ch19_peh_tuni... 1497 -- Intern this new Sub definition:
ffa_ch19_peh_tuni... 1498 Proposed_Sub.Payload.R := IP;
ffa_ch19_peh_tuni... 1499 -- Exit the Sub Body mode and enter Normal mode:
ffa_ch19_peh_tuni... 1500 Mode := Normal;
ffa_ch19_peh_tuni... 1501 -- Attempt to intern the Proposed Subroutine:
ffa_ch19_peh_tuni... 1502 Intern_Subroutine(Proposed_Sub);
ffa_ch19_peh_tuni... 1503 end if;
ffa_ch19_peh_tuni... 1504
ffa_ch19_peh_tuni... 1505 -- Begin-Comment inside a Subroutine Body:
ffa_ch19_peh_tuni... 1506 when '(' =>
ffa_ch19_peh_tuni... 1507 SubCommLevel := SubCommLevel + 1;
ffa_ch19_peh_tuni... 1508
ffa_ch19_peh_tuni... 1509 -- End-Comment inside a Subroutine Body:
ffa_ch19_peh_tuni... 1510 when ')' =>
ffa_ch19_peh_tuni... 1511 -- If cannot drop Sub Comment level:
ffa_ch19_peh_tuni... 1512 if SubCommLevel = 0 then
ffa_ch19_peh_tuni... 1513 E("Unbalanced ')' in Body of Subroutine: '"
ffa_ch19_peh_tuni... 1514 & Name & "' !");
ffa_ch19_peh_tuni... 1515 end if;
ffa_ch19_peh_tuni... 1516 SubCommLevel := SubCommLevel - 1;
ffa_ch19_peh_tuni... 1517
ffa_ch19_peh_tuni... 1518 -- Begin-Quote inside a Subroutine Body:
ffa_ch19_peh_tuni... 1519 when '[' =>
ffa_ch19_peh_tuni... 1520 -- Ignore if Commented:
ffa_ch19_peh_tuni... 1521 if SubCommLevel = 0 then
ffa_ch19_peh_tuni... 1522 SubQuoteLevel := SubQuoteLevel + 1;
ffa_ch19_peh_tuni... 1523 end if;
ffa_ch19_peh_tuni... 1524
ffa_ch19_peh_tuni... 1525 -- End-Quote inside a Subroutine Body:
ffa_ch19_peh_tuni... 1526 when ']' =>
ffa_ch19_peh_tuni... 1527 -- Ignore if Commented:
ffa_ch19_peh_tuni... 1528 if SubCommLevel = 0 then
ffa_ch19_peh_tuni... 1529 -- If cannot drop Sub Quote level:
ffa_ch19_peh_tuni... 1530 if SubQuoteLevel = 0 then
ffa_ch19_peh_tuni... 1531 E("Unbalanced ']' in Body of Subroutine: '"
ffa_ch19_peh_tuni... 1532 & Name & "' !");
ffa_ch19_peh_tuni... 1533 end if;
ffa_ch19_peh_tuni... 1534 SubQuoteLevel := SubQuoteLevel - 1;
ffa_ch19_peh_tuni... 1535 end if;
ffa_ch19_peh_tuni... 1536
ffa_ch19_peh_tuni... 1537 -- Begin-Conditional inside a Subroutine Body:
ffa_ch19_peh_tuni... 1538 when '{' =>
ffa_ch19_peh_tuni... 1539 -- Ignore if Commented or Quoted:
ffa_ch19_peh_tuni... 1540 if SubCommLevel = 0 and SubQuoteLevel = 0 then
ffa_ch19_peh_tuni... 1541 SubCondLevel := SubCondLevel + 1;
ffa_ch19_peh_tuni... 1542 end if;
ffa_ch19_peh_tuni... 1543
ffa_ch19_peh_tuni... 1544 -- End-Conditional inside a Subroutine Body:
ffa_ch19_peh_tuni... 1545 when '}' =>
ffa_ch19_peh_tuni... 1546 -- Ignore if Commented or Quoted:
ffa_ch19_peh_tuni... 1547 if SubCommLevel = 0 and SubQuoteLevel = 0 then
ffa_ch19_peh_tuni... 1548 -- If cannot drop Sub Conditional level:
ffa_ch19_peh_tuni... 1549 if SubCondLevel = 0 then
ffa_ch19_peh_tuni... 1550 E("Unbalanced '}' in Body of Subroutine: '"
ffa_ch19_peh_tuni... 1551 & Name & "' !");
ffa_ch19_peh_tuni... 1552 end if;
ffa_ch19_peh_tuni... 1553 SubCondLevel := SubCondLevel - 1;
ffa_ch19_peh_tuni... 1554 end if;
ffa_ch19_peh_tuni... 1555
ffa_ch19_peh_tuni... 1556 -- All other Symbols have no special effect in Sub Body :
ffa_ch19_peh_tuni... 1557 when others =>
ffa_ch19_peh_tuni... 1558 null; -- Stay in Body mode until we see the ';'.
ffa_ch19_peh_tuni... 1559 end case;
ffa_ch19_peh_tuni... 1560 end SubBody_Symbol;
ffa_ch19_peh_tuni... 1561
ffa_ch19_peh_tuni... 1562
ffa_ch19_peh_tuni... 1563 ------------------------------------------------------------------------
ffa_ch19_peh_tuni... 1564
ffa_ch19_peh_tuni... 1565 -- All Peh Symbols begin their processing here :
ffa_ch4_ffacalc.kv 1566 procedure Op(C : in Character) is
ffa_ch4_ffacalc.kv 1567 begin
ffa_ch18_subrouti... 1568
ffa_ch18_subrouti... 1569 -- See whether we are inside a 'Block' :
ffa_ch4_ffacalc.kv 1570
ffa_ch4_ffacalc.kv 1571 -- ... in a Comment block:
ffa_ch4_ffacalc.kv 1572 if CommLevel > 0 then
ffa_ch4_ffacalc.kv 1573 case C is
ffa_ch4_ffacalc.kv 1574 when ')' => -- Drop a nesting level:
ffa_ch4_ffacalc.kv 1575 CommLevel := CommLevel - 1;
ffa_ch4_ffacalc.kv 1576 when '(' => -- Add a nesting level:
ffa_ch4_ffacalc.kv 1577 CommLevel := CommLevel + 1;
ffa_ch4_ffacalc.kv 1578 when others =>
ffa_ch4_ffacalc.kv 1579 null; -- Other symbols have no effect at all
ffa_ch4_ffacalc.kv 1580 end case;
ffa_ch4_ffacalc.kv 1581
ffa_ch4_ffacalc.kv 1582 -- ... in a Quote block:
ffa_ch4_ffacalc.kv 1583 elsif QuoteLevel > 0 then
ffa_ch4_ffacalc.kv 1584 case C is
ffa_ch4_ffacalc.kv 1585 when ']' => -- Drop a nesting level:
ffa_ch4_ffacalc.kv 1586 QuoteLevel := QuoteLevel - 1;
ffa_ch4_ffacalc.kv 1587 when '[' => -- Add a nesting level:
ffa_ch4_ffacalc.kv 1588 QuoteLevel := QuoteLevel + 1;
ffa_ch4_ffacalc.kv 1589 when others =>
ffa_ch4_ffacalc.kv 1590 null; -- Other symbols have no effect on the level
ffa_ch4_ffacalc.kv 1591 end case;
ffa_ch4_ffacalc.kv 1592
ffa_ch4_ffacalc.kv 1593 -- If we aren't the mode-exiting ']', print current symbol:
ffa_ch4_ffacalc.kv 1594 if QuoteLevel > 0 then
ffa_ch4_ffacalc.kv 1595 Write_Char(C);
ffa_ch4_ffacalc.kv 1596 end if;
ffa_ch4_ffacalc.kv 1597
ffa_ch4_ffacalc.kv 1598 --- ... in a ~taken~ Conditional branch:
ffa_ch4_ffacalc.kv 1599 elsif CondLevel > 0 then
ffa_ch4_ffacalc.kv 1600 case C is
ffa_ch4_ffacalc.kv 1601 when '}' => -- Drop a nesting level:
ffa_ch4_ffacalc.kv 1602 CondLevel := CondLevel - 1;
ffa_ch4_ffacalc.kv 1603
ffa_ch4_ffacalc.kv 1604 -- If we exited the Conditional as a result,
ffa_ch4_ffacalc.kv 1605 -- we push a 1 to trigger the possible 'else' clause:
ffa_ch4_ffacalc.kv 1606 if CondLevel = 0 then
ffa_ch4_ffacalc.kv 1607 Push;
ffa_ch11_tuning_a... 1608 FFA_WBool_To_FZ(1, Stack(SP));
ffa_ch4_ffacalc.kv 1609 end if;
ffa_ch4_ffacalc.kv 1610
ffa_ch4_ffacalc.kv 1611 when '{' => -- Add a nesting level:
ffa_ch4_ffacalc.kv 1612 CondLevel := CondLevel + 1;
ffa_ch18_subrouti... 1613
ffa_ch4_ffacalc.kv 1614 when others =>
ffa_ch4_ffacalc.kv 1615 null; -- Other symbols have no effect on the level
ffa_ch4_ffacalc.kv 1616 end case;
ffa_ch13_measure_... 1617
ffa_ch19_peh_tuni... 1618 else
ffa_ch19_peh_tuni... 1619 --- ... we are not inside a 'Block' :
ffa_ch19_peh_tuni... 1620
ffa_ch19_peh_tuni... 1621 case Mode is
ffa_ch18_subrouti... 1622
ffa_ch19_peh_tuni... 1623 --- ... a character in a proposed Subroutine Name:
ffa_ch19_peh_tuni... 1624 when SubName =>
ffa_ch19_peh_tuni... 1625 SubName_Symbol(C);
ffa_ch18_subrouti... 1626
ffa_ch19_peh_tuni... 1627 --- ... a character in a proposed Subroutine Body:
ffa_ch19_peh_tuni... 1628 when SubBody =>
ffa_ch19_peh_tuni... 1629 SubBody_Symbol(C);
ffa_ch18_subrouti... 1630
ffa_ch19_peh_tuni... 1631 --- ... the second character of a Prefixed Op:
ffa_ch19_peh_tuni... 1632 when PrefixOp =>
ffa_ch19_peh_tuni... 1633 -- Drop prefix-op hammer, until another prefix-op cocks it:
ffa_ch19_peh_tuni... 1634 Mode := Normal;
ffa_ch19_peh_tuni... 1635
ffa_ch19_peh_tuni... 1636 -- Dispatch this op, where prefix is the preceding character
ffa_ch19_peh_tuni... 1637 Op_Prefixed(Prefix => PrevC, O => C);
ffa_ch19_peh_tuni... 1638
ffa_ch19_peh_tuni... 1639 -- This is a Normal Op...
ffa_ch19_peh_tuni... 1640 when Normal =>
ffa_ch19_peh_tuni... 1641 -- ... so proceed with the normal rules:
ffa_ch19_peh_tuni... 1642 Op_Normal(C);
ffa_ch19_peh_tuni... 1643
ffa_ch19_peh_tuni... 1644 -- Save the current Symbol as a possible prefix:
ffa_ch19_peh_tuni... 1645 PrevC := C;
ffa_ch18_subrouti... 1646
ffa_ch18_subrouti... 1647 end case;
ffa_ch18_subrouti... 1648
ffa_ch4_ffacalc.kv 1649 end if;
ffa_ch4_ffacalc.kv 1650 end Op;
ffa_ch4_ffacalc.kv 1651
ffa_ch19_peh_tuni... 1652 ------------------------------------------------------------------------
ffa_ch19_peh_tuni... 1653
ffa_ch18_subrouti... 1654 -----------------------------
ffa_ch18_subrouti... 1655 -- Start of Tape Execution --
ffa_ch18_subrouti... 1656 -----------------------------
ffa_ch18_subrouti... 1657
ffa_ch4_ffacalc.kv 1658 begin
ffa_ch17_peh.kv 1659 -- Reset all resettable state:
ffa_ch18_subrouti... 1660 Zap_Master;
ffa_ch18_subrouti... 1661 Zap_Cutout_Registers;
ffa_ch17_peh.kv 1662
ffa_ch17_peh.kv 1663 -- Execution begins with the first Op on the Tape:
ffa_ch17_peh.kv 1664 IP := Tape_Positions'First;
ffa_ch17_peh.kv 1665
ffa_ch4_ffacalc.kv 1666 loop
ffa_ch17_peh.kv 1667
ffa_ch17_peh.kv 1668 -- If current Op is NOT the last Op on the Tape:
ffa_ch18_subrouti... 1669 if not Last_Tape_Symbol then
ffa_ch17_peh.kv 1670
ffa_ch17_peh.kv 1671 -- ... then default successor of the current Op is the next one:
ffa_ch17_peh.kv 1672 IP_Next := IP + 1;
ffa_ch17_peh.kv 1673
ffa_ch4_ffacalc.kv 1674 else
ffa_ch17_peh.kv 1675
ffa_ch17_peh.kv 1676 -- ... but if no 'next' Op exists, or quit-with-Mu, we stay put:
ffa_ch17_peh.kv 1677 IP_Next := IP; -- ... this will trigger an exit from the loop.
ffa_ch17_peh.kv 1678
ffa_ch4_ffacalc.kv 1679 end if;
ffa_ch17_peh.kv 1680
ffa_ch17_peh.kv 1681 -- Advance Odometer for every Op (incl. prefixes, in comments, etc) :
ffa_ch17_peh.kv 1682 Ticks := Ticks + 1;
ffa_ch17_peh.kv 1683
ffa_ch17_peh.kv 1684 -- Execute the Op at the current IP:
ffa_ch17_peh.kv 1685 Op(Tape(IP));
ffa_ch17_peh.kv 1686
ffa_ch17_peh.kv 1687 -- Halt when...
ffa_ch17_peh.kv 1688 exit when
ffa_ch17_peh.kv 1689 Verdict /= Mu or -- Got a Verdict, or...
ffa_ch17_peh.kv 1690 IP_Next = IP or -- Reached the end of the Tape, or...
ffa_ch17_peh.kv 1691 Exhausted_Life; -- Exhausted Life.
ffa_ch17_peh.kv 1692
ffa_ch18_subrouti... 1693 -- If the Cutout has been armed on this Tape, then enforce it:
ffa_ch18_subrouti... 1694 if Cutout_Prohibits(IP_Next) then
ffa_ch18_subrouti... 1695 E("Attempted movement to IP:" & Tape_Positions'Image(IP_Next) &
ffa_ch18_subrouti... 1696 " violates the Cutout!");
ffa_ch18_subrouti... 1697 end if;
ffa_ch18_subrouti... 1698
ffa_ch17_peh.kv 1699 -- We did not halt yet, so select the IP of the next Op to fetch:
ffa_ch17_peh.kv 1700 IP := IP_Next;
ffa_ch17_peh.kv 1701
ffa_ch4_ffacalc.kv 1702 end loop;
ffa_ch17_peh.kv 1703
ffa_ch18_subrouti... 1704 -- At this point, the Tape has halted.
ffa_ch18_subrouti... 1705
ffa_ch18_subrouti... 1706 ------------------------------------------------------------------
ffa_ch19_peh_tuni... 1707 -- Termination in a Mode other than 'Normal' triggers a Eggog Verdict:
ffa_ch18_subrouti... 1708
ffa_ch19_peh_tuni... 1709 case Mode is
ffa_ch19_peh_tuni... 1710
ffa_ch19_peh_tuni... 1711 -- Unclosed Subroutine Name at Tape's End:
ffa_ch19_peh_tuni... 1712 when SubName =>
ffa_ch19_peh_tuni... 1713 E("The Subroutine Name at IP:"
ffa_ch19_peh_tuni... 1714 & Tape_Positions'Image(Proposed_Sub.Name.L)
ffa_ch19_peh_tuni... 1715 & " is Unterminated!");
ffa_ch19_peh_tuni... 1716
ffa_ch19_peh_tuni... 1717 -- Unclosed Subroutine Body at Tape's End:
ffa_ch19_peh_tuni... 1718 when SubBody =>
ffa_ch19_peh_tuni... 1719 E("The Body of Subroutine: '"
ffa_ch19_peh_tuni... 1720 & String(Tape(Proposed_Sub.Name.L .. Proposed_Sub.Name.R))
ffa_ch19_peh_tuni... 1721 & "' is Unterminated!");
ffa_ch19_peh_tuni... 1722
ffa_ch19_peh_tuni... 1723 -- Incomplete Prefix Op at Tape's End:
ffa_ch19_peh_tuni... 1724 when PrefixOp =>
ffa_ch19_peh_tuni... 1725 E("Prefix Op: '" & PrevC & "' is Unterminated at End of Tape!");
ffa_ch19_peh_tuni... 1726
ffa_ch19_peh_tuni... 1727 -- This is the expected Mode at Tape's End:
ffa_ch19_peh_tuni... 1728 when Normal =>
ffa_ch19_peh_tuni... 1729 null;
ffa_ch19_peh_tuni... 1730
ffa_ch19_peh_tuni... 1731 end case;
ffa_ch18_subrouti... 1732
ffa_ch19_peh_tuni... 1733 -- Unclosed Cutout triggers a Eggog Verdict:
ffa_ch18_subrouti... 1734 if Cutout_Begun and not Cutout_Armed then
ffa_ch18_subrouti... 1735 E("The Cutout declaration 'LC' at IP:"
ffa_ch18_subrouti... 1736 & Tape_Positions'Image(Cutout.L) & " is Unterminated!");
ffa_ch18_subrouti... 1737 end if;
ffa_ch18_subrouti... 1738
ffa_ch18_subrouti... 1739 ------------------------------------------------------------------
ffa_ch18_subrouti... 1740 -- The following types of Unclosed Blocks trigger a Warning:
ffa_ch18_subrouti... 1741
ffa_ch17_peh.kv 1742 if CommLevel > 0 then
ffa_ch17_peh.kv 1743 Achtung("WARNING: Tape terminated with an unclosed Comment!");
ffa_ch17_peh.kv 1744 end if;
ffa_ch17_peh.kv 1745
ffa_ch17_peh.kv 1746 if QuoteLevel > 0 then
ffa_ch17_peh.kv 1747 Achtung("WARNING: Tape terminated with an unclosed Quote!");
ffa_ch17_peh.kv 1748 end if;
ffa_ch17_peh.kv 1749
ffa_ch17_peh.kv 1750 if CondLevel > 0 then
ffa_ch17_peh.kv 1751 Achtung("WARNING: Tape terminated with an unclosed Conditional!");
ffa_ch17_peh.kv 1752 end if;
ffa_ch17_peh.kv 1753
ffa_ch18_subrouti... 1754 ------------------------------------------------------------------
ffa_ch18_subrouti... 1755 -- Non-empty stacks, after Tape has halted, also trigger a Warning:
ffa_ch18_subrouti... 1756
ffa_ch17_peh.kv 1757 -- Warn operator if we terminated with a non-empty Control Stack.
ffa_ch17_peh.kv 1758 -- This situation ought to be considered poor style in a Peh Tape;
ffa_ch17_peh.kv 1759 -- for clarity, Verdicts should be returned from a place near
ffa_ch17_peh.kv 1760 -- the visually-apparent end of a Tape. However, this is not mandatory.
ffa_ch18_subrouti... 1761 if Control_Stack_Not_Empty then
ffa_ch18_subrouti... 1762 Achtung("WARNING: Tape terminated inside a Loop or Subroutine!");
ffa_ch17_peh.kv 1763 end if;
ffa_ch17_peh.kv 1764
ffa_ch18_subrouti... 1765 -- Warn operator if we terminated with a non-empty Data Stack:
ffa_ch18_subrouti... 1766 if Data_Stack_Not_Empty then
ffa_ch18_subrouti... 1767 Achtung("WARNING: Tape terminated with a non-empty Data Stack!");
ffa_ch18_subrouti... 1768 end if;
ffa_ch18_subrouti... 1769
ffa_ch18_subrouti... 1770 ------------------------------------------------------------------
ffa_ch18_subrouti... 1771
ffa_ch18_subrouti... 1772 -- We're done with the Tape and any Warnings, so clear the state:
ffa_ch18_subrouti... 1773 Zap_Master;
ffa_ch18_subrouti... 1774 Zap_Cutout_Registers;
ffa_ch17_peh.kv 1775
ffa_ch17_peh.kv 1776 -- Return the Verdict:
ffa_ch17_peh.kv 1777 return Verdict;
ffa_ch17_peh.kv 1778
ffa_ch17_peh.kv 1779 end Peh_Machine;
ffa_ch4_ffacalc.kv 1780
ffa_ch4_ffacalc.kv 1781 end FFA_Calc;