- 4A851245719704AF35888E2D1BC00B4CEC16E66093E7D79408E98E8A2EABA0E0F5A7ED1EEE26D0F75FA651DBE4BDDD48C31722A2B9B98464362B681F5D7B4C8A+ FA29011671FB6E7C802D18C92D4B94C2D32BB54145A929ECE7780830ACE49582A6EA090AD4678B55A403FA5EBEC34AA091C8672CE1D060E18ED6C87D554E87E9ffa/ffacalc/ffa_calc.adb(108 . 6)(108 . 11)
13 QuoteLevel : Natural := 0;
14 CommLevel : Natural := 0;
15 CondLevel : Natural := 0;
16
17 -- Prefixed Operators
18 PrevC : Character := ' ';
19 HavePrefix : Boolean := False;
20
21 --------------------------------------------------------
22
23
(122 . 6)(127 . 9)
25 SP := Stack_Positions'First;
26 -- Clear Overflow flag
27 Flag := 0;
28 -- Clear prefix
29 HavePrefix := False;
30 PrevC := ' ';
31 end Zap;
32
33
(197 . 6)(205 . 13)
35 end Print_FZ;
36
37
38 -- Denote that the given op is a prefix
39 procedure IsPrefix is
40 begin
41 HavePrefix := True;
42 end IsPrefix;
43
44
45 -- Execute a Normal Op
46 procedure Op_Normal(C : in Character) is
47
(377 . 28)(392 . 6)
49 XY_Lo => Stack(SP - 1),
50 XY_Hi => Stack(SP));
51
52 -- Modular Multiplication
53 when 'M' =>
54 Want(3);
55 MustNotZero(Stack(SP));
56 FFA_FZ_Modular_Multiply(X => Stack(SP - 2),
57 Y => Stack(SP - 1),
58 Modulus => Stack(SP),
59 Product => Stack(SP - 2));
60 Drop;
61 Drop;
62
63 -- Modular Exponentiation
64 when 'X' =>
65 Want(3);
66 MustNotZero(Stack(SP));
67 FFA_FZ_Modular_Exponentiate(Base => Stack(SP - 2),
68 Exponent => Stack(SP - 1),
69 Modulus => Stack(SP),
70 Result => Stack(SP - 2));
71 Drop;
72 Drop;
73
74 -----------------
75 -- Bitwise Ops --
76 -----------------
(452 . 6)(445 . 19)
78 Drop;
79 Drop;
80
81 -- Find the position of eldest nonzero bit, if any exist
82 when 'W' =>
83 Want(1);
84 declare
85 Measure : Word;
86 begin
87 -- Find the measure ( 0 if no 1s, or 1 .. FZBitness )
88 Measure := FFA_FZ_Measure(Stack(SP));
89 -- Put on top of stack
90 FFA_FZ_Clear(Stack(SP));
91 FFA_FZ_Set_Head(Stack(SP), Measure);
92 end;
93
94 -- Put the Overflow flag on the stack
95 when 'O' =>
96 Push;
(474 . 8)(480 . 6)
98 end loop;
99 Quit(0);
100
101 ---------------------------------------------------------
102 -- Ch. 12B:
103 -- Square, give bottom and top halves
104 when 'S' =>
105 Want(1);
(483 . 13)(487 . 38)
107 FFA_FZ_Square(X => Stack(SP - 1),
108 XX_Lo => Stack(SP - 1),
109 XX_Hi => Stack(SP));
110
111 --------------
112 -- Prefixes --
113 --------------
114
115 -- 'Left...' :
116 when 'L' =>
117 IsPrefix;
118
119 -- 'Right...' :
120 when 'R' =>
121 IsPrefix;
122
123 -- 'Modular...' :
124 when 'M' =>
125 IsPrefix;
126
127 ---------------------------------------------------------
128 -- Reserved Ops, i.e. ones we have not defined yet: --
129 ---------------------------------------------------------
130 when '!' | '@' | '$' | ':' | ';' | ',' |
131 'G' | 'H' | 'I' | 'J' | 'K' | 'N' |
132 'P' | 'T' | 'V' | 'X' | 'Y' =>
133
134 E("This Operator is not defined yet: " & C);
135 ---------------------------------------------------------
136
137 ----------
138 -- NOPs --
139 ----------
140
141 -- Ops we have not yet spoken of -- do nothing
142 -- Unprintables and spaces DO NOTHING:
143 when others =>
144 null;
145
(498 . 6)(527 . 118)
147 end Op_Normal;
148
149
150 -- Execute a Prefixed Op
151 procedure Op_Prefixed(Prefix : in Character;
152 O : in Character) is
153 begin
154
155 -- The Prefixed Op:
156 case Prefix is
157
158 ---------------------------------------------------------
159 -- Left...
160 when 'L' =>
161
162 -- Which L-op?
163 case O is
164
165 -- ... Shift :
166 when 'S' =>
167 Want(2);
168 declare
169 -- Number of bit positions to shift by:
170 ShiftCount : FZBit_Index
171 := FZBit_Index(FFA_FZ_Get_Head(Stack(SP)));
172 begin
173 FFA_FZ_Quiet_ShiftLeft(N => Stack(SP - 1),
174 ShiftedN => Stack(SP - 1),
175 Count => ShiftCount);
176 end;
177 Drop;
178
179 -- ... Rotate :
180 when 'R' =>
181 E("Left-Rotate not yet defined!");
182
183 -- ... Unknown:
184 when others =>
185 E("Undefined Op: L" & O);
186
187 end case;
188 ---------------------------------------------------------
189 -- Right...
190 when 'R' =>
191
192 -- Which R-op?
193 case O is
194
195 -- ... Shift:
196 when 'S' =>
197 Want(2);
198 declare
199 -- Number of bit positions to shift by:
200 ShiftCount : FZBit_Index
201 := FZBit_Index(FFA_FZ_Get_Head(Stack(SP)));
202 begin
203 FFA_FZ_Quiet_ShiftRight(N => Stack(SP - 1),
204 ShiftedN => Stack(SP - 1),
205 Count => ShiftCount);
206 end;
207 Drop;
208
209 -- ... Rotate:
210 when 'R' =>
211 E("Right-Rotate not yet defined!");
212
213 -- ... Unknown:
214 when others =>
215 E("Undefined Op: R" & O);
216
217 end case;
218 ---------------------------------------------------------
219 -- Modular...
220 when 'M' =>
221
222 -- Which M-op?
223 case O is
224
225 -- ... Multiplication :
226 when '*' =>
227 Want(3);
228 MustNotZero(Stack(SP));
229 FFA_FZ_Modular_Multiply(X => Stack(SP - 2),
230 Y => Stack(SP - 1),
231 Modulus => Stack(SP),
232 Product => Stack(SP - 2));
233 Drop;
234 Drop;
235
236 -- ... Exponentiation :
237 when 'X' =>
238 Want(3);
239 MustNotZero(Stack(SP));
240 FFA_FZ_Modular_Exponentiate(Base => Stack(SP - 2),
241 Exponent => Stack(SP - 1),
242 Modulus => Stack(SP),
243 Result => Stack(SP - 2));
244 Drop;
245 Drop;
246
247 -- ... Unknown:
248 when others =>
249 E("Undefined Op: M" & O);
250
251 end case;
252 ---------------------------------------------------------
253 -- ... Unknown: (impossible per mechanics, but must handle case)
254 when others =>
255 E("Undefined Prefix: " & Prefix);
256
257 end case;
258
259 end Op_Prefixed;
260
261
262 -- Process a Symbol
263 procedure Op(C : in Character) is
264 begin
(548 . 6)(689 . 16)
266 when others =>
267 null; -- Other symbols have no effect on the level
268 end case;
269
270 --- ... if in a prefixed op:
271 elsif HavePrefix then
272
273 -- Drop the prefix-op hammer, until another prefix-op cocks it
274 HavePrefix := False;
275
276 -- Dispatch this op, where prefix is the preceding character
277 Op_Prefixed(Prefix => PrevC, O => C);
278
279 else
280 -- This is a Normal Op, so proceed with the normal rules.
281 Op_Normal(C);
(569 . 6)(720 . 8)
283 Op(C);
284 -- Advance Odometer
285 Pos := Pos + 1;
286 -- Save the op for use in prefixed ops
287 PrevC := C;
288 else
289 Zap;
290 Quit(0); -- if EOF, we're done