tree checksum vpatch file split hunks
all signers: bvt asciilifeform diana_coman
antecedents: ffa_ch17_peh.kv
press order:
patch:
(6 . 7)(6 . 7)- A0FAD6E06C4C14D704085539728FA1900087FCAF56DA0BA882C2714325347FAE4F83036C4D15EB8DC2734EA8214DF779423200459EC0CAD2B918C6EE71EA5CE0
5 xxxxxxx ffa_ch6_simplest_rsa ""Geological" RSA."
6 xxxxxxx ffa_ch7_turbo_egyptians ""Turbo Egyptians.""
7 xxxxxxx ffa_ch8_randomism "Interlude: Randomism."
8 xxxxxxx ffa_ch9_exodus ""Exodus from Egypt" with Comba’s Algorithm."
9 xxxxxxx ffa_ch9_exodus ""Exodus from Egypt" with Comba's Algorithm."
10 xxxxxxx ffa_ch10_karatsuba "Introducing Karatsuba's Multiplication."
11 xxxxxxx ffa_ch11_tuning_and_api "Tuning and Unified API."
12 551091 ffa_ch12_karatsuba_redux "Karatsuba Redux."
(16 . 3)(16 . 4)
14 557938 ffa_ch15_gcd "Greatest Common Divisor."
15 560516 ffa_ch16_miller_rabin "Miller-Rabin Method."
16 567223 ffa_ch17_peh "Introduction to Peh."
17 569234 ffa_ch18_subroutines "Subroutines in Peh."
(34 . 5)(34 . 5)
22
23 WIDTH must be a... see libffa/fz_lim.ads.
24 HEIGHT must be equal to or great than 1.
25 TAPESPACE must be at or below the maximum set in limits.ads.
26 LIFE may be any bus-width integer (0 gives "immortal" run.)
27 TAPESPACE must be at least 1, and at or below the maximum set in limits.ads.
28 LIFE may be any bus-width integer equal to or above 0 (0 gives "immortal" run.)
- C8DCA28206FADA4CCA7369F0429DC4CBE3B5E75702C701F84256F2A6E04DF33EF6557CD427BF2A486306675943215445982E21CEA9CAEDBCCDE0049AC9C39BE1(1 . 4)(1 . 4)- D190CE3AEB4C78D22671E7D960508560E04FA0AAE61B1E84B9486B32183DBEE0C829AE81AF30C277F5EC395EC268386640F0486C6113BCA9B96F72BE3D0341C9
33 ------------------------------------------------------------------------------
34 -----------------------------------------------------------------------------
35 ------------------------------------------------------------------------------
36 -- This file is part of 'Finite Field Arithmetic', aka 'FFA'. --
37 -- --
(79 . 123)(79 . 253)
39 -- After an Op, will contain position of NEXT op (if = to IP -> halt)
40 IP_Next : Tape_Positions;
41
42 -- Types of Entry for the Control Stack:
43 type Call_Types is (Invalid, Subroutines, Loops);
44
45 -- Control Stack Entries:
46 type Call is
47 record
48 Why : Call_Types := Invalid; -- Which call type?
49 Ret : Tape_Positions; -- The IP we must return to after it
50 end record;
51
52 -- Control Stack; permits bidirectional motion across the Tape:
53 Control_Stack : array(ControlStack_Range) of Tape_Positions
54 := (others => Tape_Positions'First);
55 Control_Stack : array(ControlStack_Range) of Call;
56
57 -- Current top of the Control Stack:
58 CSP : ControlStack_Range := ControlStack_Range'First;
59
60 -- A Segment represents a particular section of Tape, for certain uses.
61 type Segment is
62 record
63 -- The Tape Position of the FIRST Symbol on the Segment:
64 L : Tape_Positions := Tape'First; -- Default: start of the Tape.
65
66 -- The Tape Position of the LAST Symbol on the Segment:
67 R : Tape_Positions := Tape'Last; -- Default: end of the Tape.
68 end record;
69
70 -- Subtypes of Segment:
71 subtype Sub_Names is Segment; -- Subroutine Names
72 subtype Sub_Bodies is Segment; -- Subroutine Bodies
73 subtype Cutouts is Segment; -- Cutout (see Ch.18 discussion)
74
75 -- Represents a Subroutine defined on this Tape:
76 type Sub_Def is
77 record
78 Name : Sub_Names; -- Name of the Subroutine.
79 Payload : Sub_Bodies; -- Body of the Subroutine.
80 end record;
81
82 -- Subroutine Table. Once defined, Subs may not be erased or altered.
83 Subs : array(Subroutine_Table_Range) of Sub_Def;
84
85 -- Position of the most recently-defined Subroutine in Subs :
86 STP : Subroutine_Table_Range := Subs'First;
87
88 -- Registers:
89 subtype RegNames is Character range 'g' .. 'z';
90 type RegTables is array(RegNames range <>) of FZ(1 .. Wordness);
91
92 -- Ordinary Register Set (accessed if no Cutout, or when ABOVE it)
93 Registers : RegTables(RegNames'Range);
94
95 -- Carry/Borrow Flag:
96 -- 'Cutout' Register Set (accessed only if IP is IN or BELOW the Cutout)
97 CO_Registers : RegTables(RegNames'Range);
98
99 -- Carry/Borrow Flag set by certain arithmetical Ops:
100 Flag : WBool := 0;
101
102 -- Odometer:
103 Ticks : Natural := 0;
104
105 -- The current levels of the three types of nestedness:
106 -- The current levels of the three types of nestable Block:
107 QuoteLevel : Natural := 0;
108 CommLevel : Natural := 0;
109 CondLevel : Natural := 0;
110
111 -- Whether we are currently inside a Proposed Subroutine Name:
112 SubNameMode : Boolean := False;
113
114 -- Whether we are currently inside a Proposed Subroutine Body:
115 SubBodyMode : Boolean := False;
116
117 -- Current levels of nestable Blocks when reading a Subroutine Body:
118 SubQuoteLevel : Natural := 0;
119 SubCommLevel : Natural := 0;
120 SubCondLevel : Natural := 0;
121
122 -- Scratch for a Subroutine being proposed for lookup or internment:
123 Proposed_Sub : Sub_Def;
124
125 -- 'Cutout' Tape Segment. (See Ch.18 discussion re: when and how to use.)
126 -- If the Cutout is armed, it stays armed until Peh halts.
127 Cutout_Begun : Boolean := False;
128 Cutout_Armed : Boolean := False;
129 Cutout : Cutouts;
130
131 -- Prefixed Operators
132 PrevC : Character := ' ';
133 HavePrefix : Boolean := False;
134
135 -- Current Verdict. We run while 'Mu', tape remains, and Ticks under max.
136 -- Current Verdict. We run while 'Mu', Tape remains, and Ticks under max.
137 Verdict : Peh_Verdicts := Mu;
138 --------------------------------------------------------
139
140
141 -- Determine whether we have reached the given limit of Life:
142 function Exhausted_Life return Boolean is
143 -- If Life = 0, we are in "immortal" mode. Otherwise mortal:
144 MustDie : Boolean :=
145 (Dimensions.Life /= 0) and (Ticks = Dimensions.Life);
146 ------------
147 -- Cutout --
148 ------------
149
150 -- Find whether Cutout would prohibit move from current IP to the given :
151 function Cutout_Prohibits(Position : in Tape_Positions) return Boolean is
152 begin
153 if MustDie then
154 Achtung("WARNING: Exhausted Life ("
155 & Natural'Image(Ticks) & " ticks )");
156 end if;
157 return MustDie;
158 end Exhausted_Life;
159 return Cutout_Armed and IP > Cutout.R and Position < Cutout.L;
160 end Cutout_Prohibits;
161
162
163 -- Find whether given a Tape Position lies inside an armed Cutout:
164 function In_Cutout(Position : in Tape_Positions) return Boolean is
165 begin
166 return Cutout_Armed and Position in Cutout.L .. Cutout.R;
167 end In_Cutout;
168
169
170 -- Determine whether to use the Cutout Registers at the current position:
171 function Use_CO_Registers return Boolean is
172 begin
173 -- If we are either BELOW or INSIDE armed Cutout : we use only the
174 -- CO_Registers alternative register file. Otherwise: use Registers.
175 return Cutout_Armed and IP <= Cutout.R;
176 end Use_CO_Registers;
177
178
179 ----------
180 -- Zaps --
181 ----------
182
183 -- Clear all state, other than blocks, Control Stack, Tape and Verdict:
184 procedure Zap is
185 -- Zero the Data Stack and reset the SP:
186 procedure Zap_Data_Stack is
187 begin
188 -- Clear the Data Stack:
189 for i in Stack'Range loop
190 FFA_FZ_Clear(Stack(i));
191 end loop;
192 -- Set SP to bottom:
193 SP := Stack_Positions'First;
194 -- Clear all Registers:
195 SP := Stack_Positions'First;
196 end Zap_Data_Stack;
197
198
199 -- Zero all Registers (Ordinary set) :
200 procedure Zap_Ordinary_Registers is
201 begin
202 for r in RegNames'Range loop
203 FFA_FZ_Clear(Registers(r));
204 end loop;
205 -- Clear Overflow flag:
206 Flag := 0;
207 -- Clear prefix:
208 HavePrefix := False;
209 PrevC := ' ';
210 end Zap;
211 end Zap_Ordinary_Registers;
212
213
214 -- Zero all Registers (Cutout set) :
215 procedure Zap_Cutout_Registers is
216 begin
217 for r in RegNames'Range loop
218 FFA_FZ_Clear(CO_Registers(r));
219 end loop;
220 end Zap_Cutout_Registers;
221
222
223 -- Zero all Registers in the currently-active Register Set:
224 procedure Zap_Registers is
225 begin
226 if Use_CO_Registers then
227 Zap_Cutout_Registers;
228 else
229 Zap_Ordinary_Registers;
230 end if;
231 end Zap_Registers;
232
233
234 -- Zero the Overflow Flag:
235 procedure Zap_Flag is
236 begin
237 Flag := 0;
238 end Zap_Flag;
239
240
241 -- NO effect on Blocks, Control Stack, Tape, Verdict, Cutout, Subroutines
242 procedure Zap_Master is
243 begin
244 Zap_Data_Stack;
245 Zap_Registers;
246 Zap_Flag;
247 end Zap_Master;
248
249
250 -- Report a fatal error condition at the current symbol.
251 -----------
252 -- Eggog --
253 -----------
254
255 -- Report a fatal error condition at the current Symbol.
256 -- On Unixlikes, this will also end the process and return control to OS.
257 procedure E(S : in String) is
258 begin
259 Zap; -- Jettison all resettable state!
260 Zap_Master; -- Jettison all resettable state!
261 Eggog("FATAL: Tick:" & Natural'Image(Ticks) &
262 " IP:" & Tape_Positions'Image(IP) & " : " & S);
263 ", IP:" & Tape_Positions'Image(IP) &
264 ", Symbol: '" & Tape(IP) & "'" & " : " & S);
265 end E;
266
267
268 -------------------
269 -- Control Stack --
270 -------------------
271 -----------
272 -- Walls --
273 -----------
274
275 -- Push a given Tape Position to the Control Stack:
276 procedure Control_Push(Position : in Tape_Positions) is
277 -- Determine whether we are currently at the last Symbol on the Tape:
278 function Last_Tape_Symbol return Boolean is
279 begin
280 -- First, test for Overflow of Control Stack:
281 if CSP = Control_Stack'Last then
282 E("Control Stack Overflow!");
283 return IP = Tape_Positions'Last;
284 end Last_Tape_Symbol;
285
286
287 -- Certain Ops are NOT permitted to occur as the final Op on a Tape:
288 function Next_IP_On_Tape return Tape_Positions is
289 begin
290 -- Check if we are in fact on the last Symbol of the Tape:
291 if Last_Tape_Symbol then
292 E("This Op requires a succeeding Tape Position, "
293 & "but it is at the end of the Tape!");
294 end if;
295
296 -- Push given Tape Position to Control Stack:
297 CSP := CSP + 1;
298 Control_Stack(CSP) := Position;
299 end Control_Push;
300 -- ... Otherwise, return the immediate successor Tape Position:
301 return IP + 1;
302 end Next_IP_On_Tape;
303
304
305 -- Pop a Tape Position from the Control Stack:
306 function Control_Pop return Tape_Positions is
307 Position : Tape_Positions;
308 -- Determine whether we have reached the given limit of Life:
309 function Exhausted_Life return Boolean is
310 -- If Life = 0, we are in "immortal" mode. Otherwise mortal:
311 MustDie : Boolean :=
312 (Dimensions.Life /= 0) and (Ticks = Dimensions.Life);
313 begin
314 -- First, test for Underflow of Control Stack:
315 if CSP = Control_Stack'First then
316 E("Control Stack Underflow!");
317 if MustDie then
318 Achtung("WARNING: Exhausted Life ("
319 & Natural'Image(Ticks) & " ticks )");
320 end if;
321
322 -- Pop a Tape Position from Control Stack:
323 Position := Control_Stack(CSP);
324 Control_Stack(CSP) := Tape_Positions'First;
325 CSP := CSP - 1;
326 return Position;
327 end Control_Pop;
328 return MustDie;
329 end Exhausted_Life;
330
331
332 ----------------
333 -- Data Stack --
334 ----------------
335
336 -- Move SP up
337 -- Determine whether the Data Stack is Not Empty:
338 function Data_Stack_Not_Empty return Boolean is
339 begin
340 return SP /= Stack'First;
341 end Data_Stack_Not_Empty;
342
343
344 -- Raise the SP up by one:
345 procedure Push is
346 begin
347 if SP = Stack_Positions'Last then
(206 . 7)(336 . 7)
349 end Push;
350
351
352 -- Discard the top of the stack
353 -- Discard the Top of the Data Stack:
354 procedure Drop is
355 begin
356 FFA_FZ_Clear(Stack(SP));
(214 . 7)(344 . 7)
358 end Drop;
359
360
361 -- Check if stack has the necessary N items
362 -- Check whether the Data Stack has the necessary N items:
363 procedure Want(N : in Positive) is
364 begin
365 if SP < N then
(223 . 16)(353 . 11)
367 end Want;
368
369
370 -- Ensure that a divisor is not zero
371 procedure MustNotZero(D : in FZ) is
372 begin
373 if FFA_FZ_ZeroP(D) = 1 then
374 E("Division by Zero!");
375 end if;
376 end MustNotZero;
377
378 ---------
379 -- I/O --
380 ---------
381
382 -- Slide a new hex digit into the FZ on top of stack
383 -- Slide a new hex digit into the FZ on top of the Data Stack
384 procedure Ins_Hex_Digit(Digit : in Nibble) is
385 Overflow : WBool := 0;
386 begin
(260 . 9)(385 . 24)
388 end Print_FZ;
389
390
391 -- Print a Debug Trace (used in 'QD')
392 ------------------
393 -- Debug Traces --
394 ------------------
395
396 -- Print the bounds of a Tape Segment for Debug:
397 procedure Print_Segment(S : in Segment) is
398 begin
399 Write_String("(" & Tape_Positions'Image(S.L) &
400 "," & Tape_Positions'Image(S.R) & " )");
401 end Print_Segment;
402
403
404 -- Print a Debug Trace (used in 'QD') :
405 procedure Print_Trace is
406 begin
407 -- For clarity in cases where the Tape has already produced output:
408 Write_Newline;
409
410 -- Print Data Stack Trace:
411 Write_String("Data Stack:");
412 Write_Newline;
(275 . 20)(415 . 77)
414 Write_String("Control Stack:");
415 Write_Newline;
416 for i in reverse Control_Stack'First + 1 .. CSP loop
417 Write_String(" " & ControlStack_Range'Image(i) & " :"
418 & Tape_Positions'Image(Control_Stack(i)));
419 Write_String(" " & ControlStack_Range'Image(i) & " :");
420 Write_String(" Return IP:"
421 & Stack_Positions'Image(Control_Stack(i).Ret));
422 Write_String(" Call Type: ");
423 case Control_Stack(i).Why is
424 when Subroutines =>
425 Write_String("Subroutine");
426 when Loops =>
427 Write_String("Loop");
428 when others =>
429 Write_String("INVALID");
430 end case;
431 Write_Newline;
432 end loop;
433
434 -- Print All Registers:
435 Write_String("Registers:");
436 Write_Newline;
437 -- We will not print the Cutout Register Set unless it is active:
438 for r in RegNames'Range loop
439 Write_String(" " & r & " : ");
440 Print_FZ(Registers(r));
441 if Use_CO_Registers then
442 -- If the Cutout Register Set is currently active:
443 Write_String(" (C)" & r & " : ");
444 Print_FZ(CO_Registers(r));
445 else
446 -- If the Ordinary Register Set is currently active:
447 Write_String(" " & r & " : ");
448 Print_FZ(Registers(r));
449 end if;
450 end loop;
451
452 -- Print Ticks and IP:
453 -- Print Subroutine Table:
454 Write_String("Subroutines:");
455 Write_Newline;
456 -- Walk the Subroutine Table from first to last valid entry:
457 for i in Subs'First + 1 .. STP loop
458 declare
459 -- The current Sub in the Subroutine Table being examined:
460 S : Sub_Def := Subs(i);
461 -- The Name of the current Sub:
462 S_Name : String := String(Tape(S.Name.L .. S.Name.R));
463 begin
464 Write_String(" " & Subroutine_Table_Range'Image(i)
465 & " : '" & S_Name & "' ");
466 Print_Segment(S.Payload);
467 if Cutout_Armed then
468 -- Indicate whether Sub is uncallable here because of Cutout:
469 if Cutout_Prohibits(S.Payload.L) then
470 Write_String(" (Guarded)");
471 -- Indicate whether Sub lies INSIDE the Cutout:
472 elsif In_Cutout(S.Payload.R) then
473 Write_String(" (Cutout)");
474 end if;
475 end if;
476 Write_Newline;
477 end;
478 end loop;
479
480 Write_String("Cutout: ");
481 -- Print Cutout bounds, if Cutout is armed:
482 if Cutout_Armed then
483 Write_String("Armed: ");
484 Print_Segment(Cutout);
485 else
486 Write_String("NONE");
487 end if;
488 Write_Newline;
489
490 -- Print Overflow-Flag, Ticks and IP:
491 Write_String("Flag :" & WBool'Image(Flag));
492 Write_Newline;
493 Write_String("Ticks :" & Natural'Image(Ticks));
494 Write_Newline;
495 Write_String("IP :" & Tape_Positions'Image(IP));
(296 . 45)(493 . 251)
497 end Print_Trace;
498
499
500 -------------------
501 -- Control Stack --
502 -------------------
503
504 -- Determine whether the Control Stack is Not Empty:
505 function Control_Stack_Not_Empty return Boolean is
506 begin
507 return CSP /= Control_Stack'First;
508 end Control_Stack_Not_Empty;
509
510
511 -- Construct a Call and push it to the Control Stack:
512 procedure Control_Push(Call_Type : in Call_Types;
513 Return_IP : in Tape_Positions) is
514 begin
515 -- First, test for Overflow of Control Stack:
516 if CSP = Control_Stack'Last then
517 E("Control Stack Overflow!");
518 end if;
519 -- Push a Call with given parameters to the Control Stack:
520 CSP := CSP + 1;
521 Control_Stack(CSP) := (Why => Call_Type, Ret => Return_IP);
522 end Control_Push;
523
524
525 -- Pop an IP from the Control Stack, and verify expected Call Type:
526 function Control_Pop(Expected_Type : in Call_Types)
527 return Tape_Positions is
528 C : Call;
529 begin
530 -- First, test for Underflow of Control Stack:
531 if CSP = Control_Stack'First then
532 E("Control Stack Underflow!");
533 end if;
534 -- Pop from Control Stack:
535 C := Control_Stack(CSP);
536 Control_Stack(CSP).Why := Invalid;
537 CSP := CSP - 1;
538 -- Now, see whether it was NOT the expected type. If so, eggog:
539 if C.Why /= Expected_Type then
540 declare
541 CT : constant array(Call_Types) of String(1 .. 10)
542 := (" INVALID ", "Subroutine", "Loop state");
543 begin
544 E("Currently in a " & CT(C.Why) & "; but this Op exits a "
545 & CT(Expected_Type) & " !");
546 end;
547 end if;
548 -- ... The Call was of the expected type, so return it:
549 return C.Ret;
550 end Control_Pop;
551
552
553 -----------------
554 -- Subroutines --
555 -----------------
556
557 -- Find Subroutine with supplied Name in Subroutine Table, if it exists:
558 function Lookup_Subroutine(Name : in Sub_Names)
559 return Subroutine_Table_Range is
560 -- Number of Symbols in the Name of the current Proposed Subroutine:
561 Sub_Name_Length : Positive := 1 + Name.R - Name.L;
562 begin
563 -- Enforce minimum Subroutine Name length:
564 if Sub_Name_Length < Subr_Min_Name_Length then
565 E("Proposed Name is" & Positive'Image(Sub_Name_Length) &
566 " Symbols long, but the shortest permitted Name length is" &
567 Positive'Image(Subr_Min_Name_Length) & " !");
568 end if;
569 -- Walk the Subroutine Table from first to last valid entry:
570 for i in Subs'First + 1 .. STP loop
571 declare
572 -- The current Sub in the Subroutine Table being examined:
573 S : Sub_Def := Subs(i);
574 -- Number of Symbols in the Name of S:
575 S_Name_Length : Positive := 1 + S.Name.R - S.Name.L;
576 begin
577 -- If the lengths of the Names match:
578 if Sub_Name_Length = S_Name_Length then
579 -- If the two Names are actually equal:
580 if Tape(Name.L .. Name.R) = Tape(S.Name.L .. S.Name.R) then
581 return i; -- Return the table index of the located Sub
582 end if;
583 end if;
584 end;
585 end loop;
586 -- Name was not found in Subroutine Table; return the zero position:
587 return Subs'First;
588 end Lookup_Subroutine;
589
590
591 -- Attempt to intern the given Subroutine into the Subroutines Table:
592 procedure Intern_Subroutine(Sub : in Sub_Def) is
593 -- Position of the current Proposed Sub in Sub Table:
594 Index : Subroutine_Table_Range := Lookup_Subroutine(Sub.Name);
595 -- To DEFINE a Sub, it must NOT have existed in Sub Table.
596
597 -- Name of the Proposed Sub (for eggogs) :
598 S_Name : String := String(Tape(Sub.Name.L .. Sub.Name.R));
599 begin
600 -- If a Sub with this Name already exists, eggog:
601 if Index /= Subs'First then
602 E("Attempted to redefine Subroutine '" & S_Name & "' !");
603 end if;
604 -- Definitions are prohibited inside Loops or Sub calls:
605 if Control_Stack_Not_Empty then
606 E("Attempted to define Subroutine '"
607 & S_Name & "' while inside a Loop or Subroutine!");
608 end if;
609 -- If the Subroutine Table is full, eggog:
610 if STP = Subs'Last then
611 E("Cannot define the Subroutine '" & S_Name
612 & ": the Subroutine Table is Full!");
613 end if;
614 -- Finally, intern the Proposed Subroutine into the Sub Table:
615 STP := STP + 1;
616 Subs(STP) := Sub;
617 end Intern_Subroutine;
618
619
620 -- Invoke a given Subroutine:
621 procedure Invoke_Subroutine(Sub : in Sub_Def) is
622 begin
623 -- Push the Call to Control Stack:
624 Control_Push(Call_Type => Subroutines, Return_IP => Next_IP_On_Tape);
625 -- Next instruction will be the first Symbol of the Sub's Body:
626 IP_Next := Sub.Payload.L;
627 end Invoke_Subroutine;
628
629
630 -- Attempt to invoke a Subroutine with the supplied name:
631 procedure Invoke_Named_Subroutine(Name : in Sub_Names) is
632 -- Position of the current Proposed Sub in Sub Table:
633 Index : Subroutine_Table_Range := Lookup_Subroutine(Name);
634 -- To invoke a Sub, it MUST exist in the Sub Table.
635
636 -- Name of the Proposed Sub (for eggogs) :
637 S_Name : String := String(Tape(Name.L .. Name.R));
638 begin
639 -- If no defined Subroutine has this Name, eggog:
640 if Index = Subs'First then
641 E("Invoked Undefined Subroutine '" & S_Name & "' !");
642 end if;
643 -- Otherwise, proceed to the invocation:
644 declare
645 -- The Sub Table Entry we successfully looked up:
646 Sub : Sub_Def := Subs(Index);
647 begin
648 -- Recursion is prohibited in Peh Tapes. Detect it:
649 if IP in Sub.Payload.L .. Sub.Payload.R then
650 E("Recursive invocation in Subroutine '"
651 & S_Name & "' is prohibited!");
652 end if;
653 -- Prohibit Subroutines whose definitions end AFTER the current IP:
654 if IP < Sub.Payload.R then
655 E("Cannot invoke Subroutine '" & S_Name &
656 "' before the position where it is defined!");
657 end if;
658 -- Proceed to invoke the Subroutine:
659 Invoke_Subroutine(Sub);
660 end;
661 end Invoke_Named_Subroutine;
662
663
664 -- Invoke the nearest Subroutine defined to the LEFT of the current IP:
665 procedure Invoke_Left_Subroutine is
666 -- Position of the Subroutine to be invoked (Subs'First if none)
667 Index : Subroutine_Table_Range := Subs'First;
668 begin
669 -- Find the nearest invocable Sub (i.e. to the LEFT of current IP) :
670 -- Walk starting from the LAST Sub in Subs, down to the FIRST:
671 for i in reverse Subs'First + 1 .. STP loop
672 -- If a Sub's definition ended PRIOR TO the current IP:
673 if Subs(i).Payload.R < IP then
674 -- Save that Sub's table index:
675 Index := i;
676 -- If we found a Sub that met the condition, stop walking:
677 exit when Index /= Subs'First;
678 end if;
679 end loop;
680 -- If no Subs have been defined prior to current IP, then eggog:
681 if Index = Subs'First then
682 E("No Subroutines were defined prior to this position!");
683 end if;
684 -- Proceed to invoke the selected Sub:
685 Invoke_Subroutine(Subs(Index));
686 end Invoke_Left_Subroutine;
687
688
689 ---------
690 -- Peh --
691 ---------
692
693 -- For all Ops which entail Division: ensure that a Divisor is not zero:
694 procedure MustNotZero(D : in FZ) is
695 begin
696 if FFA_FZ_ZeroP(D) = 1 then
697 E("Division by Zero!");
698 end if;
699 end MustNotZero;
700
701 ------------------------------------------------------------------------
702
703 -- Execute a Normal Op
704 procedure Op_Normal(C : in Character) is
705
706 -- Over/underflow output from certain ops
707 F : Word;
708
709
710 begin
711
712 case C is
713
714 --------------
715 -- Stickies --
716 --------------
717 -- Enter Commented
718 ------------
719 -- Blocks --
720 ------------
721
722 -- Enter Comment Block: Symbols will be ignored until matching ')'
723 when '(' =>
724 CommLevel := 1;
725
726 -- Exit Commented (but we aren't in it!)
727 -- Exit a Comment Block (but if we're here, we aren't in one!)
728 when ')' =>
729 E("Mismatched close-comment parenthesis !");
730
731 -- Enter Quoted
732 -- Enter a Quote Block: Symbols will print until matching ']'
733 when '[' =>
734 QuoteLevel := 1;
735
736 -- Exit Quoted (but we aren't in it!)
737 -- Exit a Quote Block (but if we're here, we aren't in one!)
738 when ']' =>
739 E("Mismatched close-quote bracket !");
740
741 -- Enter a ~taken~ Conditional branch:
742 -- Enter a Conditional branch:
743 when '{' =>
744 Want(1);
745 if FFA_FZ_ZeroP(Stack(SP)) = 1 then
746 -- Enter a 'taken' branch.
747 -- All subsequent Symbols will be ignored until matching '}'.
748 CondLevel := 1;
749 end if;
750 Drop;
751
752 -- Exit from a ~non-taken~ Conditional branch:
753 -- ... we push a 0, to suppress the 'else' clause
754 -- ... we push a 0, to suppress the 'else' clause:
755 when '}' =>
756 Push;
757 FFA_WBool_To_FZ(0, Stack(SP));
(362 . 8)(765 . 13)
759 -- Fetch from Register --
760 -------------------------
761 when 'g' .. 'z' =>
762 -- Put value of Register on stack
763 Push;
764 Stack(SP) := Registers(C); -- Put value of Register on stack
765 if Use_CO_Registers then
766 Stack(SP) := CO_Registers(C); -- use Cutout Register set
767 else
768 Stack(SP) := Registers(C); -- use ordinary set
769 end if;
770
771 ------------------
772 -- Stack Motion --
(580 . 10)(988 . 6)
774 Print_FZ(Stack(SP));
775 Drop;
776
777 -- Zap (reset all resettables)
778 when 'Z' =>
779 Zap;
780
781 -- Put the Peh Program Version on the stack,
782 -- followed by FFA Program Version.
783 when 'V' =>
(626 . 6)(1030 . 8)
785 when
786 'Q' -- 'Quit...'
787 |
788 'Z' -- 'Zap...'
789 |
790 'L' -- 'Left...'
791 |
792 'R' -- 'Right...'
(636 . 37)(1042 . 62)
794 =>
795 HavePrefix := True;
796
797 -------------------
798 -- Control Stack --
799 -------------------
800 -----------
801 -- Loops --
802 -----------
803
804 -- Push current IP (i.e. of THIS Op) to Control Stack.
805 -- Begin Loop: Push IP (i.e. of THIS Op) to Control Stack.
806 when ':' =>
807 Control_Push(IP);
808 Control_Push(Call_Type => Loops, Return_IP => IP);
809
810 -- Conditional Return: Pop top of Stack, and...
811 -- Conditional End Loop: Pop top of Stack, and...
812 -- ... if ZERO: simply discard the top of the Control Stack.
813 -- ... if NONZERO: pop top of Control Stack and make it next IP.
814 when ',' =>
815 Want(1);
816 declare
817 Position : Tape_Positions := Control_Pop;
818 Loop_Position : Tape_Positions := Control_Pop(Loops);
819 Trigger : WBool := FFA_FZ_NZeroP(Stack(SP));
820 begin
821 if FFA_FZ_NZeroP(Stack(SP)) = 1 then
822 IP_Next := Position;
823 -- If Trigger is active, re-enter the Loop:
824 if Trigger = 1 then
825 IP_Next := Loop_Position;
826 end if;
827 end;
828 -- ... otherwise, continue normally.
829 Drop;
830
831 -- UNconditional Return: Control Stack top popped into IP_Next.
832 -----------------
833 -- Subroutines --
834 -----------------
835
836 -- Return from a Subroutine:
837 when ';' =>
838 IP_Next := Control_Pop;
839 -- Next instruction will be at the saved Return Position:
840 IP_Next := Control_Pop(Subroutines);
841
842 -- Indicate the start of a Subroutine Name, e.g. @SubName
843 -- ... if DEFINING a NEW Subroutine: is followed by @body;
844 -- ... if INVOKING EXISTING Subroutine: is followed by !
845 when '@' =>
846 -- Save the NEXT IP as the first Symbol of the proposed Name:
847 Proposed_Sub.Name.L := Next_IP_On_Tape;
848 -- Enter the Name mode:
849 SubNameMode := True;
850 -- We will remain in Name mode until we see a @ or ! .
851
852 -- '!' invokes a previously-defined Subroutine:
853 -- ... If found after @Name was given, the syntax is: @SubName!
854 -- ... If found in THIS context, with no @Name , then invokes
855 -- the nearest Subroutine defined to the LEFT of this IP.
856 -- NO Sub defined to the RIGHT of the current IP may be invoked.
857 when '!' =>
858 Invoke_Left_Subroutine;
859
860 ---------------------------------------------------------
861 -- Reserved Ops, i.e. ones we have not defined yet: --
862 ---------------------------------------------------------
863 when '!' | '@' |
864 'H' | 'I' | 'J' | 'K' | 'N' | 'T' | 'X' | 'Y' =>
865 when 'H' | 'I' | 'J' | 'K' | 'N' | 'T' | 'X' | 'Y' =>
866
867 E("This Operator is not defined yet: " & C);
868 ---------------------------------------------------------
(675 . 7)(1106 . 8)
870 -- NOPs --
871 ----------
872
873 -- Unprintables and spaces DO NOTHING:
874 -- Unprintables and spaces DO NOTHING.
875 -- (However: they occupy space, consume Life, clear Prefix.)
876 when others =>
877 null;
878
(683 . 6)(1115 . 7)
880
881 end Op_Normal;
882
883 ------------------------------------------------------------------------
884
885 -- Execute a Prefixed Op
886 procedure Op_Prefixed(Prefix : in Character;
(691 . 7)(1124 . 7)
888 -- Report an attempt to execute an undefined Prefix Op:
889 procedure Undefined_Prefix_Op is
890 begin
891 E("Undefined Prefix Op: " & Prefix & O);
892 E("Undefined Prefix Op: '" & Prefix & O & "'");
893 end Undefined_Prefix_Op;
894
895 begin
(700 . 7)(1133 . 7)
897 case Prefix is
898
899 ---------------------------------------------------------
900 -- Quit...
901 -- Quit... (See Ch. 17 discussion)
902 when 'Q' =>
903
904 -- .. Quit how?
(708 . 6)(1141 . 11)
906
907 -- ... with a 'Yes' Verdict:
908 when 'Y' =>
909 -- Prohibited from within a loop or Subroutine:
910 if Control_Stack_Not_Empty then
911 E("Attempted to proclaim a 'Yes' Verdict" &
912 " inside a Loop or Subroutine!");
913 end if;
914 Verdict := Yes;
915
916 -- ... with a 'No' Verdict:
(748 . 6)(1186 . 35)
918 end case;
919
920 ---------------------------------------------------------
921 -- Zap...
922 when 'Z' =>
923
924 -- .. Zap what?
925 case O is
926
927 -- ... Registers:
928 when 'R' =>
929 -- If in Cutout, will zap only Cutout set of regs
930 Zap_Registers;
931
932 -- ... Data Stack:
933 when 'D' =>
934 Zap_Data_Stack;
935
936 -- ... Overflow Flag:
937 when 'F' =>
938 Zap_Flag;
939
940 -- ... All Zappable State:
941 when 'A' =>
942 Zap_Master;
943
944 when others =>
945 Undefined_Prefix_Op;
946
947 end case;
948
949 ---------------------------------------------------------
950 -- Write into Register...
951 when '$' =>
952
(758 . 7)(1225 . 11)
954
955 -- Selected Register exists; move top FZ on stack into it:
956 Want(1);
957 Registers(O) := Stack(SP);
958 if Use_CO_Registers then
959 CO_Registers(O) := Stack(SP); -- use Cutout Register set
960 else
961 Registers(O) := Stack(SP); -- use ordinary set
962 end if;
963 Drop;
964
965 ---------------------------------------------------------
(786 . 6)(1257 . 29)
967 when 'R' =>
968 E("Left-Rotate not yet defined!");
969
970 -- ... 'Cutout' :
971 -- Mark the LEFT SIDE of the 'Cutout' Tape segment;
972 -- The Tape IN OR PRIOR to it will retain the ability to
973 -- move directly into points PRIOR to THIS position
974 -- on the Tape (i.e. where THIS Op had executed).
975 -- Ops on Tape AFTER 'RC' mark can move INTO Cutout,
976 -- but NOT directly into any position PRIOR to it.
977 -- If 'LC' is executed, a 'RC' MUST occur before Tape end.
978 -- FATAL if a 'LC' or 'RC' Op had previously executed.
979 when 'C' =>
980 -- Eggog if we have ALREADY begun the Cutout somewhere:
981 if Cutout_Begun then
982 E("'LC' Op may only execute ONCE on a Tape!");
983 end if;
984 -- Cutout defs are prohibited inside loops or Sub calls:
985 if Control_Stack_Not_Empty then
986 E("Attempted to execute 'LC' (Left-Cutout)" &
987 " inside a Loop or Subroutine!");
988 end if;
989 -- Set the START of the Cutout, and mark it 'begun':
990 Cutout_Begun := True;
991 Cutout.L := IP;
992
993 -- ... Unknown (Eggog):
994 when others =>
995 Undefined_Prefix_Op;
(824 . 6)(1318 . 30)
997 XY => Stack(SP - 1));
998 Drop;
999
1000 -- ... 'Cutout' :
1001 -- Mark the RIGHT SIDE of the 'Cutout' Tape segment that
1002 -- began with 'LC', and permanently arms the Cutout.
1003 -- After THIS position, no IP_Next may be set which
1004 -- directly transfers control to a point PRIOR to 'LC'.
1005 -- FATAL if no 'LC' had executed to mark the LEFT SIDE.
1006 when 'C' =>
1007 -- Eggog if we never marked the beginning with 'LC':
1008 if not Cutout_Begun then
1009 E("'RC' Op found, but no there was no prior 'LC' !");
1010 end if;
1011 -- Eggog if we have already armed the Cutout:
1012 if Cutout_Armed then
1013 E("'RC' Op found, but the Cutout is already armed!");
1014 end if;
1015 -- Cutout defs are prohibited inside loops or Sub calls:
1016 if Control_Stack_Not_Empty then
1017 E("Attempted to execute 'RC' (Right-Cutout)" &
1018 " inside a Loop or Subroutine!");
1019 end if;
1020 -- Otherwise proceed to complete and arm the Cutout:
1021 Cutout.R := IP;
1022 Cutout_Armed := True;
1023
1024 -- ... Unknown (Eggog):
1025 when others =>
1026 Undefined_Prefix_Op;
(881 . 11)(1399 . 13)
1028
1029 end Op_Prefixed;
1030
1031 ------------------------------------------------------------------------
1032
1033 -- Process a Symbol
1034 procedure Op(C : in Character) is
1035 begin
1036 -- First, see whether we are in a state of nestedness:
1037
1038 -- See whether we are inside a 'Block' :
1039
1040 -- ... in a Comment block:
1041 if CommLevel > 0 then
(929 . 10)(1449 . 136)
1043
1044 when '{' => -- Add a nesting level:
1045 CondLevel := CondLevel + 1;
1046
1047 when others =>
1048 null; -- Other symbols have no effect on the level
1049 end case;
1050
1051 --- ... in a proposed Subroutine Name:
1052 elsif SubNameMode then
1053 case C is
1054
1055 -- Attempt to INVOKE the named Subroutine:
1056 when '!' =>
1057 -- Detect attempt to invoke a Sub with no Name:
1058 if IP = Proposed_Sub.Name.L then
1059 E("Attempted to invoke a nameless Subroutine!");
1060 end if;
1061 -- Exit the Name mode:
1062 SubNameMode := False;
1063 -- Attempt to invoke the subroutine:
1064 Invoke_Named_Subroutine(Proposed_Sub.Name);
1065
1066 -- Attempt to read a body for a Subroutine Definition:
1067 when '@' =>
1068 -- Detect attempt to define a Sub with no Name:
1069 if IP = Proposed_Sub.Name.L then
1070 E("Attempted to define a nameless Subroutine!");
1071 end if;
1072 -- Save the NEXT IP as the beginning of the proposed Body:
1073 Proposed_Sub.Payload.L := Next_IP_On_Tape;
1074 -- Exit the Name mode:
1075 SubNameMode := False;
1076 -- Enter Sub Body mode:
1077 SubBodyMode := True;
1078
1079 -- Any permissible Symbol in a Subroutine Name:
1080 when '0' .. '9' | 'A' .. 'Z' | 'a' .. 'z' | '-' | '_' =>
1081 -- Save IP as the potential end of the proposed Sub Name:
1082 Proposed_Sub.Name.R := IP;
1083
1084 when others =>
1085 E("Symbol '" & C & "' is prohibited in a Subroutine Name !");
1086 end case;
1087
1088 --- ... in a proposed Subroutine Body:
1089 elsif SubBodyMode then
1090 declare
1091 -- Name of Proposed Subroutine (for eggogs) :
1092 Name : String
1093 := String(Tape(Proposed_Sub.Name.L .. Proposed_Sub.Name.R));
1094 begin
1095 case C is
1096 -- Subroutine Terminator:
1097 when ';' =>
1098 -- Only takes effect if NOT in a Comment or Quote Block:
1099 if SubCommLevel = 0 and SubQuoteLevel = 0 then
1100 if SubCondLevel /= 0 then
1101 E("Conditional Return in Subroutine: '"
1102 & Name & "' is Prohibited!" &
1103 " (Please check for unbalanced '{'.)'");
1104 end if;
1105 -- Now, Sub-Comm, Quote, and Cond levels are 0.
1106 -- The ';' becomes last Symbol of the new Sub's Body.
1107 -- Test for attempt to define a Sub with a null Body:
1108 if IP = Proposed_Sub.Payload.L then
1109 E("Null Body in Subroutine: '" & Name
1110 & "' is prohibited!");
1111 end if;
1112 -- Exit Body mode, and intern this new Sub definition:
1113 Proposed_Sub.Payload.R := IP;
1114 -- Exit the Sub Body mode:
1115 SubBodyMode := False;
1116 -- Attempt to intern the Proposed Subroutine:
1117 Intern_Subroutine(Proposed_Sub);
1118 end if;
1119
1120 -- Begin-Comment inside a Subroutine Body:
1121 when '(' =>
1122 SubCommLevel := SubCommLevel + 1;
1123
1124 -- End-Comment inside a Subroutine Body:
1125 when ')' =>
1126 -- If cannot drop Sub Comment level:
1127 if SubCommLevel = 0 then
1128 E("Unbalanced ')' in Body of Subroutine: '"
1129 & Name & "' !");
1130 end if;
1131 SubCommLevel := SubCommLevel - 1;
1132
1133 -- Begin-Quote inside a Subroutine Body:
1134 when '[' =>
1135 -- Ignore if Commented:
1136 if SubCommLevel = 0 then
1137 SubQuoteLevel := SubQuoteLevel + 1;
1138 end if;
1139
1140 -- End-Quote inside a Subroutine Body:
1141 when ']' =>
1142 -- Ignore if Commented:
1143 if SubCommLevel = 0 then
1144 -- If cannot drop Sub Quote level:
1145 if SubQuoteLevel = 0 then
1146 E("Unbalanced ']' in Body of Subroutine: '"
1147 & Name & "' !");
1148 end if;
1149 SubQuoteLevel := SubQuoteLevel - 1;
1150 end if;
1151
1152 -- Begin-Conditional inside a Subroutine Body:
1153 when '{' =>
1154 -- Ignore if Commented or Quoted:
1155 if SubCommLevel = 0 and SubQuoteLevel = 0 then
1156 SubCondLevel := SubCondLevel + 1;
1157 end if;
1158
1159 -- End-Conditional inside a Subroutine Body:
1160 when '}' =>
1161 -- Ignore if Commented or Quoted:
1162 if SubCommLevel = 0 and SubQuoteLevel = 0 then
1163 -- If cannot drop Sub Conditional level:
1164 if SubCondLevel = 0 then
1165 E("Unbalanced '}' in Body of Subroutine: '"
1166 & Name & "' !");
1167 end if;
1168 SubCondLevel := SubCondLevel - 1;
1169 end if;
1170
1171 -- All other Symbols have no special effect in Sub Body :
1172 when others =>
1173 null; -- Stay in Body mode until we see the ';'.
1174 end case;
1175 end;
1176 --- ... if in a prefixed op:
1177 elsif HavePrefix then
1178
(945 . 16)(1591 . 22)
1180 else
1181 -- This is a Normal Op, so proceed with the normal rules.
1182 Op_Normal(C);
1183
1184 end if;
1185
1186 -- In all cases, save the current symbol as possible prefix:
1187 -- In all cases, save the current Symbol as possible prefix:
1188 PrevC := C;
1189
1190 end Op;
1191
1192 -----------------------------
1193 -- Start of Tape Execution --
1194 -----------------------------
1195
1196 begin
1197 -- Reset all resettable state:
1198 Zap;
1199 Zap_Master;
1200 Zap_Cutout_Registers;
1201
1202 -- Execution begins with the first Op on the Tape:
1203 IP := Tape_Positions'First;
(962 . 7)(1614 . 7)
1205 loop
1206
1207 -- If current Op is NOT the last Op on the Tape:
1208 if IP /= Tape_Positions'Last then
1209 if not Last_Tape_Symbol then
1210
1211 -- ... then default successor of the current Op is the next one:
1212 IP_Next := IP + 1;
(986 . 12)(1638 . 45)
1214 IP_Next = IP or -- Reached the end of the Tape, or...
1215 Exhausted_Life; -- Exhausted Life.
1216
1217 -- If the Cutout has been armed on this Tape, then enforce it:
1218 if Cutout_Prohibits(IP_Next) then
1219 E("Attempted movement to IP:" & Tape_Positions'Image(IP_Next) &
1220 " violates the Cutout!");
1221 end if;
1222
1223 -- We did not halt yet, so select the IP of the next Op to fetch:
1224 IP := IP_Next;
1225
1226 end loop;
1227
1228 -- Warn operator about any unclosed blocks:
1229 -- At this point, the Tape has halted.
1230
1231 ------------------------------------------------------------------
1232 -- The following types of Unclosed Blocks trigger a Eggog Verdict:
1233
1234 -- Unclosed Subroutine Name at Tape's End:
1235 if SubNameMode then
1236 E("The Subroutine Name at IP:"
1237 & Tape_Positions'Image(Proposed_Sub.Name.L)
1238 & " is Unterminated!");
1239 end if;
1240
1241 -- Unclosed Subroutine Body at Tape's End:
1242 if SubBodyMode then
1243 E("The Body of Subroutine: '"
1244 & String(Tape(Proposed_Sub.Name.L .. Proposed_Sub.Name.R))
1245 & "' is Unterminated!");
1246 end if;
1247
1248 -- Unclosed Cutout:
1249 if Cutout_Begun and not Cutout_Armed then
1250 E("The Cutout declaration 'LC' at IP:"
1251 & Tape_Positions'Image(Cutout.L) & " is Unterminated!");
1252 end if;
1253
1254 ------------------------------------------------------------------
1255 -- The following types of Unclosed Blocks trigger a Warning:
1256
1257 if CommLevel > 0 then
1258 Achtung("WARNING: Tape terminated with an unclosed Comment!");
1259 end if;
(1004 . 16)(1689 . 27)
1261 Achtung("WARNING: Tape terminated with an unclosed Conditional!");
1262 end if;
1263
1264 ------------------------------------------------------------------
1265 -- Non-empty stacks, after Tape has halted, also trigger a Warning:
1266
1267 -- Warn operator if we terminated with a non-empty Control Stack.
1268 -- This situation ought to be considered poor style in a Peh Tape;
1269 -- for clarity, Verdicts should be returned from a place near
1270 -- the visually-apparent end of a Tape. However, this is not mandatory.
1271 if CSP /= Control_Stack'First then
1272 Achtung("WARNING: Tape terminated with a non-empty Control Stack!");
1273 if Control_Stack_Not_Empty then
1274 Achtung("WARNING: Tape terminated inside a Loop or Subroutine!");
1275 end if;
1276
1277 -- We're done with the Tape, so clear the state:
1278 Zap;
1279 -- Warn operator if we terminated with a non-empty Data Stack:
1280 if Data_Stack_Not_Empty then
1281 Achtung("WARNING: Tape terminated with a non-empty Data Stack!");
1282 end if;
1283
1284 ------------------------------------------------------------------
1285
1286 -- We're done with the Tape and any Warnings, so clear the state:
1287 Zap_Master;
1288 Zap_Cutout_Registers;
1289
1290 -- Return the Verdict:
1291 return Verdict;
(44 . 6)(44 . 10)
1296 -- The 'zero' position, as with the Data Stack, indicates 'emptiness'
1297 -- when pointed to by CSP ( see ffa_calc.adb ) and is never accessed.
1298
1299 -- Valid indices into the Subroutine Table:
1300 subtype Subroutine_Table_Range is Natural range 0 .. Subroutine_Table_Size;
1301 -- The 'zero' position indicates 'emptiness', as in the above.
1302
1303 -- Ensure that requested Peh Dimensions are permissible. Terminate if not.
1304 procedure Validate_Peh_Dimensions(Dimensions : in Peh_Dimensions);
1305
- C1545BA38D991624749345A5AE24336FCA2D3CA04E06F3E4F9B77AEEA15A717A1EB4F1B5B6E2D7F14229335706FDF94770E2F5CBE13471D6E93750A8DC3C5A2F(29 . 4)(29 . 10)
1310 -- The exact height of the Peh Control Stack. This is an invariant.
1311 Peh_Control_Stack_Size : constant Positive := 256;
1312
1313 -- The exact size of the Peh Subroutine Table. This is an invariant.
1314 Subroutine_Table_Size : constant Positive := 256;
1315
1316 -- The minimum number of Symbols in a Subroutine Name. This is an invariant.
1317 Subr_Min_Name_Length : constant Positive := 2;
1318
1319 end Limits;
- 80480CCA4FDF0CC6F56AFC761A32B2257259EEFA83755773D16058F4C13AD58293740A4F0A1DFE863860A7AD51C5A10FC9B8B1FAF859C79108455A85FE7B32B1(24 . 7)(24 . 7)
1324 --------------------------------------------
1325 -- Current 'deg. Kelvin' Version of Peh --
1326 --------------------------------------------
1327 Peh_K_Version : constant Natural := 252;
1328 Peh_K_Version : constant Natural := 251;
1329 --------------------------------------------
1330
1331 end Version;