-
+ 4775DCD387FD903F856A9EC5AD9A1A526C4DEE9C146B5393A958608E2ABDE97C75A92F32891804B3058C4316AA0399FCA0713F17C78319E836D76CC93BAADDF4ffa/ffacalc/ffa_calc.adb(0 . 0)(1 . 479)
163 ------------------------------------------------------------------------------
164 ------------------------------------------------------------------------------
165 -- This file is part of 'Finite Field Arithmetic', aka 'FFA'. --
166 -- --
167 -- (C) 2017 Stanislav Datskovskiy ( www.loper-os.org ) --
168 -- http://wot.deedbot.org/17215D118B7239507FAFED98B98228A001ABFFC7.html --
169 -- --
170 -- You do not have, nor can you ever acquire the right to use, copy or --
171 -- distribute this software ; Should you use this software for any purpose, --
172 -- or copy and distribute it to anyone or in any manner, you are breaking --
173 -- the laws of whatever soi-disant jurisdiction, and you promise to --
174 -- continue doing so for the indefinite future. In any case, please --
175 -- always : read and understand any software ; verify any PGP signatures --
176 -- that you use - for any purpose. --
177 -- --
178 -- See also http://trilema.com/2015/a-new-software-licensing-paradigm . --
179 ------------------------------------------------------------------------------
180 ------------------------------------------------------------------------------
181
182 -- Basics
183 with OS; use OS;
184 with CmdLine; use CmdLine;
185
186 -- FFA
187 with FZ_Lim; use FZ_Lim;
188 with Words; use Words;
189 with W_Pred; use W_Pred;
190 with FZ_Type; use FZ_Type;
191 with FZ_Basic; use FZ_Basic;
192 with FZ_Arith; use FZ_Arith;
193 with FZ_Cmp; use FZ_Cmp;
194 with FZ_Pred; use FZ_Pred;
195 with FZ_BitOp; use FZ_BitOp;
196 with FZ_Shift; use FZ_Shift;
197
198 -- For Output
199 with FFA_IO; use FFA_IO;
200
201
202 procedure FFA_Calc is
203
204 Width : Positive; -- Desired FFA Width
205 Height : Positive; -- Desired Height of Stack
206
207 begin
208 if Arg_Count /= 3 then
209 Eggog("Usage: ./ffa_calc WIDTH HEIGHT");
210 end if;
211
212 declare
213 Arg1 : CmdLineArg;
214 Arg2 : CmdLineArg;
215 begin
216 -- Get commandline args:
217 Get_Argument(1, Arg1); -- First arg
218 Get_Argument(2, Arg2); -- Second arg
219
220 -- Parse into Positives:
221 Width := Positive'Value(Arg1);
222 Height := Positive'Value(Arg2);
223 exception
224 when others =>
225 Eggog("Invalid arguments!");
226 end;
227
228 -- Test if proposed Width is permissible:
229 if not FZ_Valid_Bitness_P(Width) then
230 Eggog("Invalid Width: " & FZ_Validity_Rule_Doc);
231 end if;
232
233 -- The Calculator itself:
234 declare
235
236 -- The number of Words required to make a FZ of the given Bitness.
237 Wordness : Indices := Indices(Width / Bitness);
238
239 --------------------------------------------------------
240 -- State --
241 --------------------------------------------------------
242 -- The Stack:
243 subtype Stack_Positions is Natural range 0 .. Height;
244 type Stacks is array(Stack_Positions range <>) of FZ(1 .. Wordness);
245 Stack : Stacks(Stack_Positions'Range);
246
247 -- Stack Pointer:
248 SP : Stack_Positions := Stack_Positions'First;
249
250 -- Carry/Borrow Flag:
251 Flag : WBool := 0;
252
253 -- Odometer:
254 Pos : Natural := 0;
255
256 -- The current levels of the three types of nestedness:
257 QuoteLevel : Natural := 0;
258 CommLevel : Natural := 0;
259 CondLevel : Natural := 0;
260 --------------------------------------------------------
261
262
263 -- Clear the stack and set SP to bottom.
264 procedure Zap is
265 begin
266 -- Clear the stack
267 for i in Stack'Range loop
268 FZ_Clear(Stack(i));
269 end loop;
270 -- Set SP to bottom
271 SP := Stack_Positions'First;
272 -- Clear Overflow flag
273 Flag := 0;
274 end Zap;
275
276
277 -- Report a fatal error condition at the current symbol
278 procedure E(S : in String) is
279 begin
280 Eggog("Pos:" & Natural'Image(Pos) & ": " & S);
281 end E;
282
283
284 -- Move SP up
285 procedure Push is
286 begin
287 if SP = Stack_Positions'Last then
288 E("Stack Overflow!");
289 else
290 SP := SP + 1;
291 end if;
292 end Push;
293
294
295 -- Discard the top of the stack
296 procedure Drop is
297 begin
298 FZ_Clear(Stack(SP));
299 SP := SP - 1;
300 end Drop;
301
302
303 -- Check if stack has the necessary N items
304 procedure Want(N : in Positive) is
305 begin
306 if SP < N then
307 E("Stack Underflow!");
308 end if;
309 end Want;
310
311
312 -- Slide a new hex digit into the FZ on top of stack
313 procedure Ins_Hex_Digit(N : in out FZ;
314 D : in Nibble) is
315 Overflow : Word := 0;
316 begin
317 -- Make room in this FZ for one additional hex digit
318 FZ_ShiftLeft_O(N => N,
319 ShiftedN => N,
320 Count => 4,
321 Overflow => Overflow);
322
323 -- Constants which exceed the Width are forbidden:
324 if W_NZeroP(Overflow) = 1 then
325 E("Constant Exceeds Bitness!");
326 end if;
327
328 -- Set the new digit
329 FZ_Or_W(N, D);
330 end;
331
332
333 -- Execute a Normal Op
334 procedure Op_Normal(C : in Character) is
335
336 -- Over/underflow output from certain ops
337 F : Word;
338
339 begin
340
341 case C is
342
343 --------------
344 -- Stickies --
345 --------------
346 -- Enter Commented
347 when '(' =>
348 CommLevel := 1;
349
350 -- Exit Commented (but we aren't in it!)
351 when ')' =>
352 E("Mismatched close-comment parenthesis !");
353
354 -- Enter Quoted
355 when '[' =>
356 QuoteLevel := 1;
357
358 -- Exit Quoted (but we aren't in it!)
359 when ']' =>
360 E("Mismatched close-quote bracket !");
361
362 -- Enter a ~taken~ Conditional branch:
363 when '{' =>
364 Want(1);
365 if FZ_ZeroP(Stack(SP)) = 1 then
366 CondLevel := 1;
367 end if;
368 Drop;
369
370 -- Exit from a ~non-taken~ Conditional branch:
371 -- ... we push a 0, to suppress the 'else' clause
372 when '}' =>
373 Push;
374 WBool_To_FZ(0, Stack(SP));
375
376 ----------------
377 -- Immediates --
378 ----------------
379
380 -- These operate on the FZ ~currently~ at top of the stack;
381 -- and this means that the stack may NOT be empty.
382
383 when '0' .. '9' =>
384 Want(1);
385 Ins_Hex_Digit(Stack(SP),
386 Character'Pos(C) - Character'Pos('0'));
387
388 when 'A' .. 'F' =>
389 Want(1);
390 Ins_Hex_Digit(Stack(SP),
391 10 + Character'Pos(C) - Character'Pos('A'));
392
393 when 'a' .. 'f' =>
394 Want(1);
395 Ins_Hex_Digit(Stack(SP),
396 10 + Character'Pos(C) - Character'Pos('a'));
397
398 ------------------
399 -- Stack Motion --
400 ------------------
401
402 -- Push a 0 onto the stack
403 when '.' =>
404 Push;
405 FZ_Clear(Stack(SP));
406
407 -- Dup
408 when '"' =>
409 Want(1);
410 Push;
411 Stack(SP) := Stack(SP - 1);
412
413 -- Drop
414 when '_' =>
415 Want(1);
416 Drop;
417
418 -- Swap
419 when ''' =>
420 Want(2);
421 FZ_Swap(Stack(SP), Stack(SP - 1));
422
423 -- Over
424 when '`' =>
425 Want(2);
426 Push;
427 Stack(SP) := Stack(SP - 2);
428
429 ----------------
430 -- Predicates --
431 ----------------
432
433 -- Equality
434 when '=' =>
435 Want(2);
436 WBool_To_FZ(FZ_Eqp(X => Stack(SP),
437 Y => Stack(SP - 1)),
438 Stack(SP - 1));
439 Drop;
440
441 -- Less-Than
442 when '<' =>
443 Want(2);
444 WBool_To_FZ(FZ_LessThanP(X => Stack(SP - 1),
445 Y => Stack(SP)),
446 Stack(SP - 1));
447 Drop;
448
449 -- Greater-Than
450 when '>' =>
451 Want(2);
452 WBool_To_FZ(FZ_GreaterThanP(X => Stack(SP - 1),
453 Y => Stack(SP)),
454 Stack(SP - 1));
455 Drop;
456
457 ----------------
458 -- Arithmetic --
459 ----------------
460
461 -- Subtract
462 when '-' =>
463 Want(2);
464 FZ_Sub(X => Stack(SP - 1),
465 Y => Stack(SP),
466 Difference => Stack(SP - 1),
467 Underflow => F);
468 Flag := W_NZeroP(F);
469 Drop;
470
471 -- Add
472 when '+' =>
473 Want(2);
474 FZ_Add(X => Stack(SP - 1),
475 Y => Stack(SP),
476 Sum => Stack(SP - 1),
477 Overflow => F);
478 Flag := W_NZeroP(F);
479 Drop;
480
481 -----------------
482 -- Bitwise Ops --
483 -----------------
484
485 -- Bitwise-And
486 when '&' =>
487 Want(2);
488 FZ_And(X => Stack(SP - 1),
489 Y => Stack(SP),
490 Result => Stack(SP - 1));
491 Drop;
492
493 -- Bitwise-Or
494 when '|' =>
495 Want(2);
496 FZ_Or(X => Stack(SP - 1),
497 Y => Stack(SP),
498 Result => Stack(SP - 1));
499 Drop;
500
501 -- Bitwise-Xor
502 when '^' =>
503 Want(2);
504 FZ_Xor(X => Stack(SP - 1),
505 Y => Stack(SP),
506 Result => Stack(SP - 1));
507 Drop;
508
509 -- Bitwise-Not (1s-Complement)
510 when '~' =>
511 Want(1);
512 FZ_Not(Stack(SP), Stack(SP));
513
514 -----------
515 -- Other --
516 -----------
517
518 -- mUx
519 when 'U' =>
520 Want(3);
521 FZ_Mux(X => Stack(SP - 2),
522 Y => Stack(SP - 1),
523 Result => Stack(SP - 2),
524 Sel => FZ_NZeroP(Stack(SP)));
525 Drop;
526 Drop;
527
528 -- Put the Overflow flag on the stack
529 when 'O' =>
530 Push;
531 WBool_To_FZ(Flag, Stack(SP));
532
533 -- Print the FZ on the top of the stack
534 when '#' =>
535 Want(1);
536 Dump(Stack(SP));
537 Drop;
538
539 -- Zap (reset)
540 when 'Z' =>
541 Zap;
542
543 -- Quit with Stack Trace
544 when 'Q' =>
545 for I in reverse Stack'First + 1 .. SP loop
546 Dump(Stack(I));
547 end loop;
548 Quit(0);
549
550 ----------
551 -- NOPs --
552 ----------
553
554 -- Ops we have not yet spoken of -- do nothing
555 when others =>
556 null;
557
558 end case;
559
560 end Op_Normal;
561
562
563 -- Process a Symbol
564 procedure Op(C : in Character) is
565 begin
566 -- First, see whether we are in a state of nestedness:
567
568 -- ... in a Comment block:
569 if CommLevel > 0 then
570 case C is
571 when ')' => -- Drop a nesting level:
572 CommLevel := CommLevel - 1;
573 when '(' => -- Add a nesting level:
574 CommLevel := CommLevel + 1;
575 when others =>
576 null; -- Other symbols have no effect at all
577 end case;
578
579 -- ... in a Quote block:
580 elsif QuoteLevel > 0 then
581 case C is
582 when ']' => -- Drop a nesting level:
583 QuoteLevel := QuoteLevel - 1;
584 when '[' => -- Add a nesting level:
585 QuoteLevel := QuoteLevel + 1;
586 when others =>
587 null; -- Other symbols have no effect on the level
588 end case;
589
590 -- If we aren't the mode-exiting ']', print current symbol:
591 if QuoteLevel > 0 then
592 Write_Char(C);
593 end if;
594
595 --- ... in a ~taken~ Conditional branch:
596 elsif CondLevel > 0 then
597 case C is
598 when '}' => -- Drop a nesting level:
599 CondLevel := CondLevel - 1;
600
601 -- If we exited the Conditional as a result,
602 -- we push a 1 to trigger the possible 'else' clause:
603 if CondLevel = 0 then
604 Push;
605 WBool_To_FZ(1, Stack(SP));
606 end if;
607
608 when '{' => -- Add a nesting level:
609 CondLevel := CondLevel + 1;
610 when others =>
611 null; -- Other symbols have no effect on the level
612 end case;
613 else
614 -- This is a Normal Op, so proceed with the normal rules.
615 Op_Normal(C);
616 end if;
617
618 end Op;
619
620
621 -- Current Character
622 C : Character;
623
624 begin
625 -- Reset the Calculator
626 Zap;
627 -- Process characters until EOF:
628 loop
629 if Read_Char(C) then
630 -- Execute Op:
631 Op(C);
632 -- Advance Odometer
633 Pos := Pos + 1;
634 else
635 Zap;
636 Quit(0); -- if EOF, we're done
637 end if;
638 end loop;
639 end;
640
641 end FFA_Calc;