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 with CmdLine; use CmdLine;
24
25 -- FFA
26 with FFA; use FFA;
27
28 -- For the intrinsic equality operator on Words
29 use type FFA.Word;
30
31 -- For RNG:
32 with FFA_RNG; use FFA_RNG;
33
34
35 procedure FFA_Calc is
36
37 Width : Positive; -- Desired FFA Width
38 Height : Positive; -- Desired Height of Stack
39 RNG : RNG_Device; -- The active RNG device.
40
41 begin
42 if Arg_Count < 3 or Arg_Count > 4 then
43 Eggog("Usage: ./ffa_calc WIDTH HEIGHT [/dev/rng]");
44 end if;
45
46 declare
47 Arg1 : CmdLineArg;
48 Arg2 : CmdLineArg;
49 begin
50 -- Get commandline args:
51 Get_Argument(1, Arg1); -- First arg
52 Get_Argument(2, Arg2); -- Second arg
53
54 if Arg_Count = 4 then
55 -- RNG was specified:
56 declare
57 Arg3 : CmdLineArg;
58 begin
59 Get_Argument(3, Arg3); -- Third arg (optional)
60
61 -- Ada.Sequential_IO chokes on paths with trailing whitespace!
62 -- So we have to give it a trimmed path. But we can't use
63 -- Ada.Strings.Fixed.Trim, because it suffers from
64 -- SecondaryStackism-syphilis. Instead we are stuck doing this:
65 Init_RNG(RNG, Arg3(Arg3'First .. Len_Arg(3)));
66 end;
67 else
68 -- RNG was NOT specified:
69 Init_RNG(RNG); -- Use the machine default then
70 end if;
71
72 -- Parse into Positives:
73 Width := Positive'Value(Arg1);
74 Height := Positive'Value(Arg2);
75 exception
76 when others =>
77 Eggog("Invalid arguments!");
78 end;
79
80 -- Test if proposed Width is permissible:
81 if not FFA_FZ_Valid_Bitness_P(Width) then
82 Eggog("Invalid Width: " & FFA_Validity_Rule_Doc);
83 end if;
84
85 -- The Calculator itself:
86 declare
87
88 -- The number of Words required to make a FZ of the given Bitness.
89 Wordness : Indices := Indices(Width / Bitness);
90
91 --------------------------------------------------------
92 -- State --
93 --------------------------------------------------------
94 -- The Stack:
95 subtype Stack_Positions is Natural range 0 .. Height;
96 type Stacks is array(Stack_Positions range <>) of FZ(1 .. Wordness);
97 Stack : Stacks(Stack_Positions'Range);
98
99 -- Stack Pointer:
100 SP : Stack_Positions := Stack_Positions'First;
101
102 -- Carry/Borrow Flag:
103 Flag : WBool := 0;
104
105 -- Odometer:
106 Pos : Natural := 0;
107
108 -- The current levels of the three types of nestedness:
109 QuoteLevel : Natural := 0;
110 CommLevel : Natural := 0;
111 CondLevel : Natural := 0;
112
113 -- Prefixed Operators
114 PrevC : Character := ' ';
115 HavePrefix : Boolean := False;
116
117 --------------------------------------------------------
118
119
120 -- Clear the stack and set SP to bottom.
121 procedure Zap is
122 begin
123 -- Clear the stack
124 for i in Stack'Range loop
125 FFA_FZ_Clear(Stack(i));
126 end loop;
127 -- Set SP to bottom
128 SP := Stack_Positions'First;
129 -- Clear Overflow flag
130 Flag := 0;
131 -- Clear prefix
132 HavePrefix := False;
133 PrevC := ' ';
134 end Zap;
135
136
137 -- Report a fatal error condition at the current symbol
138 procedure E(S : in String) is
139 begin
140 Eggog("Pos:" & Natural'Image(Pos) & ": " & S);
141 end E;
142
143
144 -- Move SP up
145 procedure Push is
146 begin
147 if SP = Stack_Positions'Last then
148 E("Stack Overflow!");
149 else
150 SP := SP + 1;
151 end if;
152 end Push;
153
154
155 -- Discard the top of the stack
156 procedure Drop is
157 begin
158 FFA_FZ_Clear(Stack(SP));
159 SP := SP - 1;
160 end Drop;
161
162
163 -- Check if stack has the necessary N items
164 procedure Want(N : in Positive) is
165 begin
166 if SP < N then
167 E("Stack Underflow!");
168 end if;
169 end Want;
170
171
172 -- Ensure that a divisor is not zero
173 procedure MustNotZero(D : in FZ) is
174 begin
175 if FFA_FZ_ZeroP(D) = 1 then
176 E("Division by Zero!");
177 end if;
178 end MustNotZero;
179
180
181 -- Slide a new hex digit into the FZ on top of stack
182 procedure Ins_Hex_Digit(Digit : in Nibble) is
183 Overflow : WBool := 0;
184 begin
185
186 -- Insert the given nibble, and detect any overflow:
187 FFA_FZ_Insert_Bottom_Nibble(N => Stack(SP),
188 D => Digit,
189 Overflow => Overflow);
190
191 -- Constants which exceed the Width are forbidden:
192 if Overflow = 1 then
193 E("Constant Exceeds Bitness!");
194 end if;
195
196 end;
197
198
199 -- Emit an ASCII representation of N to the terminal
200 procedure Print_FZ(N : in FZ) is
201 S : String(1 .. FFA_FZ_ASCII_Length(N)); -- Mandatorily, exact size
202 begin
203 FFA_FZ_To_Hex_String(N, S); -- Convert N to ASCII hex
204 Write_String(S); -- Print the result to stdout
205 Write_Newline; -- Print newline, for clarity.
206 end Print_FZ;
207
208
209 -- Denote that the given op is a prefix
210 procedure IsPrefix is
211 begin
212 HavePrefix := True;
213 end IsPrefix;
214
215
216 -- Execute a Normal Op
217 procedure Op_Normal(C : in Character) is
218
219 -- Over/underflow output from certain ops
220 F : Word;
221
222 begin
223
224 case C is
225
226 --------------
227 -- Stickies --
228 --------------
229 -- Enter Commented
230 when '(' =>
231 CommLevel := 1;
232
233 -- Exit Commented (but we aren't in it!)
234 when ')' =>
235 E("Mismatched close-comment parenthesis !");
236
237 -- Enter Quoted
238 when '[' =>
239 QuoteLevel := 1;
240
241 -- Exit Quoted (but we aren't in it!)
242 when ']' =>
243 E("Mismatched close-quote bracket !");
244
245 -- Enter a ~taken~ Conditional branch:
246 when '{' =>
247 Want(1);
248 if FFA_FZ_ZeroP(Stack(SP)) = 1 then
249 CondLevel := 1;
250 end if;
251 Drop;
252
253 -- Exit from a ~non-taken~ Conditional branch:
254 -- ... we push a 0, to suppress the 'else' clause
255 when '}' =>
256 Push;
257 FFA_WBool_To_FZ(0, Stack(SP));
258
259 ----------------
260 -- Immediates --
261 ----------------
262
263 -- These operate on the FZ ~currently~ at top of the stack;
264 -- and this means that the stack may NOT be empty.
265
266 when '0' .. '9' =>
267 Want(1);
268 Ins_Hex_Digit(Character'Pos(C) - Character'Pos('0'));
269
270 when 'A' .. 'F' =>
271 Want(1);
272 Ins_Hex_Digit(10 + Character'Pos(C) - Character'Pos('A'));
273
274 when 'a' .. 'f' =>
275 Want(1);
276 Ins_Hex_Digit(10 + Character'Pos(C) - Character'Pos('a'));
277
278 ------------------
279 -- Stack Motion --
280 ------------------
281
282 -- Push a 0 onto the stack
283 when '.' =>
284 Push;
285 FFA_FZ_Clear(Stack(SP));
286
287 -- Dup
288 when '"' =>
289 Want(1);
290 Push;
291 Stack(SP) := Stack(SP - 1);
292
293 -- Drop
294 when '_' =>
295 Want(1);
296 Drop;
297
298 -- Swap
299 when ''' =>
300 Want(2);
301 FFA_FZ_Swap(Stack(SP), Stack(SP - 1));
302
303 -- Over
304 when '`' =>
305 Want(2);
306 Push;
307 Stack(SP) := Stack(SP - 2);
308
309 ----------------
310 -- Predicates --
311 ----------------
312
313 -- Equality
314 when '=' =>
315 Want(2);
316 FFA_WBool_To_FZ(FFA_FZ_EqP(X => Stack(SP),
317 Y => Stack(SP - 1)),
318 Stack(SP - 1));
319 Drop;
320
321 -- Less-Than
322 when '<' =>
323 Want(2);
324 FFA_WBool_To_FZ(FFA_FZ_LessThanP(X => Stack(SP - 1),
325 Y => Stack(SP)),
326 Stack(SP - 1));
327 Drop;
328
329 -- Greater-Than
330 when '>' =>
331 Want(2);
332 FFA_WBool_To_FZ(FFA_FZ_GreaterThanP(X => Stack(SP - 1),
333 Y => Stack(SP)),
334 Stack(SP - 1));
335 Drop;
336
337 ----------------
338 -- Arithmetic --
339 ----------------
340
341 -- Subtract
342 when '-' =>
343 Want(2);
344 FFA_FZ_Subtract(X => Stack(SP - 1),
345 Y => Stack(SP),
346 Difference => Stack(SP - 1),
347 Underflow => F);
348 Flag := FFA_Word_NZeroP(F);
349 Drop;
350
351 -- Add
352 when '+' =>
353 Want(2);
354 FFA_FZ_Add(X => Stack(SP - 1),
355 Y => Stack(SP),
356 Sum => Stack(SP - 1),
357 Overflow => F);
358 Flag := FFA_Word_NZeroP(F);
359 Drop;
360
361 -- Divide and give Quotient and Remainder
362 when '\' =>
363 Want(2);
364 MustNotZero(Stack(SP));
365 FFA_FZ_IDiv(Dividend => Stack(SP - 1),
366 Divisor => Stack(SP),
367 Quotient => Stack(SP - 1),
368 Remainder => Stack(SP));
369
370 -- Divide and give Quotient only
371 when '/' =>
372 Want(2);
373 MustNotZero(Stack(SP));
374 FFA_FZ_Div(Dividend => Stack(SP - 1),
375 Divisor => Stack(SP),
376 Quotient => Stack(SP - 1));
377 Drop;
378
379 -- Divide and give Remainder only
380 when '%' =>
381 Want(2);
382 MustNotZero(Stack(SP));
383 FFA_FZ_Mod(Dividend => Stack(SP - 1),
384 Divisor => Stack(SP),
385 Remainder => Stack(SP - 1));
386 Drop;
387
388 -- Multiply, give bottom and top halves
389 when '*' =>
390 Want(2);
391 FFA_FZ_Multiply(X => Stack(SP - 1),
392 Y => Stack(SP),
393 XY_Lo => Stack(SP - 1),
394 XY_Hi => Stack(SP));
395
396 -- Square, give bottom and top halves
397 when 'S' =>
398 Want(1);
399 Push;
400 FFA_FZ_Square(X => Stack(SP - 1),
401 XX_Lo => Stack(SP - 1),
402 XX_Hi => Stack(SP));
403
404 -- Greatest Common Divisor (GCD)
405 when 'G' =>
406 Want(2);
407
408 -- Note that GCD(0,0) is not factually zero, or unique.
409 -- But it is permissible to define it as zero.
410 -- (See Ch. 15 discussion.)
411
412 FFA_FZ_Greatest_Common_Divisor(X => Stack(SP - 1),
413 Y => Stack(SP),
414 Result => Stack(SP - 1));
415 Drop;
416
417 -----------------
418 -- Bitwise Ops --
419 -----------------
420
421 -- Bitwise-And
422 when '&' =>
423 Want(2);
424 FFA_FZ_And(X => Stack(SP - 1),
425 Y => Stack(SP),
426 Result => Stack(SP - 1));
427 Drop;
428
429 -- Bitwise-Or
430 when '|' =>
431 Want(2);
432 FFA_FZ_Or(X => Stack(SP - 1),
433 Y => Stack(SP),
434 Result => Stack(SP - 1));
435 Drop;
436
437 -- Bitwise-Xor
438 when '^' =>
439 Want(2);
440 FFA_FZ_Xor(X => Stack(SP - 1),
441 Y => Stack(SP),
442 Result => Stack(SP - 1));
443 Drop;
444
445 -- Bitwise-Not (1s-Complement)
446 when '~' =>
447 Want(1);
448 FFA_FZ_Not(Stack(SP), Stack(SP));
449
450 -----------
451 -- Other --
452 -----------
453
454 -- Push a FZ of RNGolade onto the stack
455 when '?' =>
456 Push;
457 FFA_FZ_Clear(Stack(SP));
458 FZ_Random(RNG, Stack(SP));
459
460 -- mUx
461 when 'U' =>
462 Want(3);
463 FFA_FZ_Mux(X => Stack(SP - 2),
464 Y => Stack(SP - 1),
465 Result => Stack(SP - 2),
466 Sel => FFA_FZ_NZeroP(Stack(SP)));
467 Drop;
468 Drop;
469
470 -- Find the position of eldest nonzero bit, if any exist
471 when 'W' =>
472 Want(1);
473 declare
474 -- Find the measure ( 0 if no 1s, or 1 .. FZBitness )
475 Measure : FZBit_Index := FFA_FZ_Measure(Stack(SP));
476 begin
477 -- Put on top of stack
478 FFA_FZ_Clear(Stack(SP));
479 FFA_FZ_Set_Head(Stack(SP), Word(Measure));
480 end;
481
482 -- Put the Overflow flag on the stack
483 when 'O' =>
484 Push;
485 FFA_WBool_To_FZ(Flag, Stack(SP));
486
487 -- Print the FZ on the top of the stack
488 when '#' =>
489 Want(1);
490 Print_FZ(Stack(SP));
491 Drop;
492
493 -- Zap (reset)
494 when 'Z' =>
495 Zap;
496
497 -- Quit with Stack Trace
498 when 'Q' =>
499 for I in reverse Stack'First + 1 .. SP loop
500 Print_FZ(Stack(I));
501 end loop;
502 Quit(0);
503
504 -- Put the FFACalc Program Version on the stack,
505 -- followed by FFA Program Version.
506 when 'V' =>
507 Push;
508 Push;
509 -- FFACalc Version:
510 FFA_FZ_Clear(Stack(SP - 1));
511 FFA_FZ_Set_Head(Stack(SP - 1), Word(FFACalc_K_Version));
512 -- FFA Version:
513 FFA_FZ_Clear(Stack(SP));
514 FFA_FZ_Set_Head(Stack(SP), Word(FFA_K_Version));
515
516 --------------
517 -- Prefixes --
518 --------------
519
520 -- 'Left...' :
521 when 'L' =>
522 IsPrefix;
523
524 -- 'Right...' :
525 when 'R' =>
526 IsPrefix;
527
528 -- 'Modular...' :
529 when 'M' =>
530 IsPrefix;
531
532 ---------------------------------------------------------
533 -- Reserved Ops, i.e. ones we have not defined yet: --
534 ---------------------------------------------------------
535 when '!' | '@' | '$' | ':' | ';' | ',' |
536 'H' | 'I' | 'J' | 'K' | 'N' |
537 'P' | 'T' | 'X' | 'Y' =>
538
539 E("This Operator is not defined yet: " & C);
540 ---------------------------------------------------------
541
542 ----------
543 -- NOPs --
544 ----------
545
546 -- Unprintables and spaces DO NOTHING:
547 when others =>
548 null;
549
550 end case;
551
552 end Op_Normal;
553
554
555 -- Execute a Prefixed Op
556 procedure Op_Prefixed(Prefix : in Character;
557 O : in Character) is
558 begin
559
560 -- The Prefixed Op:
561 case Prefix is
562
563 ---------------------------------------------------------
564 -- Left...
565 when 'L' =>
566
567 -- Which L-op?
568 case O is
569
570 -- ... Shift :
571 when 'S' =>
572 Want(2);
573 declare
574 -- Number of bit positions to shift by:
575 ShiftCount : FZBit_Index
576 := FZBit_Index(FFA_FZ_Get_Head(Stack(SP)));
577 begin
578 FFA_FZ_Quiet_ShiftLeft(N => Stack(SP - 1),
579 ShiftedN => Stack(SP - 1),
580 Count => ShiftCount);
581 end;
582 Drop;
583
584 -- ... Rotate :
585 when 'R' =>
586 E("Left-Rotate not yet defined!");
587
588 -- ... Unknown:
589 when others =>
590 E("Undefined Op: L" & O);
591
592 end case;
593 ---------------------------------------------------------
594 -- Right...
595 when 'R' =>
596
597 -- Which R-op?
598 case O is
599
600 -- ... Shift:
601 when 'S' =>
602 Want(2);
603 declare
604 -- Number of bit positions to shift by:
605 ShiftCount : FZBit_Index
606 := FZBit_Index(FFA_FZ_Get_Head(Stack(SP)));
607 begin
608 FFA_FZ_Quiet_ShiftRight(N => Stack(SP - 1),
609 ShiftedN => Stack(SP - 1),
610 Count => ShiftCount);
611 end;
612 Drop;
613
614 -- ... Rotate:
615 when 'R' =>
616 E("Right-Rotate not yet defined!");
617
618 -- 'Right-Multiply', give only lower half of the product XY
619 when '*' =>
620 Want(2);
621 FFA_FZ_Low_Multiply(X => Stack(SP - 1),
622 Y => Stack(SP),
623 XY => Stack(SP - 1));
624 Drop;
625
626 -- ... Unknown:
627 when others =>
628 E("Undefined Op: R" & O);
629
630 end case;
631 ---------------------------------------------------------
632 -- Modular...
633 when 'M' =>
634
635 -- Which M-op?
636 case O is
637
638 -- ... Multiplication (Conventional) :
639 when '*' =>
640 Want(3);
641 MustNotZero(Stack(SP));
642 FFA_FZ_Modular_Multiply(X => Stack(SP - 2),
643 Y => Stack(SP - 1),
644 Modulus => Stack(SP),
645 Product => Stack(SP - 2));
646 Drop;
647 Drop;
648
649 -- ... Squaring (Conventional) :
650 when 'S' =>
651 Want(2);
652 MustNotZero(Stack(SP));
653 FFA_FZ_Modular_Square(X => Stack(SP - 1),
654 Modulus => Stack(SP),
655 Product => Stack(SP - 1));
656 Drop;
657
658 -- ... Exponentiation (Barrettronic) :
659 when 'X' =>
660 Want(3);
661 MustNotZero(Stack(SP));
662 FFA_FZ_Modular_Exponentiate(Base => Stack(SP - 2),
663 Exponent => Stack(SP - 1),
664 Modulus => Stack(SP),
665 Result => Stack(SP - 2));
666 Drop;
667 Drop;
668
669 -- ... Unknown:
670 when others =>
671 E("Undefined Op: M" & O);
672
673 end case;
674 ---------------------------------------------------------
675 -- ... Unknown: (impossible per mechanics, but must handle case)
676 when others =>
677 E("Undefined Prefix: " & Prefix);
678
679 end case;
680
681 end Op_Prefixed;
682
683
684 -- Process a Symbol
685 procedure Op(C : in Character) is
686 begin
687 -- First, see whether we are in a state of nestedness:
688
689 -- ... in a Comment block:
690 if CommLevel > 0 then
691 case C is
692 when ')' => -- Drop a nesting level:
693 CommLevel := CommLevel - 1;
694 when '(' => -- Add a nesting level:
695 CommLevel := CommLevel + 1;
696 when others =>
697 null; -- Other symbols have no effect at all
698 end case;
699
700 -- ... in a Quote block:
701 elsif QuoteLevel > 0 then
702 case C is
703 when ']' => -- Drop a nesting level:
704 QuoteLevel := QuoteLevel - 1;
705 when '[' => -- Add a nesting level:
706 QuoteLevel := QuoteLevel + 1;
707 when others =>
708 null; -- Other symbols have no effect on the level
709 end case;
710
711 -- If we aren't the mode-exiting ']', print current symbol:
712 if QuoteLevel > 0 then
713 Write_Char(C);
714 end if;
715
716 --- ... in a ~taken~ Conditional branch:
717 elsif CondLevel > 0 then
718 case C is
719 when '}' => -- Drop a nesting level:
720 CondLevel := CondLevel - 1;
721
722 -- If we exited the Conditional as a result,
723 -- we push a 1 to trigger the possible 'else' clause:
724 if CondLevel = 0 then
725 Push;
726 FFA_WBool_To_FZ(1, Stack(SP));
727 end if;
728
729 when '{' => -- Add a nesting level:
730 CondLevel := CondLevel + 1;
731 when others =>
732 null; -- Other symbols have no effect on the level
733 end case;
734
735 --- ... if in a prefixed op:
736 elsif HavePrefix then
737
738 -- Drop the prefix-op hammer, until another prefix-op cocks it
739 HavePrefix := False;
740
741 -- Dispatch this op, where prefix is the preceding character
742 Op_Prefixed(Prefix => PrevC, O => C);
743
744 else
745 -- This is a Normal Op, so proceed with the normal rules.
746 Op_Normal(C);
747 end if;
748
749 end Op;
750
751
752 -- Current Character
753 C : Character;
754
755 begin
756 -- Reset the Calculator
757 Zap;
758 -- Process characters until EOF:
759 loop
760 if Read_Char(C) then
761 -- Execute Op:
762 Op(C);
763 -- Advance Odometer
764 Pos := Pos + 1;
765 -- Save the op for use in prefixed ops
766 PrevC := C;
767 else
768 Zap;
769 Quit(0); -- if EOF, we're done
770 end if;
771 end loop;
772 end;
773
774 end FFA_Calc;