DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / bbcp.git / blob
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
Port, TODO
[bbcp.git] / Trurl-based / System / Mod / SMath.txt
1 MODULE SMath;
2
3 (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/SMatch.odc *)
4 (* DO NOT EDIT *)
5
6 IMPORT SYSTEM;
7
8 VAR eps, e: SHORTREAL;
9
10
11 (* code procedures for 80387 math coprocessor *)
12
13 PROCEDURE [code] FLD (x: SHORTREAL);
14 PROCEDURE [code] TOP (): SHORTREAL;
15 PROCEDURE [code] FSW (): INTEGER 0DFH, 0E0H;
16 PROCEDURE [code] FSWs (): SET 0DFH, 0E0H;
17 PROCEDURE [code] ST0 (): SHORTREAL 0D9H, 0C0H;
18 PROCEDURE [code] ST1 (): SHORTREAL 0D9H, 0C1H;
19
20 PROCEDURE [code] FXCH 0D9H, 0C9H;
21 PROCEDURE [code] FLDst0 0D9H, 0C0H; (* doublicate st[0] *)
22 PROCEDURE [code] FSTPst0 0DDH, 0D8H; (* remove st[0] *)
23 PROCEDURE [code] FSTPst1 0DDH, 0D9H; (* remove st[1] *)
24 PROCEDURE [code] FSTPDe 0DBH, 05DH, 0F4H; (* FSTPD -12[FP] *) (* COMPILER DEPENDENT *)
25 PROCEDURE [code] WAIT 09BH;
26 PROCEDURE [code] FNOP 0D9H, 0D0H;
27
28 PROCEDURE [code] FLD0 0D9H, 0EEH;
29 PROCEDURE [code] FLD1 0D9H, 0E8H;
30 PROCEDURE [code] FLDPI 0D9H, 0EBH;
31 PROCEDURE [code] FLDLN2 0D9H, 0EDH;
32 PROCEDURE [code] FLDLG2 0D9H, 0ECH;
33 PROCEDURE [code] FLDL2E 0D9H, 0EAH;
34
35 PROCEDURE [code] FADD 0DEH, 0C1H;
36 PROCEDURE [code] FADDst0 0D8H, 0C0H;
37 PROCEDURE [code] FSUB 0DEH, 0E9H;
38 PROCEDURE [code] FSUBn 0DCH, 0E9H; (* no pop *)
39 PROCEDURE [code] FSUBR 0DEH, 0E1H;
40 PROCEDURE [code] FSUBst1 0D8H, 0E1H;
41 PROCEDURE [code] FMUL 0DEH, 0C9H;
42 PROCEDURE [code] FMULst0 0D8H, 0C8H;
43 PROCEDURE [code] FMULst1st0 0DCH, 0C9H;
44 PROCEDURE [code] FDIV 0DEH, 0F9H;
45 PROCEDURE [code] FDIVR 0DEH, 0F1H;
46 PROCEDURE [code] FDIVRst1 0D8H, 0F9H;
47 PROCEDURE [code] FCHS 0D9H, 0E0H;
48
49 PROCEDURE [code] FCOM 0D8H, 0D1H;
50 PROCEDURE [code] FSWax 0DFH, 0E0H;
51 PROCEDURE [code] SAHF 09EH;
52 PROCEDURE [code] JBE4 076H, 004H;
53 PROCEDURE [code] JAE4 073H, 004H;
54
55 PROCEDURE [code] FRNDINT 0D9H, 0FCH;
56 PROCEDURE [code] FSCALE 0D9H, 0FDH; (* st[0] * 2^FLOOR(st[1]) *)
57 PROCEDURE [code] FXTRACT 0D9H, 0F4H; (* exp -> st[1]; mant -> st[0] *)
58 PROCEDURE [code] FXAM 0D9H, 0E5H;
59
60 PROCEDURE [code] FSQRT 0D9H, 0FAH; (* st[0] >= 0 *)
61 PROCEDURE [code] FSIN 0D9H, 0FEH; (* |st[0]| < 2^63 *)
62 PROCEDURE [code] FCOS 0D9H, 0FFH; (* |st[0]| < 2^63 *)
63 PROCEDURE [code] FTAN 0D9H, 0F2H; (* |st[0]| < 2^63 *)
64 PROCEDURE [code] FATAN 0D9H, 0F3H; (* atan2(st[1], st[0]) *)
65 PROCEDURE [code] FYL2X 0D9H, 0F1H; (* st[1] * log2(st[0]), st[0] > 0 *)
66 PROCEDURE [code] FYL2XP1 0D9H, 0F9H; (* st[1] * log2(1 + st[0]), |st[0]| < 1-sqrt(2)/2 *)
67 PROCEDURE [code] F2XM1 0D9H, 0F0H; (* 2^st[0] - 1, |st[0]| <= 1 *)
68
69
70 PROCEDURE IsNan (x: SHORTREAL): BOOLEAN;
71 BEGIN
72 FLD(x); FXAM; FSTPst0; WAIT; RETURN FSWs() * {8, 10} = {8}
73 END IsNan;
74
75
76 (* sin, cos, tan argument reduction *)
77
78 PROCEDURE Reduce;
79 BEGIN
80 FXAM; WAIT;
81 IF ~(8 IN FSWs()) & (ABS(ST0()) > 1.0E18) THEN
82 (* to be completed *)
83 FSTPst0; FLD0
84 END;
85 END Reduce;
86
87
88 (** SHORTREAL precision **)
89
90 PROCEDURE Pi* (): SHORTREAL;
91 BEGIN
92 FLDPI; RETURN TOP()
93 END Pi;
94
95 PROCEDURE Eps* (): SHORTREAL;
96 BEGIN
97 RETURN eps
98 END Eps;
99
100
101 PROCEDURE Sqrt* (x: SHORTREAL): SHORTREAL;
102 BEGIN
103 (* 20, argument of Sqrt must not be negative *)
104 FLD(x); FSQRT; WAIT; RETURN TOP()
105 END Sqrt;
106
107
108 PROCEDURE Exp* (x: SHORTREAL): SHORTREAL;
109 BEGIN
110 (* 2 ^ (x * 1/ln(2)) *)
111 FLD(x); FLDL2E; FMUL;
112 IF ABS(ST0()) = INF THEN FLD1
113 ELSE FLDst0; FRNDINT; FXCH; FSUBst1; FNOP; F2XM1; FLD1; FADD
114 END;
115 FSCALE; FSTPst1; RETURN TOP()
116 END Exp;
117
118 PROCEDURE Ln* (x: SHORTREAL): SHORTREAL;
119 BEGIN
120 (* 20, argument of Ln must not be negative *)
121 (* ln(2) * ld(x) *)
122 FLDLN2; FLD(x); FYL2X; WAIT; RETURN TOP()
123 END Ln;
124
125 PROCEDURE Log* (x: SHORTREAL): SHORTREAL;
126 BEGIN
127 (* 20, argument of Log must not be negative *)
128 (* log(2) * ld(x) *)
129 FLDLG2; FLD(x); FYL2X; WAIT; RETURN TOP()
130 END Log;
131
132 PROCEDURE Power* (x, y: SHORTREAL): SHORTREAL;
133 BEGIN
134 ASSERT(x >= 0, 20);
135 ASSERT((x # 0.0) OR (y # 0.0), 21);
136 ASSERT((x # INF) OR (y # 0.0), 22);
137 ASSERT((x # 1.0) OR (ABS(y) # INF), 23);
138 (* 2 ^ (y * ld(x)) *)
139 FLD(y); FLD(x); FYL2X;
140 IF ABS(ST0()) = INF THEN FLD1
141 ELSE FLDst0; FRNDINT; FXCH; FSUBst1; FNOP; F2XM1; FLD1; FADD
142 END;
143 FSCALE; FSTPst1; WAIT; RETURN TOP()
144 END Power;
145
146 PROCEDURE IntPower* (x: SHORTREAL; n: INTEGER): SHORTREAL;
147 BEGIN
148 FLD1; FLD(x);
149 IF n = MIN(INTEGER) THEN RETURN IntPower(x, n + 1) / x END;
150 IF n <= 0 THEN FDIVRst1; (* 1 / x *) n := -n END;
151 WHILE n > 0 DO
152 IF ODD(n) THEN FMULst1st0; (* y := y * x *) DEC(n)
153 ELSE FMULst0; (* x := x * x *) n := n DIV 2
154 END
155 END;
156 FSTPst0; RETURN TOP()
157 END IntPower;
158
159
160 PROCEDURE Sin* (x: SHORTREAL): SHORTREAL;
161 BEGIN
162 (* 20, ABS(x) # INF *)
163 FLD(x); Reduce; FSIN; WAIT; RETURN TOP()
164 END Sin;
165
166 PROCEDURE Cos* (x: SHORTREAL): SHORTREAL;
167 BEGIN
168 (* 20, ABS(x) # INF *)
169 FLD(x); Reduce; FCOS; WAIT; RETURN TOP()
170 END Cos;
171
172 PROCEDURE Tan* (x: SHORTREAL): SHORTREAL;
173 BEGIN
174 (* 20, ABS(x) # INF *)
175 FLD(x); Reduce; FTAN; FSTPst0; WAIT; RETURN TOP()
176 END Tan;
177
178 PROCEDURE ArcSin* (x: SHORTREAL): SHORTREAL;
179 BEGIN
180 (* 20, -1.0 <= x <= 1.0 *)
181 (* atan2(x, sqrt(1 - x*x)) *)
182 FLD(x); FLDst0; FMULst0; FLD1; FSUBR; FSQRT; FNOP; FATAN; WAIT; RETURN TOP()
183 END ArcSin;
184
185 PROCEDURE ArcCos* (x: SHORTREAL): SHORTREAL;
186 BEGIN
187 (* 20, -1.0 <= x <= 1.0 *)
188 (* atan2(sqrt(1 - x*x), x) *)
189 FLD(x); FMULst0; FLD1; FSUBR; FSQRT; FLD(x); FATAN; WAIT; RETURN TOP()
190 END ArcCos;
191
192 PROCEDURE ArcTan* (x: SHORTREAL): SHORTREAL;
193 BEGIN
194 (* atan2(x, 1) *)
195 FLD(x); FLD1; FATAN; RETURN TOP()
196 END ArcTan;
197
198 PROCEDURE ArcTan2* (y, x: SHORTREAL): SHORTREAL;
199 BEGIN
200 ASSERT((y # 0) OR (x # 0), 20);
201 ASSERT((ABS(y) # INF) OR (ABS(x) # INF), 21);
202 FLD(y); FLD(x); FATAN; WAIT; RETURN TOP()
203 END ArcTan2;
204
205
206 PROCEDURE Sinh* (x: SHORTREAL): SHORTREAL;
207 BEGIN
208 (* IF IsNan(x) THEN RETURN x END; *)
209 (* abs(x) * 1/ln(2) *)
210 FLD(ABS(x)); FLDL2E; FMUL;
211 IF ST0() < 0.5 THEN
212 (* (2^z - 1) + (2^z - 1) / ((2^z - 1) + 1) *)
213 F2XM1; FLDst0; FLDst0; FLD1; FADD; FDIV; FADD
214 ELSIF ST0() # INF THEN
215 (* 2^z - 1 / 2^z *)
216 FLDst0; FRNDINT; FXCH; FSUBst1; FNOP; F2XM1; FLD1; FADD; FSCALE;
217 FSTPst1; FLDst0; FLD1; FDIVR; FSUB
218 END;
219 IF x < 0 THEN FCHS END;
220 RETURN TOP() * 0.5
221 END Sinh;
222
223 PROCEDURE Cosh* (x: SHORTREAL): SHORTREAL;
224 BEGIN
225 (* IF IsNan(x) THEN RETURN x END; *)
226 (* 2^(abs(x) * 1/ln(2)) *)
227 FLD(ABS(x));
228 IF ST0() # INF THEN
229 FLDL2E; FMUL; FLDst0; FRNDINT; FXCH; FSUBst1; FNOP; F2XM1; FLD1; FADD; FSCALE;
230 FSTPst1;
231 (* z + 1/z *)
232 FLDst0; FLD1; FDIVR; FADD
233 END;
234 RETURN TOP() * 0.5
235 END Cosh;
236
237 PROCEDURE Tanh* (x: SHORTREAL): SHORTREAL;
238 BEGIN
239 (* IF IsNan(x) THEN RETURN x END; *)
240 (* abs(x) * 1/ln(2) * 2 *)
241 FLD(ABS(x)); FLDL2E; FMUL; FADDst0;
242 IF ST0() < 0.5 THEN
243 (* (2^z - 1) / (2^z + 1) *)
244 F2XM1; FLDst0; FLD(2); FADD; FDIV
245 ELSIF ST0() < 65 THEN
246 (* 1 - 2 / (2^z + 1) *)
247 FLDst0; FRNDINT; FXCH; FSUBst1; FNOP; F2XM1; FLD1; FADD; FSCALE; FSTPst1; FLD1; FADD; FLD(2); FDIVR; FLD1; FSUBR
248 ELSE
249 FSTPst0; FLD1
250 END;
251 IF x < 0 THEN FCHS END;
252 RETURN TOP()
253 END Tanh;
254
255 PROCEDURE ArcSinh* (x: SHORTREAL): SHORTREAL;
256 BEGIN
257 (* IF IsNan(x) THEN RETURN x END; *)
258 (* x*x *)
259 FLDLN2; FLD(ABS(x)); FLDst0; FMULst0;
260 IF ST0() < 0.067 THEN
261 (* ln(2) * ld(1 + x*x / (sqrt(x*x + 1) + 1) + x) *)
262 FLDst0; FLD1; FADD; FSQRT; FLD1; FADD; FDIV; FADD; FYL2XP1
263 ELSE
264 (* ln(2) * ld(x + sqrt(x*x + 1)) *)
265 FLD1; FADD; FSQRT; FADD; FYL2X
266 END;
267 IF x < 0 THEN FCHS END;
268 RETURN TOP()
269 END ArcSinh;
270
271 PROCEDURE ArcCosh* (x: SHORTREAL): SHORTREAL;
272 BEGIN
273 (* 20, x >= 1.0 *)
274 (* IF IsNan(x) THEN RETURN x END; *)
275 (* ln(2) * ld(x + sqrt(x*x - 1)) *)
276 FLDLN2; FLD(x); FLDst0; FMULst0; FLD1; FSUB; FSQRT; FADD; FYL2X; WAIT; RETURN TOP()
277 END ArcCosh;
278
279 PROCEDURE ArcTanh* (x: SHORTREAL): SHORTREAL;
280 BEGIN
281 (* 20, -1.0 <= x <= 1.0 *)
282 (* IF IsNan(x) THEN RETURN x END; *)
283 (* |x| *)
284 FLDLN2; FLD(ABS(x));
285 IF ST0() < 0.12 THEN
286 (* ln(2) * ld(1 + 2*x / (1 - x)) *)
287 FLDst0; FLD1; FSUBR; FDIV; FADDst0; FYL2XP1
288 ELSE
289 (* ln(2) * ld((1 + x) / (1 - x)) *)
290 FLDst0; FLD1; FADD; FXCH; FLD1; FSUBR; FDIV; FNOP; FYL2X
291 END;
292 IF x < 0 THEN FCHS END;
293 WAIT;
294 RETURN TOP() * 0.5
295 END ArcTanh;
296
297
298 PROCEDURE Floor* (x: SHORTREAL): SHORTREAL;
299 BEGIN
300 FLD(x); FLDst0; FRNDINT; FCOM; FSWax; FSTPst1; SAHF; JBE4; FLD1; FSUB; RETURN TOP()
301 END Floor;
302
303 PROCEDURE Ceiling* (x: SHORTREAL): SHORTREAL;
304 BEGIN
305 FLD(x); FLDst0; FRNDINT; FCOM; FSWax; FSTPst1; SAHF; JAE4; FLD1; FADD; RETURN TOP()
306 END Ceiling;
307
308 PROCEDURE Round* (x: SHORTREAL): SHORTREAL;
309 BEGIN
310 FLD(x);
311 IF ABS(ST0()) = INF THEN RETURN TOP() END;
312 FLDst0; FRNDINT; FSUBn; FXCH;
313 IF TOP() = 0.5 THEN FLD1; FADD END;
314 RETURN TOP()
315 END Round;
316
317 PROCEDURE Trunc* (x: SHORTREAL): SHORTREAL;
318 BEGIN
319 FLD(x); FLDst0; FRNDINT;
320 IF ST1() >= 0 THEN
321 FCOM; FSWax; FSTPst1; SAHF; JBE4; FLD1; FSUB
322 ELSE
323 FCOM; FSWax; FSTPst1; SAHF; JAE4; FLD1; FADD
324 END;
325 RETURN TOP()
326 END Trunc;
327
328 PROCEDURE Frac* (x: SHORTREAL): SHORTREAL;
329 BEGIN
330 (* 20, x # INF & x # -INF *)
331 FLD(x); FLDst0; FRNDINT;
332 IF ST1() >= 0 THEN
333 FCOM; FSWax; SAHF; JBE4; FLD1; FSUB
334 ELSE
335 FCOM; FSWax; SAHF; JAE4; FLD1; FADD
336 END;
337 FSUB; WAIT; RETURN TOP()
338 END Frac;
339
340
341 PROCEDURE Sign* (x: SHORTREAL): SHORTREAL;
342 BEGIN
343 FLD(x); FXAM; WAIT;
344 CASE FSW() DIV 256 MOD 8 OF
345 | 0, 2: FSTPst0; RETURN 0.0
346 | 1, 4, 5: FSTPst0; RETURN 1.0
347 | 3, 6, 7: FSTPst0; RETURN -1.0
348 END
349 END Sign;
350
351 PROCEDURE Mantissa* (x: SHORTREAL): SHORTREAL;
352 BEGIN
353 FLD(x); FXAM; WAIT;
354 CASE FSW() DIV 256 MOD 8 OF
355 | 4, 6: FXTRACT; FSTPst1; RETURN TOP()
356 | 0, 2: FSTPst0; RETURN 0.0 (* zero *)
357 | 5: FSTPst0; RETURN 1.0 (* inf *)
358 | 7: FSTPst0; RETURN -1.0 (* -inf *)
359 | 1: FSTPst0; RETURN 1.5 (* nan *)
360 | 3: FSTPst0; RETURN -1.5 (* -nan *)
361 END
362 END Mantissa;
363
364 PROCEDURE Exponent* (x: SHORTREAL): INTEGER; (* COMPILER DEPENDENT *)
365 VAR e: INTEGER; (* e is set by FSTPDe! *)
366 BEGIN
367 FLD(x); FXAM; WAIT;
368 CASE FSW() DIV 256 MOD 8 OF
369 | 4, 6: FXTRACT; FSTPst0; FSTPDe; WAIT; RETURN e
370 | 0, 2: FSTPst0; RETURN 0 (* zero *)
371 | 1, 3, 5, 7: FSTPst0; RETURN MAX(INTEGER) (* inf or nan*)
372 END
373 END Exponent;
374
375 PROCEDURE Real* (m: SHORTREAL; e: INTEGER): SHORTREAL;
376 VAR s: SET;
377 BEGIN
378 IF (m = 0) THEN RETURN 0.0 END;
379 ASSERT(~IsNan(m) & (1 <= ABS(m)) & (ABS(m) < 2), 20);
380 IF e = MAX(INTEGER) THEN
381 SYSTEM.GET(SYSTEM.ADR(m) + 4, s);
382 SYSTEM.PUT(SYSTEM.ADR(m) + 4, s + {20..30});
383 RETURN m
384 ELSE
385 FLD(e); FLD(m); FSCALE; FSTPst1; RETURN TOP()
386 END
387 END Real;
388
389 BEGIN
390 eps := 1.0E+0; e := 2.0E+0;
391 WHILE e > 1.0E+0 DO eps := eps/2.0E+0; e := 1.0E+0 + eps END; eps := 2.0E+0 * eps;
392 END SMath.
[FORK] BlackBox Cross-Platform (Windows, GNU/Linux, OpenBSD, FreeBSD)
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024