MathgeomGLS
1000 строк · 35.8 Кб
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{**********************************************************************}
17unit dwsBigIntegerFunctions;
18
19{$I dws.inc}
20
21interface
22
23uses
24Classes, System.SysUtils,
25dwsXPlatform, dwsUtils, dwsStrings,
26dwsFunctions, dwsSymbols, dwsExprs, dwsCoreExprs, dwsExprList, dwsUnitSymbols,
27dwsConstExprs, dwsMagicExprs, dwsDataContext, dwsErrors, dwsRelExprs,
28dwsOperators, dwsTokenizer, dwsCryptoXPlatform,
29Velthuis.BigIntegers;
30
31const
32SYS_BIGINTEGER = 'BigInteger';
33
34type
35
36TBaseBigIntegerSymbol = class (TBaseSymbol)
37public
38constructor Create;
39
40function IsCompatible(typSym : TTypeSymbol) : Boolean; override;
41procedure InitData(const data : TData; offset : Integer); override;
42end;
43
44IdwsBigInteger = interface
45['{93A7FA32-DE99-44AB-A5B4-861FD50E9AAB}']
46function GetValue : BigInteger;
47procedure SetValue(const v : BigInteger);
48property Value : BigInteger read GetValue write SetValue;
49end;
50
51TBigIntegerWrapper = class (TInterfacedObject, IdwsBigInteger, IGetSelf)
52private
53FData : BigInteger;
54
55protected
56function GetValue : BigInteger;
57procedure SetValue(const v : BigInteger);
58function GetSelf : TObject;
59
60public
61constructor Create(const aBigInteger : BigInteger);
62function ToString : String; override;
63end;
64
65TBigIntegerOpExpr = class(TBinaryOpExpr)
66constructor Create(Prog: TdwsProgram; const aScriptPos : TScriptPos; aLeft, aRight : TTypedExpr); override;
67end;
68
69TBigIntegerAddOpExpr = class(TBigIntegerOpExpr)
70procedure EvalAsVariant(exec : TdwsExecution; var result : Variant); override;
71end;
72TBigIntegerSubOpExpr = class(TBigIntegerOpExpr)
73procedure EvalAsVariant(exec : TdwsExecution; var result : Variant); override;
74end;
75TBigIntegerMultOpExpr = class(TBigIntegerOpExpr)
76procedure EvalAsVariant(exec : TdwsExecution; var result : Variant); override;
77end;
78TBigIntegerDivOpExpr = class(TBigIntegerOpExpr)
79procedure EvalAsVariant(exec : TdwsExecution; var result : Variant); override;
80end;
81TBigIntegerModOpExpr = class(TBigIntegerOpExpr)
82procedure EvalAsVariant(exec : TdwsExecution; var result : Variant); override;
83end;
84
85TBigIntegerShiftLeftExpr = class(TBigIntegerOpExpr)
86procedure EvalAsVariant(exec : TdwsExecution; var result : Variant); override;
87end;
88TBigIntegerShiftRightExpr = class(TBigIntegerOpExpr)
89procedure EvalAsVariant(exec : TdwsExecution; var result : Variant); override;
90end;
91
92TBigIntegerOpAssignExpr = class(TOpAssignExpr)
93procedure TypeCheckAssign(prog : TdwsProgram; exec : TdwsExecution); override;
94end;
95
96TBigIntegerPlusAssignExpr = class(TBigIntegerOpAssignExpr)
97procedure EvalNoResult(exec : TdwsExecution); override;
98end;
99TBigIntegerMinusAssignExpr = class(TBigIntegerOpAssignExpr)
100procedure EvalNoResult(exec : TdwsExecution); override;
101end;
102TBigIntegerMultAssignExpr = class(TBigIntegerOpAssignExpr)
103procedure EvalNoResult(exec : TdwsExecution); override;
104end;
105
106TBigIntegerRelOpExpr = class(TBoolRelOpExpr)
107function Optimize(prog : TdwsProgram; exec : TdwsExecution) : TProgramExpr; override;
108end;
109TBigIntegerRelOpExprClass = class of TBigIntegerRelOpExpr;
110
111TBigIntegerEqualOpExpr = class(TBigIntegerRelOpExpr)
112function EvalAsBoolean(exec : TdwsExecution) : Boolean; override;
113end;
114TBigIntegerNotEqualOpExpr = class(TBigIntegerRelOpExpr)
115function EvalAsBoolean(exec : TdwsExecution) : Boolean; override;
116end;
117TBigIntegerGreaterOpExpr = class(TBigIntegerRelOpExpr)
118function EvalAsBoolean(exec : TdwsExecution) : Boolean; override;
119end;
120TBigIntegerGreaterEqualOpExpr = class(TBigIntegerRelOpExpr)
121function EvalAsBoolean(exec : TdwsExecution) : Boolean; override;
122end;
123TBigIntegerLessOpExpr = class(TBigIntegerRelOpExpr)
124function EvalAsBoolean(exec : TdwsExecution) : Boolean; override;
125end;
126TBigIntegerLessEqualOpExpr = class(TBigIntegerRelOpExpr)
127function EvalAsBoolean(exec : TdwsExecution) : Boolean; override;
128end;
129
130TBigIntegerCompareZeroExpr = class(TUnaryOpBoolExpr)
131private
132FOp : TTokenType;
133public
134constructor Create(prog : TdwsProgram; expr : TTypedExpr; op : TTokenType); reintroduce;
135function EvalAsBoolean(exec : TdwsExecution) : Boolean; override;
136end;
137
138TBigIntegerUnaryOpExpr = class (TUnaryOpExpr)
139public
140constructor Create(prog : TdwsProgram; expr : TTypedExpr); override;
141end;
142
143TConvIntegerToBigIntegerExpr = class(TBigIntegerUnaryOpExpr)
144procedure EvalAsVariant(exec : TdwsExecution; var result : Variant); override;
145end;
146TConvStringToBigIntegerExpr = class(TBigIntegerUnaryOpExpr)
147procedure EvalAsVariant(exec : TdwsExecution; var result : Variant); override;
148end;
149TConvBigIntegerToIntegerExpr = class(TUnaryOpIntExpr)
150function EvalAsInteger(exec : TdwsExecution) : Int64; override;
151end;
152TConvBigIntegerToFloatExpr = class(TUnaryOpFloatExpr)
153function EvalAsFloat(exec : TdwsExecution) : Double; override;
154end;
155
156TBigIntegerToStringFunc = class(TInternalMagicStringFunction)
157procedure DoEvalAsString(const args : TExprBaseListExec; var Result : UnicodeString); override;
158end;
159TStringToBigIntegerFunc = class(TInternalMagicVariantFunction)
160procedure DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant); override;
161end;
162TBigIntegerToHexFunc = class(TInternalMagicStringFunction)
163procedure DoEvalAsString(const args : TExprBaseListExec; var Result : UnicodeString); override;
164end;
165THexToBigIntegerFunc = class(TInternalMagicVariantFunction)
166procedure DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant); override;
167end;
168
169TBigIntegerToBlobFunc = class(TInternalMagicVariantFunction)
170procedure DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant); override;
171end;
172TBlobToBigIntegerFunc = class(TInternalMagicVariantFunction)
173procedure DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant); override;
174end;
175
176TBigIntegerToFloatFunc = class(TInternalMagicFloatFunction)
177procedure DoEvalAsFloat(const args : TExprBaseListExec; var Result : Double); override;
178end;
179TBigIntegerToIntegerFunc = class(TInternalMagicIntFunction)
180function DoEvalAsInteger(const args : TExprBaseListExec) : Int64; override;
181end;
182
183TBigIntegerOddFunc = class(TInternalMagicBoolFunction)
184function DoEvalAsBoolean(const args : TExprBaseListExec) : Boolean; override;
185end;
186TBigIntegerEvenFunc = class(TInternalMagicBoolFunction)
187function DoEvalAsBoolean(const args : TExprBaseListExec) : Boolean; override;
188end;
189
190TBigIntegerSignFunc = class(TInternalMagicIntFunction)
191function DoEvalAsInteger(const args : TExprBaseListExec) : Int64; override;
192end;
193
194TBigIntegerBitLengthFunc = class(TInternalMagicIntFunction)
195function DoEvalAsInteger(const args : TExprBaseListExec) : Int64; override;
196end;
197
198TBigIntegerAbsExpr = class(TBigIntegerUnaryOpExpr)
199public
200procedure EvalAsVariant(exec : TdwsExecution; var result : Variant); override;
201end;
202
203TBigIntegerGcdFunc = class(TInternalMagicVariantFunction)
204procedure DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant); override;
205end;
206
207TBigIntegerPowerFunc = class(TInternalMagicVariantFunction)
208procedure DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant); override;
209end;
210
211TBigIntegerSqrFunc = class(TInternalMagicVariantFunction)
212procedure DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant); override;
213end;
214
215TBigIntegerModPowFunc = class(TInternalMagicVariantFunction)
216procedure DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant); override;
217end;
218
219TBigIntegerDivModFunc = class(TInternalMagicProcedure)
220procedure DoEvalProc(const args : TExprBaseListExec); override;
221end;
222
223TBigIntegerRandomFunc = class(TInternalMagicVariantFunction)
224procedure DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant); override;
225end;
226
227// ------------------------------------------------------------------
228// ------------------------------------------------------------------
229// ------------------------------------------------------------------
230implementation
231// ------------------------------------------------------------------
232// ------------------------------------------------------------------
233// ------------------------------------------------------------------
234
235// RegisterBigIntegerType
236//
237procedure RegisterBigIntegerType(systemTable : TSystemSymbolTable; unitSyms : TUnitMainSymbols;
238unitTable : TSymbolTable);
239var
240typBigInteger : TBaseBigIntegerSymbol;
241begin
242if systemTable.FindLocal(SYS_BIGINTEGER)<>nil then exit;
243
244typBigInteger:=TBaseBigIntegerSymbol.Create;
245
246systemTable.AddSymbol(typBigInteger);
247end;
248
249// RegisterBigIntegerOperators
250//
251procedure RegisterBigIntegerOperators(systemTable : TSystemSymbolTable;
252unitTable : TSymbolTable; operators : TOperators);
253var
254typBigInteger : TBaseBigIntegerSymbol;
255
256procedure RegisterOperators(token : TTokenType; exprClass : TBinaryOpExprClass);
257begin
258operators.RegisterOperator(token, exprClass, typBigInteger, typBigInteger);
259operators.RegisterOperator(token, exprClass, systemTable.TypInteger, typBigInteger);
260operators.RegisterOperator(token, exprClass, typBigInteger, systemTable.TypInteger);
261end;
262
263begin
264typBigInteger:=systemTable.FindTypeSymbol(SYS_BIGINTEGER, cvMagic) as TBaseBigIntegerSymbol;
265
266if operators.FindCaster(typBigInteger, systemTable.TypInteger) <> nil then Exit;
267
268RegisterOperators(ttPLUS, TBigIntegerAddOpExpr);
269RegisterOperators(ttMINUS, TBigIntegerSubOpExpr);
270RegisterOperators(ttTIMES, TBigIntegerMultOpExpr);
271RegisterOperators(ttDIV, TBigIntegerDivOpExpr);
272RegisterOperators(ttMOD, TBigIntegerModOpExpr);
273
274operators.RegisterOperator(ttSHL, TBigIntegerShiftLeftExpr, typBigInteger, systemTable.TypInteger);
275operators.RegisterOperator(ttSAR, TBigIntegerShiftRightExpr, typBigInteger, systemTable.TypInteger);
276
277operators.RegisterOperator(ttPLUS_ASSIGN, TBigIntegerPlusAssignExpr, typBigInteger, typBigInteger);
278operators.RegisterOperator(ttPLUS_ASSIGN, TBigIntegerPlusAssignExpr, typBigInteger, systemTable.TypInteger);
279operators.RegisterOperator(ttMINUS_ASSIGN, TBigIntegerMinusAssignExpr, typBigInteger, typBigInteger);
280operators.RegisterOperator(ttMINUS_ASSIGN, TBigIntegerMinusAssignExpr, typBigInteger, systemTable.TypInteger);
281operators.RegisterOperator(ttTIMES_ASSIGN, TBigIntegerMultAssignExpr, typBigInteger, typBigInteger);
282operators.RegisterOperator(ttTIMES_ASSIGN, TBigIntegerMultAssignExpr, typBigInteger, systemTable.TypInteger);
283
284RegisterOperators(ttEQ, TBigIntegerEqualOpExpr);
285RegisterOperators(ttNOTEQ, TBigIntegerNotEqualOpExpr);
286RegisterOperators(ttGTR, TBigIntegerGreaterOpExpr);
287RegisterOperators(ttGTREQ, TBigIntegerGreaterEqualOpExpr);
288RegisterOperators(ttLESS, TBigIntegerLessOpExpr);
289RegisterOperators(ttLESSEQ, TBigIntegerLessEqualOpExpr);
290
291operators.RegisterCaster(typBigInteger, systemTable.TypInteger, TConvIntegerToBigIntegerExpr);
292operators.RegisterCaster(typBigInteger, systemTable.TypString, TConvStringToBigIntegerExpr);
293operators.RegisterCaster(systemTable.TypInteger, typBigInteger, TConvBigIntegerToIntegerExpr);
294operators.RegisterCaster(systemTable.TypFloat, typBigInteger, TConvBigIntegerToFloatExpr);
295end;
296
297// HandleBigIntegerAbs
298//
299function HandleBigIntegerAbs(prog : TdwsProgram; argExpr : TTypedExpr) : TTypedExpr;
300begin
301if argExpr.Typ.UnAliasedTypeIs(TBaseBigIntegerSymbol) then
302Result:=TBigIntegerAbsExpr.Create(prog, argExpr)
303else Result:=nil;
304end;
305
306type
307TTypedExprBigIntegerHelper = class helper for TTypedExpr
308function EvalAsBigInteger(exec : TdwsExecution) : BigInteger;
309end;
310
311function TTypedExprBigIntegerHelper.EvalAsBigInteger(exec : TdwsExecution) : BigInteger;
312var
313v : Variant;
314begin
315if Typ.UnAliasedType.ClassType = TBaseBigIntegerSymbol then begin
316EvalAsVariant(exec, v);
317Assert(TVarData(v).VType=varUnknown);
318if TVarData(v).VUnknown<>nil then
319Result := IdwsBigInteger(TVarData(v).VUnknown).GetValue
320else Result := BigInteger.Zero;
321end else Result := EvalAsInteger(exec);
322end;
323
324// ArgBigInteger
325//
326function ArgBigInteger(const args : TExprBaseListExec; index : Integer) : BigInteger;
327begin
328Result := (args.ExprBase[index] as TTypedExpr).EvalAsBigInteger(args.Exec);
329end;
330
331// BigIntegerWrap )
332//
333function BigIntegerWrap(const bi : BigInteger) : IInterface;
334begin
335Result := TBigIntegerWrapper.Create(bi) as IdwsBigInteger;
336end;
337
338// ------------------
339// ------------------ TBaseBigIntegerSymbol ------------------
340// ------------------
341
342// Create
343//
344constructor TBaseBigIntegerSymbol.Create;
345begin
346inherited Create(SYS_BIGINTEGER);
347end;
348
349// IsCompatible
350//
351function TBaseBigIntegerSymbol.IsCompatible(typSym : TTypeSymbol) : Boolean;
352begin
353Result:=(typSym<>nil) and (typSym.UnAliasedType.ClassType=TBaseBigIntegerSymbol);
354end;
355
356// InitData
357//
358procedure TBaseBigIntegerSymbol.InitData(const data : TData; offset : Integer);
359begin
360data[offset] := IUnknown(nil);
361end;
362
363// ------------------
364// ------------------ TBigIntegerWrapper ------------------
365// ------------------
366
367// Create
368//
369constructor TBigIntegerWrapper.Create(const aBigInteger : BigInteger);
370begin
371FData := aBigInteger;
372end;
373
374// GetValue
375//
376function TBigIntegerWrapper.GetValue : BigInteger;
377begin
378Result := FData;
379end;
380
381// SetValue
382//
383procedure TBigIntegerWrapper.SetValue(const v : BigInteger);
384begin
385FData := v;
386end;
387
388// GetSelf
389//
390function TBigIntegerWrapper.GetSelf : TObject;
391begin
392Result := Self;
393end;
394
395// ToString
396//
397function TBigIntegerWrapper.ToString : String;
398begin
399Result := FData.ToString;
400end;
401
402// ------------------
403// ------------------ TBigIntegerOpExpr ------------------
404// ------------------
405
406// Create
407//
408constructor TBigIntegerOpExpr.Create(Prog: TdwsProgram; const aScriptPos : TScriptPos; aLeft, aRight : TTypedExpr);
409begin
410inherited;
411if aLeft.Typ.UnAliasedTypeIs(TBaseIntegerSymbol) then
412Typ := aRight.Typ
413else Typ := aLeft.Typ;
414end;
415
416// ------------------
417// ------------------ TBigIntegerAddOpExpr ------------------
418// ------------------
419
420procedure TBigIntegerAddOpExpr.EvalAsVariant(exec : TdwsExecution; var result : Variant);
421begin
422result := BigIntegerWrap(Left.EvalAsBigInteger(exec) + Right.EvalAsBigInteger(exec));
423end;
424
425// ------------------
426// ------------------ TBigIntegerSubOpExpr ------------------
427// ------------------
428
429procedure TBigIntegerSubOpExpr.EvalAsVariant(exec : TdwsExecution; var result : Variant);
430begin
431result := BigIntegerWrap(Left.EvalAsBigInteger(exec) - Right.EvalAsBigInteger(exec));
432end;
433
434// ------------------
435// ------------------ TBigIntegerMultOpExpr ------------------
436// ------------------
437
438procedure TBigIntegerMultOpExpr.EvalAsVariant(exec : TdwsExecution; var result : Variant);
439begin
440result := BigIntegerWrap(Left.EvalAsBigInteger(exec) * Right.EvalAsBigInteger(exec));
441end;
442
443// ------------------
444// ------------------ TBigIntegerDivOpExpr ------------------
445// ------------------
446
447procedure TBigIntegerDivOpExpr.EvalAsVariant(exec : TdwsExecution; var result : Variant);
448begin
449result := BigIntegerWrap(Left.EvalAsBigInteger(exec) div Right.EvalAsBigInteger(exec));
450end;
451
452// ------------------
453// ------------------ TBigIntegerModOpExpr ------------------
454// ------------------
455
456procedure TBigIntegerModOpExpr.EvalAsVariant(exec : TdwsExecution; var result : Variant);
457begin
458result := BigIntegerWrap(Left.EvalAsBigInteger(exec) mod Right.EvalAsBigInteger(exec));
459end;
460
461// ------------------
462// ------------------ TBigIntegerRelOpExpr ------------------
463// ------------------
464
465// Optimize
466//
467function TBigIntegerRelOpExpr.Optimize(prog : TdwsProgram; exec : TdwsExecution) : TProgramExpr;
468type
469TRelOpConverter = record
470ro : TBigIntegerRelOpExprClass;
471opR, opL : TTokenType;
472end;
473PRelOpConverter = ^TRelOpConverter;
474
475const
476cRelOpConverters : 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
485function IsZero(expr : TTypedExpr) : Boolean;
486begin
487Result := (expr.ClassType = TConstIntExpr) and (TConstIntExpr(expr).Value = 0);
488end;
489
490function RelOpConverter : PRelOpConverter;
491var
492ct : TClass;
493i : Integer;
494begin
495ct := ClassType;
496for i := 0 to High(cRelOpConverters) do begin
497Result := @cRelOpConverters[i];
498if Result.ro = ct then Exit;
499end;
500raise Exception.Create('Unsupported rel op');
501end;
502
503begin
504if IsZero(Left) and Right.Typ.UnAliasedTypeIs(TBaseBigIntegerSymbol) then begin
505Result := TBigIntegerCompareZeroExpr.Create(prog, Right, RelOpConverter.opL);
506FRight := nil;
507Free;
508Exit;
509end else if IsZero(Right) and Left.Typ.UnAliasedTypeIs(TBaseBigIntegerSymbol) then begin
510Result := TBigIntegerCompareZeroExpr.Create(prog, Left, RelOpConverter.opR);
511FLeft := nil;
512Free;
513end else Result := Self;
514end;
515
516// ------------------
517// ------------------ TBigIntegerEqualOpExpr ------------------
518// ------------------
519
520function TBigIntegerEqualOpExpr.EvalAsBoolean(exec : TdwsExecution) : Boolean;
521begin
522Result := Left.EvalAsBigInteger(exec) = Right.EvalAsBigInteger(exec);
523end;
524
525// ------------------
526// ------------------ TBigIntegerNotEqualOpExpr ------------------
527// ------------------
528
529function TBigIntegerNotEqualOpExpr.EvalAsBoolean(exec : TdwsExecution) : Boolean;
530begin
531Result := Left.EvalAsBigInteger(exec) <> Right.EvalAsBigInteger(exec);
532end;
533
534// ------------------
535// ------------------ TBigIntegerGreaterOpExpr ------------------
536// ------------------
537
538function TBigIntegerGreaterOpExpr.EvalAsBoolean(exec : TdwsExecution) : Boolean;
539begin
540Result := Left.EvalAsBigInteger(exec) > Right.EvalAsBigInteger(exec);
541end;
542
543// ------------------
544// ------------------ TBigIntegerGreaterEqualOpExpr ------------------
545// ------------------
546
547function TBigIntegerGreaterEqualOpExpr.EvalAsBoolean(exec : TdwsExecution) : Boolean;
548begin
549Result := Left.EvalAsBigInteger(exec) >= Right.EvalAsBigInteger(exec);
550end;
551
552// ------------------
553// ------------------ TBigIntegerLessOpExpr ------------------
554// ------------------
555
556function TBigIntegerLessOpExpr.EvalAsBoolean(exec : TdwsExecution) : Boolean;
557begin
558Result := Left.EvalAsBigInteger(exec) < Right.EvalAsBigInteger(exec);
559end;
560
561// ------------------
562// ------------------ TBigIntegerLessEqualOpExpr ------------------
563// ------------------
564
565function TBigIntegerLessEqualOpExpr.EvalAsBoolean(exec : TdwsExecution) : Boolean;
566begin
567Result := Left.EvalAsBigInteger(exec) <= Right.EvalAsBigInteger(exec);
568end;
569
570// ------------------
571// ------------------ TBigIntegerCompareZeroExpr ------------------
572// ------------------
573
574// Create
575//
576constructor TBigIntegerCompareZeroExpr.Create(prog : TdwsProgram; expr : TTypedExpr; op : TTokenType);
577begin
578inherited Create(prog, expr);
579FOp := op;
580end;
581
582// EvalAsBoolean
583//
584function TBigIntegerCompareZeroExpr.EvalAsBoolean(exec : TdwsExecution) : Boolean;
585var
586bi : BigInteger;
587begin
588bi := Expr.EvalAsBigInteger(exec);
589case FOp of
590ttEQ : Result := bi.IsZero;
591ttNOTEQ : Result := not bi.IsZero;
592ttGTR : Result := bi.IsPositive;
593ttGTREQ : Result := bi.IsPositive or bi.IsZero;
594ttLESS : Result := bi.IsNegative;
595ttLESSEQ : Result := bi.IsNegative or bi.IsZero;
596else
597Assert(False);
598Result := False;
599end;
600end;
601
602// ------------------
603// ------------------ TBigIntegerUnaryOpExpr ------------------
604// ------------------
605
606constructor TBigIntegerUnaryOpExpr.Create(prog : TdwsProgram; expr : TTypedExpr);
607begin
608inherited Create(prog, expr);
609Typ := prog.Root.SystemTable.SymbolTable.FindTypeSymbol(SYS_BIGINTEGER, cvMagic);
610end;
611
612// ------------------
613// ------------------ TConvIntegerToBigIntegerExpr ------------------
614// ------------------
615
616procedure TConvIntegerToBigIntegerExpr.EvalAsVariant(exec : TdwsExecution; var result : Variant);
617begin
618result := BigIntegerWrap( BigInteger( Expr.EvalAsInteger(exec) ) );
619end;
620
621// ------------------
622// ------------------ TConvStringToBigIntegerExpr ------------------
623// ------------------
624
625procedure TConvStringToBigIntegerExpr.EvalAsVariant(exec : TdwsExecution; var result : Variant);
626var
627s : String;
628begin
629Expr.EvalAsString(exec, s);
630result := BigIntegerWrap( BigInteger.Parse( s, 10 ) );
631end;
632
633// ------------------
634// ------------------ TConvBigIntegerToIntegerExpr ------------------
635// ------------------
636
637function TConvBigIntegerToIntegerExpr.EvalAsInteger(exec : TdwsExecution) : Int64;
638begin
639result := Expr.EvalAsBigInteger(exec).AsInt64;
640end;
641
642// ------------------
643// ------------------ TConvBigIntegerToFloatExpr ------------------
644// ------------------
645
646function TConvBigIntegerToFloatExpr.EvalAsFloat(exec : TdwsExecution) : Double;
647begin
648result := Expr.EvalAsBigInteger(exec).AsDouble;
649end;
650
651// ------------------
652// ------------------ TBigIntegerToStringFunc ------------------
653// ------------------
654
655// DoEvalAsString
656//
657procedure TBigIntegerToStringFunc.DoEvalAsString(const args : TExprBaseListExec; var Result : UnicodeString);
658begin
659Result := ArgBigInteger(args, 0).ToString(args.AsInteger[1]);
660end;
661
662// ------------------
663// ------------------ TStringToBigIntegerFunc ------------------
664// ------------------
665
666// DoEvalAsVariant
667//
668procedure TStringToBigIntegerFunc.DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant);
669begin
670result := BigIntegerWrap( BigInteger.Parse( args.AsString[0], args.AsInteger[1] ) );
671end;
672
673// ------------------
674// ------------------ TBigIntegerToHexFunc ------------------
675// ------------------
676
677// DoEvalAsString
678//
679procedure TBigIntegerToHexFunc.DoEvalAsString(const args : TExprBaseListExec; var Result : UnicodeString);
680begin
681Result := ArgBigInteger(args, 0).ToHexString;
682end;
683
684// ------------------
685// ------------------ THexToBigIntegerFunc ------------------
686// ------------------
687
688// DoEvalAsVariant
689//
690procedure THexToBigIntegerFunc.DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant);
691begin
692result := BigIntegerWrap( BigInteger.Parse( args.AsString[0], 16 ) );
693end;
694
695// ------------------
696// ------------------ TBigIntegerToFloatFunc ------------------
697// ------------------
698
699procedure TBigIntegerToFloatFunc.DoEvalAsFloat(const args : TExprBaseListExec; var Result : Double);
700begin
701Result := ArgBigInteger(args, 0).AsDouble;
702end;
703
704// ------------------
705// ------------------ TBigIntegerToIntegerFunc ------------------
706// ------------------
707
708function TBigIntegerToIntegerFunc.DoEvalAsInteger(const args : TExprBaseListExec) : Int64;
709begin
710Result := ArgBigInteger(args, 0).AsInt64;
711end;
712
713// ------------------
714// ------------------ TBigIntegerOddFunc ------------------
715// ------------------
716
717function TBigIntegerOddFunc.DoEvalAsBoolean(const args : TExprBaseListExec) : Boolean;
718begin
719Result := not ArgBigInteger(args, 0).IsEven;
720end;
721
722// ------------------
723// ------------------ TBigIntegerEvenFunc ------------------
724// ------------------
725
726function TBigIntegerEvenFunc.DoEvalAsBoolean(const args : TExprBaseListExec) : Boolean;
727begin
728Result := ArgBigInteger(args, 0).IsEven;
729end;
730
731// ------------------
732// ------------------ TBigIntegerSignFunc ------------------
733// ------------------
734
735function TBigIntegerSignFunc.DoEvalAsInteger(const args : TExprBaseListExec) : Int64;
736begin
737Result := ArgBigInteger(args, 0).Sign;
738end;
739
740// ------------------
741// ------------------ TBigIntegerAbsExpr ------------------
742// ------------------
743
744// EvalAsVariant
745//
746procedure TBigIntegerAbsExpr.EvalAsVariant(exec : TdwsExecution; var result : Variant);
747begin
748result := BigIntegerWrap( BigInteger.Abs(Expr.EvalAsBigInteger(exec)) );
749end;
750
751// ------------------
752// ------------------ TBigIntegerGcdFunc ------------------
753// ------------------
754
755procedure TBigIntegerGcdFunc.DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant);
756begin
757result := BigIntegerWrap( BigInteger.GreatestCommonDivisor(ArgBigInteger(args, 0), ArgBigInteger(args, 1)) );
758end;
759
760// ------------------
761// ------------------ TBigIntegerPowerFunc ------------------
762// ------------------
763
764procedure TBigIntegerPowerFunc.DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant);
765begin
766result := BigIntegerWrap( BigInteger.Pow(ArgBigInteger(args, 0), args.AsInteger[1]) );
767end;
768
769// ------------------
770// ------------------ TBigIntegerSqrFunc ------------------
771// ------------------
772
773procedure TBigIntegerSqrFunc.DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant);
774begin
775result := BigIntegerWrap( BigInteger.Sqr(ArgBigInteger(args, 0)) );
776end;
777
778// ------------------
779// ------------------ TBigIntegerDivModFunc ------------------
780// ------------------
781
782procedure TBigIntegerDivModFunc.DoEvalProc(const args : TExprBaseListExec);
783var
784q, r : BigInteger;
785begin
786BigInteger.DivMod(ArgBigInteger(args, 0), ArgBigInteger(args, 1), q, r);
787args.ExprBase[2].AssignValue(args.Exec, BigIntegerWrap(q));
788args.ExprBase[3].AssignValue(args.Exec, BigIntegerWrap(r));
789end;
790
791// ------------------
792// ------------------ TBigIntegerToBlobFunc ------------------
793// ------------------
794
795procedure TBigIntegerToBlobFunc.DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant);
796var
797bufBytes : TArray<Byte>;
798bufString : RawByteString;
799pSrc, pDest : PByte;
800i, n : Integer;
801begin
802bufBytes := ArgBigInteger(args, 0).ToByteArray;
803n := Length(bufBytes);
804SetLength(bufString, n);
805pSrc := @bufBytes[n-1];
806pDest := Pointer(bufString);
807for i := 1 to n do begin
808pDest^ := pSrc^;
809Inc(pDest);
810Dec(pSrc);
811end;
812Result := bufString;
813end;
814
815// ------------------
816// ------------------ TBlobToBigIntegerFunc ------------------
817// ------------------
818
819procedure TBlobToBigIntegerFunc.DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant);
820var
821bufBytes : TArray<Byte>;
822bufString : String;
823pSrc : PChar;
824pDest : PByte;
825i, n : Integer;
826begin
827bufString := args.AsString[0];
828n := Length(bufString);
829SetLength(bufBytes, n);
830pDest := @bufBytes[n-1];
831pSrc := Pointer(bufString);
832for i := 1 to n do begin
833pDest^ := Byte(pSrc^);
834Dec(pDest);
835Inc(pSrc);
836end;
837Result := BigIntegerWrap( BigInteger.Create(bufBytes) );
838end;
839
840// ------------------
841// ------------------ TBigIntegerShiftLeftExpr ------------------
842// ------------------
843
844procedure TBigIntegerShiftLeftExpr.EvalAsVariant(exec : TdwsExecution; var result : Variant);
845begin
846result := BigIntegerWrap( Left.EvalAsBigInteger(exec) shl Right.EvalAsInteger(exec) );
847end;
848
849// ------------------
850// ------------------ TBigIntegerShiftRightExpr ------------------
851// ------------------
852
853procedure TBigIntegerShiftRightExpr.EvalAsVariant(exec : TdwsExecution; var result : Variant);
854begin
855result := BigIntegerWrap( Left.EvalAsBigInteger(exec) shr Right.EvalAsInteger(exec) );
856end;
857
858// ------------------
859// ------------------ TBigIntegerOpAssignExpr ------------------
860// ------------------
861
862procedure TBigIntegerOpAssignExpr.TypeCheckAssign(prog : TdwsProgram; exec : TdwsExecution);
863begin
864// nothing here
865end;
866
867// ------------------
868// ------------------ TBigIntegerPlusAssignExpr ------------------
869// ------------------
870
871procedure TBigIntegerPlusAssignExpr.EvalNoResult(exec : TdwsExecution);
872begin
873FLeft.AssignValue(exec, BigIntegerWrap( FLeft.EvalAsBigInteger(exec) + FRight.EvalAsBigInteger(exec) ));
874end;
875
876// ------------------
877// ------------------ TBigIntegerMinusAssignExpr ------------------
878// ------------------
879
880procedure TBigIntegerMinusAssignExpr.EvalNoResult(exec : TdwsExecution);
881begin
882FLeft.AssignValue(exec, BigIntegerWrap( FLeft.EvalAsBigInteger(exec) - FRight.EvalAsBigInteger(exec) ));
883end;
884
885// ------------------
886// ------------------ TBigIntegerMultAssignExpr ------------------
887// ------------------
888
889procedure TBigIntegerMultAssignExpr.EvalNoResult(exec : TdwsExecution);
890begin
891FLeft.AssignValue(exec, BigIntegerWrap( FLeft.EvalAsBigInteger(exec) * FRight.EvalAsBigInteger(exec) ));
892end;
893
894// ------------------
895// ------------------ TBigIntegerRandomFunc ------------------
896// ------------------
897
898// DoEvalAsVariant
899//
900procedure TBigIntegerRandomFunc.DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant);
901
902function RandomBigIntegerOfBitLength(nb : Integer) : BigInteger;
903var
904mask : Integer;
905bytes : TBytes;
906rnd : RawByteString;
907begin
908// adapted from BigInteger.Create(NumBits: Integer; const Random: IRandom)
909// uses cryptographic random
910rnd := CryptographicRandom( (nb + 7) div 8 + 1 );
911Setlength(bytes, Length(rnd));
912System.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.
915bytes[High(Bytes)] := 0;
916
917// Set bits above required bit length to 0.
918mask := $7F shr (7 - (nb and 7));
919bytes[High(bytes)-1] := bytes[High(bytes)-1] and mask;
920
921result := BigInteger.Create(bytes);
922end;
923
924var
925bi, limit : BigInteger;
926bits : Integer;
927begin
928limit := ArgBigInteger(args, 0);
929if limit.IsZero or limit.IsNegative or limit.IsOne then begin
930bi := BigInteger.Zero;
931end else begin
932bits := limit.BitLength;
933repeat
934bi := RandomBigIntegerOfBitLength(bits);
935until bi < limit;
936end;
937result := BigIntegerWrap( bi );
938end;
939
940// ------------------
941// ------------------ TBigIntegerBitLengthFunc ------------------
942// ------------------
943
944function TBigIntegerBitLengthFunc.DoEvalAsInteger(const args : TExprBaseListExec) : Int64;
945begin
946Result := ArgBigInteger(args, 0).BitLength;
947end;
948
949// ------------------
950// ------------------ TBigIntegerModPowFunc ------------------
951// ------------------
952
953// DoEvalAsVariant
954//
955procedure TBigIntegerModPowFunc.DoEvalAsVariant(const args : TExprBaseListExec; var result : Variant);
956begin
957Result := BigIntegerWrap(BigInteger.ModPow( ArgBigInteger(args, 0), ArgBigInteger(args, 1), ArgBigInteger(args, 2) ));
958end;
959
960// ------------------------------------------------------------------
961// ------------------------------------------------------------------
962// ------------------------------------------------------------------
963initialization
964// ------------------------------------------------------------------
965// ------------------------------------------------------------------
966// ------------------------------------------------------------------
967
968dwsInternalUnit.AddSymbolsRegistrationProc(RegisterBigIntegerType);
969dwsInternalUnit.AddOperatorsRegistrationProc(RegisterBigIntegerOperators);
970dwsInternalUnit.AddAbsHandler(HandleBigIntegerAbs);
971
972RegisterInternalStringFunction(TBigIntegerToStringFunc, 'BigIntegerToHex', ['v', SYS_BIGINTEGER, 'base=10', SYS_INTEGER], [iffStateLess], 'ToString');
973RegisterInternalFunction(TStringToBigIntegerFunc, 'StringToBigInteger', ['s', SYS_STRING, 'base=10', SYS_INTEGER], SYS_BIGINTEGER, [iffStateLess], 'ToBigInteger');
974RegisterInternalStringFunction(TBigIntegerToHexFunc, 'BigIntegerToHex', ['v', SYS_BIGINTEGER], [iffStateLess], 'ToHex');
975RegisterInternalFunction(THexToBigIntegerFunc, 'HexToBigInteger', ['h', SYS_STRING], SYS_BIGINTEGER, [iffStateLess], 'HexToBigInteger');
976
977RegisterInternalFunction(TBigIntegerToBlobFunc, 'BigIntegerToBlobParameter', ['v', SYS_BIGINTEGER], SYS_VARIANT, [iffStateLess], 'ToBlobParameter');
978RegisterInternalFunction(TBlobToBigIntegerFunc, 'BlobFieldToBigInteger', ['b', SYS_STRING], SYS_BIGINTEGER, [iffStateLess]);
979
980RegisterInternalFloatFunction(TBigIntegerToFloatFunc, '', ['v', SYS_BIGINTEGER], [iffStateLess], 'ToFloat');
981RegisterInternalIntFunction(TBigIntegerToIntegerFunc, '', ['v', SYS_BIGINTEGER], [iffStateLess], 'ToInteger');
982
983RegisterInternalBoolFunction(TBigIntegerOddFunc, 'Odd', ['i', SYS_BIGINTEGER], [iffStateLess, iffOverloaded], 'IsOdd');
984RegisterInternalBoolFunction(TBigIntegerEvenFunc, 'Even', ['i', SYS_BIGINTEGER], [iffStateLess, iffOverloaded], 'IsEven');
985RegisterInternalIntFunction(TBigIntegerSignFunc, 'Sign', ['v', SYS_BIGINTEGER], [iffStateLess, iffOverloaded], 'Sign');
986RegisterInternalIntFunction(TBigIntegerBitLengthFunc, '', ['v', SYS_BIGINTEGER], [iffStateLess], 'BitLength');
987RegisterInternalFunction(TBigIntegerGcdFunc, 'Gcd', ['a', SYS_BIGINTEGER, 'b', SYS_BIGINTEGER], SYS_BIGINTEGER, [iffStateLess, iffOverloaded]);
988RegisterInternalFunction(TBigIntegerPowerFunc, 'IntPower', ['base', SYS_BIGINTEGER, 'exponent', SYS_INTEGER], SYS_BIGINTEGER, [iffStateLess, iffOverloaded], 'Power');
989RegisterInternalFunction(TBigIntegerSqrFunc, 'Sqr', ['v', SYS_BIGINTEGER], SYS_BIGINTEGER, [iffStateLess, iffOverloaded], 'Sqr');
990
991RegisterInternalProcedure(TBigIntegerDivModFunc, 'DivMod',
992['dividend', SYS_BIGINTEGER, 'divisor', SYS_BIGINTEGER,
993'@result', SYS_BIGINTEGER, '@remainder', SYS_BIGINTEGER], '', [iffOverloaded]);
994RegisterInternalFunction(TBigIntegerModPowFunc, 'ModPow', ['base', SYS_BIGINTEGER, 'exponent', SYS_BIGINTEGER, 'modulus', SYS_BIGINTEGER],
995SYS_BIGINTEGER, [iffStateLess, iffOverloaded], 'ModPow');
996RegisterInternalFunction(TBigIntegerModPowFunc, 'ModPow', ['base', SYS_BIGINTEGER, 'exponent', SYS_INTEGER, 'modulus', SYS_BIGINTEGER],
997SYS_BIGINTEGER, [iffStateLess, iffOverloaded], 'ModPow');
998
999RegisterInternalFunction(TBigIntegerRandomFunc, 'RandomBigInteger', ['limitPlusOne', SYS_BIGINTEGER], SYS_BIGINTEGER);
1000
1001end.
1002
1003