File : ffa_calc.adb
1 ------------------------------------------------------------------------------
2 ------------------------------------------------------------------------------
3 -- This file is part of 'Finite Field Arithmetic', aka 'FFA'. --
4 -- --
5 -- (C) 2018 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 -----------------
397 -- Bitwise Ops --
398 -----------------
399
400 -- Bitwise-And
401 when '&' =>
402 Want(2);
403 FFA_FZ_And(X => Stack(SP - 1),
404 Y => Stack(SP),
405 Result => Stack(SP - 1));
406 Drop;
407
408 -- Bitwise-Or
409 when '|' =>
410 Want(2);
411 FFA_FZ_Or(X => Stack(SP - 1),
412 Y => Stack(SP),
413 Result => Stack(SP - 1));
414 Drop;
415
416 -- Bitwise-Xor
417 when '^' =>
418 Want(2);
419 FFA_FZ_Xor(X => Stack(SP - 1),
420 Y => Stack(SP),
421 Result => Stack(SP - 1));
422 Drop;
423
424 -- Bitwise-Not (1s-Complement)
425 when '~' =>
426 Want(1);
427 FFA_FZ_Not(Stack(SP), Stack(SP));
428
429 -----------
430 -- Other --
431 -----------
432
433 -- Push a FZ of RNGolade onto the stack
434 when '?' =>
435 Push;
436 FFA_FZ_Clear(Stack(SP));
437 FZ_Random(RNG, Stack(SP));
438
439 -- mUx
440 when 'U' =>
441 Want(3);
442 FFA_FZ_Mux(X => Stack(SP - 2),
443 Y => Stack(SP - 1),
444 Result => Stack(SP - 2),
445 Sel => FFA_FZ_NZeroP(Stack(SP)));
446 Drop;
447 Drop;
448
449 -- Find the position of eldest nonzero bit, if any exist
450 when 'W' =>
451 Want(1);
452 declare
453 -- Find the measure ( 0 if no 1s, or 1 .. FZBitness )
454 Measure : FZBit_Index := FFA_FZ_Measure(Stack(SP));
455 begin
456 -- Put on top of stack
457 FFA_FZ_Clear(Stack(SP));
458 FFA_FZ_Set_Head(Stack(SP), Word(Measure));
459 end;
460
461 -- Put the Overflow flag on the stack
462 when 'O' =>
463 Push;
464 FFA_WBool_To_FZ(Flag, Stack(SP));
465
466 -- Print the FZ on the top of the stack
467 when '#' =>
468 Want(1);
469 Print_FZ(Stack(SP));
470 Drop;
471
472 -- Zap (reset)
473 when 'Z' =>
474 Zap;
475
476 -- Quit with Stack Trace
477 when 'Q' =>
478 for I in reverse Stack'First + 1 .. SP loop
479 Print_FZ(Stack(I));
480 end loop;
481 Quit(0);
482
483 -- Put the FFACalc Program Version on the stack,
484 -- followed by FFA Program Version.
485 when 'V' =>
486 Push;
487 Push;
488 -- FFACalc Version:
489 FFA_FZ_Clear(Stack(SP - 1));
490 FFA_FZ_Set_Head(Stack(SP - 1), Word(FFACalc_K_Version));
491 -- FFA Version:
492 FFA_FZ_Clear(Stack(SP));
493 FFA_FZ_Set_Head(Stack(SP), Word(FFA_K_Version));
494
495 -- Square, give bottom and top halves
496 when 'S' =>
497 Want(1);
498 Push;
499 FFA_FZ_Square(X => Stack(SP - 1),
500 XX_Lo => Stack(SP - 1),
501 XX_Hi => Stack(SP));
502
503 --------------
504 -- Prefixes --
505 --------------
506
507 -- 'Left...' :
508 when 'L' =>
509 IsPrefix;
510
511 -- 'Right...' :
512 when 'R' =>
513 IsPrefix;
514
515 -- 'Modular...' :
516 when 'M' =>
517 IsPrefix;
518
519 ---------------------------------------------------------
520 -- Reserved Ops, i.e. ones we have not defined yet: --
521 ---------------------------------------------------------
522 when '!' | '@' | '$' | ':' | ';' | ',' |
523 'G' | 'H' | 'I' | 'J' | 'K' | 'N' |
524 'P' | 'T' | 'X' | 'Y' =>
525
526 E("This Operator is not defined yet: " & C);
527 ---------------------------------------------------------
528
529 ----------
530 -- NOPs --
531 ----------
532
533 -- Unprintables and spaces DO NOTHING:
534 when others =>
535 null;
536
537 end case;
538
539 end Op_Normal;
540
541
542 -- Execute a Prefixed Op
543 procedure Op_Prefixed(Prefix : in Character;
544 O : in Character) is
545 begin
546
547 -- The Prefixed Op:
548 case Prefix is
549
550 ---------------------------------------------------------
551 -- Left...
552 when 'L' =>
553
554 -- Which L-op?
555 case O is
556
557 -- ... Shift :
558 when 'S' =>
559 Want(2);
560 declare
561 -- Number of bit positions to shift by:
562 ShiftCount : FZBit_Index
563 := FZBit_Index(FFA_FZ_Get_Head(Stack(SP)));
564 begin
565 FFA_FZ_Quiet_ShiftLeft(N => Stack(SP - 1),
566 ShiftedN => Stack(SP - 1),
567 Count => ShiftCount);
568 end;
569 Drop;
570
571 -- ... Rotate :
572 when 'R' =>
573 E("Left-Rotate not yet defined!");
574
575 -- ... Unknown:
576 when others =>
577 E("Undefined Op: L" & O);
578
579 end case;
580 ---------------------------------------------------------
581 -- Right...
582 when 'R' =>
583
584 -- Which R-op?
585 case O is
586
587 -- ... Shift:
588 when 'S' =>
589 Want(2);
590 declare
591 -- Number of bit positions to shift by:
592 ShiftCount : FZBit_Index
593 := FZBit_Index(FFA_FZ_Get_Head(Stack(SP)));
594 begin
595 FFA_FZ_Quiet_ShiftRight(N => Stack(SP - 1),
596 ShiftedN => Stack(SP - 1),
597 Count => ShiftCount);
598 end;
599 Drop;
600
601 -- ... Rotate:
602 when 'R' =>
603 E("Right-Rotate not yet defined!");
604
605 -- ... Unknown:
606 when others =>
607 E("Undefined Op: R" & O);
608
609 end case;
610 ---------------------------------------------------------
611 -- Modular...
612 when 'M' =>
613
614 -- Which M-op?
615 case O is
616
617 -- ... Multiplication :
618 when '*' =>
619 Want(3);
620 MustNotZero(Stack(SP));
621 FFA_FZ_Modular_Multiply(X => Stack(SP - 2),
622 Y => Stack(SP - 1),
623 Modulus => Stack(SP),
624 Product => Stack(SP - 2));
625 Drop;
626 Drop;
627
628 -- ... Exponentiation :
629 when 'X' =>
630 Want(3);
631 MustNotZero(Stack(SP));
632 FFA_FZ_Modular_Exponentiate(Base => Stack(SP - 2),
633 Exponent => Stack(SP - 1),
634 Modulus => Stack(SP),
635 Result => Stack(SP - 2));
636 Drop;
637 Drop;
638
639 -- ... Unknown:
640 when others =>
641 E("Undefined Op: M" & O);
642
643 end case;
644 ---------------------------------------------------------
645 -- ... Unknown: (impossible per mechanics, but must handle case)
646 when others =>
647 E("Undefined Prefix: " & Prefix);
648
649 end case;
650
651 end Op_Prefixed;
652
653
654 -- Process a Symbol
655 procedure Op(C : in Character) is
656 begin
657 -- First, see whether we are in a state of nestedness:
658
659 -- ... in a Comment block:
660 if CommLevel > 0 then
661 case C is
662 when ')' => -- Drop a nesting level:
663 CommLevel := CommLevel - 1;
664 when '(' => -- Add a nesting level:
665 CommLevel := CommLevel + 1;
666 when others =>
667 null; -- Other symbols have no effect at all
668 end case;
669
670 -- ... in a Quote block:
671 elsif QuoteLevel > 0 then
672 case C is
673 when ']' => -- Drop a nesting level:
674 QuoteLevel := QuoteLevel - 1;
675 when '[' => -- Add a nesting level:
676 QuoteLevel := QuoteLevel + 1;
677 when others =>
678 null; -- Other symbols have no effect on the level
679 end case;
680
681 -- If we aren't the mode-exiting ']', print current symbol:
682 if QuoteLevel > 0 then
683 Write_Char(C);
684 end if;
685
686 --- ... in a ~taken~ Conditional branch:
687 elsif CondLevel > 0 then
688 case C is
689 when '}' => -- Drop a nesting level:
690 CondLevel := CondLevel - 1;
691
692 -- If we exited the Conditional as a result,
693 -- we push a 1 to trigger the possible 'else' clause:
694 if CondLevel = 0 then
695 Push;
696 FFA_WBool_To_FZ(1, Stack(SP));
697 end if;
698
699 when '{' => -- Add a nesting level:
700 CondLevel := CondLevel + 1;
701 when others =>
702 null; -- Other symbols have no effect on the level
703 end case;
704
705 --- ... if in a prefixed op:
706 elsif HavePrefix then
707
708 -- Drop the prefix-op hammer, until another prefix-op cocks it
709 HavePrefix := False;
710
711 -- Dispatch this op, where prefix is the preceding character
712 Op_Prefixed(Prefix => PrevC, O => C);
713
714 else
715 -- This is a Normal Op, so proceed with the normal rules.
716 Op_Normal(C);
717 end if;
718
719 end Op;
720
721
722 -- Current Character
723 C : Character;
724
725 begin
726 -- Reset the Calculator
727 Zap;
728 -- Process characters until EOF:
729 loop
730 if Read_Char(C) then
731 -- Execute Op:
732 Op(C);
733 -- Advance Odometer
734 Pos := Pos + 1;
735 -- Save the op for use in prefixed ops
736 PrevC := C;
737 else
738 Zap;
739 Quit(0); -- if EOF, we're done
740 end if;
741 end loop;
742 end;
743
744 end FFA_Calc;