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