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
113
114 -- Clear the stack and set SP to bottom.
115 procedure Zap is
116 begin
117 -- Clear the stack
118 for i in Stack'Range loop
119 FFA_FZ_Clear(Stack(i));
120 end loop;
121 -- Set SP to bottom
122 SP := Stack_Positions'First;
123 -- Clear Overflow flag
124 Flag := 0;
125 end Zap;
126
127
128 -- Report a fatal error condition at the current symbol
129 procedure E(S : in String) is
130 begin
131 Eggog("Pos:" & Natural'Image(Pos) & ": " & S);
132 end E;
133
134
135 -- Move SP up
136 procedure Push is
137 begin
138 if SP = Stack_Positions'Last then
139 E("Stack Overflow!");
140 else
141 SP := SP + 1;
142 end if;
143 end Push;
144
145
146 -- Discard the top of the stack
147 procedure Drop is
148 begin
149 FFA_FZ_Clear(Stack(SP));
150 SP := SP - 1;
151 end Drop;
152
153
154 -- Check if stack has the necessary N items
155 procedure Want(N : in Positive) is
156 begin
157 if SP < N then
158 E("Stack Underflow!");
159 end if;
160 end Want;
161
162
163 -- Ensure that a divisor is not zero
164 procedure MustNotZero(D : in FZ) is
165 begin
166 if FFA_FZ_ZeroP(D) = 1 then
167 E("Division by Zero!");
168 end if;
169 end MustNotZero;
170
171
172 -- Slide a new hex digit into the FZ on top of stack
173 procedure Ins_Hex_Digit(Digit : in Nibble) is
174 Overflow : WBool := 0;
175 begin
176
177 -- Insert the given nibble, and detect any overflow:
178 FFA_FZ_Insert_Bottom_Nibble(N => Stack(SP),
179 D => Digit,
180 Overflow => Overflow);
181
182 -- Constants which exceed the Width are forbidden:
183 if Overflow = 1 then
184 E("Constant Exceeds Bitness!");
185 end if;
186
187 end;
188
189
190 -- Emit an ASCII representation of N to the terminal
191 procedure Print_FZ(N : in FZ) is
192 S : String(1 .. FFA_FZ_ASCII_Length(N)); -- Mandatorily, exact size
193 begin
194 FFA_FZ_To_Hex_String(N, S); -- Convert N to ASCII hex
195 Write_String(S); -- Print the result to stdout
196 Write_Newline; -- Print newline, for clarity.
197 end Print_FZ;
198
199
200 -- Execute a Normal Op
201 procedure Op_Normal(C : in Character) is
202
203 -- Over/underflow output from certain ops
204 F : Word;
205
206 begin
207
208 case C is
209
210 --------------
211 -- Stickies --
212 --------------
213 -- Enter Commented
214 when '(' =>
215 CommLevel := 1;
216
217 -- Exit Commented (but we aren't in it!)
218 when ')' =>
219 E("Mismatched close-comment parenthesis !");
220
221 -- Enter Quoted
222 when '[' =>
223 QuoteLevel := 1;
224
225 -- Exit Quoted (but we aren't in it!)
226 when ']' =>
227 E("Mismatched close-quote bracket !");
228
229 -- Enter a ~taken~ Conditional branch:
230 when '{' =>
231 Want(1);
232 if FFA_FZ_ZeroP(Stack(SP)) = 1 then
233 CondLevel := 1;
234 end if;
235 Drop;
236
237 -- Exit from a ~non-taken~ Conditional branch:
238 -- ... we push a 0, to suppress the 'else' clause
239 when '}' =>
240 Push;
241 FFA_WBool_To_FZ(0, Stack(SP));
242
243 ----------------
244 -- Immediates --
245 ----------------
246
247 -- These operate on the FZ ~currently~ at top of the stack;
248 -- and this means that the stack may NOT be empty.
249
250 when '0' .. '9' =>
251 Want(1);
252 Ins_Hex_Digit(Character'Pos(C) - Character'Pos('0'));
253
254 when 'A' .. 'F' =>
255 Want(1);
256 Ins_Hex_Digit(10 + Character'Pos(C) - Character'Pos('A'));
257
258 when 'a' .. 'f' =>
259 Want(1);
260 Ins_Hex_Digit(10 + Character'Pos(C) - Character'Pos('a'));
261
262 ------------------
263 -- Stack Motion --
264 ------------------
265
266 -- Push a 0 onto the stack
267 when '.' =>
268 Push;
269 FFA_FZ_Clear(Stack(SP));
270
271 -- Dup
272 when '"' =>
273 Want(1);
274 Push;
275 Stack(SP) := Stack(SP - 1);
276
277 -- Drop
278 when '_' =>
279 Want(1);
280 Drop;
281
282 -- Swap
283 when ''' =>
284 Want(2);
285 FFA_FZ_Swap(Stack(SP), Stack(SP - 1));
286
287 -- Over
288 when '`' =>
289 Want(2);
290 Push;
291 Stack(SP) := Stack(SP - 2);
292
293 ----------------
294 -- Predicates --
295 ----------------
296
297 -- Equality
298 when '=' =>
299 Want(2);
300 FFA_WBool_To_FZ(FFA_FZ_EqP(X => Stack(SP),
301 Y => Stack(SP - 1)),
302 Stack(SP - 1));
303 Drop;
304
305 -- Less-Than
306 when '<' =>
307 Want(2);
308 FFA_WBool_To_FZ(FFA_FZ_LessThanP(X => Stack(SP - 1),
309 Y => Stack(SP)),
310 Stack(SP - 1));
311 Drop;
312
313 -- Greater-Than
314 when '>' =>
315 Want(2);
316 FFA_WBool_To_FZ(FFA_FZ_GreaterThanP(X => Stack(SP - 1),
317 Y => Stack(SP)),
318 Stack(SP - 1));
319 Drop;
320
321 ----------------
322 -- Arithmetic --
323 ----------------
324
325 -- Subtract
326 when '-' =>
327 Want(2);
328 FFA_FZ_Subtract(X => Stack(SP - 1),
329 Y => Stack(SP),
330 Difference => Stack(SP - 1),
331 Underflow => F);
332 Flag := FFA_Word_NZeroP(F);
333 Drop;
334
335 -- Add
336 when '+' =>
337 Want(2);
338 FFA_FZ_Add(X => Stack(SP - 1),
339 Y => Stack(SP),
340 Sum => Stack(SP - 1),
341 Overflow => F);
342 Flag := FFA_Word_NZeroP(F);
343 Drop;
344
345 -- Divide and give Quotient and Remainder
346 when '\' =>
347 Want(2);
348 MustNotZero(Stack(SP));
349 FFA_FZ_IDiv(Dividend => Stack(SP - 1),
350 Divisor => Stack(SP),
351 Quotient => Stack(SP - 1),
352 Remainder => Stack(SP));
353
354 -- Divide and give Quotient only
355 when '/' =>
356 Want(2);
357 MustNotZero(Stack(SP));
358 FFA_FZ_Div(Dividend => Stack(SP - 1),
359 Divisor => Stack(SP),
360 Quotient => Stack(SP - 1));
361 Drop;
362
363 -- Divide and give Remainder only
364 when '%' =>
365 Want(2);
366 MustNotZero(Stack(SP));
367 FFA_FZ_Mod(Dividend => Stack(SP - 1),
368 Divisor => Stack(SP),
369 Remainder => Stack(SP - 1));
370 Drop;
371
372 -- Multiply, give bottom and top halves
373 when '*' =>
374 Want(2);
375 FFA_FZ_Multiply(X => Stack(SP - 1),
376 Y => Stack(SP),
377 XY_Lo => Stack(SP - 1),
378 XY_Hi => Stack(SP));
379
380 -- Modular Multiplication
381 when 'M' =>
382 Want(3);
383 MustNotZero(Stack(SP));
384 FFA_FZ_Modular_Multiply(X => Stack(SP - 2),
385 Y => Stack(SP - 1),
386 Modulus => Stack(SP),
387 Product => Stack(SP - 2));
388 Drop;
389 Drop;
390
391 -- Modular Exponentiation
392 when 'X' =>
393 Want(3);
394 MustNotZero(Stack(SP));
395 FFA_FZ_Modular_Exponentiate(Base => Stack(SP - 2),
396 Exponent => Stack(SP - 1),
397 Modulus => Stack(SP),
398 Result => Stack(SP - 2));
399 Drop;
400 Drop;
401
402 -----------------
403 -- Bitwise Ops --
404 -----------------
405
406 -- Bitwise-And
407 when '&' =>
408 Want(2);
409 FFA_FZ_And(X => Stack(SP - 1),
410 Y => Stack(SP),
411 Result => Stack(SP - 1));
412 Drop;
413
414 -- Bitwise-Or
415 when '|' =>
416 Want(2);
417 FFA_FZ_Or(X => Stack(SP - 1),
418 Y => Stack(SP),
419 Result => Stack(SP - 1));
420 Drop;
421
422 -- Bitwise-Xor
423 when '^' =>
424 Want(2);
425 FFA_FZ_Xor(X => Stack(SP - 1),
426 Y => Stack(SP),
427 Result => Stack(SP - 1));
428 Drop;
429
430 -- Bitwise-Not (1s-Complement)
431 when '~' =>
432 Want(1);
433 FFA_FZ_Not(Stack(SP), Stack(SP));
434
435 -----------
436 -- Other --
437 -----------
438
439 -- Push a FZ of RNGolade onto the stack
440 when '?' =>
441 Push;
442 FFA_FZ_Clear(Stack(SP));
443 FZ_Random(RNG, Stack(SP));
444
445 -- mUx
446 when 'U' =>
447 Want(3);
448 FFA_FZ_Mux(X => Stack(SP - 2),
449 Y => Stack(SP - 1),
450 Result => Stack(SP - 2),
451 Sel => FFA_FZ_NZeroP(Stack(SP)));
452 Drop;
453 Drop;
454
455 -- Put the Overflow flag on the stack
456 when 'O' =>
457 Push;
458 FFA_WBool_To_FZ(Flag, Stack(SP));
459
460 -- Print the FZ on the top of the stack
461 when '#' =>
462 Want(1);
463 Print_FZ(Stack(SP));
464 Drop;
465
466 -- Zap (reset)
467 when 'Z' =>
468 Zap;
469
470 -- Quit with Stack Trace
471 when 'Q' =>
472 for I in reverse Stack'First + 1 .. SP loop
473 Print_FZ(Stack(I));
474 end loop;
475 Quit(0);
476
477 ---------------------------------------------------------
478 -- Ch. 12B:
479 -- Square, give bottom and top halves
480 when 'S' =>
481 Want(1);
482 Push;
483 FFA_FZ_Square(X => Stack(SP - 1),
484 XX_Lo => Stack(SP - 1),
485 XX_Hi => Stack(SP));
486 ---------------------------------------------------------
487
488 ----------
489 -- NOPs --
490 ----------
491
492 -- Ops we have not yet spoken of -- do nothing
493 when others =>
494 null;
495
496 end case;
497
498 end Op_Normal;
499
500
501 -- Process a Symbol
502 procedure Op(C : in Character) is
503 begin
504 -- First, see whether we are in a state of nestedness:
505
506 -- ... in a Comment block:
507 if CommLevel > 0 then
508 case C is
509 when ')' => -- Drop a nesting level:
510 CommLevel := CommLevel - 1;
511 when '(' => -- Add a nesting level:
512 CommLevel := CommLevel + 1;
513 when others =>
514 null; -- Other symbols have no effect at all
515 end case;
516
517 -- ... in a Quote block:
518 elsif QuoteLevel > 0 then
519 case C is
520 when ']' => -- Drop a nesting level:
521 QuoteLevel := QuoteLevel - 1;
522 when '[' => -- Add a nesting level:
523 QuoteLevel := QuoteLevel + 1;
524 when others =>
525 null; -- Other symbols have no effect on the level
526 end case;
527
528 -- If we aren't the mode-exiting ']', print current symbol:
529 if QuoteLevel > 0 then
530 Write_Char(C);
531 end if;
532
533 --- ... in a ~taken~ Conditional branch:
534 elsif CondLevel > 0 then
535 case C is
536 when '}' => -- Drop a nesting level:
537 CondLevel := CondLevel - 1;
538
539 -- If we exited the Conditional as a result,
540 -- we push a 1 to trigger the possible 'else' clause:
541 if CondLevel = 0 then
542 Push;
543 FFA_WBool_To_FZ(1, Stack(SP));
544 end if;
545
546 when '{' => -- Add a nesting level:
547 CondLevel := CondLevel + 1;
548 when others =>
549 null; -- Other symbols have no effect on the level
550 end case;
551 else
552 -- This is a Normal Op, so proceed with the normal rules.
553 Op_Normal(C);
554 end if;
555
556 end Op;
557
558
559 -- Current Character
560 C : Character;
561
562 begin
563 -- Reset the Calculator
564 Zap;
565 -- Process characters until EOF:
566 loop
567 if Read_Char(C) then
568 -- Execute Op:
569 Op(C);
570 -- Advance Odometer
571 Pos := Pos + 1;
572 else
573 Zap;
574 Quit(0); -- if EOF, we're done
575 end if;
576 end loop;
577 end;
578
579 end FFA_Calc;