MathgeomGLS

1
{**********************************************************************}
2
{                                                                      }
3
{    "The contents of this file are subject to the Mozilla Public      }
4
{    License Version 1.1 (the "License"); you may not use this         }
5
{    file except in compliance with the License. You may obtain        }
6
{    a copy of the License at http://www.mozilla.org/MPL/              }
7
{                                                                      }
8
{    Software distributed under the License is distributed on an       }
9
{    "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express       }
10
{    or implied. See the License for the specific language             }
11
{    governing rights and limitations under the License.               }
12
{                                                                      }
13
{    Copyright Creative IT.                                            }
14
{    Current maintainer: Eric Grange                                   }
15
{                                                                      }
16
{**********************************************************************}
17
unit dwsBigIntegerFunctions;
18

19
{$I dws.inc}
20

21
interface
22

23
uses
24
   Classes, System.SysUtils,
25
   dwsXPlatform, dwsUtils, dwsStrings,
26
   dwsFunctions, dwsSymbols, dwsExprs, dwsCoreExprs, dwsExprList, dwsUnitSymbols,
27
   dwsConstExprs, dwsMagicExprs, dwsDataContext, dwsErrors, dwsRelExprs,
28
   dwsOperators, dwsTokenizer, dwsCryptoXPlatform,
29
   Velthuis.BigIntegers;
30

31
const
32
   SYS_BIGINTEGER = 'BigInteger';
33

34
type
35

36
   TBaseBigIntegerSymbol = class (TBaseSymbol)
37
      public
38
         constructor Create;
39

40
         function IsCompatible(typSym : TTypeSymbol) : Boolean; override;
41
         procedure InitData(const data : TData; offset : Integer); override;
42
   end;
43

44
   IdwsBigInteger = interface
45
      ['{93A7FA32-DE99-44AB-A5B4-861FD50E9AAB}']
46
      function GetValue : BigInteger;
47
      procedure SetValue(const v : BigInteger);
48
      property Value : BigInteger read GetValue write SetValue;
49
   end;
50

51
   TBigIntegerWrapper = class (TInterfacedObject, IdwsBigInteger, IGetSelf)
52
      private
53
         FData : BigInteger;
54

55
      protected
56
         function GetValue : BigInteger;
57
         procedure SetValue(const v : BigInteger);
58
         function GetSelf : TObject;
59

60
      public
61
         constructor Create(const aBigInteger : BigInteger);
62
         function ToString : String; override;
63
   end;
64

65
   TBigIntegerOpExpr = class(TBinaryOpExpr)
66
      constructor Create(Prog: TdwsProgram; const aScriptPos : TScriptPos; aLeft, aRight : TTypedExpr); override;
67
   end;
68

69
   TBigIntegerAddOpExpr = class(TBigIntegerOpExpr)
70
      procedure EvalAsVariant(exec : TdwsExecution; var result : Variant); override;
71
   end;
72
   TBigIntegerSubOpExpr = class(TBigIntegerOpExpr)
73
      procedure EvalAsVariant(exec : TdwsExecution; var result : Variant); override;
74
   end;
75
   TBigIntegerMultOpExpr = class(TBigIntegerOpExpr)
76
      procedure EvalAsVariant(exec : TdwsExecution; var result : Variant); override;
77
   end;
78
   TBigIntegerDivOpExpr = class(TBigIntegerOpExpr)
79
      procedure EvalAsVariant(exec : TdwsExecution; var result : Variant); override;
80
   end;
81
   TBigIntegerModOpExpr = class(TBigIntegerOpExpr)
82
      procedure EvalAsVariant(exec : TdwsExecution; var result : Variant); override;
83
   end;
84

85
   TBigIntegerShiftLeftExpr = class(TBigIntegerOpExpr)
86
      procedure EvalAsVariant(exec : TdwsExecution; var result : Variant); override;
87
   end;
88
   TBigIntegerShiftRightExpr = class(TBigIntegerOpExpr)
89
      procedure EvalAsVariant(exec : TdwsExecution; var result : Variant); override;
90
   end;
91

92
   TBigIntegerOpAssignExpr = class(TOpAssignExpr)
93
     procedure TypeCheckAssign(prog : TdwsProgram; exec : TdwsExecution); override;
94
   end;
95

96
   TBigIntegerPlusAssignExpr = class(TBigIntegerOpAssignExpr)
97
     procedure EvalNoResult(exec : TdwsExecution); override;
98
   end;
99
   TBigIntegerMinusAssignExpr = class(TBigIntegerOpAssignExpr)
100
     procedure EvalNoResult(exec : TdwsExecution); override;
101
   end;
102
   TBigIntegerMultAssignExpr = class(TBigIntegerOpAssignExpr)
103
     procedure EvalNoResult(exec : TdwsExecution); override;
104
   end;
105

106
   TBigIntegerRelOpExpr = class(TBoolRelOpExpr)
107
     function Optimize(prog : TdwsProgram; exec : TdwsExecution) : TProgramExpr; override;
108
   end;
109
   TBigIntegerRelOpExprClass = class of TBigIntegerRelOpExpr;
110

111
   TBigIntegerEqualOpExpr = class(TBigIntegerRelOpExpr)
112
     function EvalAsBoolean(exec : TdwsExecution) : Boolean; override;
113
   end;
114
   TBigIntegerNotEqualOpExpr = class(TBigIntegerRelOpExpr)
115
     function EvalAsBoolean(exec : TdwsExecution) : Boolean; override;
116
   end;
117
   TBigIntegerGreaterOpExpr = class(TBigIntegerRelOpExpr)
118
     function EvalAsBoolean(exec : TdwsExecution) : Boolean; override;
119
   end;
120
   TBigIntegerGreaterEqualOpExpr = class(TBigIntegerRelOpExpr)
121
     function EvalAsBoolean(exec : TdwsExecution) : Boolean; override;
122
   end;
123
   TBigIntegerLessOpExpr = class(TBigIntegerRelOpExpr)
124
     function EvalAsBoolean(exec : TdwsExecution) : Boolean; override;
125
   end;
126
   TBigIntegerLessEqualOpExpr = class(TBigIntegerRelOpExpr)
127
     function EvalAsBoolean(exec : TdwsExecution) : Boolean; override;
128
   end;
129

130
   TBigIntegerCompareZeroExpr = class(TUnaryOpBoolExpr)
131
      private
132
         FOp : TTokenType;
133
      public
134
         constructor Create(prog : TdwsProgram; expr : TTypedExpr; op : TTokenType); reintroduce;
135
         function EvalAsBoolean(exec : TdwsExecution) : Boolean; override;
136
   end;
137

138
   TBigIntegerUnaryOpExpr = class (TUnaryOpExpr)
139
      public
140
         constructor Create(prog : TdwsProgram; expr : TTypedExpr); override;
141
   end;
142

143
   TConvIntegerToBigIntegerExpr = class(TBigIntegerUnaryOpExpr)
144
      procedure EvalAsVariant(exec : TdwsExecution; var result : Variant); override;
145
   end;
146
   TConvStringToBigIntegerExpr = class(TBigIntegerUnaryOpExpr)
147
      procedure EvalAsVariant(exec : TdwsExecution; var result : Variant); override;
148
   end;
149
   TConvBigIntegerToIntegerExpr = class(TUnaryOpIntExpr)
150
      function  EvalAsInteger(exec : TdwsExecution) : Int64; override;
151
   end;
152
   TConvBigIntegerToFloatExpr = class(TUnaryOpFloatExpr)
153
      function  EvalAsFloat(exec : TdwsExecution) : Double; override;
154
   end;
155

156
   TBigIntegerToStringFunc = class(TInternalMagicStringFunction)
157
      procedure DoEvalAsString(const args : TExprBaseListExec; var Result : UnicodeString); override;
158
   end;
159
   TStringToBigIntegerFunc = class(TInternalMagicVariantFunction)
160
      procedure DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant); override;
161
   end;
162
   TBigIntegerToHexFunc = class(TInternalMagicStringFunction)
163
      procedure DoEvalAsString(const args : TExprBaseListExec; var Result : UnicodeString); override;
164
   end;
165
   THexToBigIntegerFunc = class(TInternalMagicVariantFunction)
166
      procedure DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant); override;
167
   end;
168

169
   TBigIntegerToBlobFunc = class(TInternalMagicVariantFunction)
170
      procedure DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant); override;
171
   end;
172
   TBlobToBigIntegerFunc = class(TInternalMagicVariantFunction)
173
      procedure DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant); override;
174
   end;
175

176
   TBigIntegerToFloatFunc = class(TInternalMagicFloatFunction)
177
      procedure DoEvalAsFloat(const args : TExprBaseListExec; var Result : Double); override;
178
   end;
179
   TBigIntegerToIntegerFunc = class(TInternalMagicIntFunction)
180
      function DoEvalAsInteger(const args : TExprBaseListExec) : Int64; override;
181
   end;
182

183
   TBigIntegerOddFunc = class(TInternalMagicBoolFunction)
184
      function DoEvalAsBoolean(const args : TExprBaseListExec) : Boolean; override;
185
   end;
186
   TBigIntegerEvenFunc = class(TInternalMagicBoolFunction)
187
      function DoEvalAsBoolean(const args : TExprBaseListExec) : Boolean; override;
188
   end;
189

190
   TBigIntegerSignFunc = class(TInternalMagicIntFunction)
191
      function DoEvalAsInteger(const args : TExprBaseListExec) : Int64; override;
192
   end;
193

194
   TBigIntegerBitLengthFunc = class(TInternalMagicIntFunction)
195
      function DoEvalAsInteger(const args : TExprBaseListExec) : Int64; override;
196
   end;
197

198
   TBigIntegerAbsExpr = class(TBigIntegerUnaryOpExpr)
199
      public
200
         procedure EvalAsVariant(exec : TdwsExecution; var result : Variant); override;
201
   end;
202

203
   TBigIntegerGcdFunc = class(TInternalMagicVariantFunction)
204
      procedure DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant); override;
205
   end;
206

207
   TBigIntegerPowerFunc = class(TInternalMagicVariantFunction)
208
      procedure DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant); override;
209
   end;
210

211
   TBigIntegerSqrFunc = class(TInternalMagicVariantFunction)
212
      procedure DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant); override;
213
   end;
214

215
   TBigIntegerModPowFunc = class(TInternalMagicVariantFunction)
216
      procedure DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant); override;
217
   end;
218

219
   TBigIntegerDivModFunc = class(TInternalMagicProcedure)
220
      procedure DoEvalProc(const args : TExprBaseListExec); override;
221
   end;
222

223
   TBigIntegerRandomFunc = class(TInternalMagicVariantFunction)
224
      procedure DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant); override;
225
   end;
226

227
// ------------------------------------------------------------------
228
// ------------------------------------------------------------------
229
// ------------------------------------------------------------------
230
implementation
231
// ------------------------------------------------------------------
232
// ------------------------------------------------------------------
233
// ------------------------------------------------------------------
234

235
// RegisterBigIntegerType                                      
236
//
237
procedure RegisterBigIntegerType(systemTable : TSystemSymbolTable; unitSyms : TUnitMainSymbols;
238
                                 unitTable : TSymbolTable);
239
var
240
   typBigInteger : TBaseBigIntegerSymbol;
241
begin
242
   if systemTable.FindLocal(SYS_BIGINTEGER)<>nil then exit;
243

244
   typBigInteger:=TBaseBigIntegerSymbol.Create;
245

246
   systemTable.AddSymbol(typBigInteger);
247
end;
248

249
// RegisterBigIntegerOperators
250
//
251
procedure RegisterBigIntegerOperators(systemTable : TSystemSymbolTable;
252
                                  unitTable : TSymbolTable; operators : TOperators);
253
var
254
   typBigInteger : TBaseBigIntegerSymbol;
255

256
   procedure RegisterOperators(token : TTokenType; exprClass : TBinaryOpExprClass);
257
   begin
258
      operators.RegisterOperator(token, exprClass, typBigInteger, typBigInteger);
259
      operators.RegisterOperator(token, exprClass, systemTable.TypInteger, typBigInteger);
260
      operators.RegisterOperator(token, exprClass, typBigInteger, systemTable.TypInteger);
261
   end;
262

263
begin
264
   typBigInteger:=systemTable.FindTypeSymbol(SYS_BIGINTEGER, cvMagic) as TBaseBigIntegerSymbol;
265

266
   if operators.FindCaster(typBigInteger, systemTable.TypInteger) <> nil then Exit;
267

268
   RegisterOperators(ttPLUS,     TBigIntegerAddOpExpr);
269
   RegisterOperators(ttMINUS,    TBigIntegerSubOpExpr);
270
   RegisterOperators(ttTIMES,    TBigIntegerMultOpExpr);
271
   RegisterOperators(ttDIV,      TBigIntegerDivOpExpr);
272
   RegisterOperators(ttMOD,      TBigIntegerModOpExpr);
273

274
   operators.RegisterOperator(ttSHL, TBigIntegerShiftLeftExpr,   typBigInteger, systemTable.TypInteger);
275
   operators.RegisterOperator(ttSAR, TBigIntegerShiftRightExpr,  typBigInteger, systemTable.TypInteger);
276

277
   operators.RegisterOperator(ttPLUS_ASSIGN,  TBigIntegerPlusAssignExpr, typBigInteger, typBigInteger);
278
   operators.RegisterOperator(ttPLUS_ASSIGN,  TBigIntegerPlusAssignExpr, typBigInteger, systemTable.TypInteger);
279
   operators.RegisterOperator(ttMINUS_ASSIGN, TBigIntegerMinusAssignExpr, typBigInteger, typBigInteger);
280
   operators.RegisterOperator(ttMINUS_ASSIGN, TBigIntegerMinusAssignExpr, typBigInteger, systemTable.TypInteger);
281
   operators.RegisterOperator(ttTIMES_ASSIGN, TBigIntegerMultAssignExpr, typBigInteger, typBigInteger);
282
   operators.RegisterOperator(ttTIMES_ASSIGN, TBigIntegerMultAssignExpr, typBigInteger, systemTable.TypInteger);
283

284
   RegisterOperators(ttEQ,       TBigIntegerEqualOpExpr);
285
   RegisterOperators(ttNOTEQ,    TBigIntegerNotEqualOpExpr);
286
   RegisterOperators(ttGTR,      TBigIntegerGreaterOpExpr);
287
   RegisterOperators(ttGTREQ,    TBigIntegerGreaterEqualOpExpr);
288
   RegisterOperators(ttLESS,     TBigIntegerLessOpExpr);
289
   RegisterOperators(ttLESSEQ,   TBigIntegerLessEqualOpExpr);
290

291
   operators.RegisterCaster(typBigInteger, systemTable.TypInteger, TConvIntegerToBigIntegerExpr);
292
   operators.RegisterCaster(typBigInteger, systemTable.TypString,  TConvStringToBigIntegerExpr);
293
   operators.RegisterCaster(systemTable.TypInteger, typBigInteger, TConvBigIntegerToIntegerExpr);
294
   operators.RegisterCaster(systemTable.TypFloat, typBigInteger,   TConvBigIntegerToFloatExpr);
295
end;
296

297
// HandleBigIntegerAbs
298
//
299
function HandleBigIntegerAbs(prog : TdwsProgram; argExpr : TTypedExpr) : TTypedExpr;
300
begin
301
   if argExpr.Typ.UnAliasedTypeIs(TBaseBigIntegerSymbol) then
302
      Result:=TBigIntegerAbsExpr.Create(prog, argExpr)
303
   else Result:=nil;
304
end;
305

306
type
307
   TTypedExprBigIntegerHelper = class helper for TTypedExpr
308
      function EvalAsBigInteger(exec : TdwsExecution) : BigInteger;
309
   end;
310

311
function TTypedExprBigIntegerHelper.EvalAsBigInteger(exec : TdwsExecution) : BigInteger;
312
var
313
   v : Variant;
314
begin
315
   if Typ.UnAliasedType.ClassType = TBaseBigIntegerSymbol then begin
316
      EvalAsVariant(exec, v);
317
      Assert(TVarData(v).VType=varUnknown);
318
      if TVarData(v).VUnknown<>nil then
319
         Result := IdwsBigInteger(TVarData(v).VUnknown).GetValue
320
      else Result := BigInteger.Zero;
321
   end else Result := EvalAsInteger(exec);
322
end;
323

324
// ArgBigInteger
325
//
326
function ArgBigInteger(const args : TExprBaseListExec; index : Integer) : BigInteger;
327
begin
328
   Result := (args.ExprBase[index] as TTypedExpr).EvalAsBigInteger(args.Exec);
329
end;
330

331
// BigIntegerWrap            )
332
//
333
function BigIntegerWrap(const bi : BigInteger) : IInterface;
334
begin
335
   Result := TBigIntegerWrapper.Create(bi) as IdwsBigInteger;
336
end;
337

338
// ------------------
339
// ------------------ TBaseBigIntegerSymbol ------------------
340
// ------------------
341

342
// Create
343
//
344
constructor TBaseBigIntegerSymbol.Create;
345
begin
346
   inherited Create(SYS_BIGINTEGER);
347
end;
348

349
// IsCompatible
350
//
351
function TBaseBigIntegerSymbol.IsCompatible(typSym : TTypeSymbol) : Boolean;
352
begin
353
   Result:=(typSym<>nil) and (typSym.UnAliasedType.ClassType=TBaseBigIntegerSymbol);
354
end;
355

356
// InitData
357
//
358
procedure TBaseBigIntegerSymbol.InitData(const data : TData; offset : Integer);
359
begin
360
   data[offset] := IUnknown(nil);
361
end;
362

363
// ------------------
364
// ------------------ TBigIntegerWrapper ------------------
365
// ------------------
366

367
// Create
368
//
369
constructor TBigIntegerWrapper.Create(const aBigInteger : BigInteger);
370
begin
371
   FData := aBigInteger;
372
end;
373

374
// GetValue
375
//
376
function TBigIntegerWrapper.GetValue : BigInteger;
377
begin
378
   Result := FData;
379
end;
380

381
// SetValue
382
//
383
procedure TBigIntegerWrapper.SetValue(const v : BigInteger);
384
begin
385
   FData := v;
386
end;
387

388
// GetSelf
389
//
390
function TBigIntegerWrapper.GetSelf : TObject;
391
begin
392
   Result := Self;
393
end;
394

395
// ToString
396
//
397
function TBigIntegerWrapper.ToString : String;
398
begin
399
   Result := FData.ToString;
400
end;
401

402
// ------------------
403
// ------------------ TBigIntegerOpExpr ------------------
404
// ------------------
405

406
// Create
407
//
408
constructor TBigIntegerOpExpr.Create(Prog: TdwsProgram; const aScriptPos : TScriptPos; aLeft, aRight : TTypedExpr);
409
begin
410
   inherited;
411
   if aLeft.Typ.UnAliasedTypeIs(TBaseIntegerSymbol) then
412
      Typ := aRight.Typ
413
   else Typ := aLeft.Typ;
414
end;
415

416
// ------------------
417
// ------------------ TBigIntegerAddOpExpr ------------------
418
// ------------------
419

420
procedure TBigIntegerAddOpExpr.EvalAsVariant(exec : TdwsExecution; var result : Variant);
421
begin
422
   result := BigIntegerWrap(Left.EvalAsBigInteger(exec) + Right.EvalAsBigInteger(exec));
423
end;
424

425
// ------------------
426
// ------------------ TBigIntegerSubOpExpr ------------------
427
// ------------------
428

429
procedure TBigIntegerSubOpExpr.EvalAsVariant(exec : TdwsExecution; var result : Variant);
430
begin
431
   result := BigIntegerWrap(Left.EvalAsBigInteger(exec) - Right.EvalAsBigInteger(exec));
432
end;
433

434
// ------------------
435
// ------------------ TBigIntegerMultOpExpr ------------------
436
// ------------------
437

438
procedure TBigIntegerMultOpExpr.EvalAsVariant(exec : TdwsExecution; var result : Variant);
439
begin
440
   result := BigIntegerWrap(Left.EvalAsBigInteger(exec) * Right.EvalAsBigInteger(exec));
441
end;
442

443
// ------------------
444
// ------------------ TBigIntegerDivOpExpr ------------------
445
// ------------------
446

447
procedure TBigIntegerDivOpExpr.EvalAsVariant(exec : TdwsExecution; var result : Variant);
448
begin
449
   result := BigIntegerWrap(Left.EvalAsBigInteger(exec) div Right.EvalAsBigInteger(exec));
450
end;
451

452
// ------------------
453
// ------------------ TBigIntegerModOpExpr ------------------
454
// ------------------
455

456
procedure TBigIntegerModOpExpr.EvalAsVariant(exec : TdwsExecution; var result : Variant);
457
begin
458
   result := BigIntegerWrap(Left.EvalAsBigInteger(exec) mod Right.EvalAsBigInteger(exec));
459
end;
460

461
// ------------------
462
// ------------------ TBigIntegerRelOpExpr ------------------
463
// ------------------
464

465
// Optimize
466
//
467
function TBigIntegerRelOpExpr.Optimize(prog : TdwsProgram; exec : TdwsExecution) : TProgramExpr;
468
type
469
   TRelOpConverter = record
470
      ro : TBigIntegerRelOpExprClass;
471
      opR, opL : TTokenType;
472
   end;
473
   PRelOpConverter = ^TRelOpConverter;
474

475
const
476
   cRelOpConverters : array [0..5] of TRelOpConverter = (
477
         ( ro : TBigIntegerEqualOpExpr;         opR : ttEQ;       opL : ttEQ     ),
478
         ( ro : TBigIntegerNotEqualOpExpr;      opR : ttNOTEQ;    opL : ttNOTEQ  ),
479
         ( ro : TBigIntegerGreaterOpExpr;       opR : ttGTR;      opL : ttLESS   ),
480
         ( ro : TBigIntegerGreaterEqualOpExpr;  opR : ttGTREQ;    opL : ttLESSEQ ),
481
         ( ro : TBigIntegerLessOpExpr;          opR : ttLESS;     opL : ttGTR    ),
482
         ( ro : TBigIntegerLessEqualOpExpr;     opR : ttLESSEQ;   opL : ttGTREQ  )
483
      );
484

485
   function IsZero(expr : TTypedExpr) : Boolean;
486
   begin
487
      Result := (expr.ClassType = TConstIntExpr) and (TConstIntExpr(expr).Value = 0);
488
   end;
489

490
   function RelOpConverter : PRelOpConverter;
491
   var
492
      ct : TClass;
493
      i : Integer;
494
   begin
495
      ct := ClassType;
496
      for i := 0 to High(cRelOpConverters) do begin
497
         Result := @cRelOpConverters[i];
498
         if Result.ro = ct then Exit;
499
      end;
500
      raise Exception.Create('Unsupported rel op');
501
   end;
502

503
begin
504
   if IsZero(Left) and Right.Typ.UnAliasedTypeIs(TBaseBigIntegerSymbol) then begin
505
      Result := TBigIntegerCompareZeroExpr.Create(prog, Right, RelOpConverter.opL);
506
      FRight := nil;
507
      Free;
508
      Exit;
509
   end else if IsZero(Right) and Left.Typ.UnAliasedTypeIs(TBaseBigIntegerSymbol) then begin
510
      Result := TBigIntegerCompareZeroExpr.Create(prog, Left, RelOpConverter.opR);
511
      FLeft := nil;
512
      Free;
513
   end else Result := Self;
514
end;
515

516
// ------------------
517
// ------------------ TBigIntegerEqualOpExpr ------------------
518
// ------------------
519

520
function TBigIntegerEqualOpExpr.EvalAsBoolean(exec : TdwsExecution) : Boolean;
521
begin
522
   Result := Left.EvalAsBigInteger(exec) = Right.EvalAsBigInteger(exec);
523
end;
524

525
// ------------------
526
// ------------------ TBigIntegerNotEqualOpExpr ------------------
527
// ------------------
528

529
function TBigIntegerNotEqualOpExpr.EvalAsBoolean(exec : TdwsExecution) : Boolean;
530
begin
531
   Result := Left.EvalAsBigInteger(exec) <> Right.EvalAsBigInteger(exec);
532
end;
533

534
// ------------------
535
// ------------------ TBigIntegerGreaterOpExpr ------------------
536
// ------------------
537

538
function TBigIntegerGreaterOpExpr.EvalAsBoolean(exec : TdwsExecution) : Boolean;
539
begin
540
   Result := Left.EvalAsBigInteger(exec) > Right.EvalAsBigInteger(exec);
541
end;
542

543
// ------------------
544
// ------------------ TBigIntegerGreaterEqualOpExpr ------------------
545
// ------------------
546

547
function TBigIntegerGreaterEqualOpExpr.EvalAsBoolean(exec : TdwsExecution) : Boolean;
548
begin
549
   Result := Left.EvalAsBigInteger(exec) >= Right.EvalAsBigInteger(exec);
550
end;
551

552
// ------------------
553
// ------------------ TBigIntegerLessOpExpr ------------------
554
// ------------------
555

556
function TBigIntegerLessOpExpr.EvalAsBoolean(exec : TdwsExecution) : Boolean;
557
begin
558
   Result := Left.EvalAsBigInteger(exec) < Right.EvalAsBigInteger(exec);
559
end;
560

561
// ------------------
562
// ------------------ TBigIntegerLessEqualOpExpr ------------------
563
// ------------------
564

565
function TBigIntegerLessEqualOpExpr.EvalAsBoolean(exec : TdwsExecution) : Boolean;
566
begin
567
   Result := Left.EvalAsBigInteger(exec) <= Right.EvalAsBigInteger(exec);
568
end;
569

570
// ------------------
571
// ------------------ TBigIntegerCompareZeroExpr ------------------
572
// ------------------
573

574
// Create
575
//
576
constructor TBigIntegerCompareZeroExpr.Create(prog : TdwsProgram; expr : TTypedExpr; op : TTokenType);
577
begin
578
   inherited Create(prog, expr);
579
   FOp := op;
580
end;
581

582
// EvalAsBoolean
583
//
584
function TBigIntegerCompareZeroExpr.EvalAsBoolean(exec : TdwsExecution) : Boolean;
585
var
586
   bi : BigInteger;
587
begin
588
   bi := Expr.EvalAsBigInteger(exec);
589
   case FOp of
590
      ttEQ :      Result := bi.IsZero;
591
      ttNOTEQ :   Result := not bi.IsZero;
592
      ttGTR :     Result := bi.IsPositive;
593
      ttGTREQ  :  Result := bi.IsPositive or bi.IsZero;
594
      ttLESS :    Result := bi.IsNegative;
595
      ttLESSEQ :  Result := bi.IsNegative or bi.IsZero;
596
   else
597
      Assert(False);
598
      Result := False;
599
   end;
600
end;
601

602
// ------------------
603
// ------------------ TBigIntegerUnaryOpExpr ------------------
604
// ------------------
605

606
constructor TBigIntegerUnaryOpExpr.Create(prog : TdwsProgram; expr : TTypedExpr);
607
begin
608
   inherited Create(prog, expr);
609
   Typ := prog.Root.SystemTable.SymbolTable.FindTypeSymbol(SYS_BIGINTEGER, cvMagic);
610
end;
611

612
// ------------------
613
// ------------------ TConvIntegerToBigIntegerExpr ------------------
614
// ------------------
615

616
procedure TConvIntegerToBigIntegerExpr.EvalAsVariant(exec : TdwsExecution; var result : Variant);
617
begin
618
   result := BigIntegerWrap( BigInteger( Expr.EvalAsInteger(exec) ) );
619
end;
620

621
// ------------------
622
// ------------------ TConvStringToBigIntegerExpr ------------------
623
// ------------------
624

625
procedure TConvStringToBigIntegerExpr.EvalAsVariant(exec : TdwsExecution; var result : Variant);
626
var
627
   s : String;
628
begin
629
   Expr.EvalAsString(exec, s);
630
   result := BigIntegerWrap( BigInteger.Parse( s, 10 ) );
631
end;
632

633
// ------------------
634
// ------------------ TConvBigIntegerToIntegerExpr ------------------
635
// ------------------
636

637
function TConvBigIntegerToIntegerExpr.EvalAsInteger(exec : TdwsExecution) : Int64;
638
begin
639
   result := Expr.EvalAsBigInteger(exec).AsInt64;
640
end;
641

642
// ------------------
643
// ------------------ TConvBigIntegerToFloatExpr ------------------
644
// ------------------
645

646
function TConvBigIntegerToFloatExpr.EvalAsFloat(exec : TdwsExecution) : Double;
647
begin
648
   result := Expr.EvalAsBigInteger(exec).AsDouble;
649
end;
650

651
// ------------------
652
// ------------------ TBigIntegerToStringFunc ------------------
653
// ------------------
654

655
// DoEvalAsString
656
//
657
procedure TBigIntegerToStringFunc.DoEvalAsString(const args : TExprBaseListExec; var Result : UnicodeString);
658
begin
659
   Result := ArgBigInteger(args, 0).ToString(args.AsInteger[1]);
660
end;
661

662
// ------------------
663
// ------------------ TStringToBigIntegerFunc ------------------
664
// ------------------
665

666
// DoEvalAsVariant
667
//
668
procedure TStringToBigIntegerFunc.DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant);
669
begin
670
   result := BigIntegerWrap( BigInteger.Parse( args.AsString[0], args.AsInteger[1] ) );
671
end;
672

673
// ------------------
674
// ------------------ TBigIntegerToHexFunc ------------------
675
// ------------------
676

677
// DoEvalAsString
678
//
679
procedure TBigIntegerToHexFunc.DoEvalAsString(const args : TExprBaseListExec; var Result : UnicodeString);
680
begin
681
   Result := ArgBigInteger(args, 0).ToHexString;
682
end;
683

684
// ------------------
685
// ------------------ THexToBigIntegerFunc ------------------
686
// ------------------
687

688
// DoEvalAsVariant
689
//
690
procedure THexToBigIntegerFunc.DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant);
691
begin
692
   result := BigIntegerWrap( BigInteger.Parse( args.AsString[0], 16 ) );
693
end;
694

695
// ------------------
696
// ------------------ TBigIntegerToFloatFunc ------------------
697
// ------------------
698

699
procedure TBigIntegerToFloatFunc.DoEvalAsFloat(const args : TExprBaseListExec; var Result : Double);
700
begin
701
   Result := ArgBigInteger(args, 0).AsDouble;
702
end;
703

704
// ------------------
705
// ------------------ TBigIntegerToIntegerFunc ------------------
706
// ------------------
707

708
function TBigIntegerToIntegerFunc.DoEvalAsInteger(const args : TExprBaseListExec) : Int64;
709
begin
710
   Result := ArgBigInteger(args, 0).AsInt64;
711
end;
712

713
// ------------------
714
// ------------------ TBigIntegerOddFunc ------------------
715
// ------------------
716

717
function TBigIntegerOddFunc.DoEvalAsBoolean(const args : TExprBaseListExec) : Boolean;
718
begin
719
   Result := not ArgBigInteger(args, 0).IsEven;
720
end;
721

722
// ------------------
723
// ------------------ TBigIntegerEvenFunc ------------------
724
// ------------------
725

726
function TBigIntegerEvenFunc.DoEvalAsBoolean(const args : TExprBaseListExec) : Boolean;
727
begin
728
   Result := ArgBigInteger(args, 0).IsEven;
729
end;
730

731
// ------------------
732
// ------------------ TBigIntegerSignFunc ------------------
733
// ------------------
734

735
function TBigIntegerSignFunc.DoEvalAsInteger(const args : TExprBaseListExec) : Int64;
736
begin
737
   Result := ArgBigInteger(args, 0).Sign;
738
end;
739

740
// ------------------
741
// ------------------ TBigIntegerAbsExpr ------------------
742
// ------------------
743

744
// EvalAsVariant
745
//
746
procedure TBigIntegerAbsExpr.EvalAsVariant(exec : TdwsExecution; var result : Variant);
747
begin
748
   result := BigIntegerWrap( BigInteger.Abs(Expr.EvalAsBigInteger(exec)) );
749
end;
750

751
// ------------------
752
// ------------------ TBigIntegerGcdFunc ------------------
753
// ------------------
754

755
procedure TBigIntegerGcdFunc.DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant);
756
begin
757
   result := BigIntegerWrap( BigInteger.GreatestCommonDivisor(ArgBigInteger(args, 0), ArgBigInteger(args, 1)) );
758
end;
759

760
// ------------------
761
// ------------------ TBigIntegerPowerFunc ------------------
762
// ------------------
763

764
procedure TBigIntegerPowerFunc.DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant);
765
begin
766
   result := BigIntegerWrap( BigInteger.Pow(ArgBigInteger(args, 0), args.AsInteger[1]) );
767
end;
768

769
// ------------------
770
// ------------------ TBigIntegerSqrFunc ------------------
771
// ------------------
772

773
procedure TBigIntegerSqrFunc.DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant);
774
begin
775
   result := BigIntegerWrap( BigInteger.Sqr(ArgBigInteger(args, 0)) );
776
end;
777

778
// ------------------
779
// ------------------ TBigIntegerDivModFunc ------------------
780
// ------------------
781

782
procedure TBigIntegerDivModFunc.DoEvalProc(const args : TExprBaseListExec);
783
var
784
   q, r : BigInteger;
785
begin
786
   BigInteger.DivMod(ArgBigInteger(args, 0), ArgBigInteger(args, 1), q, r);
787
   args.ExprBase[2].AssignValue(args.Exec, BigIntegerWrap(q));
788
   args.ExprBase[3].AssignValue(args.Exec, BigIntegerWrap(r));
789
end;
790

791
// ------------------
792
// ------------------ TBigIntegerToBlobFunc ------------------
793
// ------------------
794

795
procedure TBigIntegerToBlobFunc.DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant);
796
var
797
   bufBytes : TArray<Byte>;
798
   bufString : RawByteString;
799
   pSrc, pDest : PByte;
800
   i, n : Integer;
801
begin
802
   bufBytes := ArgBigInteger(args, 0).ToByteArray;
803
   n := Length(bufBytes);
804
   SetLength(bufString, n);
805
   pSrc := @bufBytes[n-1];
806
   pDest := Pointer(bufString);
807
   for i := 1 to n do begin
808
      pDest^ := pSrc^;
809
      Inc(pDest);
810
      Dec(pSrc);
811
   end;
812
   Result := bufString;
813
end;
814

815
// ------------------
816
// ------------------ TBlobToBigIntegerFunc ------------------
817
// ------------------
818

819
procedure TBlobToBigIntegerFunc.DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant);
820
var
821
   bufBytes : TArray<Byte>;
822
   bufString : String;
823
   pSrc : PChar;
824
   pDest : PByte;
825
   i, n : Integer;
826
begin
827
   bufString := args.AsString[0];
828
   n := Length(bufString);
829
   SetLength(bufBytes, n);
830
   pDest := @bufBytes[n-1];
831
   pSrc := Pointer(bufString);
832
   for i := 1 to n do begin
833
      pDest^ := Byte(pSrc^);
834
      Dec(pDest);
835
      Inc(pSrc);
836
   end;
837
   Result := BigIntegerWrap( BigInteger.Create(bufBytes) );
838
end;
839

840
// ------------------
841
// ------------------ TBigIntegerShiftLeftExpr ------------------
842
// ------------------
843

844
procedure TBigIntegerShiftLeftExpr.EvalAsVariant(exec : TdwsExecution; var result : Variant);
845
begin
846
   result := BigIntegerWrap( Left.EvalAsBigInteger(exec) shl Right.EvalAsInteger(exec) );
847
end;
848

849
// ------------------
850
// ------------------ TBigIntegerShiftRightExpr ------------------
851
// ------------------
852

853
procedure TBigIntegerShiftRightExpr.EvalAsVariant(exec : TdwsExecution; var result : Variant);
854
begin
855
   result := BigIntegerWrap( Left.EvalAsBigInteger(exec) shr Right.EvalAsInteger(exec) );
856
end;
857

858
// ------------------
859
// ------------------ TBigIntegerOpAssignExpr ------------------
860
// ------------------
861

862
procedure TBigIntegerOpAssignExpr.TypeCheckAssign(prog : TdwsProgram; exec : TdwsExecution);
863
begin
864
   // nothing here
865
end;
866

867
// ------------------
868
// ------------------ TBigIntegerPlusAssignExpr ------------------
869
// ------------------
870

871
procedure TBigIntegerPlusAssignExpr.EvalNoResult(exec : TdwsExecution);
872
begin
873
   FLeft.AssignValue(exec, BigIntegerWrap( FLeft.EvalAsBigInteger(exec) + FRight.EvalAsBigInteger(exec) ));
874
end;
875

876
// ------------------
877
// ------------------ TBigIntegerMinusAssignExpr ------------------
878
// ------------------
879

880
procedure TBigIntegerMinusAssignExpr.EvalNoResult(exec : TdwsExecution);
881
begin
882
   FLeft.AssignValue(exec, BigIntegerWrap( FLeft.EvalAsBigInteger(exec) - FRight.EvalAsBigInteger(exec) ));
883
end;
884

885
// ------------------
886
// ------------------ TBigIntegerMultAssignExpr ------------------
887
// ------------------
888

889
procedure TBigIntegerMultAssignExpr.EvalNoResult(exec : TdwsExecution);
890
begin
891
   FLeft.AssignValue(exec, BigIntegerWrap( FLeft.EvalAsBigInteger(exec) * FRight.EvalAsBigInteger(exec) ));
892
end;
893

894
// ------------------
895
// ------------------ TBigIntegerRandomFunc ------------------
896
// ------------------
897

898
// DoEvalAsVariant
899
//
900
procedure TBigIntegerRandomFunc.DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant);
901

902
   function RandomBigIntegerOfBitLength(nb : Integer) : BigInteger;
903
   var
904
      mask : Integer;
905
      bytes : TBytes;
906
      rnd : RawByteString;
907
   begin
908
      // adapted from BigInteger.Create(NumBits: Integer; const Random: IRandom)
909
      // uses cryptographic random
910
      rnd := CryptographicRandom( (nb + 7) div 8 + 1 );
911
      Setlength(bytes, Length(rnd));
912
      System.Move(rnd[1], bytes[0], Length(rnd));
913

914
      // One byte too many was allocated, to get a top byte of 0, i.e. always positive.
915
      bytes[High(Bytes)] := 0;
916

917
      // Set bits above required bit length to 0.
918
      mask := $7F shr (7 - (nb and 7));
919
      bytes[High(bytes)-1] := bytes[High(bytes)-1] and mask;
920

921
      result := BigInteger.Create(bytes);
922
   end;
923

924
var
925
   bi, limit : BigInteger;
926
   bits : Integer;
927
begin
928
   limit := ArgBigInteger(args, 0);
929
   if limit.IsZero or limit.IsNegative or limit.IsOne then begin
930
      bi := BigInteger.Zero;
931
   end else begin
932
      bits := limit.BitLength;
933
      repeat
934
         bi := RandomBigIntegerOfBitLength(bits);
935
      until bi < limit;
936
   end;
937
   result := BigIntegerWrap( bi );
938
end;
939

940
// ------------------
941
// ------------------ TBigIntegerBitLengthFunc ------------------
942
// ------------------
943

944
function TBigIntegerBitLengthFunc.DoEvalAsInteger(const args : TExprBaseListExec) : Int64;
945
begin
946
   Result := ArgBigInteger(args, 0).BitLength;
947
end;
948

949
// ------------------
950
// ------------------ TBigIntegerModPowFunc ------------------
951
// ------------------
952

953
// DoEvalAsVariant
954
//
955
procedure TBigIntegerModPowFunc.DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant);
956
begin
957
   Result := BigIntegerWrap(BigInteger.ModPow( ArgBigInteger(args, 0), ArgBigInteger(args, 1), ArgBigInteger(args, 2) ));
958
end;
959

960
// ------------------------------------------------------------------
961
// ------------------------------------------------------------------
962
// ------------------------------------------------------------------
963
initialization
964
// ------------------------------------------------------------------
965
// ------------------------------------------------------------------
966
// ------------------------------------------------------------------
967

968
   dwsInternalUnit.AddSymbolsRegistrationProc(RegisterBigIntegerType);
969
   dwsInternalUnit.AddOperatorsRegistrationProc(RegisterBigIntegerOperators);
970
   dwsInternalUnit.AddAbsHandler(HandleBigIntegerAbs);
971

972
   RegisterInternalStringFunction(TBigIntegerToStringFunc,  'BigIntegerToHex', ['v', SYS_BIGINTEGER, 'base=10', SYS_INTEGER], [iffStateLess], 'ToString');
973
   RegisterInternalFunction(TStringToBigIntegerFunc,        'StringToBigInteger', ['s', SYS_STRING, 'base=10', SYS_INTEGER], SYS_BIGINTEGER, [iffStateLess], 'ToBigInteger');
974
   RegisterInternalStringFunction(TBigIntegerToHexFunc,     'BigIntegerToHex', ['v', SYS_BIGINTEGER], [iffStateLess], 'ToHex');
975
   RegisterInternalFunction(THexToBigIntegerFunc,           'HexToBigInteger', ['h', SYS_STRING], SYS_BIGINTEGER, [iffStateLess], 'HexToBigInteger');
976

977
   RegisterInternalFunction(TBigIntegerToBlobFunc,          'BigIntegerToBlobParameter', ['v', SYS_BIGINTEGER], SYS_VARIANT, [iffStateLess], 'ToBlobParameter');
978
   RegisterInternalFunction(TBlobToBigIntegerFunc,          'BlobFieldToBigInteger', ['b', SYS_STRING], SYS_BIGINTEGER, [iffStateLess]);
979

980
   RegisterInternalFloatFunction(TBigIntegerToFloatFunc,    '',   ['v', SYS_BIGINTEGER], [iffStateLess], 'ToFloat');
981
   RegisterInternalIntFunction(TBigIntegerToIntegerFunc,    '',   ['v', SYS_BIGINTEGER], [iffStateLess], 'ToInteger');
982

983
   RegisterInternalBoolFunction(TBigIntegerOddFunc,   'Odd',      ['i', SYS_BIGINTEGER], [iffStateLess, iffOverloaded], 'IsOdd');
984
   RegisterInternalBoolFunction(TBigIntegerEvenFunc,  'Even',     ['i', SYS_BIGINTEGER], [iffStateLess, iffOverloaded], 'IsEven');
985
   RegisterInternalIntFunction(TBigIntegerSignFunc,   'Sign',     ['v', SYS_BIGINTEGER], [iffStateLess, iffOverloaded], 'Sign');
986
   RegisterInternalIntFunction(TBigIntegerBitLengthFunc, '',      ['v', SYS_BIGINTEGER], [iffStateLess], 'BitLength');
987
   RegisterInternalFunction(TBigIntegerGcdFunc,       'Gcd',      ['a', SYS_BIGINTEGER, 'b', SYS_BIGINTEGER], SYS_BIGINTEGER, [iffStateLess, iffOverloaded]);
988
   RegisterInternalFunction(TBigIntegerPowerFunc,     'IntPower', ['base', SYS_BIGINTEGER, 'exponent', SYS_INTEGER], SYS_BIGINTEGER, [iffStateLess, iffOverloaded], 'Power');
989
   RegisterInternalFunction(TBigIntegerSqrFunc,       'Sqr',      ['v', SYS_BIGINTEGER], SYS_BIGINTEGER, [iffStateLess, iffOverloaded], 'Sqr');
990

991
   RegisterInternalProcedure(TBigIntegerDivModFunc,   'DivMod',
992
                             ['dividend', SYS_BIGINTEGER, 'divisor', SYS_BIGINTEGER,
993
                              '@result', SYS_BIGINTEGER, '@remainder', SYS_BIGINTEGER], '', [iffOverloaded]);
994
   RegisterInternalFunction(TBigIntegerModPowFunc,    'ModPow',   ['base', SYS_BIGINTEGER, 'exponent', SYS_BIGINTEGER, 'modulus', SYS_BIGINTEGER],
995
                                                                  SYS_BIGINTEGER, [iffStateLess, iffOverloaded], 'ModPow');
996
   RegisterInternalFunction(TBigIntegerModPowFunc,    'ModPow',   ['base', SYS_BIGINTEGER, 'exponent', SYS_INTEGER, 'modulus', SYS_BIGINTEGER],
997
                                                                  SYS_BIGINTEGER, [iffStateLess, iffOverloaded], 'ModPow');
998

999
   RegisterInternalFunction(TBigIntegerRandomFunc,   'RandomBigInteger', ['limitPlusOne', SYS_BIGINTEGER], SYS_BIGINTEGER);
1000

1001
end.
1002

1003