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