tree checksum vpatch file split hunks
all signers: bvt asciilifeform diana_coman
antecedents: ffa_ch15_gcd.kv ffa_ch18_subroutines.kv
press order:
patch:
(17 . 3)(17 . 4)
5 560516 ffa_ch16_miller_rabin "Miller-Rabin Method."
6 567223 ffa_ch17_peh "Introduction to Peh."
7 569234 ffa_ch18_subroutines "Subroutines in Peh."
8 578827 ffa_ch19_peh_tuning_and_demos "Peh Tuning and Demo Tapes."
-(0 . 0)(1 . 219)
13 (----------------------------------------------------------------------------)
14 (----------------------------------------------------------------------------)
15 (- Demo Tape for 'Peh'; produces a random probable-prime of the given form. -)
16 (- -)
17 (- (C) 2019 Stanislav Datskovskiy ( www.loper-os.org ) -)
18 (- http://wot.deedbot.org/17215D118B7239507FAFED98B98228A001ABFFC7.html -)
19 (- -)
20 (- You do not have, nor can you ever acquire the right to use, copy or -)
21 (- distribute this software ; Should you use this software for any purpose, -)
22 (- or copy and distribute it to anyone or in any manner, you are breaking -)
23 (- the laws of whatever soi-disant jurisdiction, and you promise to -)
24 (- continue doing so for the indefinite future. In any case, please -)
25 (- always : read and understand any software ; verify any PGP signatures -)
26 (- that you use - for any purpose. -)
27 (- -)
28 (- See also http://trilema.com/2015/a-new-software-licensing-paradigm . -)
29 (----------------------------------------------------------------------------)
30 (----------------------------------------------------------------------------)
31
32 (----------------------------------------------------------------------------)
33
34 ( Largest Primorial which fits in a 2048-bit FZ : )
35
36 @Primorial@ ( Regs : none )
37 .48CB4F7B0A023C393C0A4F253FFE4D1905DEFDF482D0C7754B59B612E3B741995
38 87DC933268A053E59F021733C80D558BF9CBBAD3A38E2FB5D4BA3157227E8ACA0
39 ACF379238AFA8DB31110AF0C566DC5DBC5C8E783E1566B3B44A4E35FFC2BFE481
40 C533A1609E99A1C9AF81C8F634F7400FBD1355D091FAB7B9AFF302AAC9D60C15C
41 29E3396A18523E177B1DA3898FF1F8BF74A2CC40032736A65B25B5908950863A8
42 019065A073EBF20164F14EA4338530C2818F208BAEEB2A810A9862A09B8ADE3BE
43 BDD7CF7DC88ECB1722F7ED2DAD24FE5C4851F7D6681CA2B97306BAC70E37D177C
44 139E2688AF33E5CCEF102A2AE35276983DDCABA3720E5C165EB88C0FE
45 ;
46
47 (----------------------------------------------------------------------------)
48
49 ( Number of 'passing' M-R shots required before we will say that a candidate
50 integer is a 'probable prime': 32. Can change this if you dare. )
51
52 @MR-Shots@ ( Regs : none )
53 .20
54 ;
55
56 (----------------------------------------------------------------------------)
57
58 ( Bitmask imposed, via logical OR, on the randomly-generated candidates.
59 Consists of a 1 in the uppermost position for the current FZ width,
60 and a 1 in the lowermost position, to give ODD integers of desired width. )
61
62 @Candidate-Bitmask@ ( Regs : none )
63 .1
64 .0 ~ W
65 .1 -
66 LS
67 .1
68 |
69 ;
70
71 (----------------------------------------------------------------------------)
72
73 ( Take an integer N from stack.
74 N MUST BE > 1; assumed to be true, given that the Candidate Bitmask is > 1.
75 if N is Relatively Prime vs. Primorial:
76 Return 0;
77 else:
78 return 1. )
79
80 @Primorial-Litmus@ ( Regs : none )
81
82 ( N is on the stack already. Now find GCD(N, Primorial) : )
83 @Primorial! G
84
85 ( Was the GCD equal to 1 ? )
86 .1 =
87
88 ( Invert the answer; i.e. a 'fail' will result in 1, a 'pass' -- 0 : )
89 .1 ^
90 ;
91
92 (----------------------------------------------------------------------------)
93
94 ( Take a Bitmask specifying the bits that must be set to 1, from the stack.
95 Generate RANDOM integers, until obtains one that, when OR'd with Bitmask,
96 passes the Primorial Litmus. )
97
98 @Make-Candidate@ ( Regs : u, m, z )
99
100 ( Get the Bitmask from the stack, and assign to m : )
101 $m
102
103 ( Begin a loop: )
104 :
105
106 ( u := u + 1 , i.e. increment the 'RNG shots' counter: )
107 u .1 + $u
108
109 ( Generate a random FZ of the current FZ width : )
110 ?
111
112 ( Take the mandatory-ones Bitmask, and OR it into
113 the random FZ from above, then store this to z: )
114 m | $z
115
116 ( Run z through the Primorial Litmus: )
117 z @Primorial-Litmus!
118
119 ( If 1, i.e. Litmus failed, cycle the loop; otherwise we're done: )
120 ,
121
122 ( Return the z which passed the Primorial Litmus: )
123 z
124 ;
125
126 (----------------------------------------------------------------------------)
127
128 ( Take integers N and I from stack (I is on the top of stack, followed by N) ;
129 Fire up to I shots of Miller-Rabin Test on N, each with a RANDOM witness;
130
131 If ALL I shots PASSED, i.e. M-R did NOT 'find composite' in any of them :
132 Return 0;
133 else (i.e. if any shot FAILED) :
134 Return 1 IMMEDIATELY. )
135
136 @Iterated-MR-Test@ ( Regs : i, n, r )
137 ( i := Maximum number of Miller-Rabin shots that we will perform : )
138 $i
139
140 ( n := N, i.e. store a copy of N: )
141 $n
142
143 ( Begin a loop: )
144 :
145
146 ( Put n on the stack: )
147 n
148
149 ( Generate a random Witness for this shot: )
150 ?
151 ( Recall that it will always be brought into the valid range,
152 automatically, in constant time. See also Ch. 16A. )
153
154 ( Run a M-R test; outputs 1 if FOUND composite, and 0 if NOT: )
155 P
156
157 ( r := result )
158 $r
159
160 ( i := i - 1 , i.e. decrement the shots counter: )
161 i .1 - $i
162
163 ( If any shots still remain... )
164 i .0 >
165
166 ( Invert the M-R result: if 'NOT found composite', give a 1 : )
167 r .1 ^
168
169 ( ...shots remain, AND current one did not 'find composite' : )
170 &
171
172 ( ... then have a 1, and we cycle the loop, for the next shot;
173 Otherwise, we're done: )
174 ,
175
176 ( At this point, N has failed a M-R shot, or passed all of the shots;
177 In either case, we return r,
178 which will be 0 IFF all shots passed, and otherwise 1 : )
179 r
180 ;
181
182 (------------------------------ Main Program : ------------------------------)
183
184 ( Regs: u, t, k, x )
185
186 ( Initialize u, 'RNG' counter, i.e. how many random FZ were needed : )
187 .0 $u
188
189 ( Initialize t, 'tries' counter, i.e. how many GCD-filtered candidates tried: )
190 .0 $t
191
192 ( Initialize k to the Bitmask that is to be imposed on candidates : )
193 @Candidate-Bitmask! $k
194
195 ( Begin the main loop: )
196 :
197
198 ( t := t + 1 , i.e. increment the 'tries' counter: )
199 t .1 + $t
200
201 ( Get a candidate x, using Bitmask k, which passes Primorial Litmus: )
202 k @Make-Candidate! $x
203
204 ( Perform MR-Shots of the Miller-Rabin Test: )
205 x @MR-Shots! @Iterated-MR-Test!
206
207 ( If not yet found a candidate which passed both the initial Primorial Litmus
208 and then the full number of M-R shots, then cycle the loop : )
209 ,
210
211 ( At this point, we have found a 'probable prime' candidate, and will print: )
212
213 ( ... the Bitmask used : )
214 [Bitmask Imposed on Candidates : ] k #
215
216 ( ... the number of 'passing' M-R shots required for termination : )
217 [Number of Mandated M-R Shots : ] @MR-Shots! #
218
219 ( ... the 'RNG shots' counter : )
220 [Total Number of Random FZ Used : ] u #
221
222 ( ... the 'tries' counter, i.e. how many passed Primorial Litmus : )
223 [GCD-Filtered Candidates Tested : ] t #
224
225 ( ... finally, the candidate which passed all of the requested tests : )
226 [Probable Prime Integer : ] x #
227
228 ( Now, terminate with a 'Yes' Verdict, as we have succeeded : )
229 QY
230
231 (--------------------------------~~The End~~---------------------------------)
-(0 . 0)(1 . 146)
236 (----------------------------------------------------------------------------)
237 (----------------------------------------------------------------------------)
238 (- Demo Tape for 'Peh'; illustrates change in Flag semantics in Chapter 19. -)
239 (- -)
240 (- (C) 2019 Stanislav Datskovskiy ( www.loper-os.org ) -)
241 (- http://wot.deedbot.org/17215D118B7239507FAFED98B98228A001ABFFC7.html -)
242 (- -)
243 (- You do not have, nor can you ever acquire the right to use, copy or -)
244 (- distribute this software ; Should you use this software for any purpose, -)
245 (- or copy and distribute it to anyone or in any manner, you are breaking -)
246 (- the laws of whatever soi-disant jurisdiction, and you promise to -)
247 (- continue doing so for the indefinite future. In any case, please -)
248 (- always : read and understand any software ; verify any PGP signatures -)
249 (- that you use - for any purpose. -)
250 (- -)
251 (- See also http://trilema.com/2015/a-new-software-licensing-paradigm . -)
252 (----------------------------------------------------------------------------)
253 (----------------------------------------------------------------------------)
254
255 (----------------------------------------------------------------------------)
256
257 ( Begin the Cutout: )
258 LC
259
260 (----------------------------------------------------------------------------)
261
262 ( This subroutine causes the Cutout-Active Overflow Flag to be Set : )
263
264 @Set-OF-In-Cutout@ ( Regs : none )
265 .0 .1 - _
266 ;
267
268 (----------------------------------------------------------------------------)
269
270 ( This subroutine causes the Cutout-Active Overflow Flag to be Cleared : )
271
272 @Clear-OF-In-Cutout@ ( Regs : none )
273 ZF
274 ;
275
276 (----------------------------------------------------------------------------)
277
278
279 ( This subroutine returns the Cutout-Active Overflow Flag : )
280
281 @Get-OF-In-Cutout@ ( Regs : none )
282 O
283 ;
284
285 (----------------------------------------------------------------------------)
286
287 ( Terminate the Cutout : )
288 RC
289
290 (----------------------------------------------------------------------------)
291
292 ( This subroutine causes the Ordinary Overflow Flag to be Set : )
293
294 @Set-OF-Ordinary@ ( Regs : none )
295 .0 .1 - _
296 ;
297
298 (----------------------------------------------------------------------------)
299
300 ( This subroutine causes the Ordinary Overflow Flag to be Cleared : )
301
302 @Clear-OF-Ordinary@ ( Regs : none )
303 ZF
304 ;
305
306 (----------------------------------------------------------------------------)
307
308 ( This subroutine returns the Ordinary Overflow Flag : )
309
310 @Get-OF-Ordinary@ ( Regs : none )
311 O
312 ;
313
314 (----------------------------------------------------------------------------)
315
316 ( Display both Overflow Flags : )
317 @Show-Both-OF-Flags@ (Regs : none)
318
319 [Ordinary OF = ]
320 @Get-OF-Ordinary!
321 {[1]}{[0]}_
322
323 [ ]
324
325 @Get-OF-In-Cutout!
326 [Cutout's OF = ]
327 {[1]}{[0]}_
328 []
329 ;
330
331 (----------------------------------------------------------------------------)
332
333 (------------------------------ Main Program : ------------------------------)
334
335 ( Regs: none )
336
337
338 [Setting Ordinary OF:
339 ]
340 @Set-OF-Ordinary!
341
342 @Show-Both-OF-Flags!
343 [
344
345 ]
346
347 [Setting Cutout's OF:
348 ]
349 @Set-OF-In-Cutout!
350
351 @Show-Both-OF-Flags!
352 [
353
354 ]
355
356
357 ( Clear the Flags : )
358
359 [Clearing Ordinary OF:
360 ]
361 @Clear-OF-Ordinary!
362
363 @Show-Both-OF-Flags!
364 [
365
366 ]
367
368 [Clearing Cutout's OF:
369 ]
370 @Clear-OF-In-Cutout!
371
372 @Show-Both-OF-Flags!
373 [
374
375 ]
376
377
378 ( we're done: )
379 QY
380
381 (--------------------------------~~The End~~---------------------------------)
-(0 . 0)(1 . 98)
386 (----------------------------------------------------------------------------)
387 (----------------------------------------------------------------------------)
388 (- Demo Tape for 'Peh'; produces the largest primorial that fits in Width. -)
389 (- -)
390 (- (C) 2019 Stanislav Datskovskiy ( www.loper-os.org ) -)
391 (- http://wot.deedbot.org/17215D118B7239507FAFED98B98228A001ABFFC7.html -)
392 (- -)
393 (- You do not have, nor can you ever acquire the right to use, copy or -)
394 (- distribute this software ; Should you use this software for any purpose, -)
395 (- or copy and distribute it to anyone or in any manner, you are breaking -)
396 (- the laws of whatever soi-disant jurisdiction, and you promise to -)
397 (- continue doing so for the indefinite future. In any case, please -)
398 (- always : read and understand any software ; verify any PGP signatures -)
399 (- that you use - for any purpose. -)
400 (- -)
401 (- See also http://trilema.com/2015/a-new-software-licensing-paradigm . -)
402 (----------------------------------------------------------------------------)
403 (----------------------------------------------------------------------------)
404
405 (------------------------------ Main Program : ------------------------------)
406
407 ( p is the 'primorial accumulator', and q is the current 'potential prime'. )
408
409 ( p is initialized to the product of the first two primes, 2 and 3 : )
410 .6 $p
411
412 ( q is initialized to 5, i.e. the first prime that is not 2 or 3 :)
413 .5 $q
414
415 ( Begin a loop: )
416 :
417
418 ( Determine GCD(p, q) : )
419 p q G
420
421 ( If GCD(p, q) WAS equal to 1, we know that q is a new prime : )
422 .1 =
423 {
424 ( Find the product pq.
425 The UPPER FZ of this product will land on top of stack,
426 and the LOWER FZ will lie immediately under it : )
427 p q *
428
429 ( If the UPPER FZ of the product pq was NOT equal to 0...
430 ... then we have overflowed our Width, and must stop: )
431 {
432 ( Drop the LOWER FZ of the product pq, because
433 we have overflowed Width and cannot use it : )
434 _
435
436 ( Leave a 0 on the stack, to trigger termination : )
437 .0
438
439 ( At this point, we have the largest primorial
440 that can fit in our FZ Width, and we are done. )
441 }
442
443 ( If the UPPER FZ of the product pq WAS equal to 0...
444 ... then we have NOT overflowed our Width, and continue: )
445 {
446 ( Store the LOWER FZ of the product pq to p :)
447 $p
448
449 ( Leave a 1 on the stack, to trigger continuation : )
450 .1
451
452 ( At this point, pq is the primorial up to and
453 inclusive of q, and we keep going. )
454 }_
455 }
456
457 ( If GCD(p, q) WAS NOT equal to 1, we know that q is NOT a prime : )
458 {
459 ( Leave a 1 on the stack, to signal continuation : )
460 .1
461 }_
462
463
464 ( After either of the above cases, we must:
465 q := q + 2,
466 given as any possible next prime after the current q must be odd : )
467 q .2 + $q
468
469 ( If we have a 1, cycle the loop; otherwise, we have the Primorial, in p,
470 and must output it and terminate the Tape : )
471 ,
472
473 ( Emit a Peh Tape which defines the constant 'Primorial' : )
474 [@Primorial@ ( Regs : none )
475 .]
476 p#
477 [;
478 ]
479
480 ( Now, terminate with a 'Yes' Verdict, as we have succeeded : )
481 QY
482
483 (--------------------------------~~The End~~---------------------------------)
- 5BA13C52F966E15D2DAF2FDFE29F0515010B7E23BEAD59AAD66B61828DAF3724CB7D32D82AAA2EDB9DFB65641BECF7B2834900D916B12512DD02DE62E54E2E3A(136 . 6)(136 . 9)- F11774699154A1BDA84873CE0E8F11865BA42E40732E36CFBD819BDE949D27E0DCB5D151AAAEC1A6D34377BBAD7829239D5CD8FF49C290A75CB95C5A3EDD0169
488 -- Carry/Borrow Flag set by certain arithmetical Ops:
489 Flag : WBool := 0;
490
491 -- 'Cutout'-segregated Carry/Borrow Flag:
492 CO_Flag : WBool := 0;
493
494 -- Odometer:
495 Ticks : Natural := 0;
496
(144 . 11)(147 . 11)
498 CommLevel : Natural := 0;
499 CondLevel : Natural := 0;
500
501 -- Whether we are currently inside a Proposed Subroutine Name:
502 SubNameMode : Boolean := False;
503 -- The possible Modes of the reader:
504 type Modes is (Normal, SubName, SubBody, PrefixOp);
505
506 -- Whether we are currently inside a Proposed Subroutine Body:
507 SubBodyMode : Boolean := False;
508 -- Currently-active reader Mode:
509 Mode : Modes := Normal;
510
511 -- Current levels of nestable Blocks when reading a Subroutine Body:
512 SubQuoteLevel : Natural := 0;
(164 . 9)(167 . 8)
514 Cutout_Armed : Boolean := False;
515 Cutout : Cutouts;
516
517 -- Prefixed Operators
518 -- Prefix for Prefixed Operators
519 PrevC : Character := ' ';
520 HavePrefix : Boolean := False;
521
522 -- Current Verdict. We run while 'Mu', Tape remains, and Ticks under max.
523 Verdict : Peh_Verdicts := Mu;
(245 . 10)(247 . 14)
525 end Zap_Registers;
526
527
528 -- Zero the Overflow Flag:
529 -- Zero the currently-active Overflow Flag:
530 procedure Zap_Flag is
531 begin
532 Flag := 0;
533 if Use_CO_Registers then
534 CO_Flag := 0;
535 else
536 Flag := 0;
537 end if;
538 end Zap_Flag;
539
540
(483 . 12)(489 . 18)
542 end if;
543 Write_Newline;
544
545 -- Print Overflow-Flag, Ticks and IP:
546 Write_String("Flag :" & WBool'Image(Flag));
547 -- Print active Overflow-Flag, then Ticks and IP:
548
549 if Use_CO_Registers then
550 Write_String("Flag (CO) :" & WBool'Image(CO_Flag));
551 else
552 Write_String("Flag :" & WBool'Image(Flag));
553 end if;
554
555 Write_Newline;
556 Write_String("Ticks :" & Natural'Image(Ticks));
557 Write_String("Ticks :" & Natural'Image(Ticks));
558 Write_Newline;
559 Write_String("IP :" & Tape_Positions'Image(IP));
560 Write_String("IP :" & Tape_Positions'Image(IP));
561 Write_Newline;
562 end Print_Trace;
563
(843 . 7)(855 . 13)
565 Y => Stack(SP),
566 Difference => Stack(SP - 1),
567 Underflow => F);
568 Flag := FFA_Word_NZeroP(F);
569
570 -- If we are in the Cutout, write the CO_Flag instead of Flag:
571 if Use_CO_Registers then
572 CO_Flag := FFA_Word_NZeroP(F);
573 else
574 Flag := FFA_Word_NZeroP(F);
575 end if;
576 Drop;
577
578 -- Add
(853 . 7)(871 . 13)
580 Y => Stack(SP),
581 Sum => Stack(SP - 1),
582 Overflow => F);
583 Flag := FFA_Word_NZeroP(F);
584
585 -- If we are in the Cutout, write the CO_Flag instead of Flag:
586 if Use_CO_Registers then
587 CO_Flag := FFA_Word_NZeroP(F);
588 else
589 Flag := FFA_Word_NZeroP(F);
590 end if;
591 Drop;
592
593 -- Divide and give Quotient and Remainder
(980 . 7)(1004 . 12)
595 -- Put the Overflow flag on the stack
596 when 'O' =>
597 Push;
598 FFA_WBool_To_FZ(Flag, Stack(SP));
599 -- If we are in the Cutout, read CO_Flag instead of Flag:
600 if Use_CO_Registers then
601 FFA_WBool_To_FZ(CO_Flag, Stack(SP));
602 else
603 FFA_WBool_To_FZ(Flag, Stack(SP));
604 end if;
605
606 -- Print the FZ on the top of the stack
607 when '#' =>
(1040 . 7)(1069 . 8)
609 |
610 '$' -- Pop top of Stack into the following Register...
611 =>
612 HavePrefix := True;
613 -- Set the Prefixed Op Mode. Next Symbol is treated as prefixed:
614 Mode := PrefixOp;
615
616 -----------
617 -- Loops --
(1083 . 7)(1113 . 7)
619 -- Save the NEXT IP as the first Symbol of the proposed Name:
620 Proposed_Sub.Name.L := Next_IP_On_Tape;
621 -- Enter the Name mode:
622 SubNameMode := True;
623 Mode := SubName;
624 -- We will remain in Name mode until we see a @ or ! .
625
626 -- '!' invokes a previously-defined Subroutine:
(1201 . 7)(1231 . 7)
628 when 'D' =>
629 Zap_Data_Stack;
630
631 -- ... Overflow Flag:
632 -- ... Overflow Flag (if in Cutout, zaps CO_Flag) :
633 when 'F' =>
634 Zap_Flag;
635
(1401 . 7)(1431 . 138)
637
638 ------------------------------------------------------------------------
639
640 -- Process a Symbol
641 -- Process a character in a proposed Subroutine Name:
642 procedure SubName_Symbol(C : in Character) is
643 begin
644 case C is
645 -- Attempt to INVOKE the named Subroutine:
646 when '!' =>
647 -- Detect attempt to invoke a Sub with no Name:
648 if IP = Proposed_Sub.Name.L then
649 E("Attempted to invoke a nameless Subroutine!");
650 end if;
651 -- Exit the Sub Name mode and enter Normal mode:
652 Mode := Normal;
653 -- Attempt to invoke the subroutine:
654 Invoke_Named_Subroutine(Proposed_Sub.Name);
655
656 -- Attempt to read a body for a Subroutine Definition:
657 when '@' =>
658 -- Detect attempt to define a Sub with no Name:
659 if IP = Proposed_Sub.Name.L then
660 E("Attempted to define a nameless Subroutine!");
661 end if;
662 -- Save NEXT IP as the beginning of the proposed Body:
663 Proposed_Sub.Payload.L := Next_IP_On_Tape;
664 -- Exit the Name mode and enter Sub Body mode:
665 Mode := SubBody;
666
667 -- Any permissible Symbol in a Subroutine Name:
668 when '0' .. '9' | 'A' .. 'Z' | 'a' .. 'z' | '-' | '_' =>
669 -- Save IP as the potential end of the proposed Sub Name:
670 Proposed_Sub.Name.R := IP;
671
672 when others =>
673 E("Symbol '" & C & "' is prohibited in a Subroutine Name !");
674 end case;
675 end SubName_Symbol;
676
677 ------------------------------------------------------------------------
678
679 -- Process a character in a proposed Subroutine Body:
680 procedure SubBody_Symbol(C : in Character) is
681
682 -- Name of Proposed Subroutine (for eggogs) :
683 Name : String
684 := String(Tape(Proposed_Sub.Name.L .. Proposed_Sub.Name.R));
685
686 begin
687 case C is
688 -- Subroutine Terminator:
689 when ';' =>
690 -- Only takes effect if NOT in a Comment or Quote Block:
691 if SubCommLevel = 0 and SubQuoteLevel = 0 then
692 if SubCondLevel /= 0 then
693 E("Conditional Return in Subroutine: '"
694 & Name & "' is Prohibited!" &
695 " (Please check for unbalanced '{'.)'");
696 end if;
697 -- Now, Sub-Comm, Quote, and Cond levels are 0.
698 -- The ';' becomes last Symbol of the new Sub's Body.
699 -- Test for attempt to define a Sub with a null Body:
700 if IP = Proposed_Sub.Payload.L then
701 E("Null Body in Subroutine: '" & Name
702 & "' is prohibited!");
703 end if;
704 -- Intern this new Sub definition:
705 Proposed_Sub.Payload.R := IP;
706 -- Exit the Sub Body mode and enter Normal mode:
707 Mode := Normal;
708 -- Attempt to intern the Proposed Subroutine:
709 Intern_Subroutine(Proposed_Sub);
710 end if;
711
712 -- Begin-Comment inside a Subroutine Body:
713 when '(' =>
714 SubCommLevel := SubCommLevel + 1;
715
716 -- End-Comment inside a Subroutine Body:
717 when ')' =>
718 -- If cannot drop Sub Comment level:
719 if SubCommLevel = 0 then
720 E("Unbalanced ')' in Body of Subroutine: '"
721 & Name & "' !");
722 end if;
723 SubCommLevel := SubCommLevel - 1;
724
725 -- Begin-Quote inside a Subroutine Body:
726 when '[' =>
727 -- Ignore if Commented:
728 if SubCommLevel = 0 then
729 SubQuoteLevel := SubQuoteLevel + 1;
730 end if;
731
732 -- End-Quote inside a Subroutine Body:
733 when ']' =>
734 -- Ignore if Commented:
735 if SubCommLevel = 0 then
736 -- If cannot drop Sub Quote level:
737 if SubQuoteLevel = 0 then
738 E("Unbalanced ']' in Body of Subroutine: '"
739 & Name & "' !");
740 end if;
741 SubQuoteLevel := SubQuoteLevel - 1;
742 end if;
743
744 -- Begin-Conditional inside a Subroutine Body:
745 when '{' =>
746 -- Ignore if Commented or Quoted:
747 if SubCommLevel = 0 and SubQuoteLevel = 0 then
748 SubCondLevel := SubCondLevel + 1;
749 end if;
750
751 -- End-Conditional inside a Subroutine Body:
752 when '}' =>
753 -- Ignore if Commented or Quoted:
754 if SubCommLevel = 0 and SubQuoteLevel = 0 then
755 -- If cannot drop Sub Conditional level:
756 if SubCondLevel = 0 then
757 E("Unbalanced '}' in Body of Subroutine: '"
758 & Name & "' !");
759 end if;
760 SubCondLevel := SubCondLevel - 1;
761 end if;
762
763 -- All other Symbols have no special effect in Sub Body :
764 when others =>
765 null; -- Stay in Body mode until we see the ';'.
766 end case;
767 end SubBody_Symbol;
768
769
770 ------------------------------------------------------------------------
771
772 -- All Peh Symbols begin their processing here :
773 procedure Op(C : in Character) is
774 begin
775
(1454 . 151)(1615 . 42)
777 null; -- Other symbols have no effect on the level
778 end case;
779
780 --- ... in a proposed Subroutine Name:
781 elsif SubNameMode then
782 case C is
783 else
784 --- ... we are not inside a 'Block' :
785
786 case Mode is
787
788 -- Attempt to INVOKE the named Subroutine:
789 when '!' =>
790 -- Detect attempt to invoke a Sub with no Name:
791 if IP = Proposed_Sub.Name.L then
792 E("Attempted to invoke a nameless Subroutine!");
793 end if;
794 -- Exit the Name mode:
795 SubNameMode := False;
796 -- Attempt to invoke the subroutine:
797 Invoke_Named_Subroutine(Proposed_Sub.Name);
798 --- ... a character in a proposed Subroutine Name:
799 when SubName =>
800 SubName_Symbol(C);
801
802 -- Attempt to read a body for a Subroutine Definition:
803 when '@' =>
804 -- Detect attempt to define a Sub with no Name:
805 if IP = Proposed_Sub.Name.L then
806 E("Attempted to define a nameless Subroutine!");
807 end if;
808 -- Save the NEXT IP as the beginning of the proposed Body:
809 Proposed_Sub.Payload.L := Next_IP_On_Tape;
810 -- Exit the Name mode:
811 SubNameMode := False;
812 -- Enter Sub Body mode:
813 SubBodyMode := True;
814 --- ... a character in a proposed Subroutine Body:
815 when SubBody =>
816 SubBody_Symbol(C);
817
818 -- Any permissible Symbol in a Subroutine Name:
819 when '0' .. '9' | 'A' .. 'Z' | 'a' .. 'z' | '-' | '_' =>
820 -- Save IP as the potential end of the proposed Sub Name:
821 Proposed_Sub.Name.R := IP;
822 --- ... the second character of a Prefixed Op:
823 when PrefixOp =>
824 -- Drop prefix-op hammer, until another prefix-op cocks it:
825 Mode := Normal;
826
827 -- Dispatch this op, where prefix is the preceding character
828 Op_Prefixed(Prefix => PrevC, O => C);
829
830 -- This is a Normal Op...
831 when Normal =>
832 -- ... so proceed with the normal rules:
833 Op_Normal(C);
834
835 -- Save the current Symbol as a possible prefix:
836 PrevC := C;
837
838 when others =>
839 E("Symbol '" & C & "' is prohibited in a Subroutine Name !");
840 end case;
841
842 --- ... in a proposed Subroutine Body:
843 elsif SubBodyMode then
844 declare
845 -- Name of Proposed Subroutine (for eggogs) :
846 Name : String
847 := String(Tape(Proposed_Sub.Name.L .. Proposed_Sub.Name.R));
848 begin
849 case C is
850 -- Subroutine Terminator:
851 when ';' =>
852 -- Only takes effect if NOT in a Comment or Quote Block:
853 if SubCommLevel = 0 and SubQuoteLevel = 0 then
854 if SubCondLevel /= 0 then
855 E("Conditional Return in Subroutine: '"
856 & Name & "' is Prohibited!" &
857 " (Please check for unbalanced '{'.)'");
858 end if;
859 -- Now, Sub-Comm, Quote, and Cond levels are 0.
860 -- The ';' becomes last Symbol of the new Sub's Body.
861 -- Test for attempt to define a Sub with a null Body:
862 if IP = Proposed_Sub.Payload.L then
863 E("Null Body in Subroutine: '" & Name
864 & "' is prohibited!");
865 end if;
866 -- Exit Body mode, and intern this new Sub definition:
867 Proposed_Sub.Payload.R := IP;
868 -- Exit the Sub Body mode:
869 SubBodyMode := False;
870 -- Attempt to intern the Proposed Subroutine:
871 Intern_Subroutine(Proposed_Sub);
872 end if;
873
874 -- Begin-Comment inside a Subroutine Body:
875 when '(' =>
876 SubCommLevel := SubCommLevel + 1;
877
878 -- End-Comment inside a Subroutine Body:
879 when ')' =>
880 -- If cannot drop Sub Comment level:
881 if SubCommLevel = 0 then
882 E("Unbalanced ')' in Body of Subroutine: '"
883 & Name & "' !");
884 end if;
885 SubCommLevel := SubCommLevel - 1;
886
887 -- Begin-Quote inside a Subroutine Body:
888 when '[' =>
889 -- Ignore if Commented:
890 if SubCommLevel = 0 then
891 SubQuoteLevel := SubQuoteLevel + 1;
892 end if;
893
894 -- End-Quote inside a Subroutine Body:
895 when ']' =>
896 -- Ignore if Commented:
897 if SubCommLevel = 0 then
898 -- If cannot drop Sub Quote level:
899 if SubQuoteLevel = 0 then
900 E("Unbalanced ']' in Body of Subroutine: '"
901 & Name & "' !");
902 end if;
903 SubQuoteLevel := SubQuoteLevel - 1;
904 end if;
905
906 -- Begin-Conditional inside a Subroutine Body:
907 when '{' =>
908 -- Ignore if Commented or Quoted:
909 if SubCommLevel = 0 and SubQuoteLevel = 0 then
910 SubCondLevel := SubCondLevel + 1;
911 end if;
912
913 -- End-Conditional inside a Subroutine Body:
914 when '}' =>
915 -- Ignore if Commented or Quoted:
916 if SubCommLevel = 0 and SubQuoteLevel = 0 then
917 -- If cannot drop Sub Conditional level:
918 if SubCondLevel = 0 then
919 E("Unbalanced '}' in Body of Subroutine: '"
920 & Name & "' !");
921 end if;
922 SubCondLevel := SubCondLevel - 1;
923 end if;
924
925 -- All other Symbols have no special effect in Sub Body :
926 when others =>
927 null; -- Stay in Body mode until we see the ';'.
928 end case;
929 end;
930 --- ... if in a prefixed op:
931 elsif HavePrefix then
932
933 -- Drop the prefix-op hammer, until another prefix-op cocks it
934 HavePrefix := False;
935
936 -- Dispatch this op, where prefix is the preceding character
937 Op_Prefixed(Prefix => PrevC, O => C);
938
939 else
940 -- This is a Normal Op, so proceed with the normal rules.
941 Op_Normal(C);
942
943 end if;
944
945 -- In all cases, save the current Symbol as possible prefix:
946 PrevC := C;
947
948 end Op;
949
950 ------------------------------------------------------------------------
951
952 -----------------------------
953 -- Start of Tape Execution --
954 -----------------------------
(1652 . 23)(1704 . 33)
956 -- At this point, the Tape has halted.
957
958 ------------------------------------------------------------------
959 -- The following types of Unclosed Blocks trigger a Eggog Verdict:
960 -- Termination in a Mode other than 'Normal' triggers a Eggog Verdict:
961
962 -- Unclosed Subroutine Name at Tape's End:
963 if SubNameMode then
964 E("The Subroutine Name at IP:"
965 & Tape_Positions'Image(Proposed_Sub.Name.L)
966 & " is Unterminated!");
967 end if;
968
969 -- Unclosed Subroutine Body at Tape's End:
970 if SubBodyMode then
971 E("The Body of Subroutine: '"
972 & String(Tape(Proposed_Sub.Name.L .. Proposed_Sub.Name.R))
973 & "' is Unterminated!");
974 end if;
975 case Mode is
976
977 -- Unclosed Subroutine Name at Tape's End:
978 when SubName =>
979 E("The Subroutine Name at IP:"
980 & Tape_Positions'Image(Proposed_Sub.Name.L)
981 & " is Unterminated!");
982
983 -- Unclosed Subroutine Body at Tape's End:
984 when SubBody =>
985 E("The Body of Subroutine: '"
986 & String(Tape(Proposed_Sub.Name.L .. Proposed_Sub.Name.R))
987 & "' is Unterminated!");
988
989 -- Incomplete Prefix Op at Tape's End:
990 when PrefixOp =>
991 E("Prefix Op: '" & PrevC & "' is Unterminated at End of Tape!");
992
993 -- This is the expected Mode at Tape's End:
994 when Normal =>
995 null;
996
997 end case;
998
999 -- Unclosed Cutout:
1000 -- Unclosed Cutout triggers a Eggog Verdict:
1001 if Cutout_Begun and not Cutout_Armed then
1002 E("The Cutout declaration 'LC' at IP:"
1003 & Tape_Positions'Image(Cutout.L) & " is Unterminated!");
(24 . 7)(24 . 7)
1008 --------------------------------------------
1009 -- Current 'deg. Kelvin' Version of Peh --
1010 --------------------------------------------
1011 Peh_K_Version : constant Natural := 251;
1012 Peh_K_Version : constant Natural := 250;
1013 --------------------------------------------
1014
1015 end Version;
-(0 . 0)(1 . 4)
1020 The contents of this directory are OBSOLETE!
1021
1022 However they are retained for reference, and for use by
1023 students of Chapters 1, 2, and 3.
- DBD50A883D03E0FA142CC64DFE52D846C5280F1A1A533A2DE47D2448DFBC5713D52635E2DC59DD85EF7DDBB104DC051F88296E394B059CEC88E4E99AA1C2EC9B(69 . 6)(69 . 7)
1028
1029 end FZ_IDiv;
1030
1031
1032 -- Exactly same thing as IDiv, but keep only the Quotient
1033 procedure FZ_Div(Dividend : in FZ;
1034 Divisor : in FZ;
(79 . 6)(80 . 7)
1036 FZ_IDiv(Dividend, Divisor, Quotient, Remainder);
1037 end FZ_Div;
1038
1039
1040 -- Modulus. Permits the asymmetric Dividend and Divisor in FZ_Mod_Exp.
1041 procedure FZ_Mod(Dividend : in FZ;
1042 Divisor : in FZ;
(99 . 48)(101 . 43)
1044 -- Performs Restoring Division on a given segment of Dividend:Divisor
1045 procedure Slice(Index : Dividend_Index;
1046 Cut : Divisor_Cuts) is
1047
1048 -- Borrow, from comparator
1049 C : WBool;
1050
1051 -- Left-Shift Overflow
1052 LsO : WBool;
1053
1054 -- Current cut of Remainder register
1055 Rs : FZ renames R(1 .. Cut);
1056
1057 -- Current cut of Divisor
1058 Ds : FZ renames Divisor(1 .. Cut);
1059
1060 -- Current word of Dividend, starting from the highest
1061 W : Word := Dividend(Dividend'Last + 1 - Index);
1062
1063 begin
1064
1065 declare
1066
1067 -- Borrow, from comparator
1068 C : WBool;
1069
1070 -- Left-Shift Overflow
1071 LsO : WBool;
1072
1073 -- Current cut of Remainder register
1074 Rs : FZ renames R(1 .. Cut);
1075 -- For each bit in the current Dividend word:
1076 for b in 1 .. Bitness loop
1077
1078 -- Current cut of Divisor
1079 Ds : FZ renames Divisor(1 .. Cut);
1080 -- Send top bit of current Dividend word to the bottom of W
1081 W := Rotate_Left(W, 1);
1082
1083 -- Current word of Dividend, starting from the highest
1084 W : Word := Dividend(Dividend'Last + 1 - Index);
1085 -- Advance Rs, shifting in the current Dividend bit
1086 FZ_ShiftLeft_O_I(N => Rs, ShiftedN => Rs, Count => 1,
1087 OF_In => W and 1,
1088 Overflow => LsO);
1089
1090 begin
1091 -- Subtract Divisor-Cut from R-Cut; Underflow goes into C
1092 FZ_Sub(X => Rs, Y => Ds, Difference => Rs, Underflow => C);
1093
1094 -- For each bit in the current Dividend word:
1095 for b in 1 .. Bitness loop
1096
1097 -- Send top bit of current Dividend word to the bottom of W
1098 W := Rotate_Left(W, 1);
1099
1100 -- Advance Rs, shifting in the current Dividend bit
1101 FZ_ShiftLeft_O_I(N => Rs, ShiftedN => Rs, Count => 1,
1102 OF_In => W and 1,
1103 Overflow => LsO);
1104
1105 -- Subtract Divisor-Cut from R-Cut; Underflow goes into C
1106 FZ_Sub(X => Rs, Y => Ds, Difference => Rs, Underflow => C);
1107
1108 -- If C=1, subtraction underflowed, and we must undo it:
1109 FZ_Add_Gated(X => Rs, Y => Ds, Sum => Rs,
1110 Gate => C and W_Not(LsO));
1111
1112 end loop;
1113 -- If C=1, subtraction underflowed, and we must undo it:
1114 FZ_Add_Gated(X => Rs, Y => Ds, Sum => Rs,
1115 Gate => C and W_Not(LsO));
1116
1117 end;
1118 end loop;
1119
1120 end Slice;
1121