ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/client/FBNumeric.pas
Revision: 381
Committed: Sat Jan 15 00:06:22 2022 UTC (3 days, 16 hours ago) by tony
File size: 15452 byte(s)
Log Message:
Release Candidate 1
Line File contents
1 (*
2 * Firebird Interface (fbintf). The fbintf components provide a set of
3 * Pascal language bindings for the Firebird API. Although predominantly
4 * a new development they include source code taken from IBX and may be
5 * considered a derived product. This software thus also includes the copyright
6 * notice and license conditions from IBX.
7 *
8 * Except for those parts dervied from IBX, contents of this file are subject
9 * to the Initial Developer's Public License Version 1.0 (the "License"); you
10 * may not use this file except in compliance with the License. You may obtain a
11 * copy of the License here:
12 *
13 * http://www.firebirdsql.org/index.php?op=doc&id=idpl
14 *
15 * Software distributed under the License is distributed on an "AS
16 * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
17 * implied. See the License for the specific language governing rights
18 * and limitations under the License.
19 *
20 * The Initial Developer of the Original Code is Tony Whyman.
21 *
22 * The Original Code is (C) 2021 Tony Whyman, MWA Software
23 * (http://www.mwasoftware.co.uk).
24 *
25 * All Rights Reserved.
26 *
27 * Contributor(s): ______________________________________.
28 *
29 *)
30 unit FBNumeric;
31
32 {$IFDEF MSWINDOWS}
33 {$DEFINE WINDOWS}
34 {$ENDIF}
35
36 {$IFDEF FPC}
37 {$mode delphi}
38 {$codepage UTF8}
39 {$interfaces COM}
40 {$ENDIF}
41
42 interface
43
44 uses
45 Classes, SysUtils, IB, FBActivityMonitor, FmtBCD;
46
47 { The IFBNumeric interface is a managed type to hold a fixed point integer
48 as a 64-bit signed integer plus a scale factor. i.e. the scale factor is
49 the base 10 exponent in
50
51 Fixed Point Value = <64-bit signed integer> * 10^<scale factor>
52
53 }
54
55 function StrToNumeric(aValue: AnsiString): IFBNumeric;
56 function DoubleToNumeric(aValue: double): IFBNumeric;
57 function BCDToNumeric(aValue: TBCD): IFBNumeric;
58 function CurrToNumeric(aValue: currency): IFBNumeric;
59 function IntToNumeric(aValue: Int64): IFBNumeric;
60 function NumericFromRawValues(aValue: Int64; aScale: integer): IFBNumeric;
61 function NumericToDouble(aValue: Int64; aScale: integer): double;
62
63 function TryStrToNumeric(S: Ansistring; out Value: int64; out scale: integer): boolean;
64
65 function SafeSmallInt(aValue: Int64): Smallint;
66 function SafeInteger(aValue: Int64): integer;
67
68 {Numeric Arithmetic}
69 function NumericAdd(x,y: IFBNumeric): IFBNumeric; overload; {returns x + y}
70 function NumericSubtract(x,y: IFBNumeric): IFBNumeric; overload; {returns x - y}
71 function NumericMultiply(x,y: IFBNumeric): IFBNumeric; overload; {returns x * y}
72 function NumericDivide(x,y: IFBNumeric): IFBNumeric; overload; {returns x / y}
73 function NumericCompare(x,y: IFBNumeric): integer; overload; {returns -1: x < y; 0: x = y; 1: x > y}
74 function NegateNumeric(x: IFBNumeric): IFBNumeric; overload; {returns -x}
75
76 {integer operations}
77 function NumericAdd(x: IFBNumeric; y: int64): IFBNumeric; overload; {returns x + y}
78 function NumericSubtract(x: IFBNumeric; y: int64): IFBNumeric; overload; {returns x - y}
79 function NumericSubtract(x: int64; y: IFBNumeric): IFBNumeric; overload; {returns x - y}
80 function NumericMultiply(x: IFBNumeric; y: int64): IFBNumeric; overload; {returns x * y}
81 function NumericDivide(x: IFBNumeric; y: int64): IFBNumeric; overload; {returns x / y}
82 function NumericDivide(x: int64; y: IFBNumeric): IFBNumeric; overload; {returns x / y}
83 function NumericCompare(x: IFBNumeric; y: int64): integer; overload; {returns -1: x < y; 0: x = y; 1: x > y}
84
85 {floating point operations}
86 function NumericAdd(x: IFBNumeric; y: double): IFBNumeric; overload; {returns x + y}
87 function NumericSubtract(x: IFBNumeric; y: double): IFBNumeric; overload; {returns x - y}
88 function NumericSubtract(x: double; y: IFBNumeric): IFBNumeric; overload; {returns x - y}
89 function NumericMultiply(x: IFBNumeric; y: double): IFBNumeric; overload; {returns x * y}
90 function NumericDivide(x: IFBNumeric; y: double): IFBNumeric; overload; {returns x div y}
91 function NumericDivide(x: double; y: IFBNumeric): IFBNumeric; overload; {returns x div y}
92 function NumericCompare(x: IFBNumeric; y: double): integer; overload; {returns -1: x < y; 0: x = y; 1: x > y}
93
94 implementation
95
96 uses IBUtils, FBMessages, Math;
97
98 type
99
100 { TIBNumeric }
101
102 { TFBNumeric }
103
104 TFBNumeric = class(TFBInterfacedObject,IFBNumeric)
105 private
106 FValue: Int64;
107 FScale: integer;
108 public
109 constructor Create(aValue: Int64; aScale: integer);
110 constructor CreateFromInt(aValue: Int64);
111 constructor CreateFromStr(aValue: AnsiString);
112 constructor CreateFromDouble(aValue: double);
113 constructor CreateFromCurr(aValue: Currency);
114 constructor CreateFromBCD(aValue: TBCD);
115 public
116 {IFBNumeric}
117 function getRawValue: Int64;
118 function getScale: integer;
119 function AdjustScaleTo(aNewScale: integer): IFBNumeric;
120 function getAsString: AnsiString;
121 function getAsDouble: double;
122 function getAsCurrency: Currency;
123 function getAsBCD: TBCD;
124 function getAsInt64: Int64; {scaled}
125 function getAsInteger: integer; {scaled - may be truncated}
126 function getAsSmallInt: SmallInt; {scaled - may be truncated}
127 end;
128
129 function StrToNumeric(aValue: AnsiString): IFBNumeric;
130 begin
131 Result := TFBNumeric.CreateFromStr(aValue);
132 end;
133
134 function DoubleToNumeric(aValue: double): IFBNumeric;
135 begin
136 Result := TFBNumeric.CreateFromDouble(aValue);
137 end;
138
139 function BCDToNumeric(aValue: TBCD): IFBNumeric;
140 begin
141 Result := TFBNumeric.CreateFromBCD(aValue);
142 end;
143
144 function CurrToNumeric(aValue: currency): IFBNumeric;
145 begin
146 Result := TFBNumeric.CreateFromCurr(aValue);
147 end;
148
149 function IntToNumeric(aValue: Int64): IFBNumeric;
150 begin
151 Result := TFBNumeric.CreateFromINT(aValue);
152 end;
153
154 function NumericFromRawValues(aValue: Int64; aScale: integer): IFBNumeric;
155 begin
156 Result := TFBNumeric.Create(aValue,aScale);
157 end;
158
159 function TryStrToNumeric(S: Ansistring; out Value: int64; out scale: integer): boolean;
160 var i: integer;
161 ds: integer;
162 exponent: integer;
163 begin
164 Result := false;
165 ds := 0;
166 exponent := 0;
167 S := Trim(S);
168 Value := 0;
169 scale := 0;
170 if Length(S) = 0 then
171 Exit;
172 {$IF declared(DefaultFormatSettings)}
173 with DefaultFormatSettings do
174 {$ELSE}
175 {$IF declared(FormatSettings)}
176 with FormatSettings do
177 {$IFEND}
178 {$IFEND}
179 begin
180 for i := length(S) downto 1 do
181 begin
182 if S[i] = AnsiChar(DecimalSeparator) then
183 begin
184 if ds <> 0 then Exit; {only one allowed}
185 ds := i;
186 dec(exponent);
187 system.Delete(S,i,1);
188 end
189 else
190 if S[i] in ['+','-'] then
191 begin
192 if (i > 1) and not (S[i-1] in ['e','E']) then
193 Exit; {malformed}
194 end
195 else
196 if S[i] in ['e','E'] then {scientific notation}
197 begin
198 if ds <> 0 then Exit; {not permitted in exponent}
199 if exponent <> 0 then Exit; {only one allowed}
200 exponent := i;
201 end
202 else
203 if not (S[i] in ['0'..'9']) then
204 {Note: ThousandSeparator not allowed by Delphi specs}
205 Exit; {bad character}
206 end;
207
208 if exponent > 0 then
209 begin
210 Result := TryStrToInt(system.copy(S,exponent+1,maxint),Scale);
211 if Result then
212 begin
213 {adjust scale for decimal point}
214 if ds <> 0 then
215 Scale := Scale - (exponent - ds);
216 Result := TryStrToInt64(system.copy(S,1,exponent-1),Value);
217 end;
218 end
219 else
220 begin
221 if ds > 0 then
222 begin
223 {remove trailing zeroes}
224 while (ds < length(S)) and (S[length(S)] = '0') do {no need to check length as ds > 0}
225 system.delete(S,Length(S),1);
226 scale := ds - Length(S) - 1;
227 end;
228 Result := TryStrToInt64(S,Value);
229 end;
230 end;
231 end;
232
233 function NumericToDouble(aValue: Int64; aScale: integer): double;
234 begin
235 Result := aValue * IntPower(10,aScale);
236 end;
237
238 function SafeSmallInt(aValue: Int64): Smallint;
239 begin
240 if aValue > High(smallint) then
241 IBError(ibxeIntegerOverflow,[]);
242 if aValue < Low(smallint) then
243 IBError(ibxIntegerUnderflow,[]);
244 Result := aValue;
245 end;
246
247 function SafeInteger(aValue: Int64): integer;
248 begin
249 if aValue > High(integer) then
250 IBError(ibxeIntegerOverflow,[]);
251 if aValue < Low(integer) then
252 IBError(ibxIntegerUnderflow,[]);
253 Result := aValue;
254 end;
255
256 {AdjustScale returns a raw int64 value derived from x but with aNewScale}
257
258 function AdjustScale(x: IFBNumeric; aNewScale: integer): int64;
259 var rValue: double;
260 begin
261 rValue := x.getrawValue;
262 Result := Round(rValue * IntPower(10,x.getScale-aNewScale));
263 end;
264
265 function CompareInt(a,b: integer): integer;
266 begin
267 if a < b then
268 Result := -1
269 else
270 if a = b then
271 Result := 0
272 else
273 Result := 1;
274 end;
275
276 function NumericAdd(x, y: IFBNumeric): IFBNumeric;
277 begin
278 case CompareInt(x.getScale,y.getScale) of
279 0:
280 Result := NumericFromRawValues(x.getRawValue + y.getRawValue,x.getScale);
281 1:
282 Result := NumericFromRawValues(AdjustScale(x,y.getscale) + y.getRawValue,y.getScale);
283 else
284 Result := NumericFromRawValues(AdjustScale(y,x.getscale) + x.getRawValue,x.getScale);
285 end;
286 end;
287
288 function NumericSubtract(x, y: IFBNumeric): IFBNumeric;
289 begin
290 case CompareInt(x.getScale,y.getScale) of
291 0:
292 Result := NumericFromRawValues(x.getRawValue - y.getRawValue,x.getScale);
293 1:
294 Result := NumericFromRawValues(AdjustScale(x,y.getscale) - y.getRawValue,y.getScale);
295 else
296 Result := NumericFromRawValues(AdjustScale(y,x.getscale) - x.getRawValue,x.getScale);
297 end;
298 end;
299
300 function NumericMultiply(x, y: IFBNumeric): IFBNumeric;
301 begin
302 Result := NumericFromRawValues(x.getRawValue * y.getRawValue,x.getScale+y.getScale);
303 end;
304
305 function NumericDivide(x, y: IFBNumeric): IFBNumeric;
306 var z: double;
307 begin
308 {Compute actual value as a double}
309 z := (x.getRawValue / y.getRawValue) * IntPower(10, x.getScale - y.getScale);
310 {Return numeric at original no. of decimal places of numerator}
311 Result := DoubleTONumeric(z).AdjustScaleTo(x.getScale);
312 end;
313
314 function NumericCompare(x, y: IFBNumeric): integer;
315 begin
316 case CompareInt(x.getScale,y.getScale) of
317 0:
318 Result := CompareInt(x.getRawValue,y.getRawValue);
319 1:
320 Result := CompareInt(AdjustScale(x,y.getscale),y.getRawValue);
321 else
322 Result := CompareInt(x.getRawValue,AdjustScale(y,x.getscale));
323 end;
324 end;
325
326 function NegateNumeric(x: IFBNumeric): IFBNumeric;
327 begin
328 Result := NumericFromRawValues(-x.getRawValue,x.getScale);
329 end;
330
331 function NumericAdd(x: IFBNumeric; y: int64): IFBNumeric;
332 begin
333 Result := NumericAdd(x,IntToNumeric(y));
334 end;
335
336 function NumericSubtract(x: IFBNumeric; y: int64): IFBNumeric;
337 begin
338 Result := NumericSubtract(x,IntToNumeric(y));
339 end;
340
341 function NumericSubtract(x: int64; y: IFBNumeric): IFBNumeric;
342 begin
343 Result := NumericSubtract(IntToNumeric(x),y);
344 end;
345
346 function NumericMultiply(x: IFBNumeric; y: int64): IFBNumeric;
347 begin
348 Result := NumericMultiply(x,IntToNumeric(y));
349 end;
350
351 function NumericDivide(x: IFBNumeric; y: int64): IFBNumeric;
352 begin
353 Result := NumericDivide(x,IntToNumeric(y));
354 end;
355
356 function NumericDivide(x: int64; y: IFBNumeric): IFBNumeric;
357 begin
358 Result := NumericDivide(IntToNumeric(x),y);
359 end;
360
361 function NumericCompare(x: IFBNumeric; y: int64): integer;
362 begin
363 Result := NumericCompare(x,IntToNumeric(y));
364 end;
365
366 function NumericAdd(x: IFBNumeric; y: double): IFBNumeric;
367 begin
368 Result := NumericAdd(x,DoubleToNumeric(y));
369 end;
370
371 function NumericSubtract(x: IFBNumeric; y: double): IFBNumeric;
372 begin
373 Result := NumericSubtract(x,DoubleToNumeric(y));
374 end;
375
376 function NumericSubtract(x: double; y: IFBNumeric): IFBNumeric;
377 begin
378 Result := NumericSubtract(DoubleToNumeric(x),y);
379 end;
380
381 function NumericMultiply(x: IFBNumeric; y: double): IFBNumeric;
382 begin
383 Result := NumericMultiply(x,DoubleToNumeric(y));
384 end;
385
386 function NumericDivide(x: IFBNumeric; y: double): IFBNumeric;
387 begin
388 Result := NumericDivide(x,DoubleToNumeric(y));
389 end;
390
391 function NumericDivide(x: double; y: IFBNumeric): IFBNumeric;
392 begin
393 Result := NumericDivide(DoubleToNumeric(x),y);
394 end;
395
396 function NumericCompare(x: IFBNumeric; y: double): integer;
397 begin
398 Result := NumericCompare(x,DoubleToNumeric(y));
399 end;
400
401 constructor TFBNumeric.Create(aValue: Int64; aScale: integer);
402 begin
403 inherited Create;
404 FValue := aValue;
405 FScale := aScale;
406 end;
407
408 constructor TFBNumeric.CreateFromInt(aValue: Int64);
409 begin
410 inherited Create;
411 FValue := aValue;
412 FScale := 0;
413 end;
414
415 constructor TFBNumeric.CreateFromStr(aValue: AnsiString);
416 begin
417 inherited Create;
418 if not TryStrToNumeric(aValue,FValue,FScale) then
419 IBError(ibxeInvalidDataConversion,[aValue]);
420 end;
421
422 constructor TFBNumeric.CreateFromDouble(aValue: double);
423
424 function WithinLimits(a: double): boolean;
425 begin
426 a := abs(frac(a));
427 Result := (a > 0.001) and (a < 0.999); {avoid small rounding errors converting to decimal}
428 end;
429
430 var aScale: integer;
431 i: int64;
432 begin
433 aScale := 0;
434 while WithinLimits(AValue) do
435 begin
436 aValue := aValue * 10;
437 Inc(aScale);
438 end;
439 i := Round(aValue);
440 Create(i,-aScale);
441 end;
442
443 constructor TFBNumeric.CreateFromCurr(aValue: Currency);
444 begin
445 inherited Create;
446 Move(aValue,FValue,sizeof(Int64));
447 FScale := -4;
448 end;
449
450 constructor TFBNumeric.CreateFromBCD(aValue: TBCD);
451 var ScaledBCD: TBCD;
452 begin
453 inherited Create;
454 FScale := -BCDScale(aValue);
455 BCDMultiply(aValue,Power(10,-FScale),ScaledBCD);
456 FValue := BCDToInteger(ScaledBCD,true);
457 end;
458
459 function TFBNumeric.getRawValue: Int64;
460 begin
461 Result := FValue;
462 end;
463
464 function TFBNumeric.getScale: integer;
465 begin
466 Result := FScale;
467 end;
468
469 function TFBNumeric.AdjustScaleTo(aNewScale: integer): IFBNumeric;
470 begin
471 if FScale = aNewScale then
472 Result := TFBNumeric.Create(FValue,FScale)
473 else
474 Result := TFBNumeric.Create(AdjustScale(self,aNewScale),aNewScale);
475 end;
476
477 function TFBNumeric.getAsString: AnsiString;
478 var Scaling : AnsiString;
479 i: Integer;
480 begin
481 Result := IntToStr(FValue);
482 Scaling := '';
483 if FScale > 0 then
484 begin
485 for i := 1 to FScale do
486 Result := Result + '0';
487 end
488 else
489 if FScale < 0 then
490 {$IF declared(DefaultFormatSettings)}
491 with DefaultFormatSettings do
492 {$ELSE}
493 {$IF declared(FormatSettings)}
494 with FormatSettings do
495 {$IFEND}
496 {$IFEND}
497 begin
498 if Length(Result) > -FScale then
499 system.Insert(DecimalSeparator,Result,Length(Result) + FScale+1)
500 else
501 begin
502 Scaling := '0' + DecimalSeparator;
503 for i := -1 downto FScale + Length(Result) do
504 Scaling := Scaling + '0';
505 if FValue < 0 then
506 system.insert(Scaling,Result,2)
507 else
508 Result := Scaling + Result;
509 end;
510 end;
511 end;
512
513 function TFBNumeric.getAsDouble: double;
514 begin
515 Result := NumericToDouble(FValue,FScale);
516 end;
517
518 function TFBNumeric.getAsCurrency: Currency;
519 var value: int64;
520 begin
521 if FScale <> -4 then
522 begin
523 value := AdjustScaleTo(-4).GetRawValue;
524 Move(value,Result,sizeof(Currency));
525 end
526 else
527 Move(FValue,Result,sizeof(Currency));
528 end;
529
530 function TFBNumeric.getAsBCD: TBCD;
531 begin
532 Result := DoubleToBCD(getAsDouble);
533 end;
534
535 function TFBNumeric.getAsInt64: Int64;
536 var
537 Scaling : Int64;
538 i: Integer;
539 Val: Int64;
540 begin
541 Scaling := 1;
542 Val := FValue;
543 if FScale > 0 then begin
544 for i := 1 to FScale do Scaling := Scaling * 10;
545 result := Val * Scaling;
546 end else if FScale < 0 then begin
547 for i := -1 downto FScale do Scaling := Scaling * 10;
548 result := Val div Scaling;
549 end else
550 result := Val;
551 end;
552
553 function TFBNumeric.getAsInteger: integer;
554 begin
555 Result := SafeInteger(getAsInt64);
556 end;
557
558 function TFBNumeric.getAsSmallInt: SmallInt;
559 begin
560 Result := SafeSmallInt(getAsInt64);
561 end;
562
563 end.
564

Properties

Name Value
svn:eol-style native