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