- CA1DED1102A88D8097CAFD58FCA38F21C1B8500B936868DD036FA2446F78FC467A2C90058504CB04AF542E5925A3270F34A0B96B38DEB584868F52D608D6B460+ 74DCE12DC3FA30B4FD9E60AE209C1DEBA564B19DD95B413F02FA9A0E45120242CD9682A079C92B7E5A2EB19941A7EEC6F0F3EC9C2B88058F88CF891828496D58ffa/ffacalc/ffa_calc.adb(22 . 22)(22 . 10)
71 with CmdLine; use CmdLine;
72
73 -- FFA
74 with FZ_Lim; use FZ_Lim;
75 with Words; use Words;
76 with W_Pred; use W_Pred;
77 with FZ_Type; use FZ_Type;
78 with FZ_Basic; use FZ_Basic;
79 with FZ_Arith; use FZ_Arith;
80 with FZ_Cmp; use FZ_Cmp;
81 with FZ_Pred; use FZ_Pred;
82 with FZ_BitOp; use FZ_BitOp;
83 with FZ_Shift; use FZ_Shift;
84 with FZ_Divis; use FZ_Divis;
85 with FZ_Mul; use FZ_Mul;
86 with FZ_ModEx; use FZ_ModEx;
87 with FFA; use FFA;
88
89 -- For Output
90 with FFA_IO; use FFA_IO;
91 -- For the intrinsic equality operator on Words
92 use type FFA.Word;
93
94 -- For RNG:
95 with FFA_RNG; use FFA_RNG;
(89 . 8)(77 . 8)
97 end;
98
99 -- Test if proposed Width is permissible:
100 if not FZ_Valid_Bitness_P(Width) then
101 Eggog("Invalid Width: " & FZ_Validity_Rule_Doc);
102 if not FFA_FZ_Valid_Bitness_P(Width) then
103 Eggog("Invalid Width: " & FFA_Validity_Rule_Doc);
104 end if;
105
106 -- The Calculator itself:
(128 . 7)(116 . 7)
108 begin
109 -- Clear the stack
110 for i in Stack'Range loop
111 FZ_Clear(Stack(i));
112 FFA_FZ_Clear(Stack(i));
113 end loop;
114 -- Set SP to bottom
115 SP := Stack_Positions'First;
(158 . 7)(146 . 7)
117 -- Discard the top of the stack
118 procedure Drop is
119 begin
120 FZ_Clear(Stack(SP));
121 FFA_FZ_Clear(Stack(SP));
122 SP := SP - 1;
123 end Drop;
124
(175 . 33)(163 . 40)
126 -- Ensure that a divisor is not zero
127 procedure MustNotZero(D : in FZ) is
128 begin
129 if FZ_ZeroP(D) = 1 then
130 if FFA_FZ_ZeroP(D) = 1 then
131 E("Division by Zero!");
132 end if;
133 end MustNotZero;
134
135
136 -- Slide a new hex digit into the FZ on top of stack
137 procedure Ins_Hex_Digit(N : in out FZ;
138 D : in Nibble) is
139 Overflow : Word := 0;
140 procedure Ins_Hex_Digit(Digit : in Nibble) is
141 Overflow : WBool := 0;
142 begin
143 -- Make room in this FZ for one additional hex digit
144 FZ_ShiftLeft_O(N => N,
145 ShiftedN => N,
146 Count => 4,
147 Overflow => Overflow);
148
149 -- Insert the given nibble, and detect any overflow:
150 FFA_FZ_Insert_Bottom_Nibble(N => Stack(SP),
151 D => Digit,
152 Overflow => Overflow);
153
154 -- Constants which exceed the Width are forbidden:
155 if W_NZeroP(Overflow) = 1 then
156 if Overflow = 1 then
157 E("Constant Exceeds Bitness!");
158 end if;
159
160 -- Set the new digit
161 FZ_Or_W(N, D);
162 end;
163
164
165 -- Emit an ASCII representation of N to the terminal
166 procedure Print_FZ(N : in FZ) is
167 S : String(1 .. FFA_FZ_ASCII_Length(N)); -- Mandatorily, exact size
168 begin
169 FFA_FZ_To_Hex_String(N, S); -- Convert N to ASCII hex
170 Write_String(S); -- Print the result to stdout
171 Write_Newline; -- Print newline, for clarity.
172 end Print_FZ;
173
174
175 -- Execute a Normal Op
176 procedure Op_Normal(C : in Character) is
177
(234 . 7)(229 . 7)
179 -- Enter a ~taken~ Conditional branch:
180 when '{' =>
181 Want(1);
182 if FZ_ZeroP(Stack(SP)) = 1 then
183 if FFA_FZ_ZeroP(Stack(SP)) = 1 then
184 CondLevel := 1;
185 end if;
186 Drop;
(243 . 7)(238 . 7)
188 -- ... we push a 0, to suppress the 'else' clause
189 when '}' =>
190 Push;
191 WBool_To_FZ(0, Stack(SP));
192 FFA_WBool_To_FZ(0, Stack(SP));
193
194 ----------------
195 -- Immediates --
(254 . 18)(249 . 15)
197
198 when '0' .. '9' =>
199 Want(1);
200 Ins_Hex_Digit(Stack(SP),
201 Character'Pos(C) - Character'Pos('0'));
202 Ins_Hex_Digit(Character'Pos(C) - Character'Pos('0'));
203
204 when 'A' .. 'F' =>
205 Want(1);
206 Ins_Hex_Digit(Stack(SP),
207 10 + Character'Pos(C) - Character'Pos('A'));
208 Ins_Hex_Digit(10 + Character'Pos(C) - Character'Pos('A'));
209
210 when 'a' .. 'f' =>
211 Want(1);
212 Ins_Hex_Digit(Stack(SP),
213 10 + Character'Pos(C) - Character'Pos('a'));
214 Ins_Hex_Digit(10 + Character'Pos(C) - Character'Pos('a'));
215
216 ------------------
217 -- Stack Motion --
(274 . 7)(266 . 7)
219 -- Push a 0 onto the stack
220 when '.' =>
221 Push;
222 FZ_Clear(Stack(SP));
223 FFA_FZ_Clear(Stack(SP));
224
225 -- Dup
226 when '"' =>
(290 . 7)(282 . 7)
228 -- Swap
229 when ''' =>
230 Want(2);
231 FZ_Swap(Stack(SP), Stack(SP - 1));
232 FFA_FZ_Swap(Stack(SP), Stack(SP - 1));
233
234 -- Over
235 when '`' =>
(305 . 25)(297 . 25)
237 -- Equality
238 when '=' =>
239 Want(2);
240 WBool_To_FZ(FZ_Eqp(X => Stack(SP),
241 Y => Stack(SP - 1)),
242 Stack(SP - 1));
243 FFA_WBool_To_FZ(FFA_FZ_EqP(X => Stack(SP),
244 Y => Stack(SP - 1)),
245 Stack(SP - 1));
246 Drop;
247
248 -- Less-Than
249 when '<' =>
250 Want(2);
251 WBool_To_FZ(FZ_LessThanP(X => Stack(SP - 1),
252 Y => Stack(SP)),
253 Stack(SP - 1));
254 FFA_WBool_To_FZ(FFA_FZ_LessThanP(X => Stack(SP - 1),
255 Y => Stack(SP)),
256 Stack(SP - 1));
257 Drop;
258
259 -- Greater-Than
260 when '>' =>
261 Want(2);
262 WBool_To_FZ(FZ_GreaterThanP(X => Stack(SP - 1),
263 Y => Stack(SP)),
264 Stack(SP - 1));
265 FFA_WBool_To_FZ(FFA_FZ_GreaterThanP(X => Stack(SP - 1),
266 Y => Stack(SP)),
267 Stack(SP - 1));
268 Drop;
269
270 ----------------
(333 . 66)(325 . 66)
272 -- Subtract
273 when '-' =>
274 Want(2);
275 FZ_Sub(X => Stack(SP - 1),
276 Y => Stack(SP),
277 Difference => Stack(SP - 1),
278 Underflow => F);
279 Flag := W_NZeroP(F);
280 FFA_FZ_Subtract(X => Stack(SP - 1),
281 Y => Stack(SP),
282 Difference => Stack(SP - 1),
283 Underflow => F);
284 Flag := FFA_Word_NZeroP(F);
285 Drop;
286
287 -- Add
288 when '+' =>
289 Want(2);
290 FZ_Add(X => Stack(SP - 1),
291 Y => Stack(SP),
292 Sum => Stack(SP - 1),
293 Overflow => F);
294 Flag := W_NZeroP(F);
295 FFA_FZ_Add(X => Stack(SP - 1),
296 Y => Stack(SP),
297 Sum => Stack(SP - 1),
298 Overflow => F);
299 Flag := FFA_Word_NZeroP(F);
300 Drop;
301
302 -- Divide and give Quotient and Remainder
303 when '\' =>
304 Want(2);
305 MustNotZero(Stack(SP));
306 FZ_IDiv(Dividend => Stack(SP - 1),
307 Divisor => Stack(SP),
308 Quotient => Stack(SP - 1),
309 Remainder => Stack(SP));
310 FFA_FZ_IDiv(Dividend => Stack(SP - 1),
311 Divisor => Stack(SP),
312 Quotient => Stack(SP - 1),
313 Remainder => Stack(SP));
314
315 -- Divide and give Quotient only
316 when '/' =>
317 Want(2);
318 MustNotZero(Stack(SP));
319 FZ_Div(Dividend => Stack(SP - 1),
320 Divisor => Stack(SP),
321 Quotient => Stack(SP - 1));
322 FFA_FZ_Div(Dividend => Stack(SP - 1),
323 Divisor => Stack(SP),
324 Quotient => Stack(SP - 1));
325 Drop;
326
327 -- Divide and give Remainder only
328 when '%' =>
329 Want(2);
330 MustNotZero(Stack(SP));
331 FZ_Mod(Dividend => Stack(SP - 1),
332 Divisor => Stack(SP),
333 Remainder => Stack(SP - 1));
334 FFA_FZ_Mod(Dividend => Stack(SP - 1),
335 Divisor => Stack(SP),
336 Remainder => Stack(SP - 1));
337 Drop;
338
339 -- Multiply, give bottom and top halves
340 when '*' =>
341 Want(2);
342 FZ_Mult(X => Stack(SP - 1),
343 Y => Stack(SP),
344 XY_Lo => Stack(SP - 1),
345 XY_Hi => Stack(SP));
346 FFA_FZ_Multiply(X => Stack(SP - 1),
347 Y => Stack(SP),
348 XY_Lo => Stack(SP - 1),
349 XY_Hi => Stack(SP));
350
351 -- Modular Multiplication
352 when 'M' =>
353 Want(3);
354 MustNotZero(Stack(SP));
355 FZ_Mod_Mul(X => Stack(SP - 2),
356 Y => Stack(SP - 1),
357 Modulus => Stack(SP),
358 Product => Stack(SP - 2));
359 FFA_FZ_Modular_Multiply(X => Stack(SP - 2),
360 Y => Stack(SP - 1),
361 Modulus => Stack(SP),
362 Product => Stack(SP - 2));
363 Drop;
364 Drop;
365
(400 . 10)(392 . 10)
367 when 'X' =>
368 Want(3);
369 MustNotZero(Stack(SP));
370 FZ_Mod_Exp(Base => Stack(SP - 2),
371 Exponent => Stack(SP - 1),
372 Modulus => Stack(SP),
373 Result => Stack(SP - 2));
374 FFA_FZ_Modular_Exponentiate(Base => Stack(SP - 2),
375 Exponent => Stack(SP - 1),
376 Modulus => Stack(SP),
377 Result => Stack(SP - 2));
378 Drop;
379 Drop;
380
(414 . 31)(406 . 31)
382 -- Bitwise-And
383 when '&' =>
384 Want(2);
385 FZ_And(X => Stack(SP - 1),
386 Y => Stack(SP),
387 Result => Stack(SP - 1));
388 FFA_FZ_And(X => Stack(SP - 1),
389 Y => Stack(SP),
390 Result => Stack(SP - 1));
391 Drop;
392
393 -- Bitwise-Or
394 when '|' =>
395 Want(2);
396 FZ_Or(X => Stack(SP - 1),
397 Y => Stack(SP),
398 Result => Stack(SP - 1));
399 FFA_FZ_Or(X => Stack(SP - 1),
400 Y => Stack(SP),
401 Result => Stack(SP - 1));
402 Drop;
403
404 -- Bitwise-Xor
405 when '^' =>
406 Want(2);
407 FZ_Xor(X => Stack(SP - 1),
408 Y => Stack(SP),
409 Result => Stack(SP - 1));
410 FFA_FZ_Xor(X => Stack(SP - 1),
411 Y => Stack(SP),
412 Result => Stack(SP - 1));
413 Drop;
414
415 -- Bitwise-Not (1s-Complement)
416 when '~' =>
417 Want(1);
418 FZ_Not(Stack(SP), Stack(SP));
419 FFA_FZ_Not(Stack(SP), Stack(SP));
420
421 -----------
422 -- Other --
(447 . 28)(439 . 28)
424 -- Push a FZ of RNGolade onto the stack
425 when '?' =>
426 Push;
427 FZ_Clear(Stack(SP));
428 FFA_FZ_Clear(Stack(SP));
429 FZ_Random(RNG, Stack(SP));
430
431 -- mUx
432 when 'U' =>
433 Want(3);
434 FZ_Mux(X => Stack(SP - 2),
435 Y => Stack(SP - 1),
436 Result => Stack(SP - 2),
437 Sel => FZ_NZeroP(Stack(SP)));
438 FFA_FZ_Mux(X => Stack(SP - 2),
439 Y => Stack(SP - 1),
440 Result => Stack(SP - 2),
441 Sel => FFA_FZ_NZeroP(Stack(SP)));
442 Drop;
443 Drop;
444
445 -- Put the Overflow flag on the stack
446 when 'O' =>
447 Push;
448 WBool_To_FZ(Flag, Stack(SP));
449 FFA_WBool_To_FZ(Flag, Stack(SP));
450
451 -- Print the FZ on the top of the stack
452 when '#' =>
453 Want(1);
454 Dump(Stack(SP));
455 Print_FZ(Stack(SP));
456 Drop;
457
458 -- Zap (reset)
(478 . 7)(470 . 7)
460 -- Quit with Stack Trace
461 when 'Q' =>
462 for I in reverse Stack'First + 1 .. SP loop
463 Dump(Stack(I));
464 Print_FZ(Stack(I));
465 end loop;
466 Quit(0);
467
(537 . 7)(529 . 7)
469 -- we push a 1 to trigger the possible 'else' clause:
470 if CondLevel = 0 then
471 Push;
472 WBool_To_FZ(1, Stack(SP));
473 FFA_WBool_To_FZ(1, Stack(SP));
474 end if;
475
476 when '{' => -- Add a nesting level: