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