1 unit uPSRuntime;
2 {$I PascalScript.inc}
3 {
4
5 RemObjects Pascal Script III
6 Copyright (C) 2000-2009 by Carlo Kok (ck@carlo-kok.com)
7
8 }
9
10 interface
11 uses
12 SysUtils, uPSUtils{$IFDEF DELPHI6UP}, variants{$ENDIF}{$IFDEF MACOS},uPSCMac{$ELSE}{$IFNDEF PS_NOIDISPATCH}{$IFDEF DELPHI3UP}, ActiveX, Windows{$ELSE}, Ole2{$ENDIF}{$ENDIF}{$ENDIF};
13
14
15 type
16 TPSExec = class;
17 TPSStack = class;
18 TPSRuntimeAttributes = class;
19 TPSRuntimeAttribute = class;
20
21 TPSError = (ErNoError, erCannotImport, erInvalidType, ErInternalError,
22 erInvalidHeader, erInvalidOpcode, erInvalidOpcodeParameter, erNoMainProc,
23 erOutOfGlobalVarsRange, erOutOfProcRange, ErOutOfRange, erOutOfStackRange,
24 ErTypeMismatch, erUnexpectedEof, erVersionError, ErDivideByZero, ErMathError,
25 erCouldNotCallProc, erOutofRecordRange, erOutOfMemory, erException,
26 erNullPointerException, erNullVariantError, erInterfaceNotSupported, erCustomError);
27
28 TPSStatus = (isNotLoaded, isLoaded, isRunning, isPaused);
29
30 PByteArray = ^TByteArray;
31
32 TByteArray = array[0..1023] of Byte;
33
34 PDWordArray = ^TDWordArray;
35
36 TDWordArray = array[0..1023] of Cardinal;
37 {@link(TPSProcRec)
38 PIFProcRec is a pointer to a TIProcRec record}
39 TPSProcRec = class;
40 TIFProcRec = TPSProcRec;
41 TPSExternalProcRec = class;
42 TIFPSExternalProcRec = TPSExternalProcRec;
43 TIFExternalProcRec = TPSExternalProcRec;
44 PIFProcRec = TPSProcRec;
45 PProcRec = ^TProcRec;
46
allernull47 TPSProcPtr = function(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
48
49 TPSFreeProc = procedure (Caller: TPSExec; p: PProcRec);
50
51 TPSProcRec = class
52 private
53 FAttributes: TPSRuntimeAttributes;
54 public
55
56 constructor Create(Owner: TPSExec);
57
58 destructor Destroy; override;
59
60
61 property Attributes: TPSRuntimeAttributes read FAttributes;
62 end;
63
64 TPSExternalProcRec = class(TPSProcRec)
65 private
66 FExt1: Pointer;
67 FExt2: Pointer;
68 FName: tbtstring;
69 FProcPtr: TPSProcPtr;
70 FDecl: tbtstring;
71 public
72
73 property Name: tbtstring read FName write FName;
74
75 property Decl: tbtstring read FDecl write FDecl;
76
77 property Ext1: Pointer read FExt1 write FExt1;
78
79 property Ext2: Pointer read FExt2 write FExt2;
80
81 property ProcPtr: TPSProcPtr read FProcPtr write FProcPtr;
82 end;
83
84 TPSInternalProcRec = class(TPSProcRec)
85 private
86 FData: PByteArray;
87 FLength: Cardinal;
88 FExportNameHash: Longint;
89 FExportDecl: tbtstring;
90 FExportName: tbtstring;
91 public
92
93 property Data: PByteArray read FData;
94
95 property Length: Cardinal read FLength;
96
97 property ExportNameHash: Longint read FExportNameHash;
98
99 property ExportName: tbtstring read FExportName write FExportName;
100
101 property ExportDecl: tbtstring read FExportDecl write FExportDecl;
102
103
104 destructor Destroy; override;
105 end;
106
107 TProcRec = record
108
109 Name: ShortString;
110
111 Hash: Longint;
112
113 ProcPtr: TPSProcPtr;
114
115 FreeProc: TPSFreeProc;
116
117 Ext1, Ext2: Pointer;
118 end;
119
120 PBTReturnAddress = ^TBTReturnAddress;
121
122 TBTReturnAddress = packed record
123
124 ProcNo: TPSInternalProcRec;
125
126 Position, StackBase: Cardinal;
127 end;
128
129 TPSTypeRec = class
130 private
131 FExportNameHash: Longint;
132 FExportName: tbtstring;
133 FBaseType: TPSBaseType;
134 FAttributes: TPSRuntimeAttributes;
135 protected
136 FRealSize: Cardinal;
137 public
138
139 property RealSize: Cardinal read FRealSize;
140
141 property BaseType: TPSBaseType read FBaseType write FBaseType;
142
143 property ExportName: tbtstring read FExportName write FExportName;
144
145 property ExportNameHash: Longint read FExportNameHash write FExportNameHash;
146
147 property Attributes: TPSRuntimeAttributes read FAttributes write FAttributes;
148
149 procedure CalcSize; virtual;
150
151 constructor Create(Owner: TPSExec);
152 destructor Destroy; override;
153 end;
154
155 TPSTypeRec_ProcPtr = class(TPSTypeRec)
156 private
157 FParamInfo: tbtstring;
158 public
159
160 property ParamInfo: tbtstring read FParamInfo write FParamInfo;
161 procedure CalcSize; override;
162 end;
163 PIFTypeRec = TPSTypeRec;
164
165 TPSTypeRec_Class = class(TPSTypeRec)
166 private
167 FCN: tbtstring;
168 public
169
170 property CN: tbtstring read FCN write FCN;
171 end;
172 {$IFNDEF PS_NOINTERFACES}
173
174 TPSTypeRec_Interface = class(TPSTypeRec)
175 private
176 FGuid: TGUID;
177 public
178
179 property Guid: TGUID read FGuid write FGuid;
180 end;
181 {$ENDIF}
182
183 TPSTypeRec_Array = class(TPSTypeRec)
184 private
185 FArrayType: TPSTypeRec;
186 public
187
188 property ArrayType: TPSTypeRec read FArrayType write FArrayType;
189 procedure CalcSize; override;
190 end;
191
192 TPSTypeRec_StaticArray = class(TPSTypeRec_Array)
193 private
194 FSize: Longint;
195 FStartOffset: LongInt;
196 public
197
198 property Size: Longint read FSize write FSize;
199 property StartOffset: LongInt read FStartOffset write FStartOffset;
200
201 procedure CalcSize; override;
202 end;
203
204 TPSTypeRec_Set = class(TPSTypeRec)
205 private
206 FBitSize: Longint;
207 FByteSize: Longint;
208 public
209 {The number of bytes this would require (same as realsize)}
210 property aByteSize: Longint read FByteSize write FByteSize;
211 property aBitSize: Longint read FBitSize write FBitSize;
212 procedure CalcSize; override;
213 end;
214
215 TPSTypeRec_Record = class(TPSTypeRec)
216 private
217 FFieldTypes: TPSList;
218 FRealFieldOffsets: TPSList;
219 public
220
221 property FieldTypes: TPSList read FFieldTypes;
222
223 property RealFieldOffsets: TPSList read FRealFieldOffsets;
224
225 procedure CalcSize; override;
226
227 constructor Create(Owner: TPSExec);
228 destructor Destroy; override;
229 end;
230
231 PPSVariant = ^TPSVariant;
232
233 PIFVariant = PPSVariant;
234
235 TPSVariant = packed record
236 FType: TPSTypeRec;
237 end;
238
239 PPSVariantData = ^TPSVariantData;
240
241 TPSVariantData = packed record
242 VI: TPSVariant;
243 Data: array[0..0] of Byte;
244 end;
245
246 PPSVariantU8 = ^TPSVariantU8;
247
248 TPSVariantU8 = packed record
249 VI: TPSVariant;
250 Data: tbtU8;
251 end;
252
253
254 PPSVariantS8 = ^TPSVariantS8;
255
256 TPSVariantS8 = packed record
257 VI: TPSVariant;
258 Data: tbts8;
259 end;
260
261
262 PPSVariantU16 = ^TPSVariantU16;
263
264 TPSVariantU16 = packed record
265 VI: TPSVariant;
266 Data: tbtU16;
267 end;
268
269
270 PPSVariantS16 = ^TPSVariantS16;
271
272 TPSVariantS16 = packed record
273 VI: TPSVariant;
274 Data: tbts16;
275 end;
276
277
278 PPSVariantU32 = ^TPSVariantU32;
279
280 TPSVariantU32 = packed record
281 VI: TPSVariant;
282 Data: tbtU32;
283 end;
284
285
286 PPSVariantS32 = ^TPSVariantS32;
287
288 TPSVariantS32 = packed record
289 VI: TPSVariant;
290 Data: tbts32;
291 end;
292 {$IFNDEF PS_NOINT64}
293
294 PPSVariantS64 = ^TPSVariantS64;
295
296 TPSVariantS64 = packed record
297 VI: TPSVariant;
298 Data: tbts64;
299 end;
300 {$ENDIF}
301
302 PPSVariantAChar = ^TPSVariantAChar;
303
304 TPSVariantAChar = packed record
305 VI: TPSVariant;
306 Data: tbtChar;
307 end;
308
309 {$IFNDEF PS_NOWIDESTRING}
310
311 PPSVariantWChar = ^TPSVariantWChar;
312
313 TPSVariantWChar = packed record
314 VI: TPSVariant;
315 Data: tbtWideChar;
316 end;
317 {$ENDIF}
318
319 PPSVariantAString = ^TPSVariantAString;
320
321 TPSVariantAString = packed record
322 VI: TPSVariant;
323 Data: tbtString;
324 end;
325
326 {$IFNDEF PS_NOWIDESTRING}
327
328 PPSVariantWString = ^TPSVariantWString;
329
330 TPSVariantWString = {$IFNDEF DELPHI2009UP}packed {$ENDIF}record
331 VI: TPSVariant;
332 Data: tbtWideString;
333 end;
334
335 PPSVariantUString = ^TPSVariantUString;
336
337 TPSVariantUString = {$IFNDEF DELPHI2009UP}packed {$ENDIF}record
338 VI: TPSVariant;
339 Data: tbtunicodestring;
340 end;
341
342 {$ENDIF}
343
344
345 PPSVariantSingle = ^TPSVariantSingle;
346
347 TPSVariantSingle = packed record
348 VI: TPSVariant;
349 Data: tbtsingle;
350 end;
351
352
353 PPSVariantDouble = ^TPSVariantDouble;
354
355 TPSVariantDouble = packed record
356 VI: TPSVariant;
357 Data: tbtDouble;
358 end;
359
360
361 PPSVariantExtended = ^TPSVariantExtended;
362
363 TPSVariantExtended = packed record
364 VI: TPSVariant;
365 Data: tbtExtended;
366 end;
367
368
369 PPSVariantCurrency = ^TPSVariantCurrency;
370
371 TPSVariantCurrency = packed record
372 VI: TPSVariant;
373 Data: tbtCurrency;
374 end;
375
376 PPSVariantSet = ^TPSVariantSet;
377
378 TPSVariantSet = packed record
379 VI: TPSVariant;
380 Data: array[0..0] of Byte;
381 end;
382
383 {$IFNDEF PS_NOINTERFACES}
384
385 PPSVariantInterface = ^TPSVariantInterface;
386
387 TPSVariantInterface = packed record
388 VI: TPSVariant;
389 Data: IUnknown;
390 end;
391 {$ENDIF}
392
393 PPSVariantClass = ^TPSVariantClass;
394
395 TPSVariantClass = packed record
396 VI: TPSVariant;
397 Data: TObject;
398 end;
399
400
401 PPSVariantRecord = ^TPSVariantRecord;
402
403 TPSVariantRecord = packed record
404 VI: TPSVariant;
405 data: array[0..0] of byte;
406 end;
407
408
409 PPSVariantDynamicArray = ^TPSVariantDynamicArray;
410
411 TPSVariantDynamicArray = packed record
412 VI: TPSVariant;
413 Data: Pointer;
414 end;
415
416
417 PPSVariantStaticArray = ^TPSVariantStaticArray;
418
419 TPSVariantStaticArray = packed record
420 VI: TPSVariant;
421 data: array[0..0] of byte;
422 end;
423
424
425 PPSVariantPointer = ^TPSVariantPointer;
426
427 TPSVariantPointer = packed record
428 VI: TPSVariant;
429 DataDest: Pointer;
430 DestType: TPSTypeRec;
431 FreeIt: LongBool;
432 end;
433
434
435 PPSVariantReturnAddress = ^TPSVariantReturnAddress;
436
437 TPSVariantReturnAddress = packed record
438 VI: TPSVariant;
439 Addr: TBTReturnAddress;
440 end;
441
442
443 PPSVariantVariant = ^TPSVariantVariant;
444
445 TPSVariantVariant = packed record
446 VI: TPSVariant;
447 Data: Variant;
448 end;
449
450 PPSVariantProcPtr = ^TPSVariantProcPtr;
451 TPSVariantProcPtr = packed record
452 VI: TPSVariant;
453 ProcNo: Cardinal;
454 Self: Pointer;
455 Ptr: Pointer;
456 {
457 ProcNo = 0 means Self/Ptr become active (Ptr = nil means it's nil)
458 }
459 end;
460
461
462 TPSVarFreeType = (
463 vtNone,
464 vtTempVar
465 );
466
467 TPSResultData = packed record
468 P: Pointer;
469 aType: TPSTypeRec;
470 FreeType: TPSVarFreeType;
471 end;
472
473
474 PPSResource = ^TPSResource;
475
476 TPSResource = record
477 Proc: Pointer;
478 P: Pointer;
479 end;
480
481 TPSAttributeUseProc = function (Sender: TPSExec; const AttribType: tbtstring; Attr: TPSRuntimeAttribute): Boolean;
482
483 TPSAttributeType = class
484 private
485 FTypeName: tbtstring;
486 FUseProc: TPSAttributeUseProc;
487 FTypeNameHash: Longint;
488 public
489
490 property UseProc: TPSAttributeUseProc read FUseProc write FUseProc;
491
492 property TypeName: tbtstring read FTypeName write FTypeName;
493
494 property TypeNameHash: Longint read FTypeNameHash write FTypeNameHash;
495 end;
496
497 PClassItem = ^TClassItem;
498
499 TClassItem = record
500
501 FName: tbtstring;
502
503 FNameHash: Longint;
504
505 b: byte;
506 case byte of
507 0: (Ptr: Pointer);
508 1: (PointerInList: Pointer);
509 3: (FReadFunc, FWriteFunc: Pointer); {Property Helper}
510 4: (Ptr2: Pointer);
511 5: (PointerInList2: Pointer);
512 6: (); {Property helper, like 3}
513 7: (); {Property helper that will pass it's name}
514 end;
515
516
517 PPSVariantIFC = ^TPSVariantIFC;
518 {Temporary variant into record}
519 TPSVariantIFC = packed record
520 Dta: Pointer;
521 aType: TPSTypeRec;
522 VarParam: Boolean;
523 end;
524 PIFPSVariantIFC = PPSVariantIFC;
525 TIFPSVariantIFC = TPSVariantIFC;
526
527 TPSRuntimeAttribute = class(TObject)
528 private
529 FValues: TPSStack;
530 FAttribType: tbtstring;
531 FOwner: TPSRuntimeAttributes;
532 FAttribTypeHash: Longint;
GetValuenull533 function GetValue(I: Longint): PIFVariant;
GetValueCountnull534 function GetValueCount: Longint;
535 public
536
537 property Owner: TPSRuntimeAttributes read FOwner;
538
539 property AttribType: tbtstring read FAttribType write FAttribType;
540
541 property AttribTypeHash: Longint read FAttribTypeHash write FAttribTypeHash;
542
543 property ValueCount: Longint read GetValueCount;
544
545 property Value[I: Longint]: PIFVariant read GetValue;
546
AddValuenull547 function AddValue(aType: TPSTypeRec): PPSVariant;
548
549 procedure DeleteValue(i: Longint);
550
551 procedure AdjustSize;
552
553
554 constructor Create(Owner: TPSRuntimeAttributes);
555
556 destructor Destroy; override;
557 end;
558
559 TPSRuntimeAttributes = class(TObject)
560 private
561 FAttributes: TPSList;
562 FOwner: TPSExec;
GetCountnull563 function GetCount: Longint;
GetItemnull564 function GetItem(I: Longint): TPSRuntimeAttribute;
565 public
566
567 property Owner: TPSExec read FOwner;
568
569 property Count: Longint read GetCount;
570
571 property Items[I: Longint]: TPSRuntimeAttribute read GetItem; default;
572
573 procedure Delete(I: Longint);
574
Addnull575 function Add: TPSRuntimeAttribute;
576
FindAttributenull577 function FindAttribute(const Name: tbtstring): TPSRuntimeAttribute;
578
579
580 constructor Create(AOwner: TPSExec);
581
582 destructor Destroy; override;
583 end;
584 TPSOnGetNVariant = function (Sender: TPSExec; const Name: tbtstring): Variant;
585 TPSOnSetNVariant = procedure (Sender: TPSExec; const Name: tbtstring; V: Variant);
586
587 TPSOnLineEvent = procedure(Sender: TPSExec);
588
589 TPSOnSpecialProcImport = function (Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean;
590
591 TPSOnException = procedure (Sender: TPSExec; ExError: TPSError; const ExParam: tbtstring; ExObject: TObject; ProcNo, Position: Cardinal);
592
593 TPSExec = class(TObject)
594 Private
595 FOnGetNVariant: TPSOnGetNVariant;
596 FOnSetNVariant: TPSOnSetNVariant;
597 FId: Pointer;
598 FJumpFlag: Boolean;
599 FCallCleanup: Boolean;
600 FOnException: TPSOnException;
ReadDatanull601 function ReadData(var Data; Len: Cardinal): Boolean;
ReadLongnull602 function ReadLong(var b: Cardinal): Boolean;
DoCalcnull603 function DoCalc(var1, Var2: Pointer; var1Type, var2type: TPSTypeRec; CalcType: Cardinal): Boolean;
DoBooleanCalcnull604 function DoBooleanCalc(var1, Var2, into: Pointer; var1Type, var2type, intotype: TPSTypeRec; Cmd: Cardinal): Boolean;
SetVariantValuenull605 function SetVariantValue(dest, Src: Pointer; desttype, srctype: TPSTypeRec): Boolean;
ReadVariablenull606 function ReadVariable(var Dest: TPSResultData; UsePointer: Boolean): Boolean;
DoBooleanNotnull607 function DoBooleanNot(Dta: Pointer; aType: TPSTypeRec): Boolean;
DoMinusnull608 function DoMinus(Dta: Pointer; aType: TPSTypeRec): Boolean;
DoIntegerNotnull609 function DoIntegerNot(Dta: Pointer; aType: TPSTypeRec): Boolean;
610 procedure RegisterStandardProcs;
611 Protected
612
613 FReturnAddressType: TPSTypeRec;
614
615 FVariantType: TPSTypeRec;
616
617 FVariantArrayType: TPSTypeRec;
618
619 FAttributeTypes: TPSList;
620
621 FExceptionStack: TPSList;
622
623 FResources: TPSList;
624
625 FExportedVars: TPSList;
626
627 FTypes: TPSList;
628
629 FProcs: TPSList;
630
631 FGlobalVars: TPSStack;
632
633 FTempVars: TPSStack;
634
635 FStack: TPSStack;
636
637 FMainProc: Cardinal;
638
639 FStatus: TPSStatus;
640
641 FCurrProc: TPSInternalProcRec;
642
643 FData: PByteArray;
644
645 FDataLength: Cardinal;
646
647 FCurrentPosition: Cardinal;
648
649 FCurrStackBase: Cardinal;
650
651 FOnRunLine: TPSOnLineEvent;
652
653 FSpecialProcList: TPSList;
654
655 FRegProcs: TPSList;
656
657 ExObject: TObject;
658
659 ExProc: Cardinal;
660
661 ExPos: Cardinal;
662
663 ExEx: TPSError;
664
665 ExParam: tbtstring;
666
InvokeExternalMethodnull667 function InvokeExternalMethod(At: TPSTypeRec_ProcPtr; Slf, Ptr: Pointer): Boolean;
668
InnerfuseCallnull669 function InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean;
670
671 procedure RunLine; virtual;
672
ImportProcnull673 function ImportProc(const Name: ShortString; proc: TPSExternalProcRec): Boolean; Virtual;
674
675 procedure ExceptionProc(proc, Position: Cardinal; Ex: TPSError; const s: tbtstring; NewObject: TObject); Virtual;
676
FindSpecialProcImportnull677 function FindSpecialProcImport(P: TPSOnSpecialProcImport): pointer;
678 Public
LastExnull679 function LastEx: TPSError;
LastExParamnull680 function LastExParam: tbtstring;
LastExProcnull681 function LastExProc: Integer;
LastExPosnull682 function LastExPos: Integer;
LastExObjectnull683 function LastExObject: TObject;
684 procedure CMD_Err(EC: TPSError);
685
686 procedure CMD_Err2(EC: TPSError; const Param: tbtstring);
687
688 procedure CMD_Err3(EC: TPSError; const Param: tbtstring; ExObject: TObject);
689
690 property Id: Pointer read FID write FID;
691
Aboutnull692 class function About: tbtstring;
693
RunProcnull694 function RunProc(Params: TPSList; ProcNo: Cardinal): Boolean;
695
RunProcPnull696 function RunProcP(const Params: array of Variant; const Procno: Cardinal): Variant;
RunProcPVarnull697 function RunProcPVar(var Params: array of Variant; const Procno: Cardinal): Variant;
698
RunProcPNnull699 function RunProcPN(const Params: array of Variant; const ProcName: tbtstring): Variant;
700
FindTypenull701 function FindType(StartAt: Cardinal; BaseType: TPSBaseType; var l: Cardinal): PIFTypeRec;
702
FindType2null703 function FindType2(BaseType: TPSBaseType): PIFTypeRec;
704
GetTypeNonull705 function GetTypeNo(l: Cardinal): PIFTypeRec;
706
GetTypenull707 function GetType(const Name: tbtstring): Cardinal;
708
GetProcnull709 function GetProc(const Name: tbtstring): Cardinal;
710
GetVarnull711 function GetVar(const Name: tbtstring): Cardinal;
712
GetVar2null713 function GetVar2(const Name: tbtstring): PIFVariant;
714
GetVarNonull715 function GetVarNo(C: Cardinal): PIFVariant;
716
GetProcNonull717 function GetProcNo(C: Cardinal): PIFProcRec;
718
GetProcCountnull719 function GetProcCount: Cardinal;
720
GetVarCountnull721 function GetVarCount: Longint;
722
GetTypeCountnull723 function GetTypeCount: Longint;
724
725
726 constructor Create;
727
728 destructor Destroy; Override;
729
730
RunScriptnull731 function RunScript: Boolean;
732
733
LoadDatanull734 function LoadData(const s: tbtstring): Boolean; virtual;
735
736 procedure Clear; Virtual;
737
738 procedure Cleanup; Virtual;
739
740 procedure Stop; Virtual;
741
742 procedure Pause; Virtual;
743
744 property CallCleanup: Boolean read FCallCleanup write FCallCleanup;
745
746 property Status: TPSStatus Read FStatus;
747
748 property OnRunLine: TPSOnLineEvent Read FOnRunLine Write FOnRunLine;
749
750 procedure ClearspecialProcImports;
751
752 procedure AddSpecialProcImport(const FName: tbtstring; P: TPSOnSpecialProcImport; Tag: Pointer);
753
RegisterFunctionNamenull754 function RegisterFunctionName(const Name: tbtstring; ProcPtr: TPSProcPtr;
755 Ext1, Ext2: Pointer): PProcRec;
756
757 procedure RegisterDelphiFunction(ProcPtr: Pointer; const Name: tbtstring; CC: TPSCallingConvention);
758
759 procedure RegisterDelphiMethod(Slf, ProcPtr: Pointer; const Name: tbtstring; CC: TPSCallingConvention);
760
GetProcAsMethodnull761 function GetProcAsMethod(const ProcNo: Cardinal): TMethod;
762
GetProcAsMethodNnull763 function GetProcAsMethodN(const ProcName: tbtstring): TMethod;
764
765 procedure RegisterAttributeType(useproc: TPSAttributeUseProc; const TypeName: tbtstring);
766
767 procedure ClearFunctionList;
768
769 property ExceptionProcNo: Cardinal Read ExProc;
770
771 property ExceptionPos: Cardinal Read ExPos;
772
773 property ExceptionCode: TPSError Read ExEx;
774
775 property ExceptionString: tbtstring read ExParam;
776
777 property ExceptionObject: TObject read ExObject write ExObject;
778
779 procedure AddResource(Proc, P: Pointer);
780
IsValidResourcenull781 function IsValidResource(Proc, P: Pointer): Boolean;
782
783 procedure DeleteResource(P: Pointer);
784
FindProcResourcenull785 function FindProcResource(Proc: Pointer): Pointer;
786
FindProcResource2null787 function FindProcResource2(Proc: Pointer; var StartAt: Longint): Pointer;
788
789 procedure RaiseCurrentException;
790
791 property OnException: TPSOnException read FOnException write FOnException;
792 property OnGetNVariant: TPSOnGetNVariant read FOnGetNVariant write FOnGetNVariant;
793 property OnSetNVariant: TPSOnSetNVariant read FOnSetNVariant write FOnSetNVariant;
794 end;
795
796 TPSStack = class(TPSList)
797 private
798 FDataPtr: Pointer;
799 FCapacity,
800 FLength: Longint;
GetItemnull801 function GetItem(I: Longint): PPSVariant;
802 procedure SetCapacity(const Value: Longint);
803 procedure AdjustLength;
804 public
805
806 property DataPtr: Pointer read FDataPtr;
807
808 property Capacity: Longint read FCapacity write SetCapacity;
809
810 property Length: Longint read FLength;
811
812
813 constructor Create;
814
815 destructor Destroy; override;
816
817 procedure Clear; {$IFDEF DELPHI5UP} reintroduce;{$ELSE} override; {$ENDIF}
818
Pushnull819 function Push(TotalSize: Longint): PPSVariant;
820
PushTypenull821 function PushType(aType: TPSTypeRec): PPSVariant;
822
823 procedure Pop;
GetIntnull824 function GetInt(ItemNo: Longint): Longint;
GetUIntnull825 function GetUInt(ItemNo: Longint): Cardinal;
826 {$IFNDEF PS_NOINT64}
GetInt64null827 function GetInt64(ItemNo: Longint): Int64;
828 {$ENDIF}
GetStringnull829 function GetString(ItemNo: Longint): string; // calls the native method
GetAnsiStringnull830 function GetAnsiString(ItemNo: Longint): tbtstring;
831 {$IFNDEF PS_NOWIDESTRING}
GetWideStringnull832 function GetWideString(ItemNo: Longint): tbtWideString;
GetUnicodeStringnull833 function GetUnicodeString(ItemNo: Longint): tbtunicodestring;
834 {$ENDIF}
GetRealnull835 function GetReal(ItemNo: Longint): Extended;
GetCurrencynull836 function GetCurrency(ItemNo: Longint): Currency;
GetBoolnull837 function GetBool(ItemNo: Longint): Boolean;
GetClassnull838 function GetClass(ItemNo: Longint): TObject;
839
840 procedure SetInt(ItemNo: Longint; const Data: Longint);
841 procedure SetUInt(ItemNo: Longint; const Data: Cardinal);
842 {$IFNDEF PS_NOINT64}
843 procedure SetInt64(ItemNo: Longint; const Data: Int64);
844 {$ENDIF}
845 procedure SetString(ItemNo: Longint; const Data: string);
846 procedure SetAnsiString(ItemNo: Longint; const Data: tbtstring);
847 {$IFNDEF PS_NOWIDESTRING}
848 procedure SetWideString(ItemNo: Longint; const Data: tbtWideString);
849 procedure SetUnicodeString(ItemNo: Longint; const Data: tbtunicodestring);
850 {$ENDIF}
851 procedure SetReal(ItemNo: Longint; const Data: Extended);
852 procedure SetCurrency(ItemNo: Longint; const Data: Currency);
853 procedure SetBool(ItemNo: Longint; const Data: Boolean);
854 procedure SetClass(ItemNo: Longint; const Data: TObject);
855
856 property Items[I: Longint]: PPSVariant read GetItem; default;
857 end;
858
859
PSErrorToStringnull860 function PSErrorToString(x: TPSError; const Param: tbtstring): tbtstring;
TIFErrorToStringnull861 function TIFErrorToString(x: TPSError; const Param: tbtstring): tbtstring;
CreateHeapVariantnull862 function CreateHeapVariant(aType: TPSTypeRec): PPSVariant;
863 procedure DestroyHeapVariant(v: PPSVariant);
864
865 procedure FreePIFVariantList(l: TPSList);
866 procedure FreePSVariantList(l: TPSList);
867
868 const
869 ENoError = ERNoError;
870
871
PIFVariantToVariantnull872 function PIFVariantToVariant(Src: PIFVariant; var Dest: Variant): Boolean;
VariantToPIFVariantnull873 function VariantToPIFVariant(Exec: TPSExec; const Src: Variant; Dest: PIFVariant): Boolean;
874
PSGetRecFieldnull875 function PSGetRecField(const avar: TPSVariantIFC; Fieldno: Longint): TPSVariantIFC;
PSGetArrayFieldnull876 function PSGetArrayField(const avar: TPSVariantIFC; Fieldno: Longint): TPSVariantIFC;
NewTPSVariantRecordIFCnull877 function NewTPSVariantRecordIFC(avar: PPSVariant; Fieldno: Longint): TPSVariantIFC;
878
NewTPSVariantIFCnull879 function NewTPSVariantIFC(avar: PPSVariant; varparam: boolean): TPSVariantIFC;
880
NewPPSVariantIFCnull881 function NewPPSVariantIFC(avar: PPSVariant; varparam: boolean): PPSVariantIFC;
882
883 procedure DisposePPSVariantIFC(aVar: PPSVariantIFC);
884
885 procedure DisposePPSVariantIFCList(list: TPSList);
886
887
PSGetObjectnull888 function PSGetObject(Src: Pointer; aType: TPSTypeRec): TObject;
PSGetUIntnull889 function PSGetUInt(Src: Pointer; aType: TPSTypeRec): Cardinal;
890 {$IFNDEF PS_NOINT64}
PSGetInt64null891 function PSGetInt64(Src: Pointer; aType: TPSTypeRec): Int64;
892 {$ENDIF}
PSGetRealnull893 function PSGetReal(Src: Pointer; aType: TPSTypeRec): Extended;
PSGetCurrencynull894 function PSGetCurrency(Src: Pointer; aType: TPSTypeRec): Currency;
PSGetIntnull895 function PSGetInt(Src: Pointer; aType: TPSTypeRec): Longint;
PSGetStringnull896 function PSGetString(Src: Pointer; aType: TPSTypeRec): string;
PSGetAnsiStringnull897 function PSGetAnsiString(Src: Pointer; aType: TPSTypeRec): tbtString;
898 {$IFNDEF PS_NOWIDESTRING}
PSGetWideStringnull899 function PSGetWideString(Src: Pointer; aType: TPSTypeRec): tbtWideString;
PSGetUnicodeStringnull900 function PSGetUnicodeString(Src: Pointer; aType: TPSTypeRec): tbtunicodestring;
901 {$ENDIF}
902
903 procedure PSSetObject(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; Const val: TObject);
904 procedure PSSetUInt(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Cardinal);
905 {$IFNDEF PS_NOINT64}
906 procedure PSSetInt64(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Int64);
907 {$ENDIF}
908 procedure PSSetReal(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Extended);
909 procedure PSSetCurrency(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Currency);
910 procedure PSSetInt(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Longint);
911 procedure PSSetString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: String);
912 procedure PSSetAnsiString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtString);
913 {$IFNDEF PS_NOWIDESTRING}
914 procedure PSSetWideString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtWideString);
915 procedure PSSetUnicodeString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtunicodestring);
916 {$ENDIF}
917
918 procedure VNSetPointerTo(const Src: TPSVariantIFC; Data: Pointer; aType: TPSTypeRec);
919
VNGetUIntnull920 function VNGetUInt(const Src: TPSVariantIFC): Cardinal;
921 {$IFNDEF PS_NOINT64}
VNGetInt64null922 function VNGetInt64(const Src: TPSVariantIFC): Int64;
923 {$ENDIF}
VNGetRealnull924 function VNGetReal(const Src: TPSVariantIFC): Extended;
VNGetCurrencynull925 function VNGetCurrency(const Src: TPSVariantIFC): Currency;
VNGetIntnull926 function VNGetInt(const Src: TPSVariantIFC): Longint;
VNGetStringnull927 function VNGetString(const Src: TPSVariantIFC): String;
VNGetAnsiStringnull928 function VNGetAnsiString(const Src: TPSVariantIFC): tbtString;
929 {$IFNDEF PS_NOWIDESTRING}
VNGetWideStringnull930 function VNGetWideString(const Src: TPSVariantIFC): tbtWideString;
VNGetUnicodeStringnull931 function VNGetUnicodeString(const Src: TPSVariantIFC): tbtunicodestring;
932 {$ENDIF}
933
934 procedure VNSetUInt(const Src: TPSVariantIFC; const Val: Cardinal);
935 {$IFNDEF PS_NOINT64}
936 procedure VNSetInt64(const Src: TPSVariantIFC; const Val: Int64);
937 {$ENDIF}
938 procedure VNSetReal(const Src: TPSVariantIFC; const Val: Extended);
939 procedure VNSetCurrency(const Src: TPSVariantIFC; const Val: Currency);
940 procedure VNSetInt(const Src: TPSVariantIFC; const Val: Longint);
941 procedure VNSetString(const Src: TPSVariantIFC; const Val: String);
942 procedure VNSetAnsiString(const Src: TPSVariantIFC; const Val: tbtString);
943 {$IFNDEF PS_NOWIDESTRING}
944 procedure VNSetWideString(const Src: TPSVariantIFC; const Val: tbtWideString);
945 procedure VNSetUnicodeString(const Src: TPSVariantIFC; const Val: tbtunicodestring);
946 {$ENDIF}
947
VGetUIntnull948 function VGetUInt(const Src: PIFVariant): Cardinal;
949 {$IFNDEF PS_NOINT64}
VGetInt64null950 function VGetInt64(const Src: PIFVariant): Int64;
951 {$ENDIF}
VGetRealnull952 function VGetReal(const Src: PIFVariant): Extended;
VGetCurrencynull953 function VGetCurrency(const Src: PIFVariant): Currency;
VGetIntnull954 function VGetInt(const Src: PIFVariant): Longint;
VGetStringnull955 function VGetString(const Src: PIFVariant): String;
VGetAnsiStringnull956 function VGetAnsiString(const Src: PIFVariant): tbtString;
957 {$IFNDEF PS_NOWIDESTRING}
VGetWideStringnull958 function VGetWideString(const Src: PIFVariant): tbtWideString;
VGetUnicodeStringnull959 function VGetUnicodeString(const Src: PIFVariant): tbtunicodestring;
960 {$ENDIF}
961
962 procedure VSetPointerTo(const Src: PIFVariant; Data: Pointer; aType: TPSTypeRec);
963 procedure VSetUInt(const Src: PIFVariant; const Val: Cardinal);
964 {$IFNDEF PS_NOINT64}
965 procedure VSetInt64(const Src: PIFVariant; const Val: Int64);
966 {$ENDIF}
967 procedure VSetReal(const Src: PIFVariant; const Val: Extended);
968 procedure VSetCurrency(const Src: PIFVariant; const Val: Currency);
969 procedure VSetInt(const Src: PIFVariant; const Val: Longint);
970 procedure VSetString(const Src: PIFVariant; const Val: string);
971 procedure VSetAnsiString(const Src: PIFVariant; const Val: tbtString);
972 {$IFNDEF PS_NOWIDESTRING}
973 procedure VSetWideString(const Src: PIFVariant; const Val: tbtWideString);
974 procedure VSetUnicodeString(const Src: PIFVariant; const Val: tbtunicodestring);
975 {$ENDIF}
976
977 type
978
979 EPSException = class(Exception)
980 private
981 FProcPos: Cardinal;
982 FProcNo: Cardinal;
983 FExec: TPSExec;
984 public
985
986 constructor Create(const Error: tbtstring; Exec: TPSExec; Procno, ProcPos: Cardinal);
987
988 property ProcNo: Cardinal read FProcNo;
989
990 property ProcPos: Cardinal read FProcPos;
991
992 property Exec: TPSExec read FExec;
993 end;
994
995 TPSRuntimeClass = class
996 protected
997 FClassName: tbtstring;
998 FClassNameHash: Longint;
999
1000 FClassItems: TPSList;
1001 FClass: TClass;
1002
1003 FEndOfVmt: Longint;
1004 public
1005
1006 procedure RegisterConstructor(ProcPtr: Pointer; const Name: tbtstring);
1007
1008 procedure RegisterVirtualConstructor(ProcPtr: Pointer; const Name: tbtstring);
1009
1010 procedure RegisterMethod(ProcPtr: Pointer; const Name: tbtstring);
1011
1012 procedure RegisterVirtualMethod(ProcPtr: Pointer; const Name: tbtstring);
1013
1014 procedure RegisterVirtualAbstractMethod(ClassDef: TClass; ProcPtr: Pointer; const Name: tbtstring);
1015
1016 procedure RegisterPropertyHelper(ReadFunc, WriteFunc: Pointer; const Name: tbtstring);
1017
1018 procedure RegisterPropertyHelperName(ReadFunc, WriteFunc: Pointer; const Name: tbtstring);
1019
1020 procedure RegisterEventPropertyHelper(ReadFunc, WriteFunc: Pointer; const Name: tbtstring);
1021
1022 constructor Create(aClass: TClass; const AName: tbtstring);
1023
1024 destructor Destroy; override;
1025 end;
1026
1027 TPSRuntimeClassImporter = class
1028 private
1029 FClasses: TPSList;
1030 public
1031
1032 constructor Create;
1033
1034 constructor CreateAndRegister(Exec: TPSExec; AutoFree: Boolean);
1035
1036 destructor Destroy; override;
1037
Addnull1038 function Add(aClass: TClass): TPSRuntimeClass;
1039
Add2null1040 function Add2(aClass: TClass; const Name: tbtstring): TPSRuntimeClass;
1041
1042 procedure Clear;
1043
FindClassnull1044 function FindClass(const Name: tbtstring): TPSRuntimeClass;
1045 end;
1046 TIFPSRuntimeClassImporter = TPSRuntimeClassImporter;
1047 TPSResourceFreeProc = procedure (Sender: TPSExec; P: TPSRuntimeClassImporter);
1048
1049
1050 procedure RegisterClassLibraryRuntime(SE: TPSExec; Importer: TPSRuntimeClassImporter);
1051
1052 procedure SetVariantToClass(V: PIFVariant; Cl: TObject);
1053 {$IFNDEF PS_NOINTERFACES}
1054 procedure SetVariantToInterface(V: PIFVariant; Cl: IUnknown);
1055 {$ENDIF}
1056
1057 procedure MyAllMethodsHandler;
1058
GetMethodInfoRecnull1059 function GetMethodInfoRec(SE: TPSExec; ProcNo: Cardinal): Pointer;
1060
MkMethodnull1061 function MkMethod(FSE: TPSExec; No: Cardinal): TMethod;
1062
1063 type
1064 TIFInternalProcRec = TPSInternalProcRec;
1065 TIFError = TPSError;
1066 TIFStatus = TPSStatus;
1067 TIFPSExec = TPSExec;
1068 TIFPSStack = TPSStack;
1069 TIFTypeRec = TPSTypeRec;
1070
1071
1072 TPSCallingConvention = uPSUtils.TPSCallingConvention;
1073 const
1074
1075 cdRegister = uPSUtils.cdRegister;
1076
1077 cdPascal = uPSUtils.cdPascal;
1078
1079 cdCdecl = uPSUtils.cdCdecl;
1080
1081 cdStdCall = uPSUtils.cdStdCall;
1082
1083 InvalidVal = Cardinal(-1);
1084
PSDynArrayGetLengthnull1085 function PSDynArrayGetLength(arr: Pointer; aType: TPSTypeRec): Longint;
1086 procedure PSDynArraySetLength(var arr: Pointer; aType: TPSTypeRec; NewLength: Longint);
1087
GetPSArrayLengthnull1088 function GetPSArrayLength(Arr: PIFVariant): Longint;
1089 procedure SetPSArrayLength(Arr: PIFVariant; NewLength: Longint);
1090
PSVariantToStringnull1091 function PSVariantToString(const p: TPSVariantIFC; const ClassProperties: tbtstring): tbtstring;
MakeStringnull1092 function MakeString(const s: tbtstring): tbtstring;
1093 {$IFNDEF PS_NOWIDESTRING}
MakeWStringnull1094 function MakeWString(const s: tbtunicodestring): tbtstring;
1095 {$ENDIF}
1096
1097 {$IFNDEF PS_NOIDISPATCH}
IDispatchInvokenull1098 function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: tbtString; const Par: array of Variant): Variant;
1099 {$ENDIF}
1100
1101
1102 implementation
1103 uses
1104 TypInfo {$IFDEF DELPHI3UP}{$IFNDEF FPC}{$IFNDEF KYLIX} , ComObj {$ENDIF}{$ENDIF}{$ENDIF}{$IFDEF PS_FPC_HAS_COM}, ComObj{$ENDIF};
1105
1106 {$IFDEF DELPHI3UP }
1107 resourceString
1108 {$ELSE }
1109 const
1110 {$ENDIF }
1111
1112 RPS_UnknownIdentifier = 'Unknown Identifier';
1113 RPS_Exception = 'Exception: %s';
1114 RPS_Invalid = '[Invalid]';
1115
1116 //- PSErrorToString
1117 RPS_NoError = 'No Error';
1118 RPS_CannotImport = 'Cannot Import %s';
1119 RPS_InvalidType = 'Invalid Type';
1120 RPS_InternalError = 'Internal error';
1121 RPS_InvalidHeader = 'Invalid Header';
1122 RPS_InvalidOpcode = 'Invalid Opcode';
1123 RPS_InvalidOpcodeParameter = 'Invalid Opcode Parameter';
1124 RPS_NoMainProc = 'no Main Proc';
1125 RPS_OutOfGlobalVarsRange = 'Out of Global Vars range';
1126 RPS_OutOfProcRange = 'Out of Proc Range';
1127 RPS_OutOfRange = 'Out Of Range';
1128 RPS_OutOfStackRange = 'Out Of Stack Range';
1129 RPS_TypeMismatch = 'Type Mismatch';
1130 RPS_UnexpectedEof = 'Unexpected End Of File';
1131 RPS_VersionError = 'Version error';
1132 RPS_DivideByZero = 'divide by Zero';
1133 RPS_MathError = 'Math error';
1134 RPS_CouldNotCallProc = 'Could not call proc';
1135 RPS_OutofRecordRange = 'Out of Record Fields Range';
1136 RPS_NullPointerException = 'Null Pointer Exception';
1137 RPS_NullVariantError = 'Null variant error';
1138 RPS_OutOfMemory = 'Out Of Memory';
1139 RPS_InterfaceNotSupported = 'Interface not supported';
1140 RPS_UnknownError = 'Unknown error';
1141
1142
1143 RPS_InvalidVariable = 'Invalid variable';
1144 RPS_InvalidArray = 'Invalid array';
1145 RPS_OLEError = 'OLE error %.8x';
1146 RPS_UnknownProcedure = 'Unknown procedure';
1147 RPS_NotEnoughParameters = 'Not enough parameters';
1148 RPS_InvalidParameter = 'Invalid parameter';
1149 RPS_TooManyParameters = 'Too many parameters';
1150 RPS_OutOfStringRange = 'Out of string range';
1151 RPS_CannotCastInterface = 'Cannot cast an interface';
1152 RPS_CannotCastObject = 'Cannot cast an object';
1153 RPS_CapacityLength = 'Capacity < Length';
1154 RPS_CanOnlySendLastItem = 'Can only remove last item from stack';
1155 RPS_NILInterfaceException = 'Nil interface';
1156 RPS_UnknownMethod = 'Unknown method';
1157
1158
1159
1160 type
1161 PPSExportedVar = ^TPSExportedVar;
1162 TPSExportedVar = record
1163 FName: tbtstring;
1164 FNameHash: Longint;
1165 FVarNo: Cardinal;
1166 end;
1167 PRaiseFrame = ^TRaiseFrame;
1168 TRaiseFrame = record
1169 NextRaise: PRaiseFrame;
1170 ExceptAddr: Pointer;
1171 ExceptObject: TObject;
1172 ExceptionRecord: Pointer;
1173 end;
1174 TPSExceptionHandler = class
1175 CurrProc: TPSInternalProcRec;
1176 BasePtr, StackSize: Cardinal;
1177 FinallyOffset, ExceptOffset, Finally2Offset, EndOfBlock: Cardinal;
1178 ExceptionData: TPSError;
1179 ExceptionObject: TObject;
1180 ExceptionParam: tbtString;
1181 destructor Destroy; override;
1182 end;
1183 TPSHeader = packed record
1184 HDR: Cardinal;
1185 PSBuildNo: Cardinal;
1186 TypeCount: Cardinal;
1187 ProcCount: Cardinal;
1188 VarCount: Cardinal;
1189 MainProcNo: Cardinal;
1190 ImportTableSize: Cardinal;
1191 end;
1192
1193 TPSExportItem = packed record
1194 ProcNo: Cardinal;
1195 NameLength: Cardinal;
1196 DeclLength: Cardinal;
1197 end;
1198
1199 TPSType = packed record
1200 BaseType: TPSBaseType;
1201 end;
1202 TPSProc = packed record
1203 Flags: Byte;
1204 end;
1205
1206 TPSVar = packed record
1207 TypeNo: Cardinal;
1208 Flags: Byte;
1209 end;
1210 PSpecialProc = ^TSpecialProc;
1211 TSpecialProc = record
1212 P: TPSOnSpecialProcImport;
1213 namehash: Longint;
1214 Name: tbtstring;
1215 tag: pointer;
1216 end;
1217
1218 destructor TPSExceptionHandler.Destroy;
1219 begin
1220 ExceptionObject.Free;
1221 inherited;
1222 end;
1223
1224 procedure P_CM_A; begin end;
1225 procedure P_CM_CA; begin end;
1226 procedure P_CM_P; begin end;
1227 procedure P_CM_PV; begin end;
1228 procedure P_CM_PO; begin end;
1229 procedure P_CM_C; begin end;
1230 procedure P_CM_G; begin end;
1231 procedure P_CM_CG; begin end;
1232 procedure P_CM_CNG; begin end;
1233 procedure P_CM_R; begin end;
1234 procedure P_CM_ST; begin end;
1235 procedure P_CM_PT; begin end;
1236 procedure P_CM_CO; begin end;
1237 procedure P_CM_CV; begin end;
1238 procedure P_CM_SP; begin end;
1239 procedure P_CM_BN; begin end;
1240 procedure P_CM_VM; begin end;
1241 procedure P_CM_SF; begin end;
1242 procedure P_CM_FG; begin end;
1243 procedure P_CM_PUEXH; begin end;
1244 procedure P_CM_POEXH; begin end;
1245 procedure P_CM_IN; begin end;
1246 procedure P_CM_SPB; begin end;
1247 procedure P_CM_INC; begin end;
1248 procedure P_CM_DEC; begin end;
1249
1250 function IntPIFVariantToVariant(Src: pointer; aType: TPSTypeRec; var Dest: Variant): Boolean; forward;
1251
1252
1253 procedure Set_Union(Dest, Src: PByteArray; ByteSize: Integer);
1254 var
1255 i: Longint;
1256 begin
1257 for i := ByteSize -1 downto 0 do
1258 Dest^[i] := Dest^[i] or Src^[i];
1259 end;
1260
1261 procedure Set_Diff(Dest, Src: PByteArray; ByteSize: Integer);
1262 var
1263 i: Longint;
1264 begin
1265 for i := ByteSize -1 downto 0 do
1266 Dest^[i] := Dest^[i] and not Src^[i];
1267 end;
1268
1269 procedure Set_Intersect(Dest, Src: PByteArray; ByteSize: Integer);
1270 var
1271 i: Longint;
1272 begin
1273 for i := ByteSize -1 downto 0 do
1274 Dest^[i] := Dest^[i] and Src^[i];
1275 end;
1276
1277 procedure Set_Subset(Dest, Src: PByteArray; ByteSize: Integer; var Val: Boolean);
1278 var
1279 i: Integer;
1280 begin
1281 for i := ByteSize -1 downto 0 do
1282 begin
1283 if not (Src^[i] and Dest^[i] = Dest^[i]) then
1284 begin
1285 Val := False;
1286 exit;
1287 end;
1288 end;
1289 Val := True;
1290 end;
1291
1292 procedure Set_Equal(Dest, Src: PByteArray; ByteSize: Integer; var Val: Boolean);
1293 var
1294 i: Longint;
1295 begin
1296 for i := ByteSize -1 downto 0 do
1297 begin
1298 if Dest^[i] <> Src^[i] then
1299 begin
1300 Val := False;
1301 exit;
1302 end;
1303 end;
1304 val := True;
1305 end;
1306
1307 procedure Set_membership(Item: Longint; Src: PByteArray; var Val: Boolean);
1308 begin
1309 Val := (Src^[Item shr 3] and (1 shl (Item and 7))) <> 0;
1310 end;
1311
1312
1313 procedure RCIFreeProc(Sender: TPSExec; P: TPSRuntimeClassImporter);
1314 begin
1315 p.Free;
1316 end;
1317
Trimnull1318 function Trim(const s: tbtstring): tbtstring;
1319 begin
1320 Result := s;
1321 while (Length(result) > 0) and (Result[1] = #32) do Delete(Result, 1, 1);
1322 while (Length(result) > 0) and (Result[Length(Result)] = #32) do Delete(Result, Length(Result), 1);
1323 end;
1324 (*function FloatToStr(E: Extended): tbtstring;
1325 begin
1326 Result := Sysutils.FloatToStr(e);
1327 end;*)
1328
1329 //-------------------------------------------------------------------
1330
Padlnull1331 function Padl(s: tbtstring; i: longInt): tbtstring;
1332 begin
1333 result := StringOfChar(tbtchar(' '), i - length(s)) + s;
1334 end;
1335 //-------------------------------------------------------------------
1336
Padznull1337 function Padz(s: tbtString; i: longInt): tbtString;
1338 begin
1339 result := StringOfChar(tbtchar('0'), i - length(s)) + s;
1340 end;
1341 //-------------------------------------------------------------------
1342
Padrnull1343 function Padr(s: tbtString; i: longInt): tbtString;
1344 begin
1345 result := s + StringOfChar(tbtchar(' '), i - Length(s));
1346 end;
1347 //-------------------------------------------------------------------
1348
1349 {$IFNDEF PS_NOWIDESTRING}
wPadlnull1350 function wPadl(s: tbtwidestring; i: longInt): tbtwidestring;
1351 begin
1352 result := StringOfChar(tbtwidechar(' '), i - length(s)) + s;
1353 end;
1354 //-------------------------------------------------------------------
1355
wPadznull1356 function wPadz(s: tbtwidestring; i: longInt): tbtwidestring;
1357 begin
1358 result := StringOfChar(tbtwidechar('0'), i - length(s)) + s;
1359 end;
1360 //-------------------------------------------------------------------
1361
wPadrnull1362 function wPadr(s: tbtwidestring; i: longInt): tbtwidestring;
1363 begin
1364 result := s + StringOfChar(tbtwidechar(' '), i - Length(s));
1365 end;
1366
uPadlnull1367 function uPadl(s: tbtunicodestring; i: longInt): tbtunicodestring;
1368 begin
1369 result := StringOfChar(tbtwidechar(' '), i - length(s)) + s;
1370 end;
1371 //-------------------------------------------------------------------
1372
uPadznull1373 function uPadz(s: tbtunicodestring; i: longInt): tbtunicodestring;
1374 begin
1375 result := StringOfChar(tbtwidechar('0'), i - length(s)) + s;
1376 end;
1377 //-------------------------------------------------------------------
1378
uPadrnull1379 function uPadr(s: tbtunicodestring; i: longInt): tbtunicodestring;
1380 begin
1381 result := s + StringOfChar(tbtwidechar(' '), i - Length(s));
1382 end;
1383
1384 {$ENDIF}
1385 {$IFNDEF PS_NOWIDESTRING}
MakeWStringnull1386 function MakeWString(const s: tbtunicodestring): tbtString;
1387 var
1388 i: Longint;
1389 e: tbtString;
1390 b: boolean;
1391 begin
1392 Result := tbtString(s);
1393 i := 1;
1394 b := false;
1395 while i <= length(result) do
1396 begin
1397 if Result[i] = '''' then
1398 begin
1399 if not b then
1400 begin
1401 b := true;
1402 Insert('''', Result, i);
1403 inc(i);
1404 end;
1405 Insert('''', Result, i);
1406 inc(i, 2);
1407 end else if (Result[i] < #32) or (Result[i] > #255) then
1408 begin
1409 e := '#'+inttostr(ord(Result[i]));
1410 Delete(Result, i, 1);
1411 if b then
1412 begin
1413 b := false;
1414 Insert('''', Result, i);
1415 inc(i);
1416 end;
1417 Insert(e, Result, i);
1418 inc(i, length(e));
1419 end else begin
1420 if not b then
1421 begin
1422 b := true;
1423 Insert('''', Result, i);
1424 inc(i, 2);
1425 end else
1426 inc(i);
1427 end;
1428 end;
1429 if b then
1430 begin
1431 Result := Result + '''';
1432 end;
1433 if Result = '' then
1434 Result := '''''';
1435 end;
1436 {$ENDIF}
MakeStringnull1437 function MakeString(const s: tbtString): tbtString;
1438 var
1439 i: Longint;
1440 e: tbtString;
1441 b: boolean;
1442 begin
1443 Result := s;
1444 i := 1;
1445 b := false;
1446 while i <= length(result) do
1447 begin
1448 if Result[i] = '''' then
1449 begin
1450 if not b then
1451 begin
1452 b := true;
1453 Insert('''', Result, i);
1454 inc(i);
1455 end;
1456 Insert('''', Result, i);
1457 inc(i, 2);
1458 end else if (Result[i] < #32) then
1459 begin
1460 e := '#'+inttostr(ord(Result[i]));
1461 Delete(Result, i, 1);
1462 if b then
1463 begin
1464 b := false;
1465 Insert('''', Result, i);
1466 inc(i);
1467 end;
1468 Insert(e, Result, i);
1469 inc(i, length(e));
1470 end else begin
1471 if not b then
1472 begin
1473 b := true;
1474 Insert('''', Result, i);
1475 inc(i, 2);
1476 end else
1477 inc(i);
1478 end;
1479 end;
1480 if b then
1481 begin
1482 Result := Result + '''';
1483 end;
1484 if Result = '' then
1485 Result := '''''';
1486 end;
1487
SafeStrnull1488 function SafeStr(const s: tbtString): tbtString;
1489 var
1490 i : Longint;
1491 begin
1492 Result := s;
1493 for i := 1 to length(s) do
1494 begin
1495 if s[i] in [#0..#31] then
1496 begin
1497 Result := Copy(s, 1, i-1);
1498 exit;
1499 end;
1500 end;
1501
1502 end;
1503
PropertyToStringnull1504 function PropertyToString(Instance: TObject; PName: tbtString): tbtString;
1505 var
1506 s: tbtString;
1507 i: Longint;
1508 PP: PPropInfo;
1509 begin
1510 if PName = '' then
1511 begin
1512 Result := tbtString(Instance.ClassName);
1513 exit;
1514 end;
1515 while Length(PName) > 0 do
1516 begin
1517 i := pos(tbtChar('.'), pname);
1518 if i = 0 then
1519 begin
1520 s := Trim(PNAme);
1521 pname := '';
1522 end else begin
1523 s := trim(Copy(PName, 1, i-1));
1524 Delete(PName, 1, i);
1525 end;
1526 pp := GetPropInfo(PTypeInfo(Instance.ClassInfo), string(s));
1527 if pp = nil then begin Result := tbtstring(RPS_UnknownIdentifier); exit; end;
1528
1529
1530 case pp^.PropType^.Kind of
1531 tkInteger: begin Result := IntToStr(GetOrdProp(Instance, pp)); exit; end;
1532 tkChar: begin Result := '#'+IntToStr(GetOrdProp(Instance, pp)); exit; end;
1533 tkEnumeration: begin Result := tbtstring(GetEnumName(pp^.PropType{$IFNDEF FPC}{$IFDEF DELPHI3UP}^{$ENDIF}{$ENDIF}, GetOrdProp(Instance, pp))); exit; end;
1534 tkFloat: begin Result := FloatToStr(GetFloatProp(Instance, PP)); exit; end;
1535 tkString, tkLString: begin Result := ''''+tbtString(GetStrProp(Instance, PP))+''''; exit; end;
1536 tkSet: begin Result := '[Set]'; exit; end;
1537 tkClass: begin Instance := TObject(GetOrdProp(Instance, pp)); end;
1538 tkMethod: begin Result := '[Method]'; exit; end;
1539 tkVariant: begin Result := '[Variant]'; exit; end;
1540 {$IFDEF DELPHI6UP}
1541 {$IFNDEF PS_NOWIDESTRING}
1542 tkWString: begin Result := ''''+tbtString(GetWideStrProp(Instance, pp))+''; end;
1543 {$IFDEF DELPHI2009UP}
1544 tkUString: begin Result := ''''+tbtString(GetUnicodeStrProp(Instance, pp))+''; end;
1545 {$ENDIF}
1546 {$ENDIF}
1547 {$ENDIF}
1548 else begin Result := '[Unknown]'; exit; end;
1549 end;
1550 if Instance = nil then begin result := 'nil'; exit; end;
1551 end;
1552 Result := tbtstring(Instance.ClassName);
1553 end;
1554
ClassVariantInfonull1555 function ClassVariantInfo(const pvar: TPSVariantIFC; const PropertyName: tbtString): tbtString;
1556 begin
1557 if pvar.aType.BaseType = btClass then
1558 begin
1559 if TObject(pvar.Dta^) = nil then
1560 Result := 'nil'
1561 else
1562 Result := PropertyToString(TObject(pvar.Dta^), PropertyName);
1563 end else if pvar.atype.basetype = btInterface then
1564 Result := 'Interface'
1565 else Result := tbtstring(RPS_InvalidType);
1566 end;
1567
PSVariantToStringnull1568 function PSVariantToString(const p: TPSVariantIFC; const ClassProperties: tbtString): tbtString;
1569 var
1570 i, n: Longint;
1571 begin
1572 if p.Dta = nil then
1573 begin
1574 Result := 'nil';
1575 exit;
1576 end;
1577 if (p.aType.BaseType = btVariant) then
1578 begin
1579 try
1580 if TVarData(p.Dta^).VType = varDispatch then
1581 Result := 'Variant(IDispatch)'
1582 else if TVarData(p.Dta^).VType = varNull then
1583 REsult := 'Null'
1584 else if (TVarData(p.Dta^).VType = varOleStr) then
1585 {$IFDEF PS_NOWIDESTRING}
1586 Result := MakeString(Variant(p.Dta^))
1587 {$ELSE}
1588 Result := MakeWString(variant(p.dta^))
1589 {$ENDIF}
1590 else if TVarData(p.Dta^).VType = varString then
1591 Result := MakeString(tbtstring(variant(p.Dta^)))
1592 else
1593 Result := tbtstring(Variant(p.Dta^));
1594 except
1595 on e: Exception do
1596 Result := tbtstring(Format (RPS_Exception, [e.Message]));
1597 end;
1598 exit;
1599 end;
1600 case p.aType.BaseType of
1601 btProcptr: begin Result := 'Proc: '+inttostr(tbtu32(p.Dta^)); end;
1602 btU8: str(tbtu8(p.dta^), Result);
1603 btS8: str(tbts8(p.dta^), Result);
1604 btU16: str(tbtu16(p.dta^), Result);
1605 btS16: str(tbts16(p.dta^), Result);
1606 btU32: str(tbtu32(p.dta^), Result);
1607 btS32: str(tbts32(p.dta^), Result);
1608 btSingle: str(tbtsingle(p.dta^), Result);
1609 btDouble: str(tbtdouble(p.dta^), Result);
1610 btExtended: str(tbtextended(p.dta^), Result);
1611 btString: Result := makestring(tbtString(p.dta^));
1612 btPChar:
1613 begin
1614 if PansiChar(p.dta^) = nil then
1615 Result := 'nil'
1616 else
1617 Result := MakeString(PAnsiChar(p.dta^));
1618 end;
1619 btchar: Result := MakeString(tbtchar(p.dta^));
1620 {$IFNDEF PS_NOWIDESTRING}
1621 btwidechar: Result := MakeWString(tbtwidechar(p.dta^));
1622 btWideString: Result := MakeWString(tbtwidestring(p.dta^));
1623 btUnicodeString: Result := MakeWString(tbtUnicodeString(p.dta^));
1624 {$ENDIF}
1625 {$IFNDEF PS_NOINT64}btS64: str(tbts64(p.dta^), Result);{$ENDIF}
1626 btStaticArray, btArray:
1627 begin
1628 Result := '';
1629 if p.aType.BaseType = btStaticArray then
1630 n := TPSTypeRec_StaticArray(p.aType).Size
1631 else
1632 n := PSDynArrayGetLength(Pointer(p.dta^), p.aType);
1633 for i := 0 to n-1 do begin
1634 if Result <> '' then
1635 Result := Result + ', ';
1636 Result := Result + PSVariantToString(PSGetArrayField(p, i), '');
1637 end;
1638 Result := '[' + Result + ']';
1639 end;
1640 btRecord:
1641 begin
1642 Result := '';
1643 n := TPSTypeRec_Record(p.aType).FFieldTypes.Count;
1644 for i := 0 to n-1 do begin
1645 if Result <> '' then
1646 Result := Result + ', ';
1647 Result := Result + PSVariantToString(PSGetRecField(p, i), '');
1648 end;
1649 Result := '(' + Result + ')';
1650 end;
1651 btPointer: Result := 'Nil';
1652 btClass, btInterface:
1653 begin
1654 Result := ClassVariantInfo(p, ClassProperties)
1655 end;
1656 else
1657 Result := tbtString(RPS_Invalid);
1658 end;
1659 end;
1660
1661
1662
TIFErrorToStringnull1663 function TIFErrorToString(x: TPSError; const Param: tbtString): tbtString;
1664 begin
1665 Result := PSErrorToString(x,param);
1666 end;
1667
PSErrorToStringnull1668 function PSErrorToString(x: TPSError; const Param: tbtString): tbtString;
1669 begin
1670 case x of
1671 ErNoError: Result := tbtString(RPS_NoError);
1672 erCannotImport: Result := tbtString(Format (RPS_CannotImport, [Safestr(Param)]));
1673 erInvalidType: Result := tbtString(RPS_InvalidType);
1674 ErInternalError: Result := tbtString(RPS_InternalError);
1675 erInvalidHeader: Result := tbtString(RPS_InvalidHeader);
1676 erInvalidOpcode: Result := tbtString(RPS_InvalidOpcode);
1677 erInvalidOpcodeParameter: Result := tbtString(RPS_InvalidOpcodeParameter);
1678 erNoMainProc: Result := tbtString(RPS_NoMainProc);
1679 erOutOfGlobalVarsRange: Result := tbtString(RPS_OutOfGlobalVarsRange);
1680 erOutOfProcRange: Result := tbtString(RPS_OutOfProcRange);
1681 ErOutOfRange: Result := tbtString(RPS_OutOfRange);
1682 erOutOfStackRange: Result := tbtString(RPS_OutOfStackRange);
1683 ErTypeMismatch: Result := tbtString(RPS_TypeMismatch);
1684 erUnexpectedEof: Result := tbtString(RPS_UnexpectedEof);
1685 erVersionError: Result := tbtString(RPS_VersionError);
1686 ErDivideByZero: Result := tbtString(RPS_DivideByZero);
1687 erMathError: Result := tbtString(RPS_MathError);
1688 erCouldNotCallProc: begin Result := tbtString(RPS_CouldNotCallProc); if (Param <> '') then Result := result +' ('+Param+')'; end;
1689 erOutofRecordRange: Result := tbtString(RPS_OutofRecordRange);
1690 erNullPointerException: Result := tbtString(RPS_NullPointerException);
1691 erNullVariantError: Result := tbtString(RPS_NullVariantError);
1692 erOutOfMemory: Result := tbtString(RPS_OutOfMemory);
1693 erException: Result := tbtString(Format (RPS_Exception, [Param]));
1694 erInterfaceNotSupported: Result := tbtString(RPS_InterfaceNotSupported);
1695 erCustomError: Result := Param;
1696 else
1697 Result := tbtString(RPS_UnknownError);
1698 end;
1699 //
1700 end;
1701
1702
1703 procedure TPSTypeRec.CalcSize;
1704 begin
1705 case BaseType of
1706 btVariant: FRealSize := sizeof(Variant);
1707 btChar, bts8, btU8: FrealSize := 1 ;
1708 {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}bts16, btU16: FrealSize := 2;
1709 {$IFNDEF PS_NOWIDESTRING}btWideString,
1710 btUnicodeString,
1711 {$ENDIF}{$IFNDEF PS_NOINTERFACES}btInterface, {$ENDIF}
1712 btclass, btPChar, btString: FrealSize := PointerSize;
1713 btSingle, bts32, btU32: FRealSize := 4;
1714 btProcPtr: FRealSize := 3 * sizeof(Pointer);
1715 btCurrency: FrealSize := Sizeof(Currency);
1716 btPointer: FRealSize := 3 * sizeof(Pointer); // ptr, type, freewhendone
1717 btDouble{$IFNDEF PS_NOINT64}, bts64{$ENDIF}: FrealSize := 8;
1718 btExtended: FrealSize := SizeOf(Extended);
1719 btReturnAddress: FrealSize := Sizeof(TBTReturnAddress);
1720 else
1721 FrealSize := 0;
1722 end;
1723 end;
1724
1725 constructor TPSTypeRec.Create(Owner: TPSExec);
1726 begin
1727 inherited Create;
1728 FAttributes := TPSRuntimeAttributes.Create(Owner);
1729 end;
1730
1731 destructor TPSTypeRec.Destroy;
1732 begin
1733 FAttributes.Free;
1734 inherited destroy;
1735 end;
1736
1737 { TPSTypeRec_Record }
1738
1739 procedure TPSTypeRec_Record.CalcSize;
1740 begin
1741 inherited;
1742 FrealSize := TPSTypeRec(FFieldTypes[FFieldTypes.Count-1]).RealSize +
1743 IPointer(RealFieldOffsets[RealFieldOffsets.Count -1]);
1744 end;
1745
1746 constructor TPSTypeRec_Record.Create(Owner: TPSExec);
1747 begin
1748 inherited Create(Owner);
1749 FRealFieldOffsets := TPSList.Create;
1750 FFieldTypes := TPSList.Create;
1751 end;
1752
1753 destructor TPSTypeRec_Record.Destroy;
1754 begin
1755 FFieldTypes.Free;
1756 FRealFieldOffsets.Free;
1757 inherited Destroy;
1758 end;
1759
1760
1761 const
1762 RTTISize = sizeof(TPSVariant);
1763
1764 procedure InitializeVariant(p: Pointer; aType: TPSTypeRec);
1765 var
1766 t: TPSTypeRec;
1767 i: Longint;
1768 begin
1769 case aType.BaseType of
1770 btChar, bts8, btU8: tbtu8(p^) := 0;
1771 {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}bts16, btU16: tbtu16(p^) := 0;
1772 btSingle: TbtSingle(P^) := 0;
1773 bts32, btU32: TbtU32(P^) := 0;
1774 btPChar, btString, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF}btClass,
1775 btInterface, btArray: Pointer(P^) := nil;
1776 btPointer:
1777 begin
1778 Pointer(p^) := nil;
1779 Pointer(Pointer(IPointer(p)+PointerSize)^) := nil;
1780 Pointer(Pointer(IPointer(p)+(2*PointerSize))^) := nil;
1781 end;
1782 btProcPtr:
1783 begin
1784 Longint(p^) := 0;
1785 Pointer(Pointer(IPointer(p)+PointerSize)^) := nil;
1786 Pointer(Pointer(IPointer(p)+(2*PointerSize))^) := nil;
1787 end;
1788 btCurrency: tbtCurrency(P^) := 0;
1789 btDouble{$IFNDEF PS_NOINT64}, bts64{$ENDIF}: {$IFNDEF PS_NOINT64}tbtS64(P^) := 0{$ELSE}tbtdouble(p^) := 0 {$ENDIF};
1790 btExtended: tbtExtended(p^) := 0;
1791 btVariant: Initialize(Variant(p^));
1792 btReturnAddress:; // there is no point in initializing a return address
1793 btRecord:
1794 begin
1795 for i := 0 to TPSTypeRec_Record(aType).FFieldTypes.Count -1 do
1796 begin
1797 t := TPSTypeRec_Record(aType).FieldTypes[i];
1798 InitializeVariant(P, t);
1799 p := Pointer(IPointer(p) + t.FrealSize);
1800 end;
1801 end;
1802 btStaticArray:
1803 begin
1804 t := TPSTypeRec_Array(aType).ArrayType;
1805 for i := 0 to TPSTypeRec_StaticArray(aType).Size -1 do
1806 begin
1807 InitializeVariant(p, t);
1808 p := Pointer(IPointer(p) + t.RealSize);
1809 end;
1810 end;
1811 btSet:
1812 begin
1813 FillChar(p^, TPSTypeRec_Set(aType).RealSize, 0);
1814 end;
1815 end;
1816 end;
1817
1818 procedure DestroyHeapVariant2(v: Pointer; aType: TPSTypeRec); forward;
1819
1820 const
1821 NeedFinalization = [btStaticArray, btRecord, btArray, btPointer, btVariant {$IFNDEF PS_NOINTERFACES}, btInterface{$ENDIF}, btString {$IFNDEF PS_NOWIDESTRING}, btUnicodestring,btWideString{$ENDIF}];
1822
1823 type
1824 TDynArrayRecHeader = packed record
1825 {$ifdef FPC}
1826 refCnt : ptrint;
1827 high : tdynarrayindex;
1828 {$else}
1829 {$ifdef CPUX64}
1830 _Padding: LongInt; // Delphi XE2+ expects 16 byte align
1831 {$endif}
1832 /// dynamic array reference count (basic garbage memory mechanism)
1833 refCnt: Longint;
1834 /// length in element count
1835 // - size in bytes = length*ElemSize
1836 length: IPointer;
1837 {$endif}
1838 end;
1839 TDynArrayRec = packed record
1840 header : TDynArrayRecHeader;
1841 datas : pointer;
1842 end;
1843 PDynArrayRec = ^TDynArrayRec;
1844
1845 procedure FinalizeVariant(p: Pointer; aType: TPSTypeRec);
1846 var
1847 t: TPSTypeRec;
1848 elsize: Cardinal;
1849 i, l: Longint;
1850 darr: PDynArrayRec;
1851 begin
1852 case aType.BaseType of
1853 btString: tbtString(p^) := '';
1854 {$IFNDEF PS_NOWIDESTRING}
1855 btWideString: tbtwidestring(p^) := '';
1856 btUnicodeString: tbtunicodestring(p^) := '';
1857 {$ENDIF}
1858 {$IFNDEF PS_NOINTERFACES}btInterface:
1859 begin
1860 {$IFNDEF DELPHI3UP}
1861 if IUnknown(p^) <> nil then
1862 IUnknown(p^).Release;
1863 {$ENDIF}
1864 IUnknown(p^) := nil;
1865 end; {$ENDIF}
1866 btVariant:
1867 begin
1868 try
1869 Finalize(Variant(p^));
1870 except
1871 end;
1872 end;
1873 btPointer:
1874 if Pointer(Pointer(IPointer(p)+PointerSize2)^) <> nil then
1875 begin
1876 DestroyHeapVariant2(Pointer(p^), Pointer(Pointer(IPointer(p)+PointerSize)^));
1877 Pointer(p^) := nil;
1878 end;
1879 btArray:
1880 begin
1881 if IPointer(P^) = 0 then exit;
1882 darr := PDynArrayRec(IPointer(p^) - sizeof(TDynArrayRecHeader));
1883 if darr^.header.refCnt < 0 then exit;// refcount < 0 means don't free
1884 Dec(darr^.header.refCnt);
1885 if darr^.header.refCnt <> 0 then exit;
1886 t := TPSTypeRec_Array(aType).ArrayType;
1887 elsize := t.RealSize;
1888 {$IFDEF FPC}
1889 l := darr^.header.high + 1;
1890 {$ELSE}
1891 l := darr^.header.length;
1892 {$ENDIF FPC}
1893 darr := @darr^.datas;
1894 case t.BaseType of
1895 btString, {$IFNDEF PS_NOWIDESTRING}
1896 btUnicodeString, btWideString, {$ENDIF}{$IFNDEF PS_NOINTERFACES}btInterface, {$ENDIF}btArray, btStaticArray,
1897 btRecord, btPointer, btVariant:
1898 begin
1899 for i := 0 to l -1 do
1900 begin
1901 FinalizeVariant(darr, t);
1902 darr := Pointer(IPointer(darr) + elsize);
1903 end;
1904 end;
1905 end;
1906 FreeMem(Pointer(IPointer(p^) - SizeOf(TDynArrayRecHeader)), IPointer(Cardinal(l) * elsize) + SizeOf(TDynArrayRecHeader));
1907 Pointer(P^) := nil;
1908 end;
1909 btRecord:
1910 begin
1911 for i := 0 to TPSTypeRec_Record(aType).FFieldTypes.Count -1 do
1912 begin
1913 t := TPSTypeRec_Record(aType).FieldTypes[i];
1914 case t.BaseType of
1915 btString, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF}{$IFNDEF PS_NOINTERFACES}btInterface, {$ENDIF}btArray, btStaticArray,
1916 btRecord: FinalizeVariant(p, t);
1917 end;
1918 p := Pointer(IPointer(p) + t.FrealSize);
1919 end;
1920 end;
1921 btStaticArray:
1922 begin
1923 t := TPSTypeRec_Array(aType).ArrayType;
1924 case t.BaseType of
1925 btString, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF}{$IFNDEF PS_NOINTERFACES}btInterface, {$ENDIF}btArray, btStaticArray,
1926 btRecord: ;
1927 else Exit;
1928 end;
1929 for i := 0 to TPSTypeRec_StaticArray(aType).Size -1 do
1930 begin
1931 FinalizeVariant(p, t);
1932 p := Pointer(IPointer(p) + t.RealSize);
1933 end;
1934 end;
1935 end;
1936 end;
1937
1938 function CreateHeapVariant2(aType: TPSTypeRec): Pointer;
1939 begin
1940 GetMem(Result, aType.RealSize);
1941 InitializeVariant(Result, aType);
1942 end;
1943
1944 procedure DestroyHeapVariant2(v: Pointer; aType: TPSTypeRec);
1945 begin
1946 if v = nil then exit;
1947 if atype.BaseType in NeedFinalization then
1948 FinalizeVariant(v, aType);
1949 FreeMem(v, aType.RealSize);
1950 end;
1951
1952
1953 function CreateHeapVariant(aType: TPSTypeRec): PPSVariant;
1954 var
1955 aSize: Longint;
1956 begin
1957 aSize := aType.RealSize + RTTISize;
1958 GetMem(Result, aSize);
1959 Result.FType := aType;
1960 InitializeVariant(Pointer(IPointer(Result)+PointerSize), aType);
1961 end;
1962
1963 procedure DestroyHeapVariant(v: PPSVariant);
1964 begin
1965 if v = nil then exit;
1966 if v.FType.BaseType in NeedFinalization then
1967 FinalizeVariant(Pointer(IPointer(v)+PointerSize), v.FType);
1968 FreeMem(v, v.FType.RealSize + RTTISize);
1969 end;
1970
1971 procedure FreePSVariantList(l: TPSList);
1972 var
1973 i: Longint;
1974 begin
1975 for i:= l.count -1 downto 0 do
1976 DestroyHeapVariant(l[i]);
1977 l.free;
1978 end;
1979
1980 procedure FreePIFVariantList(l: TPSList);
1981 begin
1982 FreePsVariantList(l);
1983 end;
1984
1985 { TPSExec }
1986
1987 procedure TPSExec.ClearFunctionList;
1988 var
1989 x: PProcRec;
1990 l: Longint;
1991 begin
1992 for l := FAttributeTypes.Count -1 downto 0 do
1993 begin
1994 TPSAttributeType(FAttributeTypes.Data^[l]).Free;
1995 end;
1996 FAttributeTypes.Clear;
1997
1998 for l := 0 to FRegProcs.Count - 1 do
1999 begin
2000 x := FRegProcs.Data^[l];
2001 if @x^.FreeProc <> nil then x^.FreeProc(Self, x);
2002 Dispose(x);
2003 end;
2004 FRegProcs.Clear;
2005 RegisterStandardProcs;
2006 end;
2007
2008 class function TPSExec.About: tbtString;
2009 begin
2010 Result := 'RemObjects Pascal Script. Copyright (c) 2004-2010 by RemObjects Software';
2011 end;
2012
2013 procedure TPSExec.Cleanup;
2014 var
2015 I: Longint;
2016 p: Pointer;
2017 begin
2018 if FStatus <> isLoaded then
2019 exit;
2020 FStack.Clear;
2021 FTempVars.Clear;
2022 for I := Longint(FGlobalVars.Count) - 1 downto 0 do
2023 begin
2024 p := FGlobalVars.Items[i];
2025 if PIFTypeRec(P^).BaseType in NeedFinalization then
2026 FinalizeVariant(Pointer(IPointer(p)+PointerSize), Pointer(P^));
2027 InitializeVariant(Pointer(IPointer(p)+PointerSize), Pointer(P^));
2028 end;
2029 end;
2030
2031 procedure TPSExec.Clear;
2032 var
2033 I: Longint;
2034 temp: PPSResource;
2035 Proc: TPSResourceFreeProc;
2036 pp: TPSExceptionHandler;
2037 begin
2038 for i := Longint(FExceptionStack.Count) -1 downto 0 do
2039 begin
2040 pp := FExceptionStack.Data^[i];
2041 pp.Free;
2042 end;
2043 for i := Longint(FResources.Count) -1 downto 0 do
2044 begin
2045 Temp := FResources.Data^[i];
2046 Proc := Temp^.Proc;
2047 Proc(Self, Temp^.P);
2048 Dispose(Temp);
2049 end;
2050 for i := Longint(FExportedVars.Count) -1 downto 0 do
2051 Dispose(PPSExportedVar(FExportedVars.Data^[I]));
2052 for I := Longint(FProcs.Count) - 1downto 0 do
2053 TPSProcRec(FProcs.Data^[i]).Destroy;
2054 FProcs.Clear;
2055 FGlobalVars.Clear;
2056 FStack.Clear;
2057 for I := Longint(FTypes.Count) - 1downto 0 do
2058 TPSTypeRec(FTypes.Data^[i]).Free;
2059 FTypes.Clear;
2060 FStatus := isNotLoaded;
2061 FResources.Clear;
2062 FExportedVars.Clear;
2063 FExceptionStack.Clear;
2064 FCurrStackBase := InvalidVal;
2065 end;
2066
2067 constructor TPSExec.Create;
2068 begin
2069 inherited Create;
2070 FAttributeTypes := TPSList.Create;
2071 FExceptionStack := TPSList.Create;
2072 FCallCleanup := False;
2073 FResources := TPSList.Create;
2074 FTypes := TPSList.Create;
2075 FProcs := TPSList.Create;
2076 FGlobalVars := TPSStack.Create;
2077 FTempVars := TPSStack.Create;
2078 FMainProc := 0;
2079 FStatus := isNotLoaded;
2080 FRegProcs := TPSList.Create;
2081 FExportedVars := TPSList.create;
2082 FSpecialProcList := TPSList.Create;
2083 RegisterStandardProcs;
2084 FReturnAddressType := TPSTypeRec.Create(self);
2085 FReturnAddressType.BaseType := btReturnAddress;
2086 FReturnAddressType.CalcSize;
2087 FVariantType := TPSTypeRec.Create(self);
2088 FVariantType.BaseType := btVariant;
2089 FVariantType.CalcSize;
2090 FVariantArrayType := TPSTypeRec_Array.Create(self);
2091 FVariantArrayType.BaseType := btArray;
2092 FVariantArrayType.CalcSize;
2093 TPSTypeRec_Array(FVariantArrayType).ArrayType := FVariantType;
2094 FStack := TPSStack.Create;
2095 end;
2096
2097 destructor TPSExec.Destroy;
2098 var
2099 I: Longint;
2100 x: PProcRec;
2101 P: PSpecialProc;
2102 begin
2103 Clear;
2104 FReturnAddressType.Free;
2105 FVariantType.Free;
2106 FVariantArrayType.Free;
2107
2108 if ExObject <> nil then ExObject.Free;
2109 for I := FSpecialProcList.Count -1 downto 0 do
2110 begin
2111 P := FSpecialProcList.Data^[I];
2112 Dispose(p);
2113 end;
2114 FResources.Free;
2115 FExportedVars.Free;
2116 FTempVars.Free;
2117 FStack.Free;
2118 FGlobalVars.Free;
2119 FProcs.Free;
2120 FTypes.Free;
2121 FSpecialProcList.Free;
2122 for i := FRegProcs.Count - 1 downto 0 do
2123 begin
2124 x := FRegProcs.Data^[i];
2125 if @x^.FreeProc <> nil then x^.FreeProc(Self, x);
2126 Dispose(x);
2127 end;
2128 FRegProcs.Free;
2129 FExceptionStack.Free;
2130 for i := FAttributeTypes.Count -1 downto 0 do
2131 begin
2132 TPSAttributeType(FAttributeTypes[i]).Free;
2133 end;
2134 FAttributeTypes.Free;
2135 inherited Destroy;
2136 end;
2137
2138 procedure TPSExec.ExceptionProc(proc, Position: Cardinal; Ex: TPSError; const s: tbtString; NewObject: TObject);
2139 var
2140 d, l: Longint;
2141 pp: TPSExceptionHandler;
2142 begin
2143 ExProc := proc;
2144 ExPos := Position;
2145 ExEx := Ex;
2146 ExParam := s;
2147 if ExObject <> nil then
2148 ExObject.Free;
2149 ExObject := NewObject;
2150 if Ex = eNoError then Exit;
2151 for d := FExceptionStack.Count -1 downto 0 do
2152 begin
2153 pp := FExceptionStack[d];
2154 if Cardinal(FStack.Count) > pp.StackSize then
2155 begin
2156 for l := Longint(FStack.count) -1 downto Longint(pp.StackSize) do
2157 FStack.Pop;
2158 end;
2159 if pp.CurrProc = nil then // no point in continuing
2160 begin
2161 pp.Free;
2162 FExceptionStack.DeleteLast;
2163
2164 FCurrStackBase := InvalidVal;
2165 FStatus := isPaused;
2166 exit;
2167 end;
2168 FCurrProc := pp.CurrProc;
2169 FData := FCurrProc.Data;
2170 FDataLength := FCurrProc.Length;
2171
2172 FCurrStackBase := pp.BasePtr;
2173 if pp.FinallyOffset <> InvalidVal then
2174 begin
2175 FCurrentPosition := pp.FinallyOffset;
2176 pp.FinallyOffset := InvalidVal;
2177 Exit;
2178 end else if (pp.ExceptOffset <> InvalidVal) and (pp.ExceptOffset <> Cardinal(InvalidVal -1)) then
2179 begin
2180 FCurrentPosition := pp.ExceptOffset;
2181 pp.ExceptOffset := Cardinal(InvalidVal -1);
2182 pp.ExceptionObject := ExObject;
2183 pp.ExceptionData := ExEx;
2184 pp.ExceptionParam := ExParam;
2185 ExObject := nil;
2186 ExEx := ENoError;
2187 Exit;
2188 end else if pp.Finally2Offset <> InvalidVal then
2189 begin
2190 FCurrentPosition := pp.Finally2Offset;
2191 pp.Finally2Offset := InvalidVal;
2192 Exit;
2193 end;
2194 pp.Free;
2195 FExceptionStack.DeleteLast;
2196 end;
2197 if FStatus <> isNotLoaded then
2198 FStatus := isPaused;
2199 end;
2200
2201 function LookupProc(List: TPSList; const Name: ShortString): PProcRec;
2202 var
2203 h, l: Longint;
2204 p: PProcRec;
2205 begin
2206 h := MakeHash(Name);
2207 for l := List.Count - 1 downto 0 do
2208 begin
2209 p := List.Data^[l];
2210 if (p^.Hash = h) and (p^.Name = Name) then
2211 begin
2212 Result := List[l];
2213 exit;
2214 end;
2215 end;
2216 Result := nil;
2217 end;
2218
ImportProcnull2219 function TPSExec.ImportProc(const Name: ShortString; proc: TPSExternalProcRec): Boolean;
2220 var
2221 u: PProcRec;
2222 fname: tbtString;
2223 I, fnh: Longint;
2224 P: PSpecialProc;
2225
2226 begin
2227 if name = '' then
2228 begin
2229 fname := proc.Decl;
2230 fname := copy(fname, 1, pos(tbtchar(':'), fname)-1);
2231 fnh := MakeHash(fname);
2232 for I := FSpecialProcList.Count -1 downto 0 do
2233 begin
2234 p := FSpecialProcList[I];
2235 IF (p^.name = '') or ((p^.namehash = fnh) and (p^.name = fname)) then
2236 begin
2237 if p^.P(Self, Proc, p^.tag) then
2238 begin
2239 Result := True;
2240 exit;
2241 end;
2242 end;
2243 end;
2244 Result := FAlse;
2245 exit;
2246 end;
2247 u := LookupProc(FRegProcs, Name);
2248 if u = nil then begin
2249 Result := False;
2250 exit;
2251 end;
2252 proc.ProcPtr := u^.ProcPtr;
2253 proc.Ext1 := u^.Ext1;
2254 proc.Ext2 := u^.Ext2;
2255 Result := True;
2256 end;
2257
RegisterFunctionNamenull2258 function TPSExec.RegisterFunctionName(const Name: tbtString; ProcPtr: TPSProcPtr; Ext1, Ext2: Pointer): PProcRec;
2259 var
2260 p: PProcRec;
2261 s: tbtString;
2262 begin
2263 s := FastUppercase(Name);
2264 New(p);
2265 p^.Name := s;
2266 p^.Hash := MakeHash(s);
2267 p^.ProcPtr := ProcPtr;
2268 p^.FreeProc := nil;
2269 p^.Ext1 := Ext1;
2270 p^.Ext2 := Ext2;
2271 FRegProcs.Add(p);
2272 Result := P;
2273 end;
2274
LoadDatanull2275 function TPSExec.LoadData(const s: tbtString): Boolean;
2276 var
2277 HDR: TPSHeader;
2278 Pos: Cardinal;
2279
2280 function read(var Data; Len: Cardinal): Boolean;
2281 begin
2282 if Longint(Pos + Len) <= Length(s) then begin
2283 Move(s[Pos + 1], Data, Len);
2284 Pos := Pos + Len;
2285 read := True;
2286 end
2287 else
2288 read := False;
2289 end;
2290 function ReadAttributes(Dest: TPSRuntimeAttributes): Boolean;
2291 var
2292 Count: Cardinal;
2293 i: Integer;
2294
2295 function ReadAttrib: Boolean;
2296 var
2297 NameLen: Longint;
2298 Name: tbtString;
2299 TypeNo: Cardinal;
2300 i, h, FieldCount: Longint;
2301 att: TPSRuntimeAttribute;
2302 varp: PIFVariant;
2303
2304 begin
2305 if (not Read(NameLen, 4)) or (NameLen > Length(s) - Longint(Pos)) then
2306 begin
2307 CMD_Err(ErOutOfRange);
2308 Result := false;
2309 exit;
2310 end;
2311 SetLength(Name, NameLen);
2312 if not Read(Name[1], NameLen) then
2313 begin
2314 CMD_Err(ErOutOfRange);
2315 Result := false;
2316 exit;
2317 end;
2318 if not Read(FieldCount, 4) then
2319 begin
2320 CMD_Err(ErOutOfRange);
2321 Result := false;
2322 exit;
2323 end;
2324 att := Dest.Add;
2325 att.AttribType := Name;
2326 att.AttribTypeHash := MakeHash(att.AttribType);
2327 for i := 0 to FieldCount -1 do
2328 begin
2329 if (not Read(TypeNo, 4)) or (TypeNo >= Cardinal(FTypes.Count)) then
2330 begin
2331 CMD_Err(ErOutOfRange);
2332 Result := false;
2333 exit;
2334 end;
2335
2336 varp := att.AddValue(FTypes[TypeNo]);
2337 case VarP^.FType.BaseType of
2338 btSet:
2339 begin
2340 if not read(PPSVariantSet(varp).Data, TPSTypeRec_Set(varp.FType).aByteSize) then
2341 begin
2342 CMD_Err(erOutOfRange);
2343
2344 DestroyHeapVariant(VarP);
2345 Result := False;
2346 exit;
2347 end;
2348 end;
2349 bts8, btchar, btU8: if not read(PPSVariantU8(VarP)^.data, 1) then
2350 begin
2351 CMD_Err(erOutOfRange);
2352 DestroyHeapVariant(VarP);
2353 Result := False;
2354 exit;
2355 end;
2356 bts16, {$IFNDEF PS_NOWIDESTRING}btwidechar,{$ENDIF} btU16: if not read(PPSVariantU16(Varp)^.Data, SizeOf(TbtU16)) then begin
2357 CMD_Err(ErOutOfRange);
2358 DestroyHeapVariant(VarP);
2359 Result := False;
2360 exit;
2361 end;
2362 bts32, btU32:
2363 begin
2364 if FCurrentPosition + 3 >= FDataLength then
2365 begin
2366 Cmd_Err(erOutOfRange);
2367 DestroyHeapVariant(VarP);
2368 Result := False;
2369 exit;;
2370 end;
2371 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
2372 PPSVariantU32(varp)^.Data := unaligned(Cardinal((@FData^[FCurrentPosition])^));
2373 {$else}
2374 PPSVariantU32(varp)^.Data := Cardinal((@FData^[FCurrentPosition])^);
2375 {$endif}
2376 Inc(FCurrentPosition, 4);
2377 end;
2378 btProcPtr:
2379 begin
2380 if FCurrentPosition + 3 >= FDataLength then
2381 begin
2382 Cmd_Err(erOutOfRange);
2383 DestroyHeapVariant(VarP);
2384 Result := False;
2385 exit;;
2386 end;
2387 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
2388 PPSVariantU32(varp)^.Data := unaligned(Cardinal((@FData^[FCurrentPosition])^));
2389 {$else}
2390 PPSVariantU32(varp)^.Data := Cardinal((@FData^[FCurrentPosition])^);
2391 {$endif}
2392 if PPSVariantU32(varp)^.Data = 0 then
2393 begin
2394 PPSVariantProcPtr(varp)^.Ptr := nil;
2395 PPSVariantProcPtr(varp)^.Self := nil;
2396 end;
2397 Inc(FCurrentPosition, 4);
2398 end;
2399 {$IFNDEF PS_NOINT64}
2400 bts64: if not read(PPSVariantS64(VarP)^.Data, sizeof(tbts64)) then
2401 begin
2402 CMD_Err(erOutOfRange);
2403 DestroyHeapVariant(VarP);
2404 Result := False;
2405 exit;
2406 end;
2407 {$ENDIF}
2408 btSingle: if not read(PPSVariantSingle(VarP)^.Data, SizeOf(TbtSingle))
2409 then begin
2410 CMD_Err(erOutOfRange);
2411 DestroyHeapVariant(VarP);
2412 Result := False;
2413 exit;
2414 end;
2415 btDouble: if not read(PPSVariantDouble(varp)^.Data, SizeOf(TbtDouble))
2416 then begin
2417 CMD_Err(erOutOfRange);
2418 DestroyHeapVariant(VarP);
2419 Result := False;
2420 exit;
2421 end;
2422 btExtended: if not read(PPSVariantExtended(varp)^.Data, SizeOf(TbtExtended))
2423 then begin
2424 CMD_Err(erOutOfRange);
2425 DestroyHeapVariant(VarP);
2426 Result := False;
2427 exit;
2428 end;
2429 btCurrency: if not read(PPSVariantExtended(varp)^.Data, SizeOf(tbtCurrency))
2430 then begin
2431 CMD_Err(erOutOfRange);
2432 DestroyHeapVariant(VarP);
2433 Result := False;
2434 exit;
2435 end;
2436 btPchar, btString:
2437 begin
2438 if not read(NameLen, 4) then
2439 begin
2440 Cmd_Err(erOutOfRange);
2441 DestroyHeapVariant(VarP);
2442 Result := False;
2443 exit;
2444 end;
2445 Inc(FCurrentPosition, 4);
2446 SetLength(PPSVariantAString(varp)^.Data, NameLen);
2447 if not read(PPSVariantAString(varp)^.Data[1], NameLen) then begin
2448 CMD_Err(erOutOfRange);
2449 DestroyHeapVariant(VarP);
2450 Result := False;
2451 exit;
2452 end;
2453 end;
2454 {$IFNDEF PS_NOWIDESTRING}
2455 btWidestring:
2456 begin
2457 if not read(NameLen, 4) then
2458 begin
2459 Cmd_Err(erOutOfRange);
2460 DestroyHeapVariant(VarP);
2461 Result := False;
2462 exit;
2463 end;
2464 Inc(FCurrentPosition, 4);
2465 SetLength(PPSVariantWString(varp).Data, NameLen);
2466 if not read(PPSVariantWString(varp).Data[1], NameLen*2) then begin
2467 CMD_Err(erOutOfRange);
2468 DestroyHeapVariant(VarP);
2469 Result := False;
2470 exit;
2471 end;
2472 end;
2473 btUnicodeString:
2474 begin
2475 if not read(NameLen, 4) then
2476 begin
2477 Cmd_Err(erOutOfRange);
2478 DestroyHeapVariant(VarP);
2479 Result := False;
2480 exit;
2481 end;
2482 Inc(FCurrentPosition, 4);
2483 SetLength(PPSVariantUString(varp).Data, NameLen);
2484 if not read(PPSVariantUString(varp).Data[1], NameLen*2) then begin
2485 CMD_Err(erOutOfRange);
2486 DestroyHeapVariant(VarP);
2487 Result := False;
2488 exit;
2489 end;
2490 end;
2491 {$ENDIF}
2492 else begin
2493 CMD_Err(erInvalidType);
2494 DestroyHeapVariant(VarP);
2495 Result := False;
2496 exit;
2497 end;
2498 end;
2499 end;
2500 h := MakeHash(att.AttribType);
2501 for i := FAttributeTypes.Count -1 downto 0 do
2502 begin
2503 if (TPSAttributeType(FAttributeTypes.Data^[i]).TypeNameHash = h) and
2504 (TPSAttributeType(FAttributeTypes.Data^[i]).TypeName = att.AttribType) then
2505 begin
2506 if not TPSAttributeType(FAttributeTypes.Data^[i]).UseProc(Self, att.AttribType, Att) then
2507 begin
2508 Result := False;
2509 exit;
2510 end;
2511 end;
2512 end;
2513 Result := True;
2514 end;
2515
2516
2517 begin
2518 if not Read(Count, 4) then
2519 begin
2520 CMD_Err(erOutofRange);
2521 Result := false;
2522 exit;
2523 end;
2524 for i := 0 to Count -1 do
2525 begin
2526 if not ReadAttrib then
2527 begin
2528 Result := false;
2529 exit;
2530 end;
2531 end;
2532 Result := True;
2533 end;
2534
2535 {$WARNINGS OFF}
2536
2537 function LoadTypes: Boolean;
2538 var
2539 currf: TPSType;
2540 Curr: PIFTypeRec;
2541 fe: Boolean;
2542 l2, l: Longint;
2543 d: Cardinal;
2544
2545 function resolve(Dta: TPSTypeRec_Record): Boolean;
2546 var
2547 offs, l: Longint;
2548 begin
2549 offs := 0;
2550 for l := 0 to Dta.FieldTypes.Count -1 do
2551 begin
2552 Dta.RealFieldOffsets.Add(Pointer(offs));
2553 offs := offs + TPSTypeRec(Dta.FieldTypes[l]).RealSize;
2554 end;
2555 Result := True;
2556 end;
2557 begin
2558 LoadTypes := True;
2559 for l := 0 to HDR.TypeCount - 1 do begin
2560 if not read(currf, SizeOf(currf)) then begin
2561 cmd_err(erUnexpectedEof);
2562 LoadTypes := False;
2563 exit;
2564 end;
2565 if (currf.BaseType and 128) <> 0 then begin
2566 fe := True;
2567 currf.BaseType := currf.BaseType - 128;
2568 end else
2569 fe := False;
2570 case currf.BaseType of
2571 {$IFNDEF PS_NOINT64}bts64, {$ENDIF}
2572 btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btCurrency,
2573 btExtended, btString, btPointer, btPChar,
2574 btVariant, btChar{$IFNDEF PS_NOWIDESTRING}, btUnicodeString, btWideString, btWideChar{$ENDIF}: begin
2575 curr := TPSTypeRec.Create(self);
2576 Curr.BaseType := currf.BaseType;
2577 FTypes.Add(Curr);
2578 end;
2579 btClass:
2580 begin
2581 Curr := TPSTypeRec_Class.Create(self);
2582 if (not Read(d, 4)) or (d > 255) then
2583 begin
2584 curr.Free;
2585 cmd_err(erUnexpectedEof);
2586 LoadTypes := False;
2587 exit;
2588 end;
2589 setlength(TPSTypeRec_Class(Curr).FCN, d);
2590 if not Read(TPSTypeRec_Class(Curr).FCN[1], d) then
2591 begin
2592 curr.Free;
2593 cmd_err(erUnexpectedEof);
2594 LoadTypes := False;
2595 exit;
2596 end;
2597 Curr.BaseType := currf.BaseType;
2598 FTypes.Add(Curr);
2599 end;
2600 btProcPtr:
2601 begin
2602 Curr := TPSTypeRec_ProcPtr.Create(self);
2603 if (not Read(d, 4)) or (d > 255) then
2604 begin
2605 curr.Free;
2606 cmd_err(erUnexpectedEof);
2607 LoadTypes := False;
2608 exit;
2609 end;
2610 setlength(TPSTypeRec_ProcPtr(Curr).FParamInfo, d);
2611 if not Read(TPSTypeRec_ProcPtr(Curr).FParamInfo[1], d) then
2612 begin
2613 curr.Free;
2614 cmd_err(erUnexpectedEof);
2615 LoadTypes := False;
2616 exit;
2617 end;
2618 Curr.BaseType := currf.BaseType;
2619 FTypes.Add(Curr);
2620 end;
2621 {$IFNDEF PS_NOINTERFACES}
2622 btInterface:
2623 begin
2624 Curr := TPSTypeRec_Interface.Create(self);
2625 if not Read(TPSTypeRec_Interface(Curr).FGUID, Sizeof(TGuid)) then
2626 begin
2627 curr.Free;
2628 cmd_err(erUnexpectedEof);
2629 LoadTypes := False;
2630 exit;
2631 end;
2632 Curr.BaseType := currf.BaseType;
2633 FTypes.Add(Curr);
2634 end;
2635 {$ENDIF}
2636 btSet:
2637 begin
2638 Curr := TPSTypeRec_Set.Create(self);
2639 if not Read(d, 4) then
2640 begin
2641 curr.Free;
2642 cmd_err(erUnexpectedEof);
2643 LoadTypes := False;
2644 exit;
2645 end;
2646 if (d > 256) then
2647 begin
2648 curr.Free;
2649 cmd_err(erTypeMismatch);
2650 LoadTypes := False;
2651 exit;
2652 end;
2653
2654 TPSTypeRec_Set(curr).aBitSize := d;
2655 TPSTypeRec_Set(curr).aByteSize := TPSTypeRec_Set(curr).aBitSize shr 3;
2656 if (TPSTypeRec_Set(curr).aBitSize and 7) <> 0 then inc(TPSTypeRec_Set(curr).fbytesize);
2657 Curr.BaseType := currf.BaseType;
2658 FTypes.Add(Curr);
2659 end;
2660 btStaticArray:
2661 begin
2662 curr := TPSTypeRec_StaticArray.Create(self);
2663 if not Read(d, 4) then
2664 begin
2665 curr.Free;
2666 cmd_err(erUnexpectedEof);
2667 LoadTypes := False;
2668 exit;
2669 end;
2670 if (d >= FTypes.Count) then
2671 begin
2672 curr.Free;
2673 cmd_err(erTypeMismatch);
2674 LoadTypes := False;
2675 exit;
2676 end;
2677 TPSTypeRec_StaticArray(curr).ArrayType := FTypes[d];
2678 if not Read(d, 4) then
2679 begin
2680 curr.Free;
2681 cmd_err(erUnexpectedEof);
2682 LoadTypes := False;
2683 exit;
2684 end;
2685 if d > (MaxInt div 4) then
2686 begin
2687 curr.Free;
2688 cmd_err(erUnexpectedEof);
2689 LoadTypes := False;
2690 exit;
2691 end;
2692 TPSTypeRec_StaticArray(curr).Size := d;
2693 if not Read(d,4) then //<-additional StartOffset
2694 begin
2695 curr.Free;
2696 cmd_err(erUnexpectedEof);
2697 LoadTypes:=false;
2698 Exit;
2699 end;
2700 TPSTypeRec_StaticArray(curr).StartOffset:=d;
2701
2702 Curr.BaseType := currf.BaseType;
2703 FTypes.Add(Curr);
2704 end;
2705 btArray: begin
2706 Curr := TPSTypeRec_Array.Create(self);
2707 if not read(d, 4) then
2708 begin // Read type
2709 curr.Free;
2710 cmd_err(erUnexpectedEof);
2711 LoadTypes := False;
2712 exit;
2713 end;
2714 if (d >= FTypes.Count) then
2715 begin
2716 curr.Free;
2717 cmd_err(erTypeMismatch);
2718 LoadTypes := False;
2719 exit;
2720 end;
2721 Curr.BaseType := currf.BaseType;
2722 TPSTypeRec_Array(curr).ArrayType := FTypes[d];
2723 FTypes.Add(Curr);
2724 end;
2725 btRecord:
2726 begin
2727 curr := TPSTypeRec_Record.Create(self);
2728 if not read(d, 4) or (d = 0) then
2729 begin
2730 curr.Free;
2731 cmd_err(erUnexpectedEof);
2732 LoadTypes := false;
2733 exit;
2734 end;
2735 while d > 0 do
2736 begin
2737 if not Read(l2, 4) then
2738 begin
2739 curr.Free;
2740 cmd_err(erUnexpectedEof);
2741 LoadTypes := false;
2742 exit;
2743 end;
2744 if Cardinal(l2) >= FTypes.Count then
2745 begin
2746 curr.Free;
2747 cmd_err(ErOutOfRange);
2748 LoadTypes := false;
2749 exit;
2750 end;
2751 TPSTypeRec_Record(curR).FFieldTypes.Add(FTypes[l2]);
2752 Dec(D);
2753 end;
2754 if not resolve(TPSTypeRec_Record(curr)) then
2755 begin
2756 curr.Free;
2757 cmd_err(erInvalidType);
2758 LoadTypes := False;
2759 exit;
2760 end;
2761 Curr.BaseType := currf.BaseType;
2762 FTypes.Add(Curr);
2763 end;
2764 else begin
2765 LoadTypes := False;
2766 CMD_Err(erInvalidType);
2767 exit;
2768 end;
2769 end;
2770 if fe then begin
2771 if not read(d, 4) then begin
2772 cmd_err(erUnexpectedEof);
2773 LoadTypes := False;
2774 exit;
2775 end;
2776 if d > PSAddrNegativeStackStart then
2777 begin
2778 cmd_err(erInvalidType);
2779 LoadTypes := False;
2780 exit;
2781 end;
2782 SetLength(Curr.FExportName, d);
2783 if not read(Curr.fExportName[1], d) then
2784 begin
2785 cmd_err(erUnexpectedEof);
2786 LoadTypes := False;
2787 exit;
2788 end;
2789 Curr.ExportNameHash := MakeHash(Curr.ExportName);
2790 end;
2791 curr.CalcSize;
2792 if HDR.PSBuildNo >= 21 then // since build 21 we support attributes
2793 begin
2794 if not ReadAttributes(Curr.Attributes) then
2795 begin
2796 LoadTypes := False;
2797 exit;
2798 end;
2799 end;
2800 end;
2801 end;
2802
2803 function LoadProcs: Boolean;
2804 var
2805 Rec: TPSProc;
2806 n: tbtString;
2807 b: Byte;
2808 l, L2, L3: Longint;
2809 Curr: TPSProcRec;
2810 begin
2811 LoadProcs := True;
2812 for l := 0 to HDR.ProcCount - 1 do begin
2813 if not read(Rec, SizeOf(Rec)) then begin
2814 cmd_err(erUnexpectedEof);
2815 LoadProcs := False;
2816 exit;
2817 end;
2818 if (Rec.Flags and 1) <> 0 then
2819 begin
2820 Curr := TPSExternalProcRec.Create(Self);
2821 if not read(b, 1) then begin
2822 Curr.Free;
2823 cmd_err(erUnexpectedEof);
2824 LoadProcs := False;
2825 exit;
2826 end;
2827 SetLength(n, b);
2828 if not read(n[1], b) then begin
2829 Curr.Free;
2830 cmd_err(erUnexpectedEof);
2831 LoadProcs := False;
2832 exit;
2833 end;
2834 TPSExternalProcRec(Curr).Name := n;
2835 if (Rec.Flags and 3 = 3) then
2836 begin
2837 if (not Read(L2, 4)) or (L2 > Length(s) - Pos) then
2838 begin
2839 Curr.Free;
2840 cmd_err(erUnexpectedEof);
2841 LoadProcs := False;
2842 exit;
2843 end;
2844 SetLength(n, L2);
2845 Read(n[1], L2); // no check is needed
2846 TPSExternalProcRec(Curr).FDecl := n;
2847 end;
2848 if not ImportProc(TPSExternalProcRec(Curr).Name, TPSExternalProcRec(Curr)) then begin
2849 if TPSExternalProcRec(Curr).Name <> '' then
2850 CMD_Err2(erCannotImport, TPSExternalProcRec(Curr).Name)
2851 else
2852 CMD_Err2(erCannotImport, TPSExternalProcRec(curr).Decl);
2853 Curr.Free;
2854 LoadProcs := False;
2855 exit;
2856 end;
2857 end else begin
2858 Curr := TPSInternalProcRec.Create(Self);
2859 if not read(L2, 4) then begin
2860 Curr.Free;
2861 cmd_err(erUnexpectedEof);
2862 LoadProcs := False;
2863 exit;
2864 end;
2865 if not read(L3, 4) then begin
2866 Curr.Free;
2867 cmd_err(erUnexpectedEof);
2868 LoadProcs := False;
2869 exit;
2870 end;
2871 if (L2 < 0) or (L2 >= Length(s)) or (L2 + L3 > Length(s)) or (L3 = 0) then begin
2872 Curr.Free;
2873 cmd_err(erUnexpectedEof);
2874 LoadProcs := False;
2875 exit;
2876 end;
2877
2878 GetMem(TPSInternalProcRec(Curr).FData, L3);
2879 Move(s[L2 + 1], TPSInternalProcRec(Curr).FData^, L3);
2880 TPSInternalProcRec(Curr).FLength := L3;
2881 if (Rec.Flags and 2) <> 0 then begin // exported
2882 if not read(L3, 4) then begin
2883 Curr.Free;
2884 cmd_err(erUnexpectedEof);
2885 LoadProcs := False;
2886 exit;
2887 end;
2888 if L3 > PSAddrNegativeStackStart then begin
2889 Curr.Free;
2890 cmd_err(erUnexpectedEof);
2891 LoadProcs := False;
2892 exit;
2893 end;
2894 SetLength(TPSInternalProcRec(Curr).FExportName, L3);
2895 if not read(TPSInternalProcRec(Curr).FExportName[1], L3) then begin
2896 Curr.Free;
2897 cmd_err(erUnexpectedEof);
2898 LoadProcs := False;
2899 exit;
2900 end;
2901 if not read(L3, 4) then begin
2902 Curr.Free;
2903 cmd_err(erUnexpectedEof);
2904 LoadProcs := False;
2905 exit;
2906 end;
2907 if L3 > PSAddrNegativeStackStart then begin
2908 Curr.Free;
2909 cmd_err(erUnexpectedEof);
2910 LoadProcs := False;
2911 exit;
2912 end;
2913 SetLength(TPSInternalProcRec(Curr).FExportDecl, L3);
2914 if not read(TPSInternalProcRec(Curr).FExportDecl[1], L3) then begin
2915 Curr.Free;
2916 cmd_err(erUnexpectedEof);
2917 LoadProcs := False;
2918 exit;
2919 end;
2920 TPSInternalProcRec(Curr).FExportNameHash := MakeHash(TPSInternalProcRec(Curr).ExportName);
2921 end;
2922 end;
2923 if (Rec.Flags and 4) <> 0 then
2924 begin
2925 if not ReadAttributes(Curr.Attributes) then
2926 begin
2927 Curr.Free;
2928 LoadProcs := False;
2929 exit;
2930 end;
2931 end;
2932 FProcs.Add(Curr);
2933 end;
2934 end;
2935 {$WARNINGS ON}
2936
2937 function LoadVars: Boolean;
2938 var
2939 l, n: Longint;
2940 e: PPSExportedVar;
2941 Rec: TPSVar;
2942 Curr: PIfVariant;
2943 begin
2944 LoadVars := True;
2945 for l := 0 to HDR.VarCount - 1 do begin
2946 if not read(Rec, SizeOf(Rec)) then begin
2947 cmd_err(erUnexpectedEof);
2948 LoadVars := False;
2949 exit;
2950 end;
2951 if Rec.TypeNo >= HDR.TypeCount then begin
2952 cmd_err(erInvalidType);
2953 LoadVars := False;
2954 exit;
2955 end;
2956 Curr := FGlobalVars.PushType(FTypes.Data^[Rec.TypeNo]);
2957 if Curr = nil then begin
2958 cmd_err(erInvalidType);
2959 LoadVars := False;
2960 exit;
2961 end;
2962 if (Rec.Flags and 1) <> 0 then
2963 begin
2964 if not read(n, 4) then begin
2965 cmd_err(erUnexpectedEof);
2966 LoadVars := False;
2967 exit;
2968 end;
2969 new(e);
2970 try
2971 SetLength(e^.FName, n);
2972 if not Read(e^.FName[1], n) then
2973 begin
2974 dispose(e);
2975 cmd_err(erUnexpectedEof);
2976 LoadVars := False;
2977 exit;
2978 end;
2979 e^.FNameHash := MakeHash(e^.FName);
2980 e^.FVarNo := FGlobalVars.Count;
2981 FExportedVars.Add(E);
2982 except
2983 dispose(e);
2984 cmd_err(erInvalidType);
2985 LoadVars := False;
2986 exit;
2987 end;
2988 end;
2989 end;
2990 end;
2991
2992 begin
2993 Clear;
2994 Pos := 0;
2995 LoadData := False;
2996 if not read(HDR, SizeOf(HDR)) then
2997 begin
2998 CMD_Err(erInvalidHeader);
2999 exit;
3000 end;
3001 if HDR.HDR <> PSValidHeader then
3002 begin
3003 CMD_Err(erInvalidHeader);
3004 exit;
3005 end;
3006 if (HDR.PSBuildNo > PSCurrentBuildNo) or (HDR.PSBuildNo < PSLowBuildSupport) then begin
3007 CMD_Err(erInvalidHeader);
3008 exit;
3009 end;
3010 if not LoadTypes then
3011 begin
3012 Clear;
3013 exit;
3014 end;
3015 if not LoadProcs then
3016 begin
3017 Clear;
3018 exit;
3019 end;
3020 if not LoadVars then
3021 begin
3022 Clear;
3023 exit;
3024 end;
3025 if (HDR.MainProcNo >= FProcs.Count) and (HDR.MainProcNo <> InvalidVal)then begin
3026 CMD_Err(erNoMainProc);
3027 Clear;
3028 exit;
3029 end;
3030 // Load Import Table
3031 FMainProc := HDR.MainProcNo;
3032 FStatus := isLoaded;
3033 Result := True;
3034 end;
3035
3036
3037 procedure TPSExec.Pause;
3038 begin
3039 if FStatus = isRunning then
3040 FStatus := isPaused;
3041 end;
3042
ReadDatanull3043 function TPSExec.ReadData(var Data; Len: Cardinal): Boolean;
3044 begin
3045 if FCurrentPosition + Len <= FDataLength then begin
3046 Move(FData^[FCurrentPosition], Data, Len);
3047 FCurrentPosition := FCurrentPosition + Len;
3048 Result := True;
3049 end
3050 else
3051 Result := False;
3052 end;
3053
3054 procedure TPSExec.CMD_Err(EC: TPSError); // Error
3055 begin
3056 CMD_Err3(ec, '', nil);
3057 end;
3058
3059 procedure VNSetPointerTo(const Src: TPSVariantIFC; Data: Pointer; aType: TPSTypeRec);
3060 begin
3061 if Src.aType.BaseType = btPointer then
3062 begin
3063 if atype.BaseType in NeedFinalization then
3064 FinalizeVariant(src.Dta, Src.aType);
3065 Pointer(Src.Dta^) := Data;
3066 Pointer(Pointer(IPointer(Src.Dta)+PointerSize)^) := aType;
3067 Pointer(Pointer(IPointer(Src.Dta)+(2*PointerSize))^) := nil;
3068 end;
3069 end;
3070
3071 function VNGetUInt(const Src: TPSVariantIFC): Cardinal;
3072 begin
3073 Result := PSGetUInt(Src.Dta, Src.aType);
3074 end;
3075
3076 {$IFNDEF PS_NOINT64}
3077 function VNGetInt64(const Src: TPSVariantIFC): Int64;
3078 begin
3079 Result := PSGetInt64(Src.Dta, Src.aType);
3080 end;
3081 {$ENDIF}
3082
3083 function VNGetReal(const Src: TPSVariantIFC): Extended;
3084 begin
3085 Result := PSGetReal(Src.Dta, Src.aType);
3086 end;
3087
3088 function VNGetCurrency(const Src: TPSVariantIFC): Currency;
3089 begin
3090 Result := PSGetCurrency(Src.Dta, Src.aType);
3091 end;
3092
3093 function VNGetInt(const Src: TPSVariantIFC): Longint;
3094 begin
3095 Result := PSGetInt(Src.Dta, Src.aType);
3096 end;
3097
3098 function VNGetAnsiString(const Src: TPSVariantIFC): tbtString;
3099 begin
3100 Result := PSGetAnsiString(Src.Dta, Src.aType);
3101 end;
3102
3103 {$IFNDEF PS_NOWIDESTRING}
3104 function VNGetWideString(const Src: TPSVariantIFC): tbtWideString;
3105 begin
3106 Result := PSGetWideString(Src.Dta, Src.aType);
3107 end;
3108
3109 function VNGetUnicodeString(const Src: TPSVariantIFC): tbtunicodestring;
3110 begin
3111 Result := PSGetUnicodeString(Src.Dta, Src.aType);
3112 end;
3113 {$ENDIF}
3114
3115 procedure VNSetUInt(const Src: TPSVariantIFC; const Val: Cardinal);
3116 var
3117 Dummy: Boolean;
3118 begin
3119 PSSetUInt(Src.Dta, Src.aType, Dummy, Val);
3120 end;
3121
3122 {$IFNDEF PS_NOINT64}
3123 procedure VNSetInt64(const Src: TPSVariantIFC; const Val: Int64);
3124 var
3125 Dummy: Boolean;
3126 begin
3127 PSSetInt64(Src.Dta, Src.aType, Dummy, Val);
3128 end;
3129 {$ENDIF}
3130
3131 procedure VNSetReal(const Src: TPSVariantIFC; const Val: Extended);
3132 var
3133 Dummy: Boolean;
3134 begin
3135 PSSetReal(Src.Dta, Src.aType, Dummy, Val);
3136 end;
3137
3138 procedure VNSetCurrency(const Src: TPSVariantIFC; const Val: Currency);
3139 var
3140 Dummy: Boolean;
3141 begin
3142 PSSetCurrency(Src.Dta, Src.aType, Dummy, Val);
3143 end;
3144
3145 procedure VNSetInt(const Src: TPSVariantIFC; const Val: Longint);
3146 var
3147 Dummy: Boolean;
3148 begin
3149 PSSetInt(Src.Dta, Src.aType, Dummy, Val);
3150 end;
3151
3152 procedure VNSetAnsiString(const Src: TPSVariantIFC; const Val: tbtString);
3153 var
3154 Dummy: Boolean;
3155 begin
3156 PSSetAnsiString(Src.Dta, Src.aType, Dummy, Val);
3157 end;
3158
3159 function VNGetString(const Src: TPSVariantIFC): String;
3160 begin
3161 {$IFNDEF PS_NOWIDESTRING}
3162 {$IFDEF DELPHI2009UP}
3163 Result := VNGetUnicodeString(Src);
3164 {$ELSE}
3165 Result := VNGetAnsiString(Src);
3166 {$ENDIF}
3167 {$ELSE}
3168 Result := VNGetAnsiString(Src);
3169 {$ENDIF}
3170 end;
3171
3172 procedure VNSetString(const Src: TPSVariantIFC; const Val: String);
3173 begin
3174 {$IFNDEF PS_NOWIDESTRING}
3175 {$IFDEF DELPHI2009UP}
3176 VNSetUnicodeString(Src, Val);
3177 {$ELSE}
3178 VNSetAnsiString(Src, Val);
3179 {$ENDIF}
3180 {$ELSE}
3181 VNSetAnsiString(Src, Val);
3182 {$ENDIF}
3183 end;
3184
3185 {$IFNDEF PS_NOWIDESTRING}
3186 procedure VNSetWideString(const Src: TPSVariantIFC; const Val: tbtWideString);
3187 var
3188 Dummy: Boolean;
3189 begin
3190 PSSetWideString(Src.Dta, Src.aType, Dummy, Val);
3191 end;
3192
3193 procedure VNSetUnicodeString(const Src: TPSVariantIFC; const Val: tbtunicodestring);
3194 var
3195 Dummy: Boolean;
3196 begin
3197 PSSetUnicodeString(Src.Dta, Src.aType, Dummy, Val);
3198 end;
3199
3200 {$ENDIF}
3201
3202 function VGetUInt(const Src: PIFVariant): Cardinal;
3203 begin
3204 Result := PSGetUInt(@PPSVariantData(src).Data, src.FType);
3205 end;
3206
3207 {$IFNDEF PS_NOINT64}
3208 function VGetInt64(const Src: PIFVariant): Int64;
3209 begin
3210 Result := PSGetInt64(@PPSVariantData(src).Data, src.FType);
3211 end;
3212 {$ENDIF}
3213
3214 function VGetReal(const Src: PIFVariant): Extended;
3215 begin
3216 Result := PSGetReal(@PPSVariantData(src).Data, src.FType);
3217 end;
3218
3219 function VGetCurrency(const Src: PIFVariant): Currency;
3220 begin
3221 Result := PSGetCurrency(@PPSVariantData(src).Data, src.FType);
3222 end;
3223
3224 function VGetInt(const Src: PIFVariant): Longint;
3225 begin
3226 Result := PSGetInt(@PPSVariantData(src).Data, src.FType);
3227 end;
3228
3229 function VGetAnsiString(const Src: PIFVariant): tbtString;
3230 begin
3231 Result := PSGetAnsiString(@PPSVariantData(src).Data, src.FType);
3232 end;
3233
3234 {$IFNDEF PS_NOWIDESTRING}
3235 function VGetWideString(const Src: PIFVariant): tbtWideString;
3236 begin
3237 Result := PSGetWideString(@PPSVariantData(src).Data, src.FType);
3238 end;
3239
3240 function VGetUnicodeString(const Src: PIFVariant): tbtunicodestring;
3241 begin
3242 Result := PSGetUnicodeString(@PPSVariantData(src).Data, src.FType);
3243 end;
3244
3245 {$ENDIF}
3246
3247
3248 procedure VSetPointerTo(const Src: PIFVariant; Data: Pointer; aType: TPSTypeRec);
3249 var
3250 temp: TPSVariantIFC;
3251 begin
3252 if (Atype = nil) or (Data = nil) or (Src = nil) then raise Exception.Create(RPS_InvalidVariable);
3253 temp.Dta := @PPSVariantData(Src).Data;
3254 temp.aType := Src.FType;
3255 temp.VarParam := false;
3256 VNSetPointerTo(temp, Data, AType);
3257 end;
3258
3259 procedure VSetUInt(const Src: PIFVariant; const Val: Cardinal);
3260 var
3261 Dummy: Boolean;
3262 begin
3263 PSSetUInt(@PPSVariantData(src).Data, src.FType, Dummy, Val);
3264 end;
3265
3266 {$IFNDEF PS_NOINT64}
3267 procedure VSetInt64(const Src: PIFVariant; const Val: Int64);
3268 var
3269 Dummy: Boolean;
3270 begin
3271 PSSetInt64(@PPSVariantData(src).Data, src.FType, Dummy, Val);
3272 end;
3273 {$ENDIF}
3274
3275 procedure VSetReal(const Src: PIFVariant; const Val: Extended);
3276 var
3277 Dummy: Boolean;
3278 begin
3279 PSSetReal(@PPSVariantData(src).Data, src.FType, Dummy, Val);
3280 end;
3281
3282 procedure VSetCurrency(const Src: PIFVariant; const Val: Currency);
3283 var
3284 Dummy: Boolean;
3285 begin
3286 PSSetCurrency(@PPSVariantData(src).Data, src.FType, Dummy, Val);
3287 end;
3288
3289 procedure VSetInt(const Src: PIFVariant; const Val: Longint);
3290 var
3291 Dummy: Boolean;
3292 begin
3293 PSSetInt(@PPSVariantData(src).Data, src.FType, Dummy, Val);
3294 end;
3295
3296 procedure VSetAnsiString(const Src: PIFVariant; const Val: tbtString);
3297 var
3298 Dummy: Boolean;
3299 begin
3300 PSSetAnsiString(@PPSVariantData(src).Data, src.FType, Dummy, Val);
3301 end;
3302
3303 function VGetString(const Src: PIFVariant): String;
3304 begin
3305 {$IFNDEF PS_NOWIDESTRING}
3306 {$IFDEF DELPHI2009UP}
3307 Result := PSGetUnicodeString(@PPSVariantData(src).Data, src.FType);
3308 {$ELSE}
3309 Result := PSGetAnsiString(@PPSVariantData(src).Data, src.FType);
3310 {$ENDIF}
3311 {$ELSE}
3312 Result := PSGetAnsiString(@PPSVariantData(src).Data, src.FType);
3313 {$ENDIF}
3314 end;
3315
3316 procedure VSetString(const Src: PIFVariant; const Val: string);
3317 var
3318 Dummy: Boolean;
3319 begin
3320 {$IFNDEF PS_NOWIDESTRING}
3321 {$IFDEF DELPHI2009UP}
3322 PSSetUnicodeString(@PPSVariantData(src).Data, src.FType, Dummy, Val);
3323 {$ELSE}
3324 PSSetAnsiString(@PPSVariantData(src).Data, src.FType, Dummy, Val);
3325 {$ENDIF}
3326 {$ELSE}
3327 PSSetAnsiString(@PPSVariantData(src).Data, src.FType, Dummy, Val);
3328 {$ENDIF}
3329 end;
3330
3331
3332 {$IFNDEF PS_NOWIDESTRING}
3333 procedure VSetWideString(const Src: PIFVariant; const Val: tbtWideString);
3334 var
3335 Dummy: Boolean;
3336 begin
3337 PSSetWideString(@PPSVariantData(src).Data, src.FType, Dummy, Val);
3338 end;
3339
3340 procedure VSetUnicodeString(const Src: PIFVariant; const Val: tbtunicodestring);
3341 var
3342 Dummy: Boolean;
3343 begin
3344 PSSetUnicodeString(@PPSVariantData(src).Data, src.FType, Dummy, Val);
3345 end;
3346
3347
3348 {$ENDIF}
3349
3350 {$IFNDEF PS_NOWIDESTRING}
3351 function VarToWideStr(const Data: Variant): tbtunicodestring;
3352 begin
3353 if not VarIsNull(Data) then
3354 Result := Data
3355 else
3356 Result := '';
3357 end;
3358 {$ENDIF}
3359
3360 function PSGetUInt(Src: Pointer; aType: TPSTypeRec): Cardinal;
3361 begin
3362 if aType.BaseType = btPointer then
3363 begin
3364 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3365 Src := Pointer(Src^);
3366 if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
3367 end;
3368 case aType.BaseType of
3369 btU8: Result := tbtu8(src^);
3370 btS8: Result := tbts8(src^);
3371 btU16: Result := tbtu16(src^);
3372 btS16: Result := tbts16(src^);
3373 btU32: Result := tbtu32(src^);
3374 btS32: Result := tbts32(src^);
3375 {$IFNDEF PS_NOINT64} btS64: Result := tbts64(src^);
3376 {$ENDIF}
3377 btChar: Result := Ord(tbtchar(Src^));
3378 {$IFNDEF PS_NOWIDESTRING} btWideChar: Result := Ord(tbtwidechar(Src^));{$ENDIF}
3379 btVariant:
3380 case VarType(Variant(Src^)) of
3381 varString:
3382 if Length(VarToStr(Variant(Src^))) = 1 then
3383 Result := Ord(VarToStr(Variant(Src^))[1])
3384 else
3385 raise Exception.Create(RPS_TypeMismatch);
3386 {$IFNDEF PS_NOWIDESTRING}
3387 varOleStr:
3388 if Length(VarToWideStr(Variant(Src^))) = 1 then
3389 Result := Ord(VarToWideStr(Variant(Src^))[1])
3390 else
3391 raise Exception.Create(RPS_TypeMismatch);
3392 {$ENDIF}
3393 else
3394 Result := Variant(src^);
3395 end;
3396 else raise Exception.Create(RPS_TypeMismatch);
3397 end;
3398 end;
3399
3400 function PSGetObject(Src: Pointer; aType: TPSTypeRec): TObject;
3401 begin
3402 if aType.BaseType = btPointer then
3403 begin
3404 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3405 Src := Pointer(Src^);
3406 if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
3407 end;
3408 case aType.BaseType of
3409 btClass: Result := TObject(Src^);
3410 else raise Exception.Create(RPS_TypeMismatch);
3411 end;
3412 end;
3413
3414 procedure PSSetObject(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; Const val: TObject);
3415 begin
3416 if aType.BaseType = btPointer then
3417 begin
3418 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3419 Src := Pointer(Src^);
3420 if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
3421 end;
3422 case aType.BaseType of
3423 btClass: TObject(Src^) := Val;
3424 else raise Exception.Create(RPS_TypeMismatch);
3425 end;
3426 end;
3427
3428
3429 {$IFNDEF PS_NOINT64}
3430 function PSGetInt64(Src: Pointer; aType: TPSTypeRec): Int64;
3431 begin
3432 if aType.BaseType = btPointer then
3433 begin
3434 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3435 Src := Pointer(Src^);
3436 if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
3437 end;
3438 case aType.BaseType of
3439 btU8: Result := tbtu8(src^);
3440 btS8: Result := tbts8(src^);
3441 btU16: Result := tbtu16(src^);
3442 btS16: Result := tbts16(src^);
3443 btU32: Result := tbtu32(src^);
3444 btS32: Result := tbts32(src^);
3445 btS64: Result := tbts64(src^);
3446 btChar: Result := Ord(tbtchar(Src^));
3447 {$IFNDEF PS_NOWIDESTRING}
3448 btWideChar: Result := Ord(tbtwidechar(Src^));
3449 {$ENDIF}
3450 {$IFDEF DELPHI6UP}
3451 btVariant: Result := Variant(src^);
3452 {$ENDIF}
3453 else raise Exception.Create(RPS_TypeMismatch);
3454 end;
3455 end;
3456 {$ENDIF}
3457
3458 function PSGetReal(Src: Pointer; aType: TPSTypeRec): Extended;
3459 begin
3460 if aType.BaseType = btPointer then
3461 begin
3462 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3463 Src := Pointer(Src^);
3464 if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
3465 end;
3466 case aType.BaseType of
3467 btU8: Result := tbtu8(src^);
3468 btS8: Result := tbts8(src^);
3469 btU16: Result := tbtu16(src^);
3470 btS16: Result := tbts16(src^);
3471 btU32: Result := tbtu32(src^);
3472 btS32: Result := tbts32(src^);
3473 {$IFNDEF PS_NOINT64} btS64: Result := tbts64(src^);{$ENDIF}
3474 btSingle: Result := tbtsingle(Src^);
3475 btDouble: Result := tbtdouble(Src^);
3476 btExtended: Result := tbtextended(Src^);
3477 btCurrency: Result := tbtcurrency(Src^);
3478 btVariant: Result := Variant(src^);
3479 else raise Exception.Create(RPS_TypeMismatch);
3480 end;
3481 end;
3482
3483 function PSGetCurrency(Src: Pointer; aType: TPSTypeRec): Currency;
3484 begin
3485 if aType.BaseType = btPointer then
3486 begin
3487 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3488 Src := Pointer(Src^);
3489 if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
3490 end;
3491 case aType.BaseType of
3492 btU8: Result := tbtu8(src^);
3493 btS8: Result := tbts8(src^);
3494 btU16: Result := tbtu16(src^);
3495 btS16: Result := tbts16(src^);
3496 btU32: Result := tbtu32(src^);
3497 btS32: Result := tbts32(src^);
3498 {$IFNDEF PS_NOINT64} btS64: Result := tbts64(src^);{$ENDIF}
3499 btSingle: Result := tbtsingle(Src^);
3500 btDouble: Result := tbtdouble(Src^);
3501 btExtended: Result := tbtextended(Src^);
3502 btCurrency: Result := tbtcurrency(Src^);
3503 btVariant: Result := Variant(src^);
3504 else raise Exception.Create(RPS_TypeMismatch);
3505 end;
3506 end;
3507
3508
3509 function PSGetInt(Src: Pointer; aType: TPSTypeRec): Longint;
3510 begin
3511 if aType.BaseType = btPointer then
3512 begin
3513 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3514 Src := Pointer(Src^);
3515 if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
3516 end;
3517 case aType.BaseType of
3518 btU8: Result := tbtu8(src^);
3519 btS8: Result := tbts8(src^);
3520 btU16: Result := tbtu16(src^);
3521 btS16: Result := tbts16(src^);
3522 btU32: Result := tbtu32(src^);
3523 btS32: Result := tbts32(src^);
3524 {$IFNDEF PS_NOINT64} btS64: Result := tbts64(src^);{$ENDIF}
3525 btChar: Result := Ord(tbtchar(Src^));
3526 {$IFNDEF PS_NOWIDESTRING} btWideChar: Result := Ord(tbtwidechar(Src^));{$ENDIF}
3527 btVariant: Result := Variant(src^);
3528 else raise Exception.Create(RPS_TypeMismatch);
3529 end;
3530 end;
3531
3532
3533 function PSGetAnsiString(Src: Pointer; aType: TPSTypeRec): tbtString;
3534 begin
3535 if aType.BaseType = btPointer then
3536 begin
3537 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3538 Src := Pointer(Src^);
3539 if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
3540 end;
3541 case aType.BaseType of
3542 btU8: Result := tbtchar(tbtu8(src^));
3543 btChar: Result := tbtchar(Src^);
3544 btPchar: Result := pansichar(src^);
3545 {$IFNDEF PS_NOWIDESTRING} btWideChar: Result := tbtString(tbtwidechar(Src^));{$ENDIF}
3546 btString: Result := tbtstring(src^);
3547 {$IFNDEF PS_NOWIDESTRING}
3548 btUnicodeString: result := tbtString(tbtUnicodestring(src^));
3549 btWideString: Result := tbtString(tbtwidestring(src^));{$ENDIF}
3550 btVariant: Result := tbtString(Variant(src^));
3551 else raise Exception.Create(RPS_TypeMismatch);
3552 end;
3553 end;
3554 {$IFNDEF PS_NOWIDESTRING}
3555 function PSGetWideString(Src: Pointer; aType: TPSTypeRec): tbtWideString;
3556 begin
3557 if aType.BaseType = btPointer then
3558 begin
3559 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3560 Src := Pointer(Src^);
3561 if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
3562 end;
3563 case aType.BaseType of
3564 btU8: Result := chr(tbtu8(src^));
3565 btU16: Result := widechar(src^);
3566 btChar: Result := tbtwidestring(tbtchar(Src^));
3567 btPchar: Result := tbtwidestring(pansichar(src^));
3568 btWideChar: Result := tbtwidechar(Src^);
3569 btString: Result := tbtwidestring(tbtstring(src^));
3570 btWideString: Result := tbtwidestring(src^);
3571 btVariant: Result := Variant(src^);
3572 btUnicodeString: result := tbtUnicodeString(src^);
3573 else raise Exception.Create(RPS_TypeMismatch);
3574 end;
3575 end;
3576
3577 function PSGetUnicodeString(Src: Pointer; aType: TPSTypeRec): tbtunicodestring;
3578 begin
3579 if aType.BaseType = btPointer then
3580 begin
3581 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3582 Src := Pointer(Src^);
3583 if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
3584 end;
3585 case aType.BaseType of
3586 btU8: Result := chr(tbtu8(src^));
3587 btU16: Result := widechar(src^);
3588 btChar: Result := tbtunicodestring(tbtchar(Src^));
3589 btPchar: Result := tbtunicodestring(pansichar(src^));
3590 btWideChar: Result := tbtwidechar(Src^);
3591 btString: Result := tbtunicodestring(tbtstring(src^));
3592 btWideString: Result := tbtwidestring(src^);
3593 btVariant: Result := Variant(src^);
3594 btUnicodeString: result := tbtUnicodeString(src^);
3595 else raise Exception.Create(RPS_TypeMismatch);
3596 end;
3597 end;
3598 {$ENDIF}
3599
3600 procedure PSSetUInt(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Cardinal);
3601 begin
3602 if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
3603 if aType.BaseType = btPointer then
3604 begin
3605 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3606 Src := Pointer(Src^);
3607 if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
3608 end;
3609 case aType.BaseType of
3610 btU8: tbtu8(src^) := Val;
3611 btS8: tbts8(src^) := Val;
3612 btU16: tbtu16(src^) := Val;
3613 btS16: tbts16(src^) := Val;
3614 btProcPtr:
3615 begin
3616 tbtu32(src^) := Val;
3617 Pointer(Pointer(IPointer(Src)+PointerSize)^) := nil;
3618 Pointer(Pointer(IPointer(Src)+PointerSize2)^) := nil;
3619 end;
3620 btU32: tbtu32(src^) := Val;
3621 btS32: tbts32(src^) := Val;
3622 {$IFNDEF PS_NOINT64} btS64: tbts64(src^) := Val;{$ENDIF}
3623 btChar: tbtchar(Src^) := tbtChar(Val);
3624 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtwidechar(Src^) := tbtwidechar(Val);{$ENDIF}
3625 btSingle: tbtSingle(src^) := Val;
3626 btDouble: tbtDouble(src^) := Val;
3627 btCurrency: tbtCurrency(src^) := Val;
3628 btExtended: tbtExtended(src^) := Val;
3629 btVariant:
3630 begin
3631 try
3632 Variant(src^) := {$IFDEF DELPHI6UP}val{$ELSE}tbts32(val){$ENDIF};
3633 except
3634 Ok := false;
3635 end;
3636 end;
3637 else ok := false;
3638 end;
3639 end;
3640
3641 {$IFNDEF PS_NOINT64}
3642 procedure PSSetInt64(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Int64);
3643 begin
3644 if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
3645 if aType.BaseType = btPointer then
3646 begin
3647 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3648 Src := Pointer(Src^);
3649 if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
3650 end;
3651 case aType.BaseType of
3652 btU8: tbtu8(src^) := Val;
3653 btS8: tbts8(src^) := Val;
3654 btU16: tbtu16(src^) := Val;
3655 btS16: tbts16(src^) := Val;
3656 btU32: tbtu32(src^) := Val;
3657 btS32: tbts32(src^) := Val;
3658 btS64: tbts64(src^) := Val;
3659 btChar: tbtchar(Src^) := tbtChar(Val);
3660 {$IFNDEF PS_NOWIDESTRING}
3661 btWideChar: tbtwidechar(Src^) := tbtwidechar(Val);
3662 {$ENDIF}
3663 btSingle: tbtSingle(src^) := Val;
3664 btDouble: tbtDouble(src^) := Val;
3665 btCurrency: tbtCurrency(src^) := Val;
3666 btExtended: tbtExtended(src^) := Val;
3667 {$IFDEF DELPHI6UP}
3668 btVariant:
3669 begin
3670 try
3671 Variant(src^) := Val;
3672 except
3673 Ok := false;
3674 end;
3675 end;
3676 {$ENDIF}
3677 else ok := false;
3678 end;
3679 end;
3680 {$ENDIF}
3681
3682 procedure PSSetReal(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Extended);
3683 begin
3684 if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
3685 if aType.BaseType = btPointer then
3686 begin
3687 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3688 Src := Pointer(Src^);
3689 if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
3690 end;
3691 case aType.BaseType of
3692 btSingle: tbtSingle(src^) := Val;
3693 btDouble: tbtDouble(src^) := Val;
3694 btCurrency: tbtCurrency(src^) := Val;
3695 btExtended: tbtExtended(src^) := Val;
3696 btVariant:
3697 begin
3698 try
3699 Variant(src^) := Val;
3700 except
3701 Ok := false;
3702 end;
3703 end;
3704 else ok := false;
3705 end;
3706 end;
3707
3708 procedure PSSetCurrency(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Currency);
3709 begin
3710 if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
3711 if aType.BaseType = btPointer then
3712 begin
3713 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3714 Src := Pointer(Src^);
3715 if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
3716 end;
3717 case aType.BaseType of
3718 btSingle: tbtSingle(src^) := Val;
3719 btDouble: tbtDouble(src^) := Val;
3720 btCurrency: tbtCurrency(src^) := Val;
3721 btExtended: tbtExtended(src^) := Val;
3722 btVariant:
3723 begin
3724 try
3725 Variant(src^) := Val;
3726 except
3727 Ok := false;
3728 end;
3729 end;
3730 else ok := false;
3731 end;
3732 end;
3733
3734 procedure PSSetInt(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Longint);
3735 begin
3736 if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
3737 if aType.BaseType = btPointer then
3738 begin
3739 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3740 Src := Pointer(Src^);
3741 if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
3742 end;
3743 case aType.BaseType of
3744 btU8: tbtu8(src^) := Val;
3745 btS8: tbts8(src^) := Val;
3746 btU16: tbtu16(src^) := Val;
3747 btS16: tbts16(src^) := Val;
3748 btProcPtr:
3749 begin
3750 tbtu32(src^) := Val;
3751 Pointer(Pointer(IPointer(Src)+PointerSize)^) := nil;
3752 Pointer(Pointer(IPointer(Src)+PointerSize2)^) := nil;
3753 end;
3754 btU32: tbtu32(src^) := Val;
3755 btS32: tbts32(src^) := Val;
3756 {$IFNDEF PS_NOINT64} btS64: tbts64(src^) := Val;{$ENDIF}
3757 btChar: tbtchar(Src^) := tbtChar(Val);
3758 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtwidechar(Src^) := tbtwidechar(Val);{$ENDIF}
3759 btSingle: tbtSingle(src^) := Val;
3760 btDouble: tbtDouble(src^) := Val;
3761 btCurrency: tbtCurrency(src^) := Val;
3762 btExtended: tbtExtended(src^) := Val;
3763 btVariant:
3764 begin
3765 try
3766 Variant(src^) := Val;
3767 except
3768 Ok := false;
3769 end;
3770 end;
3771 else ok := false;
3772 end;
3773 end;
3774
3775
3776 procedure PSSetAnsiString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtString);
3777 begin
3778 if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
3779 if aType.BaseType = btPointer then
3780 begin
3781 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3782 Src := Pointer(Src^);
3783 if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
3784 end;
3785 case aType.BaseType of
3786 btString: tbtstring(src^) := val;
3787 btChar: if AnsiString(val) <> '' then tbtchar(src^) := AnsiString(val)[1];
3788 {$IFNDEF PS_NOWIDESTRING}
3789 btUnicodeString: tbtunicodestring(src^) := tbtUnicodeString(AnsiString(val));
3790 btWideString: tbtwidestring(src^) := tbtwidestring(AnsiString(val));
3791 btWideChar: if AnsiString(val) <> '' then tbtwidechar(src^) := tbtwidechar(AnsiString(val)[1]);
3792 {$ENDIF}
3793 btVariant:
3794 begin
3795 try
3796 Variant(src^) := Val;
3797 except
3798 Ok := false;
3799 end;
3800 end;
3801 else ok := false;
3802 end;
3803 end;
3804 {$IFNDEF PS_NOWIDESTRING}
3805 procedure PSSetWideString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtWideString);
3806 begin
3807 if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
3808 if aType.BaseType = btPointer then
3809 begin
3810 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3811 Src := Pointer(Src^);
3812 if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
3813 end;
3814 case aType.BaseType of
3815 btChar: if val <> '' then tbtchar(src^) := tbtChar(val[1]);
3816 btWideChar: if val <> '' then tbtwidechar(src^) := val[1];
3817 btString: tbtstring(src^) := tbtString(val);
3818 btWideString: tbtwidestring(src^) := val;
3819 btUnicodeString: tbtunicodestring(src^) := val;
3820 btVariant:
3821 begin
3822 try
3823 Variant(src^) := Val;
3824 except
3825 Ok := false;
3826 end;
3827 end;
3828 else ok := false;
3829 end;
3830 end;
3831
3832 procedure PSSetUnicodeString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtunicodestring);
3833 begin
3834 if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
3835 if aType.BaseType = btPointer then
3836 begin
3837 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3838 Src := Pointer(Src^);
3839 if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
3840 end;
3841 case aType.BaseType of
3842 btString: tbtstring(src^) := tbtString(val);
3843 btWideString: tbtwidestring(src^) := val;
3844 btUnicodeString: tbtunicodestring(src^) := val;
3845 btVariant:
3846 begin
3847 try
3848 Variant(src^) := Val;
3849 except
3850 Ok := false;
3851 end;
3852 end;
3853 else ok := false;
3854 end;
3855 end;
3856 {$ENDIF}
3857
3858 function PSGetString(Src: Pointer; aType: TPSTypeRec): string;
3859 begin
3860 {$IFNDEF PS_NOWIDESTRING}
3861 {$IFDEF DELPHI2009UP}
3862 result := PSGetUnicodeString(Src, aType);
3863 {$ELSE}
3864 result := PSGetAnsiString(Src, aType);
3865 {$ENDIF}
3866 {$ELSE}
3867 result := PSGetAnsiString(Src, aType);
3868 {$ENDIF}
3869 end;
3870
3871 procedure PSSetString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: String);
3872 begin
3873 {$IFNDEF PS_NOWIDESTRING}
3874 {$IFDEF DELPHI2009UP}
3875 PSSetUnicodeString(Src, aType, Ok, Val);
3876 {$ELSE}
3877 PSSetAnsiString(Src, aType, Ok, Val);
3878 {$ENDIF}
3879 {$ELSE}
3880 PSSetAnsiString(Src, aType, Ok, Val);
3881 {$ENDIF}
3882 end;
3883
3884
3885 function CopyArrayContents(dest, src: Pointer; Len: Longint; aType: TPSTypeRec): Boolean; forward;
3886
3887 function CopyRecordContents(dest, src: Pointer; aType: TPSTypeRec_Record): Boolean;
3888 var
3889 o, i: Longint;
3890 begin
3891 for i := 0 to aType.FieldTypes.Count -1 do
3892 begin
3893 o := Longint(atype.RealFieldOffsets[i]);
3894 CopyArrayContents(Pointer(IPointer(Dest)+Cardinal(o)), Pointer(IPointer(Src)+Cardinal(o)), 1, aType.FieldTypes[i]);
3895 end;
3896 Result := true;
3897 end;
3898
3899 function CreateArrayFromVariant(Exec: TPSExec; dest: Pointer; src: Variant; DestType: TPSTypeRec): Boolean;
3900 var
3901 i: Integer;
3902 r: Pointer;
3903 lVarType: TPSTypeRec;
3904 v: variant;
3905 begin
3906 lVarType := Exec.FindType2(btVariant);
3907 if lVarType = nil then begin result := false; exit; end;
3908 PSDynArraySetLength(Pointer(dest^), desttype, VarArrayHighBound(src, 1) - VarArrayLowBound(src, 1) + 1);
3909 r := Pointer(Dest^);
3910 DestType := TPSTypeRec_Array(DestType).ArrayType;
3911 for i := 0 to VarArrayHighBound(src, 1) - VarArrayLowBound(src, 1) do begin
3912 v := src[i + VarArrayLowBound(src, 1)];
3913 if not Exec.SetVariantValue(r, @v, desttype, lVarType) then begin result := false; exit; end;
3914 //r := Pointer(IPointer(r) + Longint(DestType.RealSize));
3915 r := Pointer(IPointer(r) + DestType.RealSize);
3916 end;
3917 Result := true;
3918 end;
3919
3920 function CopyArrayContents(dest, src: Pointer; Len: Longint; aType: TPSTypeRec): Boolean;
3921 var
3922 elsize: Cardinal;
3923 i: Longint;
3924 begin
3925 try
3926 case aType.BaseType of
3927 btU8, btS8, btChar:
3928 for i := 0 to Len -1 do
3929 begin
3930 tbtU8(Dest^) := tbtU8(Src^);
3931 Dest := Pointer(IPointer(Dest) + 1);
3932 Src := Pointer(IPointer(Src) + 1);
3933 end;
3934 btU16, btS16{$IFNDEF PS_NOWIDESTRING}, btWideChar{$ENDIF}:
3935 for i := 0 to Len -1 do
3936 begin
3937 tbtU16(Dest^) := tbtU16(Src^);
3938 Dest := Pointer(IPointer(Dest) + 2);
3939 Src := Pointer(IPointer(Src) + 2);
3940 end;
3941 btProcPtr:
3942 for i := 0 to Len -1 do
3943 begin
3944 tbtU32(Dest^) := tbtU32(Src^);
3945 Dest := Pointer(IPointer(Dest) + PointerSize);
3946 Src := Pointer(IPointer(Src) + PointerSize);
3947 Pointer(Dest^) := Pointer(Src^);
3948 Dest := Pointer(IPointer(Dest) + PointerSize);
3949 Src := Pointer(IPointer(Src) + PointerSize);
3950 Pointer(Dest^) := Pointer(Src^);
3951 Dest := Pointer(IPointer(Dest) + PointerSize);
3952 Src := Pointer(IPointer(Src) + PointerSize);
3953 end;
3954 btClass, btpchar:
3955 for i := 0 to Len -1 do
3956 begin
3957 Pointer(Dest^) := Pointer(Src^);
3958 Dest := Pointer(IPointer(Dest) + PointerSize);
3959 Src := Pointer(IPointer(Src) + PointerSize);
3960 end;
3961 btU32, btS32, btSingle:
3962 for i := 0 to Len -1 do
3963 begin
3964 tbtU32(Dest^) := tbtU32(Src^);
3965 Dest := Pointer(IPointer(Dest) + 4);
3966 Src := Pointer(IPointer(Src) + 4);
3967 end;
3968 btDouble:
3969 for i := 0 to Len -1 do
3970 begin
3971 tbtDouble(Dest^) := tbtDouble(Src^);
3972 Dest := Pointer(IPointer(Dest) + 8);
3973 Src := Pointer(IPointer(Src) + 8);
3974 end;
3975 {$IFNDEF PS_NOINT64}bts64:
3976 for i := 0 to Len -1 do
3977 begin
3978 tbts64(Dest^) := tbts64(Src^);
3979 Dest := Pointer(IPointer(Dest) + 8);
3980 Src := Pointer(IPointer(Src) + 8);
3981 end;{$ENDIF}
3982 btExtended:
3983 for i := 0 to Len -1 do
3984 begin
3985 tbtExtended(Dest^) := tbtExtended(Src^);
3986 Dest := Pointer(IPointer(Dest) + SizeOf(Extended));
3987 Src := Pointer(IPointer(Src) + SizeOf(Extended));
3988 end;
3989 btCurrency:
3990 for i := 0 to Len -1 do
3991 begin
3992 tbtCurrency(Dest^) := tbtCurrency(Src^);
3993 Dest := Pointer(IPointer(Dest) + SizeOf(Currency));
3994 Src := Pointer(IPointer(Src) + SizeOf(Currency));
3995 end;
3996 btVariant:
3997 for i := 0 to Len -1 do
3998 begin
3999 variant(Dest^) := variant(Src^);
4000 Dest := Pointer(IPointer(Dest) + Sizeof(Variant));
4001 Src := Pointer(IPointer(Src) + Sizeof(Variant));
4002 end;
4003 btString:
4004 for i := 0 to Len -1 do
4005 begin
4006 tbtString(Dest^) := tbtString(Src^);
4007 Dest := Pointer(IPointer(Dest) + PointerSize);
4008 Src := Pointer(IPointer(Src) + PointerSize);
4009 end;
4010 {$IFNDEF PS_NOWIDESTRING}
4011 btUnicodeString:
4012 for i := 0 to Len -1 do
4013 begin
4014 tbtunicodestring(Dest^) := tbtunicodestring(Src^);
4015 Dest := Pointer(IPointer(Dest) + PointerSize);
4016 Src := Pointer(IPointer(Src) + PointerSize);
4017 end;
4018 btWideString:
4019 for i := 0 to Len -1 do
4020 begin
4021 tbtWideString(Dest^) := tbtWideString(Src^);
4022 Dest := Pointer(IPointer(Dest) + PointerSize);
4023 Src := Pointer(IPointer(Src) + PointerSize);
4024 end;
4025 {$ENDIF}
4026 btStaticArray:
4027 begin
4028 elSize := aType.RealSize;
4029 for i := 0 to Len -1 do
4030 begin
4031 if not CopyArrayContents(Dest, Src, TPSTypeRec_StaticArray(aType).Size, TPSTypeRec_StaticArray(aType).ArrayType) then
4032 begin
4033 result := false;
4034 exit;
4035 end;
4036 Dest := Pointer(IPointer(Dest) + elsize);
4037 Src := Pointer(IPointer(Src) + elsize);
4038 end;
4039 end;
4040 btArray:
4041 begin
4042 for i := 0 to Len -1 do
4043 begin
4044 if Pointer(Dest^) <> nil then
4045 begin
4046 PSDynArraySetLength(Pointer(Dest^), aType, 0);
4047 end;
4048 Pointer(Dest^) := Pointer(Src^);
4049 if Pointer(Dest^) <> nil then
4050 begin
4051 Inc(PDynArrayRec(PAnsiChar(Dest^) - SizeOf(TDynArrayRecHeader))^.header.refCnt);
4052 end;
4053 Dest := Pointer(IPointer(Dest) + PointerSize);
4054 Src := Pointer(IPointer(Src) + PointerSize);
4055 end;
4056 end;
4057 btRecord:
4058 begin
4059 elSize := aType.RealSize;
4060 for i := 0 to Len -1 do
4061 begin
4062 if not CopyRecordContents(Dest, Src, TPSTypeRec_Record(aType)) then
4063 begin
4064 result := false;
4065 exit;
4066 end;
4067 Dest := Pointer(IPointer(Dest) + elsize);
4068 Src := Pointer(IPointer(Src) + elsize);
4069 end;
4070 end;
4071 btSet:
4072 begin
4073 elSize := aType.RealSize;
4074 for i := 0 to Len -1 do
4075 begin
4076 Move(Src^, Dest^, elSize);
4077 Dest := Pointer(IPointer(Dest) + elsize);
4078 Src := Pointer(IPointer(Src) + elsize);
4079 end;
4080 end;
4081 {$IFNDEF PS_NOINTERFACES}
4082 btInterface:
4083 begin
4084 for i := 0 to Len -1 do
4085 begin
4086 {$IFNDEF DELPHI3UP}
4087 if IUnknown(Dest^) <> nil then
4088 begin
4089 IUnknown(Dest^).Release;
4090 IUnknown(Dest^) := nil;
4091 end;
4092 {$ENDIF}
4093 IUnknown(Dest^) := IUnknown(Src^);
4094 {$IFNDEF DELPHI3UP}
4095 if IUnknown(Dest^) <> nil then
4096 IUnknown(Dest^).AddRef;
4097 {$ENDIF}
4098 Dest := Pointer(IPointer(Dest) + PointerSize);
4099 Src := Pointer(IPointer(Src) + PointerSize);
4100 end;
4101 end;
4102 {$ENDIF}
4103 btPointer:
4104 begin
4105 if (Pointer(Pointer(IPointer(Dest)+PointerSize2)^) = nil) and (Pointer(Pointer(IPointer(Src)+PointerSize2)^) = nil) then
4106 begin
4107 for i := 0 to Len -1 do
4108 begin
4109 Pointer(Dest^) := Pointer(Src^);
4110 Dest := Pointer(IPointer(Dest) + PointerSize);
4111 Src := Pointer(IPointer(Src) + PointerSize);
4112 Pointer(Dest^) := Pointer(Src^);
4113 Dest := Pointer(IPointer(Dest) + PointerSize);
4114 Src := Pointer(IPointer(Src) + PointerSize);
4115 Pointer(Dest^) := nil;
4116 Dest := Pointer(IPointer(Dest) + PointerSize);
4117 Src := Pointer(IPointer(Src) + PointerSize);
4118 end;
4119 end else begin
4120 for i := 0 to Len -1 do
4121 begin
4122 if Pointer(Pointer(IPointer(Dest)+PointerSize2)^) <> nil then
4123 DestroyHeapVariant2(Pointer(Dest^), Pointer(Pointer(IPointer(Dest)+PointerSize)^));
4124 if Pointer(Src^) <> nil then
4125 begin
4126 if not LongBool(Pointer(IPointer(Src) + PointerSize2)^) then
4127 begin
4128 Pointer(Dest^) := Pointer(Src^);
4129 Pointer(Pointer(IPointer(Dest) + PointerSize)^) := Pointer(Pointer(IPointer(Src) + PointerSize)^);
4130 Pointer(Pointer(IPointer(Dest) + PointerSize2)^) := Pointer(Pointer(IPointer(Src) + PointerSize2)^);
4131 end else
4132 begin
4133 Pointer(Dest^) := CreateHeapVariant2(Pointer(Pointer(IPointer(Src) + PointerSize)^));
4134 Pointer(Pointer(IPointer(Dest) + PointerSize)^) := Pointer(Pointer(IPointer(Src) + PointerSize)^);
4135 LongBool(Pointer(IPointer(Dest) + PointerSize2)^) := true;
4136 if not CopyArrayContents(Pointer(Dest^), Pointer(Src^), 1, Pointer(Pointer(IPointer(Dest) + PointerSize)^)) then
4137 begin
4138 Result := false;
4139 exit;
4140 end;
4141 end;
4142 end else
4143 begin
4144 Pointer(Dest^) := nil;
4145 Pointer(Pointer(IPointer(Dest) + PointerSize)^) := nil;
4146 Pointer(Pointer(IPointer(Dest) + PointerSize2)^) := nil;
4147 end;
4148 Dest := Pointer(IPointer(Dest) + PointerSize*3);
4149 Src := Pointer(IPointer(Src) + PointerSize*3);
4150 end;
4151 end;
4152 end;
4153 // btResourcePointer = 15;
4154 // btVariant = 16;
4155 else
4156 Result := False;
4157 exit;
4158 end;
4159 except
4160 Result := False;
4161 exit;
4162 end;
4163 Result := true;
4164 end;
4165
4166 function GetPSArrayLength(Arr: PIFVariant): Longint;
4167 begin
4168 result := PSDynArrayGetLength(PPSVariantDynamicArray(arr).Data, arr.FType);
4169 end;
4170
4171 procedure SetPSArrayLength(Arr: PIFVariant; NewLength: Longint);
4172 begin
4173 PSDynArraySetLength(PPSVariantDynamicArray(arr).Data, arr.FType, NewLength);
4174 end;
4175
4176
4177 function PSDynArrayGetLength(arr: Pointer; aType: TPSTypeRec): Longint;
4178 begin
4179 if aType.BaseType <> btArray then raise Exception.Create(RPS_InvalidArray);
4180 if arr = nil then Result := 0 else result:=PDynArrayRec(PAnsiChar(arr) - SizeOf(TDynArrayRecHeader))^.header.{$IFDEF FPC}high + 1{$ELSE}length{$ENDIF FPC};
4181 end;
4182
4183 procedure PSDynArraySetLength(var arr: Pointer; aType: TPSTypeRec; NewLength: Longint);
4184 var
4185 elSize, i, OldLen: Longint;
4186 darr : PDynArrayRec;
4187 begin
4188 if aType.BaseType <> btArray then raise Exception.Create(RPS_InvalidArray);
4189 OldLen := PSDynArrayGetLength(arr, aType);
4190 elSize := TPSTypeRec_Array(aType).ArrayType.RealSize;
4191 if NewLength<0 then
4192 NewLength:=0;
4193 if (OldLen = 0) and (NewLength = 0) then exit; // already are both 0
4194 if (OldLen = NewLength) then exit; // already same size, noop
4195 darr := PDynArrayRec(PAnsiChar(Arr) - SizeOf(TDynArrayRecHeader));
4196 if (OldLen <> 0) and (darr^.header.refCnt = 1) then // unique copy of this dynamic array
4197 begin
4198 for i := NewLength to OldLen -1 do
4199 begin
4200 if TPSTypeRec_Array(aType).ArrayType.BaseType in NeedFinalization then
4201 FinalizeVariant(Pointer(IPointer(arr) + Cardinal(elsize * i)), TPSTypeRec_Array(aType).ArrayType);
4202 end;
4203 if NewLength <= 0 then
4204 begin
4205 FreeMem(darr);
4206 arr := nil;
4207 exit;
4208 end;
4209 ReallocMem(darr, Longint(NewLength * elSize) + SizeOf(TDynArrayRecHeader));
4210 {$IFDEF FPC}
4211 darr^.header.high := NewLength -1;
4212 {$ELSE}
4213 darr^.header.length := NewLength;
4214 {$ENDIF}
4215 arr := @darr^.datas;
4216 for i := OldLen to NewLength -1 do
4217 begin
4218 InitializeVariant(Pointer(IPointer(arr) + Cardinal(elsize * i)), TPSTypeRec_Array(aType).ArrayType);
4219 end;
4220 end else
4221 begin
4222 if NewLength = 0 then
4223 begin
4224 FinalizeVariant(@arr, aType);
4225 arr := nil;
4226 exit;
4227 end;
4228 GetMem(darr, Longint(NewLength * elSize) + SizeOf(TDynArrayRecHeader));
4229 darr^.header.refCnt:=1;
4230 {$IFDEF FPC}
4231 darr^.header.high := NewLength - 1;
4232 {$ELSE}
4233 {$IFDEF CPUX64}
4234 darr^.header._Padding:=0;
4235 {$ENDIF CPUX64}
4236 darr^.header.length := NewLength;
4237 {$ENDIF FPC}
4238 for i := 0 to NewLength -1 do
4239 begin
4240 InitializeVariant(Pointer(IPointer(@darr^.datas) + Cardinal(elsize * i)), TPSTypeRec_Array(aType).ArrayType);
4241 end;
4242 if OldLen <> 0 then
4243 begin
4244 if OldLen > NewLength then
4245 CopyArrayContents(@darr^.datas, arr, NewLength, TPSTypeRec_Array(aType).ArrayType)
4246 else
4247 CopyArrayContents(@darr^.datas, arr, OldLen, TPSTypeRec_Array(aType).ArrayType);
4248 FinalizeVariant(@arr, aType);
4249 end;
4250 arr := @darr^.datas;
4251 end;
4252 end;
4253
4254
4255 {$IFDEF FPC}
4256
4257 function OleErrorMessage(ErrorCode: HResult): tbtString;
4258 begin
4259 Result := SysErrorMessage(ErrorCode);
4260 if Result = '' then
4261 Result := Format(RPS_OLEError, [ErrorCode]);
4262 end;
4263
4264 procedure OleError(ErrorCode: HResult);
4265 begin
4266 raise Exception.Create(OleErrorMessage(ErrorCode));
4267 end;
4268
4269 procedure OleCheck(Result: HResult);
4270 begin
4271 if Result < 0 then OleError(Result);
4272 end;
4273 {$ENDIF}
4274
4275
4276 {$IFNDEF DELPHI3UP}
4277 function OleErrorMessage(ErrorCode: HResult): tbtString;
4278 begin
4279 Result := SysErrorMessage(ErrorCode);
4280 if Result = '' then
4281 Result := Format(RPS_OLEError, [ErrorCode]);
4282 end;
4283
4284 procedure OleError(ErrorCode: HResult);
4285 begin
4286 raise Exception.Create(OleErrorMessage(ErrorCode));
4287 end;
4288
4289 procedure OleCheck(Result: HResult);
4290 begin
4291 if Result < 0 then OleError(Result);
4292 end;
4293
4294 procedure AssignInterface(var Dest: IUnknown; const Src: IUnknown);
4295 var
4296 OldDest: IUnknown;
4297 begin
4298 { Like Delphi 3+'s _IntfCopy, reference source before releasing old dest.
4299 so that self assignment (I := I) works right }
4300 OldDest := Dest;
4301 Dest := Src;
4302 if Src <> nil then
4303 Src.AddRef;
4304 if OldDest <> nil then
4305 OldDest.Release;
4306 end;
4307
4308 procedure AssignVariantFromIDispatch(var Dest: Variant; const Src: IDispatch);
4309 begin
4310 VarClear(Dest);
4311 TVarData(Dest).VDispatch := Src;
4312 TVarData(Dest).VType := varDispatch;
4313 if Src <> nil then
4314 Src.AddRef;
4315 end;
4316
4317 procedure AssignIDispatchFromVariant(var Dest: IDispatch; const Src: Variant);
4318 const
4319 RPS_InvalidVariantRef = 'Invalid variant ref';
4320 var
4321 NewDest: IDispatch;
4322 begin
4323 case TVarData(Src).VType of
4324 varEmpty: NewDest := nil;
4325 varDispatch: NewDest := TVarData(Src).VDispatch;
4326 varDispatch or varByRef: NewDest := Pointer(TVarData(Src).VPointer^);
4327 else
4328 raise Exception.Create(RPS_InvalidVariantRef);
4329 end;
4330 AssignInterface(IUnknown(Dest), NewDest);
4331 end;
4332 {$ENDIF}
4333
SetVariantValuenull4334 function TPSExec.SetVariantValue(dest, Src: Pointer; desttype, srctype: TPSTypeRec): Boolean;
4335 var
4336 Tmp: TObject;
4337 tt: TPSVariantPointer;
4338 begin
4339 Result := True;
4340 try
4341 case desttype.BaseType of
4342 btSet:
4343 begin
4344 if desttype = srctype then
4345 Move(Src^, Dest^, TPSTypeRec_Set(desttype).aByteSize)
4346 else
4347 Result := False;
4348 end;
4349 btU8: tbtu8(Dest^) := PSGetUInt(Src, srctype);
4350 btS8: tbts8(Dest^) := PSGetInt(Src, srctype);
4351 btU16: tbtu16(Dest^) := PSGetUInt(Src, srctype);
4352 btS16: tbts16(Dest^) := PSGetInt(Src, srctype);
4353 btProcPtr:
4354 begin
4355 if srctype.BaseType = btPointer then
4356 begin
4357 srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
4358 Src := Pointer(Src^);
4359 if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch);
4360 end;
4361 case srctype.BaseType of
4362 btu32:
4363 begin
4364 Pointer(Dest^) := Pointer(Src^);
4365 end;
4366 btProcPtr:
4367 begin
4368 Pointer(Dest^) := Pointer(Src^);
4369 Pointer(Pointer(IPointer(Dest)+PointerSize)^) := Pointer(Pointer(IPointer(Src)+PointerSize)^);
4370 Pointer(Pointer(IPointer(Dest)+PointerSize2)^) := Pointer(Pointer(IPointer(Src)+PointerSize2)^);
4371 end;
4372 else raise Exception.Create(RPS_TypeMismatch);
4373 end;
4374 end;
4375 btU32:
4376 begin
4377 if srctype.BaseType = btPointer then
4378 begin
4379 srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
4380 Src := Pointer(Src^);
4381 if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch);
4382 end;
4383 case srctype.BaseType of
4384 btU8: tbtu32(Dest^) := tbtu8(src^);
4385 btS8: tbtu32(Dest^) := tbts8(src^);
4386 btU16: tbtu32(Dest^) := tbtu16(src^);
4387 btS16: tbtu32(Dest^) := tbts16(src^);
4388 btU32: tbtu32(Dest^) := tbtu32(src^);
4389 btS32: tbtu32(Dest^) := tbts32(src^);
4390 {$IFNDEF PS_NOINT64} btS64: tbtu32(Dest^) := tbts64(src^);{$ENDIF}
4391 btChar: tbtu32(Dest^) := Ord(tbtchar(Src^));
4392 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtu32(Dest^) := Ord(tbtwidechar(Src^));{$ENDIF}
4393 btVariant: tbtu32(Dest^) := Variant(src^);
4394 else raise Exception.Create(RPS_TypeMismatch);
4395 end;
4396 end;
4397 btS32:
4398 begin
4399 if srctype.BaseType = btPointer then
4400 begin
4401 srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
4402 Src := Pointer(Src^);
4403 if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch);
4404 end;
4405 case srctype.BaseType of
4406 btU8: tbts32(Dest^) := tbtu8(src^);
4407 btS8: tbts32(Dest^) := tbts8(src^);
4408 btU16: tbts32(Dest^) := tbtu16(src^);
4409 btS16: tbts32(Dest^) := tbts16(src^);
4410 btU32: tbts32(Dest^) := tbtu32(src^);
4411 btS32: tbts32(Dest^) := tbts32(src^);
4412 {$IFNDEF PS_NOINT64} btS64: tbts32(Dest^) := tbts64(src^);{$ENDIF}
4413 btChar: tbts32(Dest^) := Ord(tbtchar(Src^));
4414 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(Dest^) := Ord(tbtwidechar(Src^));{$ENDIF}
4415 btVariant: tbts32(Dest^) := Variant(src^);
4416 // nx change start - allow assignment of class
4417 btClass: tbtu32(Dest^) := tbtu32(src^);
4418 // nx change start
4419 else raise Exception.Create(RPS_TypeMismatch);
4420 end;
4421 end;
4422 {$IFNDEF PS_NOINT64}
4423 btS64: tbts64(Dest^) := PSGetInt64(Src, srctype);
4424 {$ENDIF}
4425 btSingle:
4426 begin
4427 if srctype.BaseType = btPointer then
4428 begin
4429 srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
4430 Src := Pointer(Src^);
4431 if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch);
4432 end;
4433 case srctype.BaseType of
4434 btU8: tbtsingle(Dest^) := tbtu8(src^);
4435 btS8: tbtsingle(Dest^) := tbts8(src^);
4436 btU16: tbtsingle(Dest^) := tbtu16(src^);
4437 btS16: tbtsingle(Dest^) := tbts16(src^);
4438 btU32: tbtsingle(Dest^) := tbtu32(src^);
4439 btS32: tbtsingle(Dest^) := tbts32(src^);
4440 {$IFNDEF PS_NOINT64} btS64: tbtsingle(Dest^) := tbts64(src^);{$ENDIF}
4441 btSingle: tbtsingle(Dest^) := tbtsingle(Src^);
4442 btDouble: tbtsingle(Dest^) := tbtdouble(Src^);
4443 btExtended: tbtsingle(Dest^) := tbtextended(Src^);
4444 btCurrency: tbtsingle(Dest^) := tbtcurrency(Src^);
4445 btVariant: tbtsingle(Dest^) := Variant(src^);
4446 else raise Exception.Create(RPS_TypeMismatch);
4447 end;
4448 end;
4449 btDouble:
4450 begin
4451 if srctype.BaseType = btPointer then
4452 begin
4453 srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
4454 Src := Pointer(Src^);
4455 if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch);
4456 end;
4457 case srctype.BaseType of
4458 btU8: tbtdouble(Dest^) := tbtu8(src^);
4459 btS8: tbtdouble(Dest^) := tbts8(src^);
4460 btU16: tbtdouble(Dest^) := tbtu16(src^);
4461 btS16: tbtdouble(Dest^) := tbts16(src^);
4462 btU32: tbtdouble(Dest^) := tbtu32(src^);
4463 btS32: tbtdouble(Dest^) := tbts32(src^);
4464 {$IFNDEF PS_NOINT64} btS64: tbtdouble(Dest^) := tbts64(src^);{$ENDIF}
4465 btSingle: tbtdouble(Dest^) := tbtsingle(Src^);
4466 btDouble: tbtdouble(Dest^) := tbtdouble(Src^);
4467 btExtended: tbtdouble(Dest^) := tbtextended(Src^);
4468 btCurrency: tbtdouble(Dest^) := tbtcurrency(Src^);
4469 btVariant: tbtdouble(Dest^) := Variant(src^);
4470 else raise Exception.Create(RPS_TypeMismatch);
4471 end;
4472
4473 end;
4474 btExtended:
4475 begin
4476 if srctype.BaseType = btPointer then
4477 begin
4478 srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
4479 Src := Pointer(Src^);
4480 if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch);
4481 end;
4482 case srctype.BaseType of
4483 btU8: tbtextended(Dest^) := tbtu8(src^);
4484 btS8: tbtextended(Dest^) := tbts8(src^);
4485 btU16: tbtextended(Dest^) := tbtu16(src^);
4486 btS16: tbtextended(Dest^) := tbts16(src^);
4487 btU32: tbtextended(Dest^) := tbtu32(src^);
4488 btS32: tbtextended(Dest^) := tbts32(src^);
4489 {$IFNDEF PS_NOINT64} btS64: tbtextended(Dest^) := tbts64(src^);{$ENDIF}
4490 btSingle: tbtextended(Dest^) := tbtsingle(Src^);
4491 btDouble: tbtextended(Dest^) := tbtdouble(Src^);
4492 btExtended: tbtextended(Dest^) := tbtextended(Src^);
4493 btCurrency: tbtextended(Dest^) := tbtcurrency(Src^);
4494 btVariant: tbtextended(Dest^) := Variant(src^);
4495 else raise Exception.Create(RPS_TypeMismatch);
4496 end;
4497 end;
4498 btCurrency: tbtcurrency(Dest^) := PSGetCurrency(Src, srctype);
4499 btPChar: pansichar(dest^) := pansichar(PSGetAnsiString(Src, srctype));
4500 btString:
4501 tbtstring(dest^) := PSGetAnsiString(Src, srctype);
4502 btChar: tbtchar(dest^) := tbtchar(PSGetUInt(Src, srctype));
4503 {$IFNDEF PS_NOWIDESTRING}
4504 btWideString: tbtwidestring(dest^) := PSGetWideString(Src, srctype);
4505 btUnicodeString: tbtUnicodeString(dest^) := PSGetUnicodeString(Src, srctype);
4506 btWideChar: tbtwidechar(dest^) := widechar(PSGetUInt(Src, srctype));
4507 {$ENDIF}
4508 btStaticArray:
4509 begin
4510 if desttype <> srctype then
4511 Result := False
4512 else
4513 CopyArrayContents(dest, Src, TPSTypeRec_StaticArray(desttype).Size, TPSTypeRec_StaticArray(desttype).ArrayType);
4514 end;
4515 btArray:
4516 begin
4517 if (srctype.BaseType = btStaticArray) and (TPSTypeRec_Array(desttype).ArrayType = TPSTypeRec_Array(srctype).ArrayType) then
4518 begin
4519 PSDynArraySetLength(Pointer(Dest^), desttype, TPSTypeRec_StaticArray(srctype).Size);
4520 CopyArrayContents(Pointer(dest^), Src, TPSTypeRec_StaticArray(srctype).Size, TPSTypeRec_StaticArray(srctype).ArrayType);
4521 end else if (srctype.BaseType = btvariant) and VarIsArray(Variant(src^)) then
4522 Result := CreateArrayFromVariant(Self, dest, Variant(src^), desttype)
4523 else if (desttype <> srctype) and not ((desttype.BaseType = btarray) and (srctype.BaseType = btArray)
4524 and (TPSTypeRec_Array(desttype).ArrayType = TPSTypeRec_Array(srctype).ArrayType)) then
4525 Result := False
4526 else
4527 CopyArrayContents(dest, src, 1, desttype);
4528 end;
4529 btRecord:
4530 begin
4531 if desttype <> srctype then
4532 Result := False
4533 else
4534 CopyArrayContents(dest, Src, 1, desttype);
4535 end;
4536 btVariant:
4537 begin
4538 {$IFNDEF PS_NOINTERFACES}
4539 if srctype.ExportName = 'IDISPATCH' then
4540 begin
4541 {$IFDEF DELPHI3UP}
4542 Variant(Dest^) := IDispatch(Src^);
4543 {$ELSE}
4544 AssignVariantFromIDispatch(Variant(Dest^), IDispatch(Src^));
4545 {$ENDIF}
4546 end else
4547 {$ENDIF}
4548 if srctype.BaseType = btVariant then
4549 variant(Dest^) := variant(src^)
4550 else
4551 begin
4552 tt.VI.FType := FindType2(btPointer);
4553 tt.DestType := srctype;
4554 tt.DataDest := src;
4555 tt.FreeIt := False;
4556 Result := PIFVariantToVariant(@tt, variant(dest^));
4557 end;
4558 end;
4559 btClass:
4560 begin
4561 if srctype.BaseType = btClass then
4562 TObject(Dest^) := TObject(Src^)
4563 else
4564 // nx change start
4565 if (srctype.BaseType in [btS32, btU32]) then
4566 TbtU32(Dest^) := TbtU32(Src^)
4567 else
4568 // nx change end
4569 Result := False;
4570 end;
4571 {$IFNDEF PS_NOINTERFACES}
4572 btInterface:
4573 begin
4574 if Srctype.BaseType = btVariant then
4575 begin
4576 if desttype.ExportName = 'IDISPATCH' then
4577 begin
4578 {$IFDEF Delphi3UP}
4579 IDispatch(Dest^) := IDispatch(Variant(Src^));
4580 {$ELSE}
4581 AssignIDispatchFromVariant(IDispatch(Dest^), Variant(Src^));
4582 {$ENDIF}
4583 end else
4584 Result := False;
4585 {$IFDEF Delphi3UP}
4586 end else
4587 if srctype.BaseType = btClass then
4588 begin
4589 if (TObject(Src^) = nil) or not TObject(Src^).GetInterface(TPSTypeRec_Interface(desttype).Guid, IUnknown(Dest^)) then
4590 begin
4591 Result := false;
4592 Cmd_Err(erInterfaceNotSupported);
4593 exit;
4594 end;
4595 {$ENDIF}
4596 end else if srctype.BaseType = btInterface then
4597 begin
4598 {$IFNDEF Delphi3UP}
4599 if IUnknown(Dest^) <> nil then
4600 begin
4601 IUnknown(Dest^).Release;
4602 IUnknown(Dest^) := nil;
4603 end;
4604 {$ENDIF}
4605 IUnknown(Dest^) := IUnknown(Src^);
4606 {$IFNDEF Delphi3UP}
4607 if IUnknown(Dest^) <> nil then
4608 IUnknown(Dest^).AddRef;
4609 {$ENDIF}
4610 end else
4611 Result := False;
4612 end;
4613 {$ENDIF}
4614 else begin
4615 Result := False;
4616 end;
4617 end;
4618 if Result = False then
4619 CMD_Err(ErTypeMismatch);
4620 except
4621 {$IFDEF DELPHI6UP}
4622 Tmp := AcquireExceptionObject;
4623 {$ELSE}
4624 if RaiseList <> nil then
4625 begin
4626 Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
4627 PRaiseFrame(RaiseList)^.ExceptObject := nil;
4628 end else
4629 Tmp := nil;
4630 {$ENDIF}
4631 if Tmp <> nil then
4632 begin
4633 if Tmp is EPSException then
4634 begin
4635 Result := False;
4636 ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, tbtString(EPSException(tmp).Message), nil);
4637 exit;
4638 end else
4639 if Tmp is EDivByZero then
4640 begin
4641 Result := False;
4642 CMD_Err3(erDivideByZero, tbtString(Exception(Tmp).Message), Tmp);
4643 Exit;
4644 end;
4645 if Tmp is EZeroDivide then
4646 begin
4647 Result := False;
4648 CMD_Err3(erDivideByZero, tbtString(Exception(Tmp).Message), Tmp);
4649 Exit;
4650 end;
4651 if Tmp is EMathError then
4652 begin
4653 Result := False;
4654 CMD_Err3(erMathError, tbtString(Exception(Tmp).Message), Tmp);
4655 Exit;
4656 end;
4657 end;
4658 if (tmp <> nil) and (Tmp is Exception) then
4659 CMD_Err3(erException, tbtString(Exception(Tmp).Message), Tmp)
4660 else
4661 CMD_Err3(erException, '', Tmp);
4662 Result := False;
4663 end;
4664 end;
4665
4666 function SpecImport(Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean; forward;
4667
4668
Class_ISnull4669 function Class_IS(Self: TPSExec; Obj: TObject; var2type: TPSTypeRec): Boolean;
4670 var
4671 R: TPSRuntimeClassImporter;
4672 cc: TPSRuntimeClass;
4673 begin
4674 if Obj = nil then
4675 begin
4676 Result := false;
4677 exit;
4678 end;
4679 r := Self.FindSpecialProcImport(SpecImport);
4680 if R = nil then
4681 begin
4682 Result := false;
4683 exit;
4684 end;
4685 cc := r.FindClass(var2type.ExportName);
4686 if cc = nil then
4687 begin
4688 result := false;
4689 exit;
4690 end;
4691 try
4692 Result := Obj is cc.FClass;
4693 except
4694 Result := false;
4695 end;
4696 end;
4697
4698 type
4699 TVariantArray = array of Variant;
4700 PVariantArray = ^TVariantArray;
VariantInArraynull4701 function VariantInArray(var1: Pointer; var1Type: TPSTypeRec; var2: PVariantArray): Boolean;
4702 var
4703 lDest: Variant;
4704 i: Integer;
4705 begin
4706 IntPIFVariantToVariant(var1, var1Type, lDest);
4707 result := false;
4708 for i := 0 to Length(var2^) -1 do begin
4709 if var2^[i] = lDest then begin
4710 result := true;
4711 break;
4712 end;
4713 end;
4714 end;
4715
4716
DoBooleanCalcnull4717 function TPSExec.DoBooleanCalc(var1, Var2, into: Pointer; var1Type, var2type, intotype: TPSTypeRec; Cmd: Cardinal): Boolean;
4718 var
4719 b: Boolean;
4720 Tmp: TObject;
4721 tvar: Variant;
4722
4723
4724 procedure SetBoolean(b: Boolean; var Ok: Boolean);
4725 begin
4726 Ok := True;
4727 case IntoType.BaseType of
4728 btU8: tbtu8(Into^):= Cardinal(b);
4729 btS8: tbts8(Into^) := Longint(b);
4730 btU16: tbtu16(Into^) := Cardinal(b);
4731 btS16: tbts16(Into^) := Longint(b);
4732 btU32: tbtu32(Into^) := Cardinal(b);
4733 btS32: tbts32(Into^) := Longint(b);
4734 btVariant: Variant(Into^) := b;
4735 else begin
4736 CMD_Err(ErTypeMismatch);
4737 Ok := False;
4738 end;
4739 end;
4740 end;
4741 begin
4742 Result := true;
4743 try
4744 case Cmd of
4745 0: begin { >= }
4746 case var1Type.BaseType of
4747 btU8:
4748 if (var2Type.BaseType = btString) or (Var2Type.BaseType = btPChar) then
4749 b := tbtchar(tbtu8(var1^)) >= PSGetAnsiString(Var2, var2type)
4750 else
4751 b := tbtu8(var1^) >= PSGetUInt(Var2, var2type);
4752 btS8: b := tbts8(var1^) >= PSGetInt(Var2, var2type);
4753 btU16: b := tbtu16(var1^) >= PSGetUInt(Var2, var2type);
4754 btS16: b := tbts16(var1^) >= PSGetInt(Var2, var2type);
4755 btU32: b := tbtu32(var1^) >= PSGetUInt(Var2, var2type);
4756 btS32:
4757 begin
4758 if var2type.BaseType = btPointer then
4759 begin
4760 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
4761 var2 := Pointer(var2^);
4762 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
4763 end;
4764 case var2type.BaseType of
4765 btU8: b := tbts32(var1^) >= tbtu8(Var2^);
4766 btS8: b := tbts32(var1^) >= tbts8(Var2^);
4767 btU16: b := tbts32(var1^) >= tbtu16(Var2^);
4768 btS16: b := tbts32(var1^) >= tbts16(Var2^);
4769 btU32: b := tbts32(var1^) >= Longint(tbtu32(Var2^));
4770 btS32: b := tbts32(var1^) >= tbts32(Var2^);
4771 btDouble: b := PSGetReal(Var1, var1type) >= tbtdouble(var2^);
4772 btSingle: B := psGetReal(Var1, var1Type) >= tbtsingle(var2^);
4773 btExtended: B := psGetReal(Var1, var1Type) >= tbtExtended(var2^);
4774 {$IFNDEF PS_NOINT64} btS64: b := tbts32(var1^) >= tbts64(Var2^);{$ENDIF}
4775 btChar: b := tbts32(var1^) >= Ord(tbtchar(Var2^));
4776 {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbts32(var1^) >= Ord(tbtwidechar(Var2^));{$ENDIF}
4777 btVariant: b := tbts32(var1^) >= Variant(Var2^);
4778 else raise Exception.Create(RPS_TypeMismatch);
4779 end;
4780 end;
4781 btSingle: b := tbtsingle(var1^) >= PSGetReal(Var2, var2type);
4782 btDouble: b := tbtdouble(var1^) >= PSGetReal(Var2, var2type);
4783 btCurrency: b := tbtcurrency(var1^) >= PSGetCurrency(Var2, var2type);
4784 btExtended: b := tbtextended(var1^) >= PSGetReal(Var2, var2type);
4785 {$IFNDEF PS_NOINT64}
4786 btS64: b := tbts64(var1^) >= PSGetInt64(Var2, var2type);
4787 {$ENDIF}
4788 btPChar,btString: b := tbtstring(var1^) >= PSGetAnsiString(Var2, var2type);
4789 btChar: b := tbtchar(var1^) >= PSGetAnsiString(Var2, var2type);
4790 {$IFNDEF PS_NOWIDESTRING}
4791 btWideChar: b := tbtwidechar(var1^) >= PSGetWideString(Var2, var2type);
4792 btWideString: b := tbtwidestring(var1^) >= PSGetWideString(Var2, var2type);
4793 btUnicodeString: b := tbtUnicodestring(var1^) >= PSGetUnicodeString(Var2, var2type);
4794 {$ENDIF}
4795 btVariant:
4796 begin
4797 if not IntPIFVariantToVariant(var2, var2type, tvar) then
4798 begin
4799 Result := false;
4800 end else
4801 b := Variant(var1^) >= tvar;
4802 end;
4803 btSet:
4804 begin
4805 if var1Type = var2Type then
4806 begin
4807 Set_Subset(var2, var1, TPSTypeRec_Set(var1Type).aByteSize, b);
4808 end else result := False;
4809 end;
4810 else begin
4811 CMD_Err(ErTypeMismatch);
4812 exit;
4813 end;
4814 end;
4815 if not Result then begin
4816 CMD_Err(ErTypeMismatch);
4817 exit;
4818 end;
4819 SetBoolean(b, Result);
4820 end;
4821 1: begin { <= }
4822 case var1Type.BaseType of
4823 btU8:
4824 if (var2Type.BaseType = btString) or (Var2Type.BaseType = btPChar) then
4825 b := tbtchar(tbtu8(var1^)) <= PSGetAnsiString(Var2, var2type)
4826 else
4827 b := tbtu8(var1^) <= PSGetUInt(Var2, var2type);
4828 btS8: b := tbts8(var1^) <= PSGetInt(Var2, var2type);
4829 btU16: b := tbtu16(var1^) <= PSGetUInt(Var2, var2type);
4830 btS16: b := tbts16(var1^) <= PSGetInt(Var2, var2type);
4831 btU32: b := tbtu32(var1^) <= PSGetUInt(Var2, var2type);
4832 btS32:
4833 begin
4834 if var2type.BaseType = btPointer then
4835 begin
4836 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
4837 var2 := Pointer(var2^);
4838 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
4839 end;
4840 case var2type.BaseType of
4841 btU8: b := tbts32(var1^) <= tbtu8(Var2^);
4842 btS8: b := tbts32(var1^) <= tbts8(Var2^);
4843 btU16: b := tbts32(var1^) <= tbtu16(Var2^);
4844 btS16: b := tbts32(var1^) <= tbts16(Var2^);
4845 btU32: b := tbts32(var1^) <= Longint(tbtu32(Var2^));
4846 btS32: b := tbts32(var1^) <= tbts32(Var2^);
4847 btDouble: b := PSGetReal(Var1, var1type) <= tbtdouble(var2^);
4848 btSingle: B := psGetReal(Var1, var1Type) <= tbtsingle(var2^);
4849 btExtended: B := psGetReal(Var1, var1Type) <= tbtExtended(var2^);
4850 {$IFNDEF PS_NOINT64} btS64: b := tbts32(var1^) <= tbts64(Var2^);{$ENDIF}
4851 btChar: b := tbts32(var1^) <= Ord(tbtchar(Var2^));
4852 {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbts32(var1^) <= Ord(tbtwidechar(Var2^));{$ENDIF}
4853 btVariant: b := tbts32(var1^) <= Variant(Var2^);
4854 else raise Exception.Create(RPS_TypeMismatch);
4855 end;
4856 end; btSingle: b := tbtsingle(var1^) <= PSGetReal(Var2, var2type);
4857 btCurrency: b := tbtcurrency(var1^) <= PSGetCurrency(Var2, var2type);
4858 btDouble: b := tbtdouble(var1^) <= PSGetReal(Var2, var2type);
4859 btExtended: b := tbtextended(var1^) <= PSGetReal(Var2, var2type);
4860 {$IFNDEF PS_NOINT64}
4861 btS64: b := tbts64(var1^) <= PSGetInt64(Var2, var2type);
4862 {$ENDIF}
4863 btPChar,btString: b := tbtstring(var1^) <= PSGetAnsiString(Var2, var2type);
4864 btChar: b := tbtchar(var1^) <= PSGetAnsiString(Var2, var2type);
4865 {$IFNDEF PS_NOWIDESTRING}
4866 btWideChar: b := tbtwidechar(var1^) <= PSGetWideString(Var2, var2type);
4867 btWideString: b := tbtwidestring(var1^) <= PSGetWideString(Var2, var2type);
4868 btUnicodeString: b := tbtUnicodestring(var1^) <= PSGetUnicodeString(Var2, var2type);
4869 {$ENDIF}
4870 btVariant:
4871 begin
4872 if not IntPIFVariantToVariant(var2, var2type, tvar) then
4873 begin
4874 Result := false;
4875 end else
4876 b := Variant(var1^) <= tvar;
4877 end;
4878 btSet:
4879 begin
4880 if var1Type = var2Type then
4881 begin
4882 Set_Subset(var1, var2, TPSTypeRec_Set(var1Type).aByteSize, b);
4883 end else result := False;
4884 end;
4885 else begin
4886 CMD_Err(ErTypeMismatch);
4887 exit;
4888 end;
4889 end;
4890 if not Result then begin
4891 CMD_Err(erTypeMismatch);
4892 exit;
4893 end;
4894 SetBoolean(b, Result);
4895 end;
4896 2: begin { > }
4897 case var1Type.BaseType of
4898 btU8:
4899 if (var2Type.BaseType = btString) or (Var2Type.BaseType = btPChar) then
4900 b := tbtchar(tbtu8(var1^)) > PSGetAnsiString(Var2, var2type)
4901 else
4902 b := tbtu8(var1^) > PSGetUInt(Var2, var2type);
4903 btS8: b := tbts8(var1^) > PSGetInt(Var2, var2type);
4904 btU16: b := tbtu16(var1^) > PSGetUInt(Var2, var2type);
4905 btS16: b := tbts16(var1^) > PSGetInt(Var2, var2type);
4906 btU32: b := tbtu32(var1^) > PSGetUInt(Var2, var2type);
4907 btS32:
4908 begin
4909 if var2type.BaseType = btPointer then
4910 begin
4911 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
4912 var2 := Pointer(var2^);
4913 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
4914 end;
4915 case var2type.BaseType of
4916 btU8: b := tbts32(var1^) > tbtu8(Var2^);
4917 btS8: b := tbts32(var1^) > tbts8(Var2^);
4918 btU16: b := tbts32(var1^) > tbtu16(Var2^);
4919 btS16: b := tbts32(var1^) > tbts16(Var2^);
4920 btU32: b := tbts32(var1^) > Longint(tbtu32(Var2^));
4921 btS32: b := tbts32(var1^) > tbts32(Var2^);
4922 btDouble: b := PSGetReal(Var1, var1type) > tbtdouble(var2^);
4923 btSingle: B := psGetReal(Var1, var1Type) > tbtsingle(var2^);
4924 btExtended: B := psGetReal(Var1, var1Type) > tbtExtended(var2^);
4925 {$IFNDEF PS_NOINT64} btS64: b := tbts32(var1^) > tbts64(Var2^);{$ENDIF}
4926 btChar: b := tbts32(var1^) > Ord(tbtchar(Var2^));
4927 {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbts32(var1^) = Ord(tbtwidechar(Var2^));{$ENDIF}
4928 btVariant: b := tbts32(var1^) > Variant(Var2^);
4929 else raise Exception.Create(RPS_TypeMismatch);
4930 end;
4931 end; btSingle: b := tbtsingle(var1^) > PSGetReal(Var2, var2type);
4932 btDouble: b := tbtdouble(var1^) > PSGetReal(Var2, var2type);
4933 btExtended: b := tbtextended(var1^) > PSGetReal(Var2, var2type);
4934 btCurrency: b := tbtcurrency(var1^) > PSGetCurrency(Var2, var2type);
4935 {$IFNDEF PS_NOINT64}
4936 btS64: b := tbts64(var1^) > PSGetInt64(Var2, var2type);
4937 {$ENDIF}
4938 btPChar,btString: b := tbtstring(var1^) > PSGetAnsiString(Var2, var2type);
4939 btChar: b := tbtchar(var1^) > PSGetAnsiString(Var2, var2type);
4940 {$IFNDEF PS_NOWIDESTRING}
4941 btWideChar: b := tbtwidechar(var1^) > PSGetWideString(Var2, var2type);
4942 btWideString: b := tbtwidestring(var1^) > PSGetWideString(Var2, var2type);
4943 btUnicodeString: b := tbtUnicodestring(var1^) > PSGetUnicodeString(Var2, var2type);
4944 {$ENDIF}
4945 btVariant:
4946 begin
4947 if not IntPIFVariantToVariant(var2, var2type, tvar) then
4948 begin
4949 Result := false;
4950 end else
4951 b := Variant(var1^) > tvar;
4952 end;
4953 else begin
4954 CMD_Err(erTypeMismatch);
4955 exit;
4956 end;
4957 end;
4958 if not Result then begin
4959 CMD_Err(erTypeMismatch);
4960 exit;
4961 end;
4962 SetBoolean(b, Result);
4963 end;
4964 3: begin { < }
4965 case var1Type.BaseType of
4966 btU8:
4967 if (var2Type.BaseType = btString) or (Var2Type.BaseType = btPChar) then
4968 b := tbtchar(tbtu8(var1^)) < PSGetAnsiString(Var2, var2type)
4969 else
4970 b := tbtu8(var1^) < PSGetUInt(Var2, var2type);
4971 btS8: b := tbts8(var1^) < PSGetInt(Var2, var2type);
4972 btU16: b := tbtu16(var1^) < PSGetUInt(Var2, var2type);
4973 btS16: b := tbts16(var1^) < PSGetInt(Var2, var2type);
4974 btU32: b := tbtu32(var1^) < PSGetUInt(Var2, var2type);
4975 btS32:
4976 begin
4977 if var2type.BaseType = btPointer then
4978 begin
4979 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
4980 var2 := Pointer(var2^);
4981 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
4982 end;
4983 case var2type.BaseType of
4984 btU8: b := tbts32(var1^) < tbtu8(Var2^);
4985 btS8: b := tbts32(var1^) < tbts8(Var2^);
4986 btU16: b := tbts32(var1^) < tbtu16(Var2^);
4987 btS16: b := tbts32(var1^) < tbts16(Var2^);
4988 btU32: b := tbts32(var1^) < Longint(tbtu32(Var2^));
4989 btS32: b := tbts32(var1^) < tbts32(Var2^);
4990 btDouble: b := PSGetReal(Var1, var1type) < tbtdouble(var2^);
4991 btSingle: B := psGetReal(Var1, var1Type) < tbtsingle(var2^);
4992 btExtended: B := psGetReal(Var1, var1Type) < tbtExtended(var2^);
4993 {$IFNDEF PS_NOINT64} btS64: b := tbts32(var1^) < tbts64(Var2^);{$ENDIF}
4994 btChar: b := tbts32(var1^) < Ord(tbtchar(Var2^));
4995 {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbts32(var1^) < Ord(tbtwidechar(Var2^));{$ENDIF}
4996 btVariant: b := tbts32(var1^) < Variant(Var2^);
4997 else raise Exception.Create(RPS_TypeMismatch);
4998 end;
4999 end; btSingle: b := tbtsingle(var1^) < PSGetReal(Var2, var2type);
5000 btDouble: b := tbtdouble(var1^) < PSGetReal(Var2, var2type);
5001 btCurrency: b := tbtcurrency(var1^) < PSGetCurrency(Var2, var2type);
5002 btExtended: b := tbtextended(var1^) < PSGetReal(Var2, var2type);
5003 {$IFNDEF PS_NOINT64}
5004 btS64: b := tbts64(var1^) < PSGetInt64(Var2, var2type);
5005 {$ENDIF}
5006 btPChar,btString: b := tbtstring(var1^) < PSGetAnsiString(Var2, var2type);
5007 btChar: b := tbtchar(var1^) < PSGetAnsiString(Var2, var2type);
5008 {$IFNDEF PS_NOWIDESTRING}
5009 btWideChar: b := tbtwidechar(var1^) < PSGetWideString(Var2, var2type);
5010 btWideString: b := tbtwidestring(var1^) < PSGetWideString(Var2, var2type);
5011 btUnicodeString: b := tbtUnicodestring(var1^) < PSGetUnicodeString(Var2, var2type);
5012 {$ENDIF}
5013 btVariant:
5014 begin
5015 if not IntPIFVariantToVariant(var2, var2type, tvar) then
5016 begin
5017 Result := false;
5018 end else
5019 b := Variant(var1^) < tvar;
5020 end;
5021 else begin
5022 CMD_Err(erTypeMismatch);
5023 exit;
5024 end;
5025 end;
5026 if not Result then begin
5027 CMD_Err(erTypeMismatch);
5028 exit;
5029 end;
5030 SetBoolean(b, Result);
5031 end;
5032 4: begin { <> }
5033 case var1Type.BaseType of
5034 btInterface:
5035 begin
5036 if var2Type.BaseType = btInterface then
5037 b := Pointer(var1^) <> Pointer(var2^) // no need to cast it to IUnknown
5038 else
5039 Result := false;
5040 end;
5041 btClass:
5042 begin
5043 if var2Type.BaseType = btclass then
5044 b := TObject(var1^) <> TObject(var2^)
5045 else
5046 Result := false;
5047 end;
5048 btU8:
5049 if (var2Type.BaseType = btString) or (Var2Type.BaseType = btPChar) then
5050 b := tbtchar(tbtu8(var1^)) <> PSGetAnsiString(Var2, var2type)
5051 else
5052 b := tbtu8(var1^) <> PSGetUInt(Var2, var2type);
5053 btS8: b := tbts8(var1^) <> PSGetInt(Var2, var2type);
5054 btU16: b := tbtu16(var1^) <> PSGetUInt(Var2, var2type);
5055 btS16: b := tbts16(var1^) <> PSGetInt(Var2, var2type);
5056 btProcPtr:
5057 begin
5058 if Pointer(Var1^) = Pointer(Var2^) then
5059 begin
5060 if Longint(Var1^) = 0 then
5061 b := ((Pointer(Pointer(IPointer(Var1)+PointerSize2)^) <> Pointer(Pointer(IPointer(Var2)+PointerSize2)^)) or
5062 (Pointer(Pointer(IPointer(Var1)+PointerSize2)^) <> Pointer(Pointer(IPointer(Var2)+PointerSize2)^)))
5063 else
5064 b := False;
5065 end else b := True;
5066 end;
5067 btU32: b := tbtu32(var1^) <> PSGetUInt(Var2, var2type);
5068 btS32:
5069 begin
5070 if var2type.BaseType = btPointer then
5071 begin
5072 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5073 var2 := Pointer(var2^);
5074 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5075 end;
5076 case var2type.BaseType of
5077 btU8: b := tbts32(var1^) <> tbtu8(Var2^);
5078 btS8: b := tbts32(var1^) <> tbts8(Var2^);
5079 btU16: b := tbts32(var1^) <> tbtu16(Var2^);
5080 btS16: b := tbts32(var1^) <> tbts16(Var2^);
5081 btProcPtr, btU32: b := tbts32(var1^)<> Longint(tbtu32(Var2^));
5082 btS32: b := tbts32(var1^) <> tbts32(Var2^);
5083 btDouble: b := PSGetReal(Var1, var1type) <> tbtdouble(var2^);
5084 btSingle: B := psGetReal(Var1, var1Type) <> tbtsingle(var2^);
5085 btExtended: B := psGetReal(Var1, var1Type) <> tbtExtended(var2^);
5086 {$IFNDEF PS_NOINT64} btS64: b := tbts32(var1^) <> tbts64(Var2^);{$ENDIF}
5087 btChar: b := tbts32(var1^) <> Ord(tbtchar(Var2^));
5088 {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbts32(var1^) <> Ord(tbtwidechar(Var2^));{$ENDIF}
5089 btVariant: b := tbts32(var1^) <> Variant(Var2^);
5090 else raise Exception.Create(RPS_TypeMismatch);
5091 end;
5092 end; btSingle: b := tbtsingle(var1^) <> PSGetReal(Var2, var2type);
5093 btDouble: b := tbtdouble(var1^) <> PSGetReal(Var2, var2type);
5094 btExtended: b := tbtextended(var1^) <> PSGetReal(Var2, var2type);
5095 btCurrency: b := tbtcurrency(var1^) <> PSGetCurrency(Var2, var2type);
5096 btPChar,btString: b := tbtstring(var1^) <> PSGetAnsiString(Var2, var2type);
5097 {$IFNDEF PS_NOINT64}
5098 btS64: b := tbts64(var1^) <> PSGetInt64(Var2, var2type);
5099 {$ENDIF}
5100 btChar: b := tbtchar(var1^) <> PSGetAnsiString(Var2, var2type);
5101 {$IFNDEF PS_NOWIDESTRING}
5102 btWideChar: b := tbtwidechar(var1^) <> PSGetWideString(Var2, var2type);
5103 btWideString: b := tbtwidestring(var1^) <> PSGetWideString(Var2, var2type);
5104 btUnicodeString: b := tbtUnicodeString(var1^) <> PSGetUnicodeString(Var2, var2type);
5105 {$ENDIF}
5106 btVariant:
5107 begin
5108 if not IntPIFVariantToVariant(var2, var2type, tvar) then
5109 begin
5110 Result := false;
5111 end else
5112 b := Variant(var1^) <> tvar;
5113 end;
5114 btSet:
5115 begin
5116 if var1Type = var2Type then
5117 begin
5118 Set_Equal(var1, var2, TPSTypeRec_Set(var1Type).aByteSize, b);
5119 b := not b;
5120 end else result := False;
5121 end;
5122 btRecord:
5123 begin
5124 if var1Type = var2Type then
5125 begin
5126 Set_Equal(var1, var2, TPSTypeRec_Record(var1Type).RealSize, b);
5127 b := not b;
5128 end else result := False;
5129 end
5130
5131 else begin
5132 CMD_Err(erTypeMismatch);
5133 exit;
5134 end;
5135 end;
5136 if not Result then begin
5137 CMD_Err(erTypeMismatch);
5138 exit;
5139 end;
5140 SetBoolean(b, Result);
5141 end;
5142 5: begin { = }
5143 case var1Type.BaseType of
5144 btInterface:
5145 begin
5146 if var2Type.BaseType = btInterface then
5147 b := Pointer(var1^) = Pointer(var2^) // no need to cast it to IUnknown
5148 else
5149 Result := false;
5150 end;
5151 btClass:
5152 begin
5153 if var2Type.BaseType = btclass then
5154 b := TObject(var1^) = TObject(var2^)
5155 else
5156 Result := false;
5157 end;
5158 btU8:
5159 if (var2Type.BaseType = btString) or (Var2Type.BaseType = btPChar) then
5160 b := tbtchar(tbtu8(var1^)) = PSGetAnsiString(Var2, var2type)
5161 else
5162 b := tbtu8(var1^) = PSGetUInt(Var2, var2type);
5163 btS8: b := tbts8(var1^) = PSGetInt(Var2, var2type);
5164 btU16: b := tbtu16(var1^) = PSGetUInt(Var2, var2type);
5165 btS16: b := tbts16(var1^) = PSGetInt(Var2, var2type);
5166 btU32: b := tbtu32(var1^) = PSGetUInt(Var2, var2type);
5167 btProcPtr:
5168 begin
5169 if Pointer(Var1^) = Pointer(Var2^) then
5170 begin
5171 if Longint(Var1^) = 0 then
5172 b := ((Pointer(Pointer(IPointer(Var1)+PointerSize2)^) = Pointer(Pointer(IPointer(Var2)+PointerSize2)^)) and
5173 (Pointer(Pointer(IPointer(Var1)+PointerSize2)^) = Pointer(Pointer(IPointer(Var2)+PointerSize2)^)))
5174 else
5175 b := True;
5176 end else b := False;
5177 end;
5178 btS32:
5179 begin
5180 if var2type.BaseType = btPointer then
5181 begin
5182 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5183 var2 := Pointer(var2^);
5184 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5185 end;
5186 case var2type.BaseType of
5187 btU8: b := tbts32(var1^) = tbtu8(Var2^);
5188 btS8: b := tbts32(var1^) = tbts8(Var2^);
5189 btU16: b := tbts32(var1^) = tbtu16(Var2^);
5190 btS16: b := tbts32(var1^) = tbts16(Var2^);
5191 btProcPtr, btU32: b := tbts32(var1^) = Longint(tbtu32(Var2^));
5192 btS32: b := tbts32(var1^) = tbts32(Var2^);
5193 btDouble: b := PSGetReal(Var1, var1type) = tbtdouble(var2^);
5194 btSingle: B := psGetReal(Var1, var1Type) = tbtsingle(var2^);
5195 btExtended: B := psGetReal(Var1, var1Type) = tbtExtended(var2^);
5196 {$IFNDEF PS_NOINT64} btS64: b := tbts32(var1^) = tbts64(Var2^);{$ENDIF}
5197 btChar: b := tbts32(var1^) = Ord(tbtchar(Var2^));
5198 {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbts32(var1^) = Ord(tbtwidechar(Var2^));{$ENDIF}
5199 btVariant: b := tbts32(var1^) = Variant(Var2^);
5200 else raise Exception.Create(RPS_TypeMismatch);
5201 end;
5202 end; btSingle: b := tbtsingle(var1^) = PSGetReal(Var2, var2type);
5203 btDouble: b := tbtdouble(var1^) = PSGetReal(Var2, var2type);
5204 btExtended: b := tbtextended(var1^) = PSGetReal(Var2, var2type);
5205 btCurrency: b := tbtcurrency(var1^) = PSGetCurrency(Var2, var2type);
5206 btPchar, btString: b := tbtstring(var1^) = PSGetAnsiString(Var2, var2type);
5207 {$IFNDEF PS_NOINT64}
5208 btS64: b := tbts64(var1^) = PSGetInt64(Var2, var2type);
5209 {$ENDIF}
5210 btChar: b := tbtchar(var1^) = PSGetAnsiString(Var2, var2type);
5211 {$IFNDEF PS_NOWIDESTRING}
5212 btWideChar: b := tbtwidechar(var1^) = PSGetWideString(Var2, var2type);
5213 btWideString: b := tbtwidestring(var1^) = PSGetWideString(Var2, var2type);
5214 btUnicodeString: b := tbtUnicodestring(var1^) = PSGetUnicodeString(Var2, var2type);
5215 {$ENDIF}
5216 btVariant:
5217 begin
5218 if not IntPIFVariantToVariant(var2, var2type, tvar) then
5219 begin
5220 Result := false;
5221 end else
5222 b := Variant(var1^) = tvar;
5223 end;
5224 btSet:
5225 begin
5226 if var1Type = var2Type then
5227 begin
5228 Set_Equal(var1, var2, TPSTypeRec_Set(var1Type).aByteSize, b);
5229 end else result := False;
5230 end;
5231 btRecord:
5232 begin
5233 if var1Type = var2Type then
5234 begin
5235 Set_Equal(var1, var2, TPSTypeRec_Record(var1Type).RealSize, b);
5236 end else result := False;
5237 end
5238 else begin
5239 CMD_Err(erTypeMismatch);
5240 exit;
5241 end;
5242 end;
5243 if not Result then begin
5244 CMD_Err(erTypeMismatch);
5245 exit;
5246 end;
5247 SetBoolean(b, Result);
5248 end;
5249 6: begin { in }
5250 if (var2Type.BaseType = btArray) and (TPSTypeRec_Array(var2type).ArrayType.BaseType = btVariant) then
5251 begin
5252 b := VariantInArray(var1, var1Type, var2);
5253 SetBoolean(b, Result);
5254 end else
5255 if var2Type.BaseType = btSet then
5256 begin
5257 Cmd := PSGetUInt(var1, var1type);
5258 if not Result then
5259 begin
5260 CMD_Err(erTypeMismatch);
5261 exit;
5262 end;
5263 if Cmd >= Cardinal(TPSTypeRec_Set(var2Type).aBitSize) then
5264 begin
5265 cmd_Err(erOutofRecordRange);
5266 Result := False;
5267 Exit;
5268 end;
5269 Set_membership(Cmd, var2, b);
5270 SetBoolean(b, Result);
5271 end else
5272 begin
5273 CMD_Err(erTypeMismatch);
5274 exit;
5275 end;
5276 end;
5277 7:
5278 begin // is
5279 case var1Type.BaseType of
5280 btClass:
5281 begin
5282 if var2type.BaseType <> btU32 then
5283 Result := False
5284 else
5285 begin
5286 var2type := FTypes[tbtu32(var2^)];
5287 if (var2type = nil) or (var2type.BaseType <> btClass) then
5288 Result := false
5289 else
5290 begin
5291 Setboolean(Class_IS(Self, TObject(var1^), var2type), Result);
5292 end;
5293 end;
5294 end;
5295 else begin
5296 CMD_Err(erTypeMismatch);
5297 exit;
5298 end;
5299 end;
5300 if not Result then begin
5301 CMD_Err(erTypeMismatch);
5302 exit;
5303 end;
5304 end;
5305 else begin
5306 Result := False;
5307 CMD_Err(erInvalidOpcodeParameter);
5308 exit;
5309 end;
5310 end;
5311 except
5312 {$IFDEF DELPHI6UP}
5313 Tmp := AcquireExceptionObject;
5314 {$ELSE}
5315 if RaiseList <> nil then
5316 begin
5317 Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
5318 PRaiseFrame(RaiseList)^.ExceptObject := nil;
5319 end else
5320 Tmp := nil;
5321 {$ENDIF}
5322 if Tmp <> nil then
5323 begin
5324 if Tmp is EPSException then
5325 begin
5326 Result := False;
5327 ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, tbtString(EPSException(tmp).Message), nil);
5328 exit;
5329 end else
5330 if Tmp is EDivByZero then
5331 begin
5332 Result := False;
5333 CMD_Err3(erDivideByZero, tbtString(Exception(Tmp).Message), Tmp);
5334 Exit;
5335 end;
5336 if Tmp is EZeroDivide then
5337 begin
5338 Result := False;
5339 CMD_Err3(erDivideByZero, tbtString(Exception(Tmp).Message), Tmp);
5340 Exit;
5341 end;
5342 if Tmp is EMathError then
5343 begin
5344 Result := False;
5345 CMD_Err3(erMathError, tbtString(Exception(Tmp).Message), Tmp);
5346 Exit;
5347 end;
5348 end;
5349 if (tmp <> nil) and (Tmp is Exception) then
5350 CMD_Err3(erException, tbtString(Exception(Tmp).Message), Tmp)
5351 else
5352 CMD_Err3(erException, '', Tmp);
5353 Result := False;
5354 end;
5355 end;
5356
VarIsFloatnull5357 function VarIsFloat(const V: Variant): Boolean;
5358 begin
5359 Result := VarType(V) in [varSingle, varDouble, varCurrency];
5360 end;
5361
DoCalcnull5362 function TPSExec.DoCalc(var1, Var2: Pointer; var1Type, var2type: TPSTypeRec; CalcType: Cardinal): Boolean;
5363 { var1=dest, var2=src }
5364 var
5365 Tmp: TObject;
5366 tvar: Variant;
5367 begin
5368 try
5369 Result := True;
5370 case CalcType of
5371 0: begin { + }
5372 case var1Type.BaseType of
5373 btU8: tbtU8(var1^) := tbtU8(var1^) + PSGetUInt(Var2, var2type);
5374 btS8: tbts8(var1^) := tbts8(var1^) + PSGetInt(Var2, var2type);
5375 btU16: tbtU16(var1^) := tbtU16(var1^) + PSGetUInt(Var2, var2type);
5376 btS16: tbts16(var1^) := tbts16(var1^) + PSGetInt(Var2, var2type);
5377 btU32:
5378 begin
5379 if var2type.BaseType = btPointer then
5380 begin
5381 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5382 var2 := Pointer(var2^);
5383 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5384 end;
5385 case var2type.BaseType of
5386 btU8: tbtU32(var1^) := tbtU32(var1^) + tbtu8(var2^);
5387 btS8: tbtU32(var1^) := tbtU32(var1^) + cardinal(longint(tbts8(var2^)));
5388 btU16: tbtU32(var1^) := tbtU32(var1^) + tbtu16(var2^);
5389 btS16: tbtU32(var1^) := tbtU32(var1^) + cardinal(longint(tbts16(var2^)));
5390 btU32: tbtU32(var1^) := tbtU32(var1^) + tbtu32(var2^);
5391 btS32: tbtU32(var1^) := tbtU32(var1^) + cardinal(tbts32(var2^));
5392 {$IFNDEF PS_NOINT64} btS64: tbtU32(var1^) := tbtU32(var1^) + tbts64(var2^);{$ENDIF}
5393 btChar: tbtU32(var1^) := tbtU32(var1^) + Ord(tbtchar(var2^));
5394 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtU32(var1^) := tbtU32(var1^) + Ord(tbtwidechar(var2^));{$ENDIF}
5395 btVariant: tbtU32(var1^) := tbtU32(var1^) + Variant(var2^);
5396 else raise Exception.Create(RPS_TypeMismatch);
5397 end;
5398 end;
5399 btS32:
5400 begin
5401 if var2type.BaseType = btPointer then
5402 begin
5403 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5404 var2 := Pointer(var2^);
5405 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5406 end;
5407 case var2type.BaseType of
5408 btU8: tbts32(var1^) := tbts32(var1^) + tbtu8(var2^);
5409 btS8: tbts32(var1^) := tbts32(var1^) + tbts8(var2^);
5410 btU16: tbts32(var1^) := tbts32(var1^) + tbtu16(var2^);
5411 btS16: tbts32(var1^) := tbts32(var1^) + tbts16(var2^);
5412 btU32: tbts32(var1^) := tbts32(var1^) + Longint(tbtu32(var2^));
5413 btS32: tbts32(var1^) := tbts32(var1^) + tbts32(var2^);
5414 {$IFNDEF PS_NOINT64} btS64: tbts32(var1^) := tbts32(var1^) + tbts64(var2^);{$ENDIF}
5415 btChar: tbts32(var1^) := tbts32(var1^) + Ord(tbtchar(var2^));
5416 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(var1^) := tbts32(var1^) + Ord(tbtwidechar(var2^));{$ENDIF}
5417 btVariant: tbts32(var1^) := tbts32(var1^) + Variant(var2^);
5418 else raise Exception.Create(RPS_TypeMismatch);
5419 end;
5420 end;
5421 {$IFNDEF PS_NOINT64}
5422 btS64: tbts64(var1^) := tbts64(var1^) + PSGetInt64(var2, var2type);
5423 {$ENDIF}
5424 btSingle:
5425 begin
5426 if var2type.BaseType = btPointer then
5427 begin
5428 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5429 var2 := Pointer(var2^);
5430 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5431 end;
5432 case var2type.BaseType of
5433 btU8: tbtsingle(var1^) := tbtsingle(var1^) + tbtu8(var2^);
5434 btS8: tbtsingle(var1^) := tbtsingle(var1^) + tbts8(var2^);
5435 btU16: tbtsingle(var1^) := tbtsingle(var1^) + tbtu16(var2^);
5436 btS16: tbtsingle(var1^) := tbtsingle(var1^) + tbts16(var2^);
5437 btU32: tbtsingle(var1^) := tbtsingle(var1^) + tbtu32(var2^);
5438 btS32: tbtsingle(var1^) := tbtsingle(var1^) + tbts32(var2^);
5439 {$IFNDEF PS_NOINT64} btS64: tbtsingle(var1^) := tbtsingle(var1^) + tbts64(var2^);{$ENDIF}
5440 btSingle: tbtsingle(var1^) := tbtsingle(var1^) + tbtsingle(var2^);
5441 btDouble: tbtsingle(var1^) := tbtsingle(var1^) + tbtdouble(var2^);
5442 btExtended: tbtsingle(var1^) := tbtsingle(var1^) + tbtextended(var2^);
5443 btCurrency: tbtsingle(var1^) := tbtsingle(var1^) + tbtcurrency(var2^);
5444 btVariant: tbtsingle(var1^) := tbtsingle(var1^) + Variant(var2^);
5445 else raise Exception.Create(RPS_TypeMismatch);
5446 end;
5447 end;
5448 btDouble:
5449 begin
5450 if var2type.BaseType = btPointer then
5451 begin
5452 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5453 var2 := Pointer(var2^);
5454 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5455 end;
5456 case var2type.BaseType of
5457 btU8: tbtdouble(var1^) := tbtdouble(var1^) + tbtu8(var2^);
5458 btS8: tbtdouble(var1^) := tbtdouble(var1^) + tbts8(var2^);
5459 btU16: tbtdouble(var1^) := tbtdouble(var1^) + tbtu16(var2^);
5460 btS16: tbtdouble(var1^) := tbtdouble(var1^) + tbts16(var2^);
5461 btU32: tbtdouble(var1^) := tbtdouble(var1^) + tbtu32(var2^);
5462 btS32: tbtdouble(var1^) := tbtdouble(var1^) + tbts32(var2^);
5463 {$IFNDEF PS_NOINT64} btS64: tbtdouble(var1^) := tbtdouble(var1^) + tbts64(var2^);{$ENDIF}
5464 btSingle: tbtdouble(var1^) := tbtdouble(var1^) + tbtsingle(var2^);
5465 btDouble: tbtdouble(var1^) := tbtdouble(var1^) + tbtdouble(var2^);
5466 btExtended: tbtdouble(var1^) := tbtdouble(var1^) + tbtextended(var2^);
5467 btCurrency: tbtdouble(var1^) := tbtdouble(var1^) + tbtcurrency(var2^);
5468 btVariant: tbtdouble(var1^) := tbtdouble(var1^) + Variant(var2^);
5469 else raise Exception.Create(RPS_TypeMismatch);
5470 end;
5471 end;
5472 btCurrency:
5473 begin
5474 if var2type.BaseType = btPointer then
5475 begin
5476 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5477 var2 := Pointer(var2^);
5478 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5479 end;
5480 case var2type.BaseType of
5481 btU8: tbtcurrency(var1^) := tbtcurrency(var1^) + tbtu8(var2^);
5482 btS8: tbtcurrency(var1^) := tbtcurrency(var1^) + tbts8(var2^);
5483 btU16: tbtcurrency(var1^) := tbtcurrency(var1^) + tbtu16(var2^);
5484 btS16: tbtcurrency(var1^) := tbtcurrency(var1^) + tbts16(var2^);
5485 btU32: tbtcurrency(var1^) := tbtdouble(var1^) + tbtu32(var2^);
5486 btS32: tbtcurrency(var1^) := tbtcurrency(var1^) + tbts32(var2^);
5487 {$IFNDEF PS_NOINT64} btS64: tbtcurrency(var1^) := tbtdouble(var1^) + tbts64(var2^);{$ENDIF}
5488 btSingle: tbtcurrency(var1^) := tbtcurrency(var1^) + tbtsingle(var2^);
5489 btDouble: tbtcurrency(var1^) := tbtcurrency(var1^) + tbtdouble(var2^);
5490 btExtended: tbtcurrency(var1^) := tbtcurrency(var1^) + tbtextended(var2^);
5491 btCurrency: tbtcurrency(var1^) := tbtcurrency(var1^) + tbtcurrency(var2^);
5492 btVariant: tbtcurrency(var1^) := tbtcurrency(var1^) + Variant(var2^);
5493 else raise Exception.Create(RPS_TypeMismatch);
5494 end;
5495 end;
5496 btExtended:
5497 begin
5498 if var2type.BaseType = btPointer then
5499 begin
5500 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5501 var2 := Pointer(var2^);
5502 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5503 end;
5504 case var2type.BaseType of
5505 btU8: tbtextended(var1^) := tbtextended(var1^) + tbtu8(var2^);
5506 btS8: tbtextended(var1^) := tbtextended(var1^) + tbts8(var2^);
5507 btU16: tbtextended(var1^) := tbtextended(var1^) + tbtu16(var2^);
5508 btS16: tbtextended(var1^) := tbtextended(var1^) + tbts16(var2^);
5509 btU32: tbtextended(var1^) := tbtextended(var1^) + tbtu32(var2^);
5510 btS32: tbtextended(var1^) := tbtextended(var1^) + tbts32(var2^);
5511 {$IFNDEF PS_NOINT64} btS64: tbtextended(var1^) := tbtextended(var1^) + tbts64(var2^);{$ENDIF}
5512 btSingle: tbtextended(var1^) := tbtextended(var1^) + tbtsingle(var2^);
5513 btDouble: tbtextended(var1^) := tbtextended(var1^) + tbtdouble(var2^);
5514 btExtended: tbtextended(var1^) := tbtextended(var1^) + tbtextended(var2^);
5515 btCurrency: tbtextended(var1^) := tbtextended(var1^) + tbtcurrency(var2^);
5516 btVariant: tbtextended(var1^) := tbtextended(var1^) + Variant(var2^);
5517 else raise Exception.Create(RPS_TypeMismatch);
5518 end;
5519 end;
5520 btPchar, btString: tbtstring(var1^) := tbtstring(var1^) + PSGetAnsiString(Var2, var2type);
5521 btChar: tbtchar(var1^) := tbtchar(ord(tbtchar(var1^)) + PSGetUInt(Var2, var2type));
5522 {$IFNDEF PS_NOWIDESTRING}
5523 btWideChar: tbtwidechar(var1^) := widechar(ord(tbtwidechar(var1^)) + PSGetUInt(Var2, var2type));
5524 btWideString: tbtwidestring(var1^) := tbtwidestring(var1^) + PSGetWideString(Var2, var2type);
5525 btUnicodeString: tbtUnicodestring(var1^) := tbtUnicodestring(var1^) + PSGetUnicodeString(Var2, var2type);
5526 {$ENDIF}
5527 btVariant:
5528 begin
5529 tvar := null;
5530 if not IntPIFVariantToVariant(var2, var2type, tvar) then
5531 begin
5532 Result := false;
5533 end else
5534 Variant(var1^) := Variant(var1^) + tvar;
5535 end;
5536 btSet:
5537 begin
5538 if var1Type = var2Type then
5539 begin
5540 Set_Union(var1, var2, TPSTypeRec_Set(var1Type).aByteSize);
5541 end else result := False;
5542 end;
5543
5544 else begin
5545 CMD_Err(erTypeMismatch);
5546 exit;
5547 end;
5548 end;
5549 if not Result then begin
5550 CMD_Err(erTypeMismatch);
5551 exit;
5552 end;
5553 end;
5554 1: begin { - }
5555 case var1Type.BaseType of
5556 btU8: tbtU8(var1^) := tbtU8(var1^) - PSGetUInt(Var2, var2type);
5557 btS8: tbts8(var1^) := tbts8(var1^) - PSGetInt(Var2, var2type);
5558 btU16: tbtU16(var1^) := tbtU16(var1^) - PSGetUInt(Var2, var2type);
5559 btS16: tbts16(var1^) := tbts16(var1^) - PSGetInt(Var2, var2type);
5560 btU32:
5561 begin
5562 if var2type.BaseType = btPointer then
5563 begin
5564 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5565 var2 := Pointer(var2^);
5566 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5567 end;
5568 case var2type.BaseType of
5569 btU8: tbtU32(var1^) := tbtU32(var1^) - tbtu8(var2^);
5570 btS8: tbtU32(var1^) := tbtU32(var1^) - cardinal(longint(tbts8(var2^)));
5571 btU16: tbtU32(var1^) := tbtU32(var1^) - tbtu16(var2^);
5572 btS16: tbtU32(var1^) := tbtU32(var1^) - cardinal(longint(tbts16(var2^)));
5573 btU32: tbtU32(var1^) := tbtU32(var1^) - tbtu32(var2^);
5574 btS32: tbtU32(var1^) := tbtU32(var1^) - cardinal(tbts32(var2^));
5575 {$IFNDEF PS_NOINT64} btS64: tbtU32(var1^) := tbtU32(var1^) - tbts64(var2^);{$ENDIF}
5576 btChar: tbtU32(var1^) := tbtU32(var1^) - Ord(tbtchar(var2^));
5577 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtU32(var1^) := tbtU32(var1^) - Ord(tbtwidechar(var2^));{$ENDIF}
5578 btVariant: tbtU32(var1^) := tbtU32(var1^) - Variant(var2^);
5579 else raise Exception.Create(RPS_TypeMismatch);
5580 end;
5581 end;
5582 btS32:
5583 begin
5584 if var2type.BaseType = btPointer then
5585 begin
5586 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5587 var2 := Pointer(var2^);
5588 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5589 end;
5590 case var2type.BaseType of
5591 btU8: tbts32(var1^) := tbts32(var1^) - tbtu8(var2^);
5592 btS8: tbts32(var1^) := tbts32(var1^) - tbts8(var2^);
5593 btU16: tbts32(var1^) := tbts32(var1^) - tbtu16(var2^);
5594 btS16: tbts32(var1^) := tbts32(var1^) - tbts16(var2^);
5595 btU32: tbts32(var1^) := tbts32(var1^) - Longint(tbtu32(var2^));
5596 btS32: tbts32(var1^) := tbts32(var1^) - tbts32(var2^);
5597 {$IFNDEF PS_NOINT64} btS64: tbts32(var1^) := tbts32(var1^) - tbts64(var2^);{$ENDIF}
5598 btChar: tbts32(var1^) := tbts32(var1^) - Ord(tbtchar(var2^));
5599 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(var1^) := tbts32(var1^) - Ord(tbtwidechar(var2^));{$ENDIF}
5600 btVariant: tbts32(var1^) := tbts32(var1^) - Variant(var2^);
5601 else raise Exception.Create(RPS_TypeMismatch);
5602 end;
5603 end;
5604 {$IFNDEF PS_NOINT64}
5605 btS64: tbts64(var1^) := tbts64(var1^) - PSGetInt64(var2, var2type);
5606 {$ENDIF}
5607 btSingle:
5608 begin
5609 if var2type.BaseType = btPointer then
5610 begin
5611 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5612 var2 := Pointer(var2^);
5613 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5614 end;
5615 case var2type.BaseType of
5616 btU8: tbtsingle(var1^) := tbtsingle(var1^) - tbtu8(var2^);
5617 btS8: tbtsingle(var1^) := tbtsingle(var1^) - tbts8(var2^);
5618 btU16: tbtsingle(var1^) := tbtsingle(var1^) - tbtu16(var2^);
5619 btS16: tbtsingle(var1^) := tbtsingle(var1^) - tbts16(var2^);
5620 btU32: tbtsingle(var1^) := tbtsingle(var1^) - tbtu32(var2^);
5621 btS32: tbtsingle(var1^) := tbtsingle(var1^) - tbts32(var2^);
5622 {$IFNDEF PS_NOINT64} btS64: tbtsingle(var1^) := tbtsingle(var1^) - tbts64(var2^);{$ENDIF}
5623 btSingle: tbtsingle(var1^) := tbtsingle(var1^) - tbtsingle(var2^);
5624 btDouble: tbtsingle(var1^) := tbtsingle(var1^) - tbtdouble(var2^);
5625 btExtended: tbtsingle(var1^) := tbtsingle(var1^) - tbtextended(var2^);
5626 btCurrency: tbtsingle(var1^) := tbtsingle(var1^) - tbtcurrency(var2^);
5627 btVariant: tbtsingle(var1^) := tbtsingle(var1^) - Variant(var2^);
5628 else raise Exception.Create(RPS_TypeMismatch);
5629 end;
5630 end;
5631 btCurrency:
5632 begin
5633 if var2type.BaseType = btPointer then
5634 begin
5635 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5636 var2 := Pointer(var2^);
5637 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5638 end;
5639 case var2type.BaseType of
5640 btU8: tbtcurrency(var1^) := tbtcurrency(var1^) - tbtu8(var2^);
5641 btS8: tbtcurrency(var1^) := tbtcurrency(var1^) - tbts8(var2^);
5642 btU16: tbtcurrency(var1^) := tbtcurrency(var1^) - tbtu16(var2^);
5643 btS16: tbtcurrency(var1^) := tbtcurrency(var1^) - tbts16(var2^);
5644 btU32: tbtcurrency(var1^) := tbtdouble(var1^) - tbtu32(var2^);
5645 btS32: tbtcurrency(var1^) := tbtcurrency(var1^) - tbts32(var2^);
5646 {$IFNDEF PS_NOINT64} btS64: tbtcurrency(var1^) := tbtdouble(var1^) - tbts64(var2^);{$ENDIF}
5647 btSingle: tbtcurrency(var1^) := tbtcurrency(var1^) - tbtsingle(var2^);
5648 btDouble: tbtcurrency(var1^) := tbtcurrency(var1^) - tbtdouble(var2^);
5649 btExtended: tbtcurrency(var1^) := tbtcurrency(var1^) - tbtextended(var2^);
5650 btCurrency: tbtcurrency(var1^) := tbtcurrency(var1^) - tbtcurrency(var2^);
5651 btVariant: tbtcurrency(var1^) := tbtcurrency(var1^) - Variant(var2^);
5652 else raise Exception.Create(RPS_TypeMismatch);
5653 end;
5654 end;
5655 btDouble:
5656 begin
5657 if var2type.BaseType = btPointer then
5658 begin
5659 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5660 var2 := Pointer(var2^);
5661 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5662 end;
5663 case var2type.BaseType of
5664 btU8: tbtdouble(var1^) := tbtdouble(var1^) - tbtu8(var2^);
5665 btS8: tbtdouble(var1^) := tbtdouble(var1^) - tbts8(var2^);
5666 btU16: tbtdouble(var1^) := tbtdouble(var1^) - tbtu16(var2^);
5667 btS16: tbtdouble(var1^) := tbtdouble(var1^) - tbts16(var2^);
5668 btU32: tbtdouble(var1^) := tbtdouble(var1^) - tbtu32(var2^);
5669 btS32: tbtdouble(var1^) := tbtdouble(var1^) - tbts32(var2^);
5670 {$IFNDEF PS_NOINT64} btS64: tbtdouble(var1^) := tbtdouble(var1^) - tbts64(var2^);{$ENDIF}
5671 btSingle: tbtdouble(var1^) := tbtdouble(var1^) - tbtsingle(var2^);
5672 btDouble: tbtdouble(var1^) := tbtdouble(var1^) - tbtdouble(var2^);
5673 btExtended: tbtdouble(var1^) := tbtdouble(var1^) - tbtextended(var2^);
5674 btCurrency: tbtdouble(var1^) := tbtdouble(var1^) - tbtcurrency(var2^);
5675 btVariant: tbtdouble(var1^) := tbtdouble(var1^) - Variant(var2^);
5676 else raise Exception.Create(RPS_TypeMismatch);
5677 end;
5678 end;
5679 btExtended:
5680 begin
5681 if var2type.BaseType = btPointer then
5682 begin
5683 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5684 var2 := Pointer(var2^);
5685 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5686 end;
5687 case var2type.BaseType of
5688 btU8: tbtextended(var1^) := tbtextended(var1^) - tbtu8(var2^);
5689 btS8: tbtextended(var1^) := tbtextended(var1^) - tbts8(var2^);
5690 btU16: tbtextended(var1^) := tbtextended(var1^) - tbtu16(var2^);
5691 btS16: tbtextended(var1^) := tbtextended(var1^) - tbts16(var2^);
5692 btU32: tbtextended(var1^) := tbtextended(var1^) - tbtu32(var2^);
5693 btS32: tbtextended(var1^) := tbtextended(var1^) - tbts32(var2^);
5694 {$IFNDEF PS_NOINT64} btS64: tbtextended(var1^) := tbtextended(var1^) -+tbts64(var2^);{$ENDIF}
5695 btSingle: tbtextended(var1^) := tbtextended(var1^) - tbtsingle(var2^);
5696 btDouble: tbtextended(var1^) := tbtextended(var1^) - tbtdouble(var2^);
5697 btExtended: tbtextended(var1^) := tbtextended(var1^) - tbtextended(var2^);
5698 btCurrency: tbtextended(var1^) := tbtextended(var1^) - tbtcurrency(var2^);
5699 btVariant: tbtextended(var1^) := tbtextended(var1^) - Variant(var2^);
5700 else raise Exception.Create(RPS_TypeMismatch);
5701 end;
5702 end;
5703 btChar: tbtchar(var1^):= tbtchar(ord(tbtchar(var1^)) - PSGetUInt(Var2, var2type));
5704 {$IFNDEF PS_NOWIDESTRING}
5705 btWideChar: tbtwidechar(var1^) := widechar(ord(tbtwidechar(var1^)) - PSGetUInt(Var2, var2type));
5706 {$ENDIF}
5707 btVariant:
5708 begin
5709 if not IntPIFVariantToVariant(var2, var2type, tvar) then
5710 begin
5711 Result := false;
5712 end else
5713 Variant(var1^) := Variant(var1^) - tvar;
5714 end;
5715 btSet:
5716 begin
5717 if var1Type = var2Type then
5718 begin
5719 Set_Diff(var1, var2, TPSTypeRec_Set(var1Type).aByteSize);
5720 end else result := False;
5721 end;
5722 else begin
5723 CMD_Err(erTypeMismatch);
5724 exit;
5725 end;
5726 end;
5727 if not Result then begin
5728 CMD_Err(erTypeMismatch);
5729 exit;
5730 end;
5731 end;
5732 2: begin { * }
5733 case var1Type.BaseType of
5734 btU8: tbtU8(var1^) := tbtU8(var1^) * PSGetUInt(Var2, var2type);
5735 btS8: tbts8(var1^) := tbts8(var1^) * PSGetInt(Var2, var2type);
5736 btU16: tbtU16(var1^) := tbtU16(var1^) * PSGetUInt(Var2, var2type);
5737 btS16: tbts16(var1^) := tbts16(var1^) * PSGetInt(Var2, var2type);
5738 btU32:
5739 begin
5740 if var2type.BaseType = btPointer then
5741 begin
5742 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5743 var2 := Pointer(var2^);
5744 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5745 end;
5746 case var2type.BaseType of
5747 btU8: tbtU32(var1^) := tbtU32(var1^) * tbtu8(var2^);
5748 btS8: tbtU32(var1^) := tbtU32(var1^) * cardinal(longint(tbts8(var2^)));
5749 btU16: tbtU32(var1^) := tbtU32(var1^) * tbtu16(var2^);
5750 btS16: tbtU32(var1^) := tbtU32(var1^) * cardinal(longint(tbts16(var2^)));
5751 btU32: tbtU32(var1^) := tbtU32(var1^) * tbtu32(var2^);
5752 btS32: tbtU32(var1^) := tbtU32(var1^) * cardinal(tbts32(var2^));
5753 {$IFNDEF PS_NOINT64} btS64: tbtU32(var1^) := tbtU32(var1^) * tbts64(var2^);{$ENDIF}
5754 btChar: tbtU32(var1^) := tbtU32(var1^) * Ord(tbtchar(var2^));
5755 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtU32(var1^) := tbtU32(var1^) * Ord(tbtwidechar(var2^));{$ENDIF}
5756 btVariant: tbtU32(var1^) := tbtU32(var1^) * Variant(var2^);
5757 else raise Exception.Create(RPS_TypeMismatch);
5758 end;
5759 end;
5760 btS32:
5761 begin
5762 if var2type.BaseType = btPointer then
5763 begin
5764 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5765 var2 := Pointer(var2^);
5766 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5767 end;
5768 case var2type.BaseType of
5769 btU8: tbts32(var1^) := tbts32(var1^) * tbtu8(var2^);
5770 btS8: tbts32(var1^) := tbts32(var1^) * tbts8(var2^);
5771 btU16: tbts32(var1^) := tbts32(var1^) * tbtu16(var2^);
5772 btS16: tbts32(var1^) := tbts32(var1^) * tbts16(var2^);
5773 btU32: tbts32(var1^) := tbts32(var1^) * Longint(tbtu32(var2^));
5774 btS32: tbts32(var1^) := tbts32(var1^) * tbts32(var2^);
5775 {$IFNDEF PS_NOINT64} btS64: tbts32(var1^) := tbts32(var1^) * tbts64(var2^);{$ENDIF}
5776 btChar: tbts32(var1^) := tbts32(var1^) * Ord(tbtchar(var2^));
5777 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(var1^) := tbts32(var1^) * Ord(tbtwidechar(var2^));{$ENDIF}
5778 btVariant: tbts32(var1^) := tbts32(var1^) * Variant(var2^);
5779 else raise Exception.Create(RPS_TypeMismatch);
5780 end;
5781 end;
5782 {$IFNDEF PS_NOINT64}
5783 btS64: tbts64(var1^) := tbts64(var1^) * PSGetInt64(var2, var2type);
5784 {$ENDIF}
5785 btCurrency:
5786 begin
5787 if var2type.BaseType = btPointer then
5788 begin
5789 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5790 var2 := Pointer(var2^);
5791 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5792 end;
5793 case var2type.BaseType of
5794 btU8: tbtcurrency(var1^) := tbtcurrency(var1^) * tbtu8(var2^);
5795 btS8: tbtcurrency(var1^) := tbtcurrency(var1^) * tbts8(var2^);
5796 btU16: tbtcurrency(var1^) := tbtcurrency(var1^) * tbtu16(var2^);
5797 btS16: tbtcurrency(var1^) := tbtcurrency(var1^) * tbts16(var2^);
5798 btU32: tbtcurrency(var1^) := tbtdouble(var1^) * tbtu32(var2^);
5799 btS32: tbtcurrency(var1^) := tbtcurrency(var1^) * tbts32(var2^);
5800 {$IFNDEF PS_NOINT64} btS64: tbtcurrency(var1^) := tbtdouble(var1^) * tbts64(var2^);{$ENDIF}
5801 btSingle: tbtcurrency(var1^) := tbtcurrency(var1^) * tbtsingle(var2^);
5802 btDouble: tbtcurrency(var1^) := tbtcurrency(var1^) * tbtdouble(var2^);
5803 btExtended: tbtcurrency(var1^) := tbtcurrency(var1^) * tbtextended(var2^);
5804 btCurrency: tbtcurrency(var1^) := tbtcurrency(var1^) * tbtcurrency(var2^);
5805 btVariant: tbtcurrency(var1^) := tbtcurrency(var1^) * Variant(var2^);
5806 else raise Exception.Create(RPS_TypeMismatch);
5807 end;
5808 end;
5809 btSingle:
5810 begin
5811 if var2type.BaseType = btPointer then
5812 begin
5813 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5814 var2 := Pointer(var2^);
5815 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5816 end;
5817 case var2type.BaseType of
5818 btU8: tbtsingle(var1^) := tbtsingle(var1^) *tbtu8(var2^);
5819 btS8: tbtsingle(var1^) := tbtsingle(var1^) *tbts8(var2^);
5820 btU16: tbtsingle(var1^) := tbtsingle(var1^) *tbtu16(var2^);
5821 btS16: tbtsingle(var1^) := tbtsingle(var1^) *tbts16(var2^);
5822 btU32: tbtsingle(var1^) := tbtsingle(var1^) *tbtu32(var2^);
5823 btS32: tbtsingle(var1^) := tbtsingle(var1^) *tbts32(var2^);
5824 {$IFNDEF PS_NOINT64} btS64: tbtsingle(var1^) := tbtsingle(var1^) *tbts64(var2^);{$ENDIF}
5825 btSingle: tbtsingle(var1^) := tbtsingle(var1^) *tbtsingle(var2^);
5826 btDouble: tbtsingle(var1^) := tbtsingle(var1^) *tbtdouble(var2^);
5827 btExtended: tbtsingle(var1^) := tbtsingle(var1^) *tbtextended(var2^);
5828 btCurrency: tbtsingle(var1^) := tbtsingle(var1^) *tbtcurrency(var2^);
5829 btVariant: tbtsingle(var1^) := tbtsingle(var1^) * Variant(var2^);
5830 else raise Exception.Create(RPS_TypeMismatch);
5831 end;
5832 end;
5833 btDouble:
5834 begin
5835 if var2type.BaseType = btPointer then
5836 begin
5837 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5838 var2 := Pointer(var2^);
5839 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5840 end;
5841 case var2type.BaseType of
5842 btU8: tbtdouble(var1^) := tbtdouble(var1^) *tbtu8(var2^);
5843 btS8: tbtdouble(var1^) := tbtdouble(var1^) *tbts8(var2^);
5844 btU16: tbtdouble(var1^) := tbtdouble(var1^) *tbtu16(var2^);
5845 btS16: tbtdouble(var1^) := tbtdouble(var1^) *tbts16(var2^);
5846 btU32: tbtdouble(var1^) := tbtdouble(var1^) *tbtu32(var2^);
5847 btS32: tbtdouble(var1^) := tbtdouble(var1^) *tbts32(var2^);
5848 {$IFNDEF PS_NOINT64} btS64: tbtdouble(var1^) := tbtdouble(var1^) *tbts64(var2^);{$ENDIF}
5849 btSingle: tbtdouble(var1^) := tbtdouble(var1^) *tbtsingle(var2^);
5850 btDouble: tbtdouble(var1^) := tbtdouble(var1^) *tbtdouble(var2^);
5851 btExtended: tbtdouble(var1^) := tbtdouble(var1^) *tbtextended(var2^);
5852 btCurrency: tbtdouble(var1^) := tbtdouble(var1^) *tbtcurrency(var2^);
5853 btVariant: tbtdouble(var1^) := tbtdouble(var1^) * Variant(var2^);
5854 else raise Exception.Create(RPS_TypeMismatch);
5855 end;
5856 end;
5857 btExtended:
5858 begin
5859 if var2type.BaseType = btPointer then
5860 begin
5861 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5862 var2 := Pointer(var2^);
5863 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5864 end;
5865 case var2type.BaseType of
5866 btU8: tbtextended(var1^) := tbtextended(var1^) *tbtu8(var2^);
5867 btS8: tbtextended(var1^) := tbtextended(var1^) *tbts8(var2^);
5868 btU16: tbtextended(var1^) := tbtextended(var1^) *tbtu16(var2^);
5869 btS16: tbtextended(var1^) := tbtextended(var1^) *tbts16(var2^);
5870 btU32: tbtextended(var1^) := tbtextended(var1^) *tbtu32(var2^);
5871 btS32: tbtextended(var1^) := tbtextended(var1^) *tbts32(var2^);
5872 {$IFNDEF PS_NOINT64} btS64: tbtextended(var1^) := tbtextended(var1^) *tbts64(var2^);{$ENDIF}
5873 btSingle: tbtextended(var1^) := tbtextended(var1^) *tbtsingle(var2^);
5874 btDouble: tbtextended(var1^) := tbtextended(var1^) *tbtdouble(var2^);
5875 btExtended: tbtextended(var1^) := tbtextended(var1^) *tbtextended(var2^);
5876 btCurrency: tbtextended(var1^) := tbtextended(var1^) *tbtcurrency(var2^);
5877 btVariant: tbtextended(var1^) := tbtextended(var1^) * Variant(var2^);
5878 else raise Exception.Create(RPS_TypeMismatch);
5879 end;
5880 end;
5881 btVariant:
5882 begin
5883 if not IntPIFVariantToVariant(var2, var2type, tvar) then
5884 begin
5885 Result := false;
5886 end else
5887 Variant(var1^) := Variant(var1^) * tvar;
5888 end;
5889 btSet:
5890 begin
5891 if var1Type = var2Type then
5892 begin
5893 Set_Intersect(var1, var2, TPSTypeRec_Set(var1Type).aByteSize);
5894 end else result := False;
5895 end;
5896 else begin
5897 CMD_Err(erTypeMismatch);
5898 exit;
5899 end;
5900 end;
5901 if not Result then begin
5902 CMD_Err(erTypeMismatch);
5903 exit;
5904 end;
5905 end;
5906 3: begin { / }
5907 case var1Type.BaseType of
5908 btU8: tbtU8(var1^) := tbtU8(var1^) div PSGetUInt(Var2, var2type);
5909 btS8: tbts8(var1^) := tbts8(var1^) div PSGetInt(Var2, var2type);
5910 btU16: tbtU16(var1^) := tbtU16(var1^) div PSGetUInt(Var2, var2type);
5911 btS16: tbts16(var1^) := tbts16(var1^) div PSGetInt(Var2, var2type);
5912 btU32:
5913 begin
5914 if var2type.BaseType = btPointer then
5915 begin
5916 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5917 var2 := Pointer(var2^);
5918 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5919 end;
5920 case var2type.BaseType of
5921 btU8: tbtU32(var1^) := tbtU32(var1^) div tbtu8(var2^);
5922 btS8: tbtU32(var1^) := tbtU32(var1^) div cardinal(longint(tbts8(var2^)));
5923 btU16: tbtU32(var1^) := tbtU32(var1^) div tbtu16(var2^);
5924 btS16: tbtU32(var1^) := tbtU32(var1^) div cardinal(longint(tbts16(var2^)));
5925 btU32: tbtU32(var1^) := tbtU32(var1^) div tbtu32(var2^);
5926 btS32: tbtU32(var1^) := tbtU32(var1^) div cardinal(tbts32(var2^));
5927 {$IFNDEF PS_NOINT64} btS64: tbtU32(var1^) := tbtU32(var1^) div tbts64(var2^);{$ENDIF}
5928 btChar: tbtU32(var1^) := tbtU32(var1^) div Ord(tbtchar(var2^));
5929 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtU32(var1^) := tbtU32(var1^) div Ord(tbtwidechar(var2^));{$ENDIF}
5930 btVariant: tbtU32(var1^) := tbtU32(var1^) div Variant(var2^);
5931 else raise Exception.Create(RPS_TypeMismatch);
5932 end;
5933 end;
5934 btS32:
5935 begin
5936 if var2type.BaseType = btPointer then
5937 begin
5938 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5939 var2 := Pointer(var2^);
5940 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5941 end;
5942 case var2type.BaseType of
5943 btU8: tbts32(var1^) := tbts32(var1^) div tbtu8(var2^);
5944 btS8: tbts32(var1^) := tbts32(var1^) div tbts8(var2^);
5945 btU16: tbts32(var1^) := tbts32(var1^) div tbtu16(var2^);
5946 btS16: tbts32(var1^) := tbts32(var1^) div tbts16(var2^);
5947 btU32: tbts32(var1^) := tbts32(var1^) div Longint(tbtu32(var2^));
5948 btS32: tbts32(var1^) := tbts32(var1^) div tbts32(var2^);
5949 {$IFNDEF PS_NOINT64} btS64: tbts32(var1^) := tbts32(var1^) div tbts64(var2^);{$ENDIF}
5950 btChar: tbts32(var1^) := tbts32(var1^) div Ord(tbtchar(var2^));
5951 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(var1^) := tbts32(var1^) div Ord(tbtwidechar(var2^));{$ENDIF}
5952 btVariant: tbts32(var1^) := tbts32(var1^) div Variant(var2^);
5953 else raise Exception.Create(RPS_TypeMismatch);
5954 end;
5955 end;
5956 {$IFNDEF PS_NOINT64}
5957 btS64: tbts64(var1^) := tbts64(var1^) div PSGetInt64(var2, var2type);
5958 {$ENDIF}
5959 btSingle:
5960 begin
5961 if var2type.BaseType = btPointer then
5962 begin
5963 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5964 var2 := Pointer(var2^);
5965 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5966 end;
5967 case var2type.BaseType of
5968 btU8: tbtsingle(var1^) := tbtsingle(var1^) / tbtu8(var2^);
5969 btS8: tbtsingle(var1^) := tbtsingle(var1^) / tbts8(var2^);
5970 btU16: tbtsingle(var1^) := tbtsingle(var1^) / tbtu16(var2^);
5971 btS16: tbtsingle(var1^) := tbtsingle(var1^) / tbts16(var2^);
5972 btU32: tbtsingle(var1^) := tbtsingle(var1^) / tbtu32(var2^);
5973 btS32: tbtsingle(var1^) := tbtsingle(var1^) / tbts32(var2^);
5974 {$IFNDEF PS_NOINT64} btS64: tbtsingle(var1^) := tbtsingle(var1^) / tbts64(var2^);{$ENDIF}
5975 btSingle: tbtsingle(var1^) := tbtsingle(var1^) / tbtsingle(var2^);
5976 btDouble: tbtsingle(var1^) := tbtsingle(var1^) / tbtdouble(var2^);
5977 btExtended: tbtsingle(var1^) := tbtsingle(var1^) / tbtextended(var2^);
5978 btCurrency: tbtsingle(var1^) := tbtsingle(var1^) / tbtcurrency(var2^);
5979 btVariant: tbtsingle(var1^) := tbtsingle(var1^) / Variant(var2^);
5980 else raise Exception.Create(RPS_TypeMismatch);
5981 end;
5982 end;
5983 btCurrency:
5984 begin
5985 if var2type.BaseType = btPointer then
5986 begin
5987 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5988 var2 := Pointer(var2^);
5989 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5990 end;
5991 case var2type.BaseType of
5992 btU8: tbtcurrency(var1^) := tbtcurrency(var1^) / tbtu8(var2^);
5993 btS8: tbtcurrency(var1^) := tbtcurrency(var1^) / tbts8(var2^);
5994 btU16: tbtcurrency(var1^) := tbtcurrency(var1^) / tbtu16(var2^);
5995 btS16: tbtcurrency(var1^) := tbtcurrency(var1^) / tbts16(var2^);
5996 btU32: tbtcurrency(var1^) := tbtdouble(var1^) / tbtu32(var2^);
5997 btS32: tbtcurrency(var1^) := tbtcurrency(var1^) / tbts32(var2^);
5998 {$IFNDEF PS_NOINT64} btS64: tbtcurrency(var1^) := tbtdouble(var1^) / tbts64(var2^);{$ENDIF}
5999 btSingle: tbtcurrency(var1^) := tbtcurrency(var1^) / tbtsingle(var2^);
6000 btDouble: tbtcurrency(var1^) := tbtcurrency(var1^) / tbtdouble(var2^);
6001 btExtended: tbtcurrency(var1^) := tbtcurrency(var1^) / tbtextended(var2^);
6002 btCurrency: tbtcurrency(var1^) := tbtcurrency(var1^) / tbtcurrency(var2^);
6003 btVariant: tbtcurrency(var1^) := tbtcurrency(var1^) / Variant(var2^);
6004 else raise Exception.Create(RPS_TypeMismatch);
6005 end;
6006 end;
6007 btDouble:
6008 begin
6009 if var2type.BaseType = btPointer then
6010 begin
6011 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
6012 var2 := Pointer(var2^);
6013 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
6014 end;
6015 case var2type.BaseType of
6016 btU8: tbtdouble(var1^) := tbtdouble(var1^) / tbtu8(var2^);
6017 btS8: tbtdouble(var1^) := tbtdouble(var1^) / tbts8(var2^);
6018 btU16: tbtdouble(var1^) := tbtdouble(var1^) / tbtu16(var2^);
6019 btS16: tbtdouble(var1^) := tbtdouble(var1^) / tbts16(var2^);
6020 btU32: tbtdouble(var1^) := tbtdouble(var1^) / tbtu32(var2^);
6021 btS32: tbtdouble(var1^) := tbtdouble(var1^) / tbts32(var2^);
6022 {$IFNDEF PS_NOINT64} btS64: tbtdouble(var1^) := tbtdouble(var1^) / tbts64(var2^);{$ENDIF}
6023 btSingle: tbtdouble(var1^) := tbtdouble(var1^) / tbtsingle(var2^);
6024 btDouble: tbtdouble(var1^) := tbtdouble(var1^) / tbtdouble(var2^);
6025 btExtended: tbtdouble(var1^) := tbtdouble(var1^) / tbtextended(var2^);
6026 btCurrency: tbtdouble(var1^) := tbtdouble(var1^) / tbtcurrency(var2^);
6027 btVariant: tbtdouble(var1^) := tbtdouble(var1^) / Variant(var2^);
6028 else raise Exception.Create(RPS_TypeMismatch);
6029 end;
6030 end;
6031 btExtended:
6032 begin
6033 if var2type.BaseType = btPointer then
6034 begin
6035 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
6036 var2 := Pointer(var2^);
6037 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
6038 end;
6039 case var2type.BaseType of
6040 btU8: tbtextended(var1^) := tbtextended(var1^) / tbtu8(var2^);
6041 btS8: tbtextended(var1^) := tbtextended(var1^) / tbts8(var2^);
6042 btU16: tbtextended(var1^) := tbtextended(var1^) / tbtu16(var2^);
6043 btS16: tbtextended(var1^) := tbtextended(var1^) / tbts16(var2^);
6044 btU32: tbtextended(var1^) := tbtextended(var1^) / tbtu32(var2^);
6045 btS32: tbtextended(var1^) := tbtextended(var1^) / tbts32(var2^);
6046 {$IFNDEF PS_NOINT64} btS64: tbtextended(var1^) := tbtextended(var1^) / tbts64(var2^);{$ENDIF}
6047 btSingle: tbtextended(var1^) := tbtextended(var1^) / tbtsingle(var2^);
6048 btDouble: tbtextended(var1^) := tbtextended(var1^) / tbtdouble(var2^);
6049 btExtended: tbtextended(var1^) := tbtextended(var1^) / tbtextended(var2^);
6050 btCurrency: tbtextended(var1^) := tbtextended(var1^) / tbtcurrency(var2^);
6051 btVariant: tbtextended(var1^) := tbtextended(var1^) / Variant(var2^);
6052 else raise Exception.Create(RPS_TypeMismatch);
6053 end;
6054 end;
6055 btVariant:
6056 begin
6057 if not IntPIFVariantToVariant(var2, var2type, tvar) then
6058 begin
6059 Result := false;
6060 end else
6061 begin
6062 if VarIsFloat(variant(var1^)) then
6063 Variant(var1^) := Variant(var1^) / tvar
6064 else
6065 Variant(var1^) := Variant(var1^) div tvar;
6066 end;
6067 end;
6068 else begin
6069 CMD_Err(erTypeMismatch);
6070 exit;
6071 end;
6072 end;
6073 if not Result then begin
6074 CMD_Err(erTypeMismatch);
6075 exit;
6076 end;
6077 end;
6078 4: begin { MOD }
6079 case var1Type.BaseType of
6080 btU8: tbtU8(var1^) := tbtU8(var1^) mod PSGetUInt(Var2, var2type);
6081 btS8: tbts8(var1^) := tbts8(var1^) mod PSGetInt(Var2, var2type);
6082 btU16: tbtU16(var1^) := tbtU16(var1^) mod PSGetUInt(Var2, var2type);
6083 btS16: tbts16(var1^) := tbts16(var1^) mod PSGetInt(Var2, var2type);
6084 btU32:
6085 begin
6086 if var2type.BaseType = btPointer then
6087 begin
6088 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
6089 var2 := Pointer(var2^);
6090 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
6091 end;
6092 case var2type.BaseType of
6093 btU8: tbtU32(var1^) := tbtU32(var1^) mod tbtu8(var2^);
6094 btS8: tbtU32(var1^) := tbtU32(var1^) mod cardinal(longint(tbts8(var2^)));
6095 btU16: tbtU32(var1^) := tbtU32(var1^) mod tbtu16(var2^);
6096 btS16: tbtU32(var1^) := tbtU32(var1^) mod cardinal(longint(tbts16(var2^)));
6097 btU32: tbtU32(var1^) := tbtU32(var1^) mod tbtu32(var2^);
6098 btS32: tbtU32(var1^) := tbtU32(var1^) mod cardinal(tbts32(var2^));
6099 {$IFNDEF PS_NOINT64} btS64: tbtU32(var1^) := tbtU32(var1^) mod tbts64(var2^);{$ENDIF}
6100 btChar: tbtU32(var1^) := tbtU32(var1^) mod Ord(tbtchar(var2^));
6101 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtU32(var1^) := tbtU32(var1^) mod Ord(tbtwidechar(var2^));{$ENDIF}
6102 btVariant: tbtU32(var1^) := tbtU32(var1^) mod Variant(var2^);
6103 else raise Exception.Create(RPS_TypeMismatch);
6104 end;
6105 end;
6106 btS32:
6107 begin
6108 if var2type.BaseType = btPointer then
6109 begin
6110 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
6111 var2 := Pointer(var2^);
6112 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
6113 end;
6114 case var2type.BaseType of
6115 btU8: tbts32(var1^) := tbts32(var1^) mod tbtu8(var2^);
6116 btS8: tbts32(var1^) := tbts32(var1^) mod tbts8(var2^);
6117 btU16: tbts32(var1^) := tbts32(var1^) mod tbtu16(var2^);
6118 btS16: tbts32(var1^) := tbts32(var1^) mod tbts16(var2^);
6119 btU32: tbts32(var1^) := tbts32(var1^) mod Longint(tbtu32(var2^));
6120 btS32: tbts32(var1^) := tbts32(var1^) mod tbts32(var2^);
6121 {$IFNDEF PS_NOINT64} btS64: tbts32(var1^) := tbts32(var1^) mod tbts64(var2^);{$ENDIF}
6122 btChar: tbts32(var1^) := tbts32(var1^) mod Ord(tbtchar(var2^));
6123 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(var1^) := tbts32(var1^) mod Ord(tbtwidechar(var2^));{$ENDIF}
6124 btVariant: tbts32(var1^) := tbts32(var1^) mod Variant(var2^);
6125 else raise Exception.Create(RPS_TypeMismatch);
6126 end;
6127 end;
6128 {$IFNDEF PS_NOINT64}
6129 btS64: tbts64(var1^) := tbts64(var1^) mod PSGetInt64(var2, var2type);
6130 {$ENDIF}
6131 btVariant:
6132 begin
6133 if not IntPIFVariantToVariant(var2, var2type, tvar) then
6134 begin
6135 Result := false;
6136 end else
6137 Variant(var1^) := Variant(var1^) mod tvar;
6138 end;
6139 else begin
6140 CMD_Err(erTypeMismatch);
6141 exit;
6142 end;
6143 end;
6144 if not Result then begin
6145 CMD_Err(erTypeMismatch);
6146 exit;
6147 end;
6148 end;
6149 5: begin { SHL }
6150 case var1Type.BaseType of
6151 btU8: tbtU8(var1^) := tbtU8(var1^) shl PSGetUInt(Var2, var2type);
6152 btS8: tbts8(var1^) := tbts8(var1^) shl PSGetInt(Var2, var2type);
6153 btU16: tbtU16(var1^) := tbtU16(var1^) shl PSGetUInt(Var2, var2type);
6154 btS16: tbts16(var1^) := tbts16(var1^) shl PSGetInt(Var2, var2type);
6155 btU32: tbtU32(var1^) := tbtU32(var1^) shl PSGetUInt(Var2, var2type);
6156 btS32: tbts32(var1^) := tbts32(var1^) shl PSGetInt(Var2, var2type);
6157 {$IFNDEF PS_NOINT64}
6158 btS64: tbts64(var1^) := tbts64(var1^) shl PSGetInt64(var2, var2type);
6159 {$ENDIF}
6160 btVariant:
6161 begin
6162 if not IntPIFVariantToVariant(var2, var2type, tvar) then
6163 begin
6164 Result := false;
6165 end else
6166 Variant(var1^) := Variant(var1^) shl tvar;
6167 end;
6168 else begin
6169 CMD_Err(erTypeMismatch);
6170 exit;
6171 end;
6172 end;
6173 if not Result then begin
6174 CMD_Err(erTypeMismatch);
6175 exit;
6176 end;
6177 end;
6178 6: begin { SHR }
6179 case var1Type.BaseType of
6180 btU8: tbtU8(var1^) := tbtU8(var1^) shr PSGetUInt(Var2, var2type);
6181 btS8: tbts8(var1^) := tbts8(var1^) shr PSGetInt(Var2, var2type);
6182 btU16: tbtU16(var1^) := tbtU16(var1^) shr PSGetUInt(Var2, var2type);
6183 btS16: tbts16(var1^) := tbts16(var1^) shr PSGetInt(Var2, var2type);
6184 btU32: tbtU32(var1^) := tbtU32(var1^) shr PSGetUInt(Var2, var2type);
6185 btS32: tbts32(var1^) := tbts32(var1^) shr PSGetInt(Var2, var2type);
6186 {$IFNDEF PS_NOINT64}
6187 btS64: tbts64(var1^) := tbts64(var1^) shr PSGetInt64(var2, var2type);
6188 {$ENDIF}
6189 btVariant:
6190 begin
6191 if not IntPIFVariantToVariant(var2, var2type, tvar) then
6192 begin
6193 Result := false;
6194 end else
6195 Variant(var1^) := Variant(var1^) shr tvar;
6196 end;
6197 else begin
6198 CMD_Err(erTypeMismatch);
6199 exit;
6200 end;
6201 end;
6202 if not Result then begin
6203 CMD_Err(erTypeMismatch);
6204 exit;
6205 end;
6206 end;
6207 7: begin { AND }
6208 case var1Type.BaseType of
6209 btU8: tbtU8(var1^) := tbtU8(var1^) and PSGetUInt(Var2, var2type);
6210 btS8: tbts8(var1^) := tbts8(var1^) and PSGetInt(Var2, var2type);
6211 btU16: tbtU16(var1^) := tbtU16(var1^) and PSGetUInt(Var2, var2type);
6212 btS16: tbts16(var1^) := tbts16(var1^) and PSGetInt(Var2, var2type);
6213 btU32: tbtU32(var1^) := tbtU32(var1^) and PSGetUInt(Var2, var2type);
6214 btS32: tbts32(var1^) := tbts32(var1^) and PSGetInt(Var2, var2type);
6215 {$IFNDEF PS_NOINT64}
6216 btS64: tbts64(var1^) := tbts64(var1^) and PSGetInt64(var2, var2type);
6217 {$ENDIF}
6218 btVariant:
6219 begin
6220 if not IntPIFVariantToVariant(var2, var2type, tvar) then
6221 begin
6222 Result := false;
6223 end else
6224 Variant(var1^) := Variant(var1^) and tvar;
6225 end;
6226 else begin
6227 CMD_Err(erTypeMismatch);
6228 exit;
6229 end;
6230 end;
6231 if not Result then begin
6232 CMD_Err(erTypeMismatch);
6233 exit;
6234 end;
6235 end;
6236 8: begin { OR }
6237 case var1Type.BaseType of
6238 btU8: tbtU8(var1^) := tbtU8(var1^) or PSGetUInt(Var2, var2type);
6239 btS8: tbts8(var1^) := tbts8(var1^) or PSGetInt(Var2, var2type);
6240 btU16: tbtU16(var1^) := tbtU16(var1^) or PSGetUInt(Var2, var2type);
6241 btS16: tbts16(var1^) := tbts16(var1^) or PSGetInt(Var2, var2type);
6242 btU32: tbtU32(var1^) := tbtU32(var1^) or PSGetUInt(Var2, var2type);
6243 btS32: tbts32(var1^) := tbts32(var1^) or PSGetInt(Var2, var2type);
6244 {$IFNDEF PS_NOINT64}
6245 btS64: tbts64(var1^) := tbts64(var1^) or PSGetInt64(var2, var2type);
6246 {$ENDIF}
6247 btVariant:
6248 begin
6249 if not IntPIFVariantToVariant(var2, var2type, tvar) then
6250 begin
6251 Result := false;
6252 end else
6253 Variant(var1^) := Variant(var1^) or tvar;
6254 end;
6255 else begin
6256 CMD_Err(erTypeMismatch);
6257 exit;
6258 end;
6259 end;
6260 if not Result then begin
6261 CMD_Err(erTypeMismatch);
6262 exit;
6263 end;
6264 end;
6265 9: begin { XOR }
6266 case var1Type.BaseType of
6267 btU8: tbtU8(var1^) := tbtU8(var1^) xor PSGetUInt(Var2, var2type);
6268 btS8: tbts8(var1^) := tbts8(var1^) xor PSGetInt(Var2, var2type);
6269 btU16: tbtU16(var1^) := tbtU16(var1^) xor PSGetUInt(Var2, var2type);
6270 btS16: tbts16(var1^) := tbts16(var1^) xor PSGetInt(Var2, var2type);
6271 btU32: tbtU32(var1^) := tbtU32(var1^) xor PSGetUInt(Var2, var2type);
6272 btS32: tbts32(var1^) := tbts32(var1^) xor PSGetInt(Var2, var2type);
6273 {$IFNDEF PS_NOINT64}
6274 btS64: tbts64(var1^) := tbts64(var1^) xor PSGetInt64(var2, var2type);
6275 {$ENDIF}
6276 btVariant:
6277 begin
6278 if not IntPIFVariantToVariant(var2, var2type, tvar) then
6279 begin
6280 Result := false;
6281 end else
6282 Variant(var1^) := Variant(var1^) xor tvar;
6283 end;
6284 else begin
6285 CMD_Err(erTypeMismatch);
6286 exit;
6287 end;
6288 end;
6289 if not Result then begin
6290 CMD_Err(erTypeMismatch);
6291 exit;
6292 end;
6293 end;
6294 10:
6295 begin // as
6296 case var1Type.BaseType of
6297 btClass:
6298 begin
6299 if var2type.BaseType <> btU32 then
6300 Result := False
6301 else
6302 begin
6303 var2type := FTypes[tbtu32(var2^)];
6304 if (var2type = nil) or (var2type.BaseType <> btClass) then
6305 Result := false
6306 else
6307 begin
6308 if not Class_IS(Self, TObject(var1^), var2type) then
6309 Result := false
6310 end;
6311 end;
6312 end;
6313 else begin
6314 CMD_Err(erTypeMismatch);
6315 exit;
6316 end;
6317 end;
6318 if not Result then begin
6319 CMD_Err(erTypeMismatch);
6320 exit;
6321 end;
6322 end;
6323 else begin
6324 Result := False;
6325 CMD_Err(erInvalidOpcodeParameter);
6326 exit;
6327 end;
6328 end;
6329 except
6330 {$IFDEF DELPHI6UP}
6331 Tmp := AcquireExceptionObject;
6332 {$ELSE}
6333 if RaiseList <> nil then
6334 begin
6335 Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
6336 PRaiseFrame(RaiseList)^.ExceptObject := nil;
6337 end else
6338 Tmp := nil;
6339 {$ENDIF}
6340 if Tmp <> nil then
6341 begin
6342 if Tmp is EPSException then
6343 begin
6344 Result := False;
6345 ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, tbtString(EPSException(tmp).Message), nil);
6346 exit;
6347 end else
6348 if Tmp is EDivByZero then
6349 begin
6350 Result := False;
6351 CMD_Err3(erDivideByZero, tbtString(Exception(Tmp).Message), Tmp);
6352 Exit;
6353 end;
6354 if Tmp is EZeroDivide then
6355 begin
6356 Result := False;
6357 CMD_Err3(erDivideByZero, tbtString(Exception(Tmp).Message), Tmp);
6358 Exit;
6359 end;
6360 if Tmp is EMathError then
6361 begin
6362 Result := False;
6363 CMD_Err3(erMathError,tbtString(Exception(Tmp).Message), Tmp);
6364 Exit;
6365 end;
6366 end;
6367 if (tmp <> nil) and (Tmp is Exception) then
6368 CMD_Err3(erException, tbtString(Exception(Tmp).Message), Tmp)
6369 else
6370 CMD_Err3(erException, '', Tmp);
6371 Result := False;
6372 end;
6373 end;
6374
TPSExec.ReadVariablenull6375 function TPSExec.ReadVariable(var Dest: TPSResultData; UsePointer: Boolean): Boolean;
6376 var
6377 VarType: Cardinal;
6378 Param: Cardinal;
6379 Tmp: PIfVariant;
6380 at: TPSTypeRec;
6381
6382 begin
6383 if FCurrentPosition + 4 >= FDataLength then
6384 begin
6385 CMD_Err(erOutOfRange); // Error
6386 Result := False;
6387 exit;
6388 end;
6389 VarType := FData^[FCurrentPosition];
6390 Inc(FCurrentPosition);
6391 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6392 Param := unaligned(Cardinal((@FData^[FCurrentPosition])^));
6393 {$else}
6394 Param := Cardinal((@FData^[FCurrentPosition])^);
6395 {$endif}
6396 Inc(FCurrentPosition, 4);
6397 case VarType of
6398 0:
6399 begin
6400 Dest.FreeType := vtNone;
6401 if Param < PSAddrNegativeStackStart then
6402 begin
6403 if Param >= Cardinal(FGlobalVars.Count) then
6404 begin
6405 CMD_Err(erOutOfGlobalVarsRange);
6406 Result := False;
6407 exit;
6408 end;
6409 Tmp := FGlobalVars.Data[param];
6410 end else
6411 begin
6412 Param := Cardinal(Longint(-PSAddrStackStart) +
6413 Longint(FCurrStackBase) + Longint(Param));
6414 if Param >= Cardinal(FStack.Count) then
6415 begin
6416 CMD_Err(erOutOfStackRange);
6417 Result := False;
6418 exit;
6419 end;
6420 Tmp := FStack.Data[param];
6421 end;
6422 if (UsePointer) and (Tmp.FType.BaseType = btPointer) then
6423 begin
6424 Dest.aType := PPSVariantPointer(Tmp).DestType;
6425 Dest.P := PPSVariantPointer(Tmp).DataDest;
6426 if Dest.P = nil then
6427 begin
6428 Cmd_Err(erNullPointerException);
6429 Result := False;
6430 exit;
6431 end;
6432 end else
6433 begin
6434 Dest.aType := PPSVariantData(Tmp).vi.FType;
6435 Dest.P := @PPSVariantData(Tmp).Data;
6436 end;
6437 end;
6438 1: begin
6439 if Param >= FTypes.Count then
6440 begin
6441 CMD_Err(erInvalidType);
6442 Result := False;
6443 exit;
6444 end;
6445 at := FTypes.Data^[Param];
6446 Param := FTempVars.FLength;
6447 FTempVars.FLength := Cardinal(Longint(Param) + Longint(at.RealSize) + Longint(RTTISize + 3)) and not 3;
6448 if FTempVars.FLength > FTempVars.FCapacity then FtempVars.AdjustLength;
6449 Tmp := Pointer(IPointer(FtempVars.FDataPtr) + IPointer(Param));
6450
6451 if Cardinal(FTempVars.FCount) >= Cardinal(FTempVars.FCapacity) then
6452 begin
6453 Inc(FTempVars.FCapacity, FCapacityInc);// := FCount + 1;
6454 ReAllocMem(FTempVars.FData, FTempVars.FCapacity shl 2);
6455 end;
6456 FTempVars.FData[FTempVars.FCount] := Tmp; // Instead of SetItem
6457 Inc(FTempVars.FCount);
6458 {$IFNDEF PS_NOSMARTLIST}
6459 Inc(FTempVars.FCheckCount);
6460 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
6461 {$ENDIF}
6462
6463
6464 Tmp.FType := at;
6465 Dest.P := @PPSVariantData(Tmp).Data;
6466 Dest.aType := tmp.FType;
6467 dest.FreeType := vtTempVar;
6468 case Dest.aType.BaseType of
6469 btSet:
6470 begin
6471 if not ReadData(Dest.P^, TPSTypeRec_Set(Dest.aType).aByteSize) then
6472 begin
6473 CMD_Err(erOutOfRange);
6474 FTempVars.Pop;
6475 Result := False;
6476 exit;
6477 end;
6478 end;
6479 bts8, btchar, btU8:
6480 begin
6481 if FCurrentPosition >= FDataLength then
6482 begin
6483 CMD_Err(erOutOfRange);
6484 FTempVars.Pop;
6485 Result := False;
6486 exit;
6487 end;
6488 tbtu8(dest.p^) := FData^[FCurrentPosition];
6489 Inc(FCurrentPosition);
6490 end;
6491 bts16, {$IFNDEF PS_NOWIDESTRING}btwidechar,{$ENDIF} btU16:
6492 begin
6493 if FCurrentPosition + 1>= FDataLength then
6494 begin
6495 CMD_Err(erOutOfRange);
6496 FTempVars.Pop;
6497 Result := False;
6498 exit;
6499 end;
6500 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6501 tbtu16(dest.p^) := unaligned(tbtu16((@FData^[FCurrentPosition])^));
6502 {$else}
6503 tbtu16(dest.p^) := tbtu16((@FData^[FCurrentPosition])^);
6504 {$endif}
6505 Inc(FCurrentPosition, 2);
6506 end;
6507 bts32, btU32:
6508 begin
6509 if FCurrentPosition + 3>= FDataLength then
6510 begin
6511 CMD_Err(erOutOfRange);
6512 FTempVars.Pop;
6513 Result := False;
6514 exit;
6515 end;
6516 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6517 tbtu32(dest.p^) := unaligned(tbtu32((@FData^[FCurrentPosition])^));
6518 {$else}
6519 tbtu32(dest.p^) := tbtu32((@FData^[FCurrentPosition])^);
6520 {$endif}
6521 Inc(FCurrentPosition, 4);
6522 end;
6523 btProcPtr:
6524 begin
6525 if FCurrentPosition + 3>= FDataLength then
6526 begin
6527 CMD_Err(erOutOfRange);
6528 FTempVars.Pop;
6529 Result := False;
6530 exit;
6531 end;
6532 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6533 tbtu32(dest.p^) := unaligned(tbtu32((@FData^[FCurrentPosition])^));
6534 {$else}
6535 tbtu32(dest.p^) := tbtu32((@FData^[FCurrentPosition])^);
6536 {$endif}
6537 tbtu32(Pointer(IPointer(dest.p)+PointerSize)^) := 0;
6538 tbtu32(Pointer(IPointer(dest.p)+PointerSize)^) := 0;
6539 Inc(FCurrentPosition, 4);
6540 end;
6541 {$IFNDEF PS_NOINT64}
6542 bts64:
6543 begin
6544 if FCurrentPosition + 7>= FDataLength then
6545 begin
6546 CMD_Err(erOutOfRange);
6547 FTempVars.Pop;
6548 Result := False;
6549 exit;
6550 end;
6551 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6552 tbts64(dest.p^) := unaligned(tbts64((@FData^[FCurrentPosition])^));
6553 {$else}
6554 tbts64(dest.p^) := tbts64((@FData^[FCurrentPosition])^);
6555 {$endif}
6556 Inc(FCurrentPosition, 8);
6557 end;
6558 {$ENDIF}
6559 btSingle:
6560 begin
6561 if FCurrentPosition + (Sizeof(Single)-1)>= FDataLength then
6562 begin
6563 CMD_Err(erOutOfRange);
6564 FTempVars.Pop;
6565 Result := False;
6566 exit;
6567 end;
6568 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6569 tbtsingle(dest.p^) := unaligned(tbtsingle((@FData^[FCurrentPosition])^));
6570 {$else}
6571 tbtsingle(dest.p^) := tbtsingle((@FData^[FCurrentPosition])^);
6572 {$endif}
6573 Inc(FCurrentPosition, Sizeof(Single));
6574 end;
6575 btDouble:
6576 begin
6577 if FCurrentPosition + (Sizeof(Double)-1)>= FDataLength then
6578 begin
6579 CMD_Err(erOutOfRange);
6580 FTempVars.Pop;
6581 Result := False;
6582 exit;
6583 end;
6584 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6585 tbtdouble(dest.p^) := unaligned(tbtdouble((@FData^[FCurrentPosition])^));
6586 {$else}
6587 tbtdouble(dest.p^) := tbtdouble((@FData^[FCurrentPosition])^);
6588 {$endif}
6589 Inc(FCurrentPosition, Sizeof(double));
6590 end;
6591
6592 btExtended:
6593 begin
6594 if FCurrentPosition + (sizeof(Extended)-1)>= FDataLength then
6595 begin
6596 CMD_Err(erOutOfRange);
6597 FTempVars.Pop;
6598 Result := False;
6599 exit;
6600 end;
6601 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6602 tbtextended(dest.p^) := unaligned(tbtextended((@FData^[FCurrentPosition])^));
6603 {$else}
6604 tbtextended(dest.p^) := tbtextended((@FData^[FCurrentPosition])^);
6605 {$endif}
6606 Inc(FCurrentPosition, sizeof(Extended));
6607 end;
6608 btPchar, btString:
6609 begin
6610 if FCurrentPosition + 3 >= FDataLength then
6611 begin
6612 Cmd_Err(erOutOfRange);
6613 FTempVars.Pop;
6614 Result := False;
6615 exit;
6616 end;
6617 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6618 Param := unaligned(Cardinal((@FData^[FCurrentPosition])^));
6619 {$else}
6620 Param := Cardinal((@FData^[FCurrentPosition])^);
6621 {$endif}
6622 Inc(FCurrentPosition, 4);
6623 Pointer(Dest.P^) := nil;
6624 SetLength(tbtstring(Dest.P^), Param);
6625 if Param <> 0 then begin
6626 if not ReadData(tbtstring(Dest.P^)[1], Param) then
6627 begin
6628 CMD_Err(erOutOfRange);
6629 FTempVars.Pop;
6630 Result := False;
6631 exit;
6632 end;
6633 pansichar(dest.p^)[Param] := #0;
6634 end;
6635 end;
6636 {$IFNDEF PS_NOWIDESTRING}
6637 btWidestring:
6638 begin
6639 if FCurrentPosition + 3 >= FDataLength then
6640 begin
6641 Cmd_Err(erOutOfRange);
6642 FTempVars.Pop;
6643 Result := False;
6644 exit;
6645 end;
6646 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6647 Param := unaligned(Cardinal((@FData^[FCurrentPosition])^));
6648 {$else}
6649 Param := Cardinal((@FData^[FCurrentPosition])^);
6650 {$endif}
6651 Inc(FCurrentPosition, 4);
6652 Pointer(Dest.P^) := nil;
6653 SetLength(tbtwidestring(Dest.P^), Param);
6654 if not ReadData(tbtwidestring(Dest.P^)[1], Param*2) then
6655 begin
6656 CMD_Err(erOutOfRange);
6657 FTempVars.Pop;
6658 Result := False;
6659 exit;
6660 end;
6661 end;
6662 btUnicodeString:
6663 begin
6664 if FCurrentPosition + 3 >= FDataLength then
6665 begin
6666 Cmd_Err(erOutOfRange);
6667 FTempVars.Pop;
6668 Result := False;
6669 exit;
6670 end;
6671 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6672 Param := unaligned(Cardinal((@FData^[FCurrentPosition])^));
6673 {$else}
6674 Param := Cardinal((@FData^[FCurrentPosition])^);
6675 {$endif}
6676 Inc(FCurrentPosition, 4);
6677 Pointer(Dest.P^) := nil;
6678 SetLength(tbtUnicodestring(Dest.P^), Param);
6679 if not ReadData(tbtUnicodestring(Dest.P^)[1], Param*2) then
6680 begin
6681 CMD_Err(erOutOfRange);
6682 FTempVars.Pop;
6683 Result := False;
6684 exit;
6685 end;
6686 end;
6687 {$ENDIF}
6688 else begin
6689 CMD_Err(erInvalidType);
6690 FTempVars.Pop;
6691 Result := False;
6692 exit;
6693 end;
6694 end;
6695 end;
6696 2:
6697 begin
6698 Dest.FreeType := vtNone;
6699 if Param < PSAddrNegativeStackStart then begin
6700 if Param >= Cardinal(FGlobalVars.Count) then
6701 begin
6702 CMD_Err(erOutOfGlobalVarsRange);
6703 Result := False;
6704 exit;
6705 end;
6706 Tmp := FGlobalVars.Data[param];
6707 end
6708 else begin
6709 Param := Cardinal(Longint(-PSAddrStackStart) + Longint(FCurrStackBase) + Longint(Param));
6710 if Param >= Cardinal(FStack.Count) then
6711 begin
6712 CMD_Err(erOutOfStackRange);
6713 Result := False;
6714 exit;
6715 end;
6716 Tmp := FStack.Data[param];
6717 end;
6718 if Tmp.FType.BaseType = btPointer then
6719 begin
6720 Dest.aType := PPSVariantPointer(Tmp).DestType;
6721 Dest.P := PPSVariantPointer(Tmp).DataDest;
6722 if Dest.P = nil then
6723 begin
6724 Cmd_Err(erNullPointerException);
6725 Result := False;
6726 exit;
6727 end;
6728 end else
6729 begin
6730 Dest.aType := PPSVariantData(Tmp).vi.FType;
6731 Dest.P := @PPSVariantData(Tmp).Data;
6732 end;
6733 if FCurrentPosition + 3 >= FDataLength then
6734 begin
6735 CMD_Err(erOutOfRange);
6736 Result := False;
6737 exit;
6738 end;
6739 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6740 Param := unaligned(Cardinal((@FData^[FCurrentPosition])^));
6741 {$else}
6742 Param := Cardinal((@FData^[FCurrentPosition])^);
6743 {$endif}
6744 Inc(FCurrentPosition, 4);
6745 case Dest.aType.BaseType of
6746 btRecord:
6747 begin
6748 if Param > Cardinal(TPSTypeRec_Record(Dest.aType).FFieldTypes.Count) then
6749 begin
6750 CMD_Err(erOutOfRange);
6751 Result := False;
6752 exit;
6753 end;
6754 Dest.P := Pointer(IPointer(Dest.P) + IPointer(TPSTypeRec_Record(Dest.aType).RealFieldOffsets[Param]));
6755 Dest.aType := TPSTypeRec_Record(Dest.aType).FieldTypes[Param];
6756 end;
6757 btArray:
6758 begin
6759 if Param >= Cardinal(PSDynArrayGetLength(Pointer(Dest.P^), dest.aType)) then
6760 begin
6761 CMD_Err(erOutOfRange);
6762 Result := False;
6763 exit;
6764 end;
6765 Dest.P := Pointer(IPointer(Dest.P^) + (Param * TPSTypeRec_Array(Dest.aType).FArrayType.RealSize));
6766 Dest.aType := TPSTypeRec_Array(dest.aType).ArrayType;
6767 end;
6768 btStaticArray:
6769 begin
6770 if Param >= Cardinal(TPSTypeRec_StaticArray(Dest.aType).Size) then
6771 begin
6772 CMD_Err(erOutOfRange);
6773 Result := False;
6774 exit;
6775 end;
6776 Dest.P := Pointer(IPointer(Dest.P) + (Param * TPSTypeRec_Array(Dest.aType).FArrayType.RealSize));
6777 Dest.aType := TPSTypeRec_Array(dest.aType).ArrayType;
6778 end;
6779 else
6780 CMD_Err(erInvalidType);
6781 Result := False;
6782 exit;
6783 end;
6784
6785 if UsePointer and (Dest.aType.BaseType = btPointer) then
6786 begin
6787 Dest.aType := TPSTypeRec(Pointer(IPointer(Dest.p)+PointerSize)^);
6788 Dest.P := Pointer(Dest.p^);
6789 if Dest.P = nil then
6790 begin
6791 Cmd_Err(erNullPointerException);
6792 Result := False;
6793 exit;
6794 end;
6795 end;
6796 end;
6797 3:
6798 begin
6799 Dest.FreeType := vtNone;
6800 if Param < PSAddrNegativeStackStart then begin
6801 if Param >= Cardinal(FGlobalVars.Count) then
6802 begin
6803 CMD_Err(erOutOfGlobalVarsRange);
6804 Result := False;
6805 exit;
6806 end;
6807 Tmp := FGlobalVars.Data[param];
6808 end
6809 else begin
6810 Param := Cardinal(Longint(-PSAddrStackStart) + Longint(FCurrStackBase) + Longint(Param));
6811 if Param >= Cardinal(FStack.Count) then
6812 begin
6813 CMD_Err(erOutOfStackRange);
6814 Result := False;
6815 exit;
6816 end;
6817 Tmp := FStack.Data[param];
6818 end;
6819 if (Tmp.FType.BaseType = btPointer) then
6820 begin
6821 Dest.aType := PPSVariantPointer(Tmp).DestType;
6822 Dest.P := PPSVariantPointer(Tmp).DataDest;
6823 if Dest.P = nil then
6824 begin
6825 Cmd_Err(erNullPointerException);
6826 Result := False;
6827 exit;
6828 end;
6829 end else
6830 begin
6831 Dest.aType := PPSVariantData(Tmp).vi.FType;
6832 Dest.P := @PPSVariantData(Tmp).Data;
6833 end;
6834 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6835 Param := unaligned(Cardinal((@FData^[FCurrentPosition])^));
6836 {$else}
6837 Param := Cardinal((@FData^[FCurrentPosition])^);
6838 {$endif}
6839 Inc(FCurrentPosition, 4);
6840 if Param < PSAddrNegativeStackStart then
6841 begin
6842 if Param >= Cardinal(FGlobalVars.Count) then
6843 begin
6844 CMD_Err(erOutOfGlobalVarsRange);
6845 Result := false;
6846 exit;
6847 end;
6848 Tmp := FGlobalVars[Param];
6849 end
6850 else begin
6851 Param := Cardinal(Longint(-PSAddrStackStart) + Longint(FCurrStackBase) + Longint(Param));
6852 if Cardinal(Param) >= Cardinal(FStack.Count) then
6853 begin
6854 CMD_Err(erOutOfStackRange);
6855 Result := false;
6856 exit;
6857 end;
6858 Tmp := FStack[Param];
6859 end;
6860 case Tmp.FType.BaseType of
6861 btu8: Param := PPSVariantU8(Tmp).Data;
6862 bts8: Param := PPSVariants8(Tmp).Data;
6863 btu16: Param := PPSVariantU16(Tmp).Data;
6864 bts16: Param := PPSVariants16(Tmp).Data;
6865 btu32: Param := PPSVariantU32(Tmp).Data;
6866 bts32: Param := PPSVariants32(Tmp).Data;
6867 btPointer:
6868 begin
6869 if PPSVariantPointer(tmp).DestType <> nil then
6870 begin
6871 case PPSVariantPointer(tmp).DestType.BaseType of
6872 btu8: Param := tbtu8(PPSVariantPointer(tmp).DataDest^);
6873 bts8: Param := tbts8(PPSVariantPointer(tmp).DataDest^);
6874 btu16: Param := tbtu16(PPSVariantPointer(tmp).DataDest^);
6875 bts16: Param := tbts16(PPSVariantPointer(tmp).DataDest^);
6876 btu32, btProcPtr: Param := tbtu32(PPSVariantPointer(tmp).DataDest^);
6877 bts32: Param := tbts32(PPSVariantPointer(tmp).DataDest^);
6878 else
6879 begin
6880 CMD_Err(ErTypeMismatch);
6881 Result := false;
6882 exit;
6883 end;
6884 end;
6885 end else
6886 begin
6887 CMD_Err(ErTypeMismatch);
6888 Result := false;
6889 exit;
6890 end;
6891 end;
6892 else
6893 CMD_Err(ErTypeMismatch);
6894 Result := false;
6895 exit;
6896 end;
6897 case Dest.aType.BaseType of
6898 btRecord:
6899 begin
6900 if Param > Cardinal(TPSTypeRec_Record(Dest.aType).FFieldTypes.Count) then
6901 begin
6902 CMD_Err(erOutOfRange);
6903 Result := False;
6904 exit;
6905 end;
6906 Dest.P := Pointer(IPointer(Dest.P) + IPointer(TPSTypeRec_Record(Dest.aType).RealFieldOffsets[Param]));
6907 Dest.aType := TPSTypeRec_Record(Dest.aType).FieldTypes[Param];
6908 end;
6909 btArray:
6910 begin
6911 if Cardinal(Param) >= Cardinal(PSDynArrayGetLength(Pointer(Dest.P^), dest.aType)) then
6912 begin
6913 CMD_Err(erOutOfRange);
6914 Result := False;
6915 exit;
6916 end;
6917 Dest.P := Pointer(IPointer(Dest.P^) + (Param * TPSTypeRec_Array(Dest.aType).FArrayType.RealSize));
6918 Dest.aType := TPSTypeRec_Array(dest.aType).ArrayType;
6919 end;
6920 btStaticArray:
6921 begin
6922 if Param >= Cardinal(TPSTypeRec_StaticArray(Dest.aType).Size) then
6923 begin
6924 CMD_Err(erOutOfRange);
6925 Result := False;
6926 exit;
6927 end;
6928 Dest.P := Pointer(IPointer(Dest.P) + (Param * TPSTypeRec_Array(Dest.aType).FArrayType.RealSize));
6929 Dest.aType := TPSTypeRec_Array(dest.aType).ArrayType;
6930 end;
6931 else
6932 CMD_Err(erInvalidType);
6933 Result := False;
6934 exit;
6935 end;
6936 if UsePointer and (Dest.aType.BaseType = btPointer) then
6937 begin
6938 Dest.aType := TPSTypeRec(Pointer(IPointer(Dest.p)+PointerSize)^);
6939 Dest.P := Pointer(Dest.p^);
6940 if Dest.P = nil then
6941 begin
6942 Cmd_Err(erNullPointerException);
6943 Result := False;
6944 exit;
6945 end;
6946 end;
6947 end;
6948 else
6949 begin
6950 Result := False;
6951 exit;
6952 end;
6953 end;
6954 Result := true;
6955 end;
6956
DoMinusnull6957 function TPSExec.DoMinus(Dta: Pointer; aType: TPSTypeRec): Boolean;
6958 begin
6959 case atype.BaseType of
6960 btU8: tbtu8(dta^) := -tbtu8(dta^);
6961 btU16: tbtu16(dta^) := -tbtu16(dta^);
6962 btU32: tbtu32(dta^) := -tbtu32(dta^);
6963 btS8: tbts8(dta^) := -tbts8(dta^);
6964 btS16: tbts16(dta^) := -tbts16(dta^);
6965 btS32: tbts32(dta^) := -tbts32(dta^);
6966 {$IFNDEF PS_NOINT64}
6967 bts64: tbts64(dta^) := -tbts64(dta^);
6968 {$ENDIF}
6969 btSingle: tbtsingle(dta^) := -tbtsingle(dta^);
6970 btDouble: tbtdouble(dta^) := -tbtdouble(dta^);
6971 btExtended: tbtextended(dta^) := -tbtextended(dta^);
6972 btCurrency: tbtcurrency(dta^) := -tbtcurrency(dta^);
6973 btVariant:
6974 begin
6975 try
6976 Variant(dta^) := - Variant(dta^);
6977 except
6978 CMD_Err(erTypeMismatch);
6979 Result := False;
6980 exit;
6981 end;
6982 end;
6983 else
6984 begin
6985 CMD_Err(erTypeMismatch);
6986 Result := False;
6987 exit;
6988 end;
6989 end;
6990 Result := True;
6991 end;
6992
TPSExec.DoBooleanNotnull6993 function TPSExec.DoBooleanNot(Dta: Pointer; aType: TPSTypeRec): Boolean;
6994 begin
6995 case aType.BaseType of
6996 btU8: tbtu8(dta^) := tbtu8(tbtu8(dta^) = 0);
6997 btU16: tbtu16(dta^) := tbtu16(tbtu16(dta^) = 0);
6998 btU32: tbtu32(dta^) := tbtu32(tbtu32(dta^) = 0);
6999 btS8: tbts8(dta^) := tbts8(tbts8(dta^) = 0);
7000 btS16: tbts16(dta^) := tbts16(tbts16(dta^) = 0);
7001 btS32: tbts32(dta^) := tbts32(tbts32(dta^) = 0);
7002 {$IFNDEF PS_NOINT64}
7003 bts64: tbts64(dta^) := tbts64(tbts64(dta^) = 0);
7004 {$ENDIF}
7005 btVariant:
7006 begin
7007 try
7008 Variant(dta^) := Variant(dta^) = 0;
7009 except
7010 CMD_Err(erTypeMismatch);
7011 Result := False;
7012 exit;
7013 end;
7014 end;
7015 else
7016 begin
7017 CMD_Err(erTypeMismatch);
7018 Result := False;
7019 exit;
7020 end;
7021 end;
7022 Result := True;
7023 end;
7024
7025
7026 procedure TPSExec.Stop;
7027 begin
7028 if FStatus = isRunning then
7029 FStatus := isLoaded
7030 else if FStatus = isPaused then begin
7031 FStatus := isLoaded;
7032 FStack.Clear;
7033 FTempVars.Clear;
7034 end;
7035 end;
7036
7037
ReadLongnull7038 function TPSExec.ReadLong(var b: Cardinal): Boolean;
7039 begin
7040 if FCurrentPosition + 3 < FDataLength then begin
7041 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
7042 b := unaligned(Cardinal((@FData^[FCurrentPosition])^));
7043 {$else}
7044 b := Cardinal((@FData^[FCurrentPosition])^);
7045 {$endif}
7046 Inc(FCurrentPosition, 4);
7047 Result := True;
7048 end
7049 else
7050 Result := False;
7051 end;
7052
TPSExec.RunProcPnull7053 function TPSExec.RunProcP(const Params: array of Variant; const Procno: Cardinal): Variant;
7054 var
7055 ParamList: TPSList;
7056 ct: PIFTypeRec;
7057 pvar: PPSVariant;
7058 res, s: tbtString;
7059 Proc: TPSInternalProcRec;
7060 i: Longint;
7061 begin
7062 if ProcNo >= FProcs.Count then raise Exception.Create(RPS_UnknownProcedure);
7063 Proc := GetProcNo(ProcNo) as TPSInternalProcRec;
7064 ParamList := TPSList.Create;
7065 try
7066 s := Proc.ExportDecl;
7067 res := grfw(s);
7068 i := High(Params);
7069 while s <> '' do
7070 begin
7071 if i < 0 then raise Exception.Create(RPS_NotEnoughParameters);
7072 ct := FTypes[StrToInt(copy(GRLW(s), 2, MaxInt))];
7073 if ct = nil then raise Exception.Create(RPS_InvalidParameter);
7074 pvar := CreateHeapVariant(ct);
7075 ParamList.Add(pvar);
7076
7077 if not VariantToPIFVariant(Self, Params[i], pvar) then raise Exception.Create(RPS_InvalidParameter);
7078
7079 Dec(i);
7080 end;
7081 if I > -1 then raise Exception.Create(RPS_TooManyParameters);
7082 if res <> '-1' then
7083 begin
7084 pvar := CreateHeapVariant(FTypes[StrToInt(res)]);
7085 ParamList.Add(pvar);
7086 end else
7087 pvar := nil;
7088
7089 RunProc(ParamList, ProcNo);
7090
7091 RaiseCurrentException;
7092
7093 if pvar <> nil then
7094 begin
7095 PIFVariantToVariant(PVar, Result);
7096 end else
7097 Result := Null;
7098 finally
7099 FreePIFVariantList(ParamList);
7100 end;
7101 end;
TPSExec.RunProcPVarnull7102 function TPSExec.RunProcPVar(var Params: array of Variant; const Procno: Cardinal): Variant;
7103 var
7104 ParamList: TPSList;
7105 ct: PIFTypeRec;
7106 pvar: PPSVariant;
7107 res, s: tbtString;
7108 Proc: TPSInternalProcRec;
7109 i: Longint;
7110 begin
7111 if ProcNo >= FProcs.Count then raise Exception.Create(RPS_UnknownProcedure);
7112 Proc := GetProcNo(ProcNo) as TPSInternalProcRec;
7113 ParamList := TPSList.Create;
7114 try
7115 s := Proc.ExportDecl;
7116 res := grfw(s);
7117 i := High(Params);
7118 while s <> '' do
7119 begin
7120 if i < 0 then raise Exception.Create(RPS_NotEnoughParameters);
7121 ct := FTypes[StrToInt(copy(GRLW(s), 2, MaxInt))];
7122 if ct = nil then raise Exception.Create(RPS_InvalidParameter);
7123 pvar := CreateHeapVariant(ct);
7124 ParamList.Add(pvar);
7125
7126 if not VariantToPIFVariant(Self, Params[i], pvar) then raise Exception.Create(RPS_InvalidParameter);
7127
7128 Dec(i);
7129 end;
7130 if I > -1 then raise Exception.Create(RPS_TooManyParameters);
7131 if res <> '-1' then
7132 begin
7133 pvar := CreateHeapVariant(FTypes[StrToInt(res)]);
7134 ParamList.Add(pvar);
7135 end else
7136 pvar := nil;
7137
7138 RunProc(ParamList, ProcNo);
7139
7140 RaiseCurrentException;
7141
7142 for i := 0 to Length(Params) - 1 do
7143 PIFVariantToVariant(ParamList[i],
7144 Params[(Length(Params) - 1) - i]);
7145
7146 if pvar <> nil then
7147 begin
7148 PIFVariantToVariant(PVar, Result);
7149 end else
7150 Result := Null;
7151 finally
7152 FreePIFVariantList(ParamList);
7153 end;
7154 end;
7155
TPSExec.RunProcPNnull7156 function TPSExec.RunProcPN(const Params: array of Variant; const ProcName: tbtString): Variant;
7157 var
7158 ProcNo: Cardinal;
7159 begin
7160 ProcNo := GetProc(ProcName);
7161 if ProcNo = InvalidVal then
7162 raise Exception.Create(RPS_UnknownProcedure);
7163 Result := RunProcP(Params, ProcNo);
7164 end;
7165
7166
TPSExec.RunProcnull7167 function TPSExec.RunProc(Params: TPSList; ProcNo: Cardinal): Boolean;
7168 var
7169 I, I2: Integer;
7170 vnew, Vd: PIfVariant;
7171 Cp: TPSInternalProcRec;
7172 oldStatus: TPSStatus;
7173 tmp: TObject;
7174 begin
7175 if FStatus <> isNotLoaded then begin
7176 if ProcNo >= FProcs.Count then begin
7177 CMD_Err(erOutOfProcRange);
7178 Result := False;
7179 exit;
7180 end;
7181 if Params <> nil then
7182 begin
7183 for I := 0 to Params.Count - 1 do
7184 begin
7185 vd := Params[I];
7186 if vd = nil then
7187 begin
7188 Result := False;
7189 exit;
7190 end;
7191 vnew := FStack.PushType(FindType2(btPointer));
7192 if vd.FType.BaseType = btPointer then
7193 begin
7194 PPSVariantPointer(vnew).DestType := PPSVariantPointer(vd).DestType;
7195 PPSVariantPointer(vnew).DataDest := PPSVariantPointer(vd).DataDest;
7196 end else begin
7197 PPSVariantPointer(vnew).DestType := vd.FType;
7198 PPSVariantPointer(vnew).DataDest := @PPSVariantData(vd).Data;
7199 end;
7200 end;
7201 end;
7202 I := FStack.Count;
7203 Cp := FCurrProc;
7204 oldStatus := FStatus;
7205 if TPSProcRec(FProcs.Data^[ProcNo]).ClassType <> TPSExternalProcRec then
7206 begin
7207 vd := FStack.PushType(FReturnAddressType);
7208 PPSVariantReturnAddress(vd).Addr.ProcNo := nil;
7209 PPSVariantReturnAddress(vd).Addr.Position := FCurrentPosition;
7210 PPSVariantReturnAddress(vd).Addr.StackBase := FCurrStackBase;
7211 FCurrStackBase := FStack.Count - 1;
7212 FCurrProc := FProcs.Data^[ProcNo];
7213 FData := FCurrProc.Data;
7214 FDataLength := FCurrProc.Length;
7215 FCurrentPosition := 0;
7216 FStatus := isPaused;
7217 Result := RunScript;
7218 end else
7219 begin
7220 try
7221 Result := TPSExternalProcRec(FProcs.Data^[ProcNo]).ProcPtr(Self, TPSExternalProcRec(FProcs.Data^[ProcNo]), FGlobalVars, FStack);
7222 if not Result then
7223 begin
7224 if ExEx = erNoError then
7225 CMD_Err(erCouldNotCallProc);
7226 end;
7227 except
7228 {$IFDEF DELPHI6UP}
7229 Tmp := AcquireExceptionObject;
7230 {$ELSE}
7231 if RaiseList <> nil then
7232 begin
7233 Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
7234 PRaiseFrame(RaiseList)^.ExceptObject := nil;
7235 end else
7236 Tmp := nil;
7237 {$ENDIF}
7238 if Tmp <> nil then
7239 begin
7240 if Tmp is EPSException then
7241 begin
7242 Result := False;
7243 ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, tbtString(EPSException(tmp).Message), nil);
7244 exit;
7245 end else
7246 if Tmp is EDivByZero then
7247 begin
7248 Result := False;
7249 CMD_Err3(erDivideByZero, tbtString(Exception(Tmp).Message), Tmp);
7250 Exit;
7251 end;
7252 if Tmp is EZeroDivide then
7253 begin
7254 Result := False;
7255 CMD_Err3(erDivideByZero, tbtString(Exception(Tmp).Message), Tmp);
7256 Exit;
7257 end;
7258 if Tmp is EMathError then
7259 begin
7260 Result := False;
7261 CMD_Err3(erMathError, tbtString(Exception(Tmp).Message), Tmp);
7262 Exit;
7263 end;
7264 end;
7265 if (Tmp <> nil) and (Tmp is Exception) then
7266 CMD_Err3(erException, tbtString(Exception(Tmp).Message), Tmp) else
7267 CMD_Err3(erException, '', Tmp);
7268 Result := false;
7269 exit;
7270 end;
7271 end;
7272 if Cardinal(FStack.Count) > Cardinal(I) then
7273 begin
7274 vd := FStack[I];
7275 if (vd <> nil) and (vd.FType = FReturnAddressType) then
7276 begin
7277 for i2 := FStack.Count - 1 downto I + 1 do
7278 FStack.Pop;
7279 FCurrentPosition := PPSVariantReturnAddress(vd).Addr.Position;
7280 FCurrStackBase := PPSVariantReturnAddress(vd).Addr.StackBase;
7281 FStack.Pop;
7282 end;
7283 end;
7284 if Params <> nil then
7285 begin
7286 for I := Params.Count - 1 downto 0 do
7287 begin
7288 if FStack.Count = 0 then
7289 Break
7290 else
7291 FStack.Pop;
7292 end;
7293 end;
7294 FStatus := oldStatus;
7295 FCurrProc := Cp;
7296 if FCurrProc <> nil then
7297 begin
7298 FData := FCurrProc.Data;
7299 FDataLength := FCurrProc.Length;
7300 end;
7301 end else begin
7302 Result := False;
7303 end;
7304 end;
7305
7306
FindType2null7307 function TPSExec.FindType2(BaseType: TPSBaseType): PIFTypeRec;
7308 var
7309 l: Cardinal;
7310 begin
7311 FindType2 := FindType(0, BaseType, l);
7312
7313 end;
7314
TPSExec.FindTypenull7315 function TPSExec.FindType(StartAt: Cardinal; BaseType: TPSBaseType; var l: Cardinal): PIFTypeRec;
7316 var
7317 I: Integer;
7318 n: PIFTypeRec;
7319 begin
7320 for I := StartAt to FTypes.Count - 1 do begin
7321 n := FTypes[I];
7322 if n.BaseType = BaseType then begin
7323 l := I;
7324 Result := n;
7325 exit;
7326 end;
7327 end;
7328 Result := nil;
7329 end;
7330
TPSExec.GetTypeNonull7331 function TPSExec.GetTypeNo(l: Cardinal): PIFTypeRec;
7332 begin
7333 Result := FTypes[l];
7334 end;
7335
GetProcnull7336 function TPSExec.GetProc(const Name: tbtString): Cardinal;
7337 var
7338 MM,
7339 I: Longint;
7340 n: PIFProcRec;
7341 s: tbtString;
7342 begin
7343 s := FastUpperCase(name);
7344 MM := MakeHash(s);
7345 for I := FProcs.Count - 1 downto 0 do begin
7346 n := FProcs.Data^[I];
7347 if (n.ClassType = TPSInternalProcRec) and (TPSInternalProcRec(n).ExportNameHash = MM) and (TPSInternalProcRec(n).ExportName = s) then begin
7348 Result := I;
7349 exit;
7350 end else if (n.ClassType = TPSExternalProcRec) and (TPSExternalProcRec(n).Name = s) then
7351 begin
7352 Result := I;
7353 exit;
7354 end;
7355 end;
7356 Result := InvalidVal;
7357 end;
7358
TPSExec.GetTypenull7359 function TPSExec.GetType(const Name: tbtString): Cardinal;
7360 var
7361 MM,
7362 I: Longint;
7363 n: PIFTypeRec;
7364 s: tbtString;
7365 begin
7366 s := FastUpperCase(name);
7367 MM := MakeHash(s);
7368 for I := 0 to FTypes.Count - 1 do begin
7369 n := FTypes.Data^[I];
7370 if (Length(n.ExportName) <> 0) and (n.ExportNameHash = MM) and (n.ExportName = s) then begin
7371 Result := I;
7372 exit;
7373 end;
7374 end;
7375 Result := InvalidVal;
7376 end;
7377
7378
7379 procedure TPSExec.AddResource(Proc, P: Pointer);
7380 var
7381 Temp: PPSResource;
7382 begin
7383 New(Temp);
7384 Temp^.Proc := Proc;
7385 Temp^.P := p;
7386 FResources.Add(temp);
7387 end;
7388
7389 procedure TPSExec.DeleteResource(P: Pointer);
7390 var
7391 i: Longint;
7392 begin
7393 for i := Longint(FResources.Count) -1 downto 0 do
7394 begin
7395 if PPSResource(FResources[I])^.P = P then
7396 begin
7397 FResources.Delete(I);
7398 exit;
7399 end;
7400 end;
7401 end;
7402
FindProcResourcenull7403 function TPSExec.FindProcResource(Proc: Pointer): Pointer;
7404 var
7405 I: Longint;
7406 temp: PPSResource;
7407 begin
7408 for i := Longint(FResources.Count) -1 downto 0 do
7409 begin
7410 temp := FResources[I];
7411 if temp^.Proc = proc then
7412 begin
7413 Result := Temp^.P;
7414 exit;
7415 end;
7416 end;
7417 Result := nil;
7418 end;
7419
IsValidResourcenull7420 function TPSExec.IsValidResource(Proc, P: Pointer): Boolean;
7421 var
7422 i: Longint;
7423 temp: PPSResource;
7424 begin
7425 for i := 0 to Longint(FResources.Count) -1 do
7426 begin
7427 temp := FResources[i];
7428 if temp^.p = p then begin
7429 result := temp^.Proc = Proc;
7430 exit;
7431 end;
7432 end;
7433 result := false;
7434 end;
7435
TPSExec.FindProcResource2null7436 function TPSExec.FindProcResource2(Proc: Pointer;
7437 var StartAt: Longint): Pointer;
7438 var
7439 I: Longint;
7440 temp: PPSResource;
7441 begin
7442 if StartAt > longint(FResources.Count) -1 then
7443 StartAt := longint(FResources.Count) -1;
7444 for i := StartAt downto 0 do
7445 begin
7446 temp := FResources[I];
7447 if temp^.Proc = proc then
7448 begin
7449 Result := Temp^.P;
7450 StartAt := i -1;
7451 exit;
7452 end;
7453 end;
7454 StartAt := -1;
7455 Result := nil;
7456 end;
7457
7458 procedure TPSExec.RunLine;
7459 begin
7460 if @FOnRunLine <> nil then
7461 FOnRunLine(Self);
7462 end;
7463
7464 procedure TPSExec.CMD_Err3(EC: TPSError; const Param: tbtString; ExObject: TObject);
7465 var
7466 l: Longint;
7467 C: Cardinal;
7468 begin
7469 C := InvalidVal;
7470 for l := FProcs.Count - 1 downto 0 do begin
7471 if FProcs.Data^[l] = FCurrProc then begin
7472 C := l;
7473 break;
7474 end;
7475 end;
7476 if @FOnException <> nil then
7477 FOnException(Self, Ec, Param, ExObject, C, FCurrentPosition);
7478 ExceptionProc(C, FCurrentPosition, EC, Param, ExObject);
7479 end;
7480
7481 procedure TPSExec.AddSpecialProcImport(const FName: tbtString;
7482 P: TPSOnSpecialProcImport; Tag: Pointer);
7483 var
7484 N: PSpecialProc;
7485 begin
7486 New(n);
7487 n^.P := P;
7488 N^.Name := FName;
7489 n^.namehash := MakeHash(N^.Name);
7490 n^.Tag := Tag;
7491 FSpecialProcList.Add(n);
7492 end;
7493
TPSExec.GetVarnull7494 function TPSExec.GetVar(const Name: tbtString): Cardinal;
7495 var
7496 l: Longint;
7497 h: longint;
7498 s: tbtString;
7499 p: PPSExportedVar;
7500 begin
7501 s := FastUpperCase(name);
7502 h := MakeHash(s);
7503 for l := FExportedVars.Count - 1 downto 0 do
7504 begin
7505 p := FexportedVars.Data^[L];
7506 if (p^.FNameHash = h) and(p^.FName=s) then
7507 begin
7508 Result := L;
7509 exit;
7510 end;
7511 end;
7512 Result := InvalidVal;
7513 end;
7514
GetVarNonull7515 function TPSExec.GetVarNo(C: Cardinal): PIFVariant;
7516 begin
7517 Result := FGlobalVars[c];
7518 end;
7519
GetVar2null7520 function TPSExec.GetVar2(const Name: tbtString): PIFVariant;
7521 begin
7522 Result := GetVarNo(GetVar(Name));
7523 end;
7524
TPSExec.GetProcNonull7525 function TPSExec.GetProcNo(C: Cardinal): PIFProcRec;
7526 begin
7527 Result := FProcs[c];
7528 end;
7529
TPSExec.DoIntegerNotnull7530 function TPSExec.DoIntegerNot(Dta: Pointer; aType: TPSTypeRec): Boolean;
7531 begin
7532 case aType.BaseType of
7533 btU8: tbtu8(dta^) := not tbtu8(dta^);
7534 btU16: tbtu16(dta^) := not tbtu16(dta^);
7535 btU32: tbtu32(dta^) := not tbtu32(dta^);
7536 btS8: tbts8(dta^) := not tbts8(dta^);
7537 btS16: tbts16(dta^) := not tbts16(dta^);
7538 btS32: tbts32(dta^) := not tbts32(dta^);
7539 {$IFNDEF PS_NOINT64}
7540 bts64: tbts64(dta^) := not tbts64(dta^);
7541 {$ENDIF}
7542 btVariant:
7543 begin
7544 try
7545 Variant(dta^) := not Variant(dta^);
7546 except
7547 CMD_Err(erTypeMismatch);
7548 Result := False;
7549 exit;
7550 end;
7551 end;
7552 else
7553 begin
7554 CMD_Err(erTypeMismatch);
7555 Result := False;
7556 exit;
7557 end;
7558 end;
7559 Result := True;
7560 end;
7561
7562 type
7563 TMyRunLine = procedure(Self: TPSExec);
7564 TPSRunLine = procedure of object;
7565
GetRunLinenull7566 function GetRunLine(FOnRunLine: TPSOnLineEvent; meth: TPSRunLine): TMyRunLine;
7567 begin
7568 if (TMethod(Meth).Code = @TPSExec.RunLine) and (@FOnRunLine = nil) then
7569 Result := nil
7570 else
7571 Result := TMethod(Meth).Code;
7572 end;
7573
RunScriptnull7574 function TPSExec.RunScript: Boolean;
7575 var
7576 CalcType: Cardinal;
7577 vd, vs, v3: TPSResultData;
7578 vtemp: PIFVariant;
7579 p: Cardinal;
7580 P2: Longint;
7581 u: PIFProcRec;
7582 Cmd: Cardinal;
7583 I: Longint;
7584 pp: TPSExceptionHandler;
7585 FExitPoint: Cardinal;
7586 FOldStatus: TPSStatus;
7587 Tmp: TObject;
7588 btemp: Boolean;
7589 CallRunline: TMyRunLine;
7590 begin
7591 FExitPoint := InvalidVal;
7592 if FStatus = isLoaded then
7593 begin
7594 for i := FExceptionStack.Count -1 downto 0 do
7595 begin
7596 pp := FExceptionStack.Data[i];
7597 pp.Free;
7598 end;
7599 FExceptionStack.Clear;
7600 end;
7601 ExceptionProc(InvalidVal, InvalidVal, erNoError, '', nil);
7602 RunScript := True;
7603 FOldStatus := FStatus;
7604 case FStatus of
7605 isLoaded: begin
7606 if FMainProc = InvalidVal then
7607 begin
7608 RunScript := False;
7609 exit;
7610 end;
7611 FStatus := isRunning;
7612 FCurrProc := FProcs.Data^[FMainProc];
7613 if FCurrProc.ClassType = TPSExternalProcRec then begin
7614 CMD_Err(erNoMainProc);
7615 FStatus := isLoaded;
7616 exit;
7617 end;
7618 FData := FCurrProc.Data;
7619 FDataLength := FCurrProc.Length;
7620 FCurrStackBase := InvalidVal;
7621 FCurrentPosition := 0;
7622 end;
7623 isPaused: begin
7624 FStatus := isRunning;
7625 end;
7626 else begin
7627 RunScript := False;
7628 exit;
7629 end;
7630 end;
7631 CallRunLine := GetRunLine(FOnRunLine, Self.RunLine);
7632 repeat
7633 FStatus := isRunning;
7634 // Cmd := InvalidVal;
7635 while FStatus = isRunning do
7636 begin
7637 if @CallRunLine <> nil then CallRunLine(Self);
7638 if FCurrentPosition >= FDataLength then
7639 begin
7640 CMD_Err(erOutOfRange); // Error
7641 break;
7642 end;
7643 // if cmd <> invalidval then ProfilerExitProc(Cmd+1);
7644 cmd := FData^[FCurrentPosition];
7645 // ProfilerEnterProc(Cmd+1);
7646 Inc(FCurrentPosition);
7647 case Cmd of
7648 CM_A:
7649 begin
7650 if not ReadVariable(vd, True) then
7651 break;
7652 if vd.FreeType <> vtNone then
7653 begin
7654 if vd.aType.BaseType in NeedFinalization then
7655 FinalizeVariant(vd.P, vd.aType);
7656 p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
7657 Dec(FTempVars.FCount);
7658 {$IFNDEF PS_NOSMARTLIST}
7659 Inc(FTempVars.FCheckCount);
7660 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
7661 {$ENDIF}
7662 FTempVars.FLength := P;
7663 if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
7664
7665 CMD_Err(erInvalidOpcodeParameter);
7666 break;
7667 end;
7668 if not ReadVariable(vs, True) then
7669 Break;
7670 // nx change end
7671 { if (vd.aType.BaseType = btClass) and (vs.aType.BaseType in [btS32]) then
7672 DWord(vd.P^):=Dword(vs.P^)
7673 else
7674 if (vd.aType.BaseType in [btS32]) and (vs.aType.BaseType = btClass) then
7675 DWord(vd.P^):=Dword(vs.P^)
7676 else}
7677 // nx change start
7678 if not SetVariantValue(vd.P, vs.P, vd.aType, vs.aType) then
7679 begin
7680 if vs.FreeType <> vtNone then
7681 begin
7682 if vs.aType.BaseType in NeedFinalization then
7683 FinalizeVariant(vs.P, vs.aType);
7684 p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
7685 Dec(FTempVars.FCount);
7686 {$IFNDEF PS_NOSMARTLIST}
7687 Inc(FTempVars.FCheckCount);
7688 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
7689 {$ENDIF}
7690 FTempVars.FLength := P;
7691 if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
7692 end;
7693 Break;
7694 end;
7695 if vs.FreeType <> vtNone then
7696 begin
7697 if vs.aType.BaseType in NeedFinalization then
7698 FinalizeVariant(vs.P, vs.aType);
7699 p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
7700 Dec(FTempVars.FCount);
7701 {$IFNDEF PS_NOSMARTLIST}
7702 Inc(FTempVars.FCheckCount);
7703 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
7704 {$ENDIF}
7705 FTempVars.FLength := P;
7706 if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
7707 end;
7708 end;
7709 CM_CA:
7710 begin
7711 if FCurrentPosition >= FDataLength then
7712 begin
7713 CMD_Err(erOutOfRange); // Error
7714 break;
7715 end;
7716 calctype := FData^[FCurrentPosition];
7717 Inc(FCurrentPosition);
7718 if not ReadVariable(vd, True) then
7719 break;
7720 if vd.FreeType <> vtNone then
7721 begin
7722 if vd.aType.BaseType in NeedFinalization then
7723 FinalizeVariant(vd.P, vd.aType);
7724 p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
7725 Dec(FTempVars.FCount);
7726 {$IFNDEF PS_NOSMARTLIST}
7727 Inc(FTempVars.FCheckCount);
7728 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
7729 {$ENDIF}
7730 FTempVars.FLength := P;
7731 if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
7732 CMD_Err(erInvalidOpcodeParameter);
7733 break;
7734 end;
7735 if not ReadVariable(vs, True) then
7736 Break;
7737 if not DoCalc(vd.P, vs.p, vd.aType, vs.aType, CalcType) then
7738 begin
7739 if vs.FreeType <> vtNone then
7740 begin
7741 if vs.aType.BaseType in NeedFinalization then
7742 FinalizeVariant(vs.P, vs.aType);
7743 p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
7744 Dec(FTempVars.FCount);
7745 {$IFNDEF PS_NOSMARTLIST}
7746 Inc(FTempVars.FCheckCount);
7747 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
7748 {$ENDIF}
7749 FTempVars.FLength := P;
7750 if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
7751 end;
7752 Break;
7753 end;
7754 if vs.FreeType <> vtNone then
7755 begin
7756 if vs.aType.BaseType in NeedFinalization then
7757 FinalizeVariant(vs.P, vs.aType);
7758 p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
7759 Dec(FTempVars.FCount);
7760 {$IFNDEF PS_NOSMARTLIST}
7761 Inc(FTempVars.FCheckCount);
7762 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
7763 {$ENDIF}
7764 FTempVars.FLength := P;
7765 if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
7766 end;
7767 end;
7768 CM_P:
7769 begin
7770 if not ReadVariable(vs, True) then
7771 Break;
7772 vtemp := FStack.PushType(vs.aType);
7773 vd.P := Pointer(IPointer(vtemp)+PointerSize);
7774 vd.aType := Pointer(vtemp^);
7775 vd.FreeType := vtNone;
7776 if not SetVariantValue(Vd.P, vs.P, vd.aType, vs.aType) then
7777 begin
7778 if vs.FreeType <> vtnone then
7779 begin
7780 if vs.aType.BaseType in NeedFinalization then
7781 FinalizeVariant(vs.P, vs.aType);
7782 p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
7783 Dec(FTempVars.FCount);
7784 {$IFNDEF PS_NOSMARTLIST}
7785 Inc(FTempVars.FCheckCount);
7786 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
7787 {$ENDIF}
7788 FTempVars.FLength := P;
7789 if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
7790 end;
7791 break;
7792 end;
7793 if vs.FreeType <> vtnone then
7794 begin
7795 if vs.aType.BaseType in NeedFinalization then
7796 FinalizeVariant(vs.P, vs.aType);
7797 p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
7798 Dec(FTempVars.FCount);
7799 {$IFNDEF PS_NOSMARTLIST}
7800 Inc(FTempVars.FCheckCount);
7801 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
7802 {$ENDIF}
7803 FTempVars.FLength := P;
7804 if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
7805 end;
7806 end;
7807 CM_PV:
7808 begin
7809 if not ReadVariable(vs, True) then
7810 Break;
7811 if vs.FreeType <> vtnone then
7812 begin
7813 FTempVars.Pop;
7814 CMD_Err(erInvalidOpcodeParameter);
7815 break;
7816 end;
7817 vtemp := FStack.PushType(FindType2(btPointer));
7818 if vs.aType.BaseType = btPointer then
7819 begin
7820 PPSVariantPointer(vtemp).DataDest := Pointer(vs.p^);
7821 PPSVariantPointer(vtemp).DestType := Pointer(Pointer(IPointer(vs.P)+PointerSize)^);
7822 PPSVariantPointer(vtemp).FreeIt := False;
7823 end
7824 else
7825 begin
7826 PPSVariantPointer(vtemp).DataDest := vs.p;
7827 PPSVariantPointer(vtemp).DestType := vs.aType;
7828 PPSVariantPointer(vtemp).FreeIt := False;
7829 end;
7830 end;
7831 CM_PO: begin
7832 if FStack.Count = 0 then
7833 begin
7834 CMD_Err(erOutOfStackRange);
7835 break;
7836 end;
7837 vtemp := FStack.Data^[FStack.Count -1];
7838 if (vtemp = nil) or (vtemp.FType.BaseType = btReturnAddress) then
7839 begin
7840 CMD_Err(erOutOfStackRange);
7841 break;
7842 end;
7843 FStack.Pop;
7844 (* Dec(FStack.FCount);
7845 {$IFNDEF PS_NOSMARTLIST}
7846 Inc(FStack.FCheckCount);
7847 if FStack.FCheckCount > FMaxCheckCount then FStack.Recreate;
7848 {$ENDIF}
7849 FStack.FLength := Longint(IPointer(vtemp) - IPointer(FStack.DataPtr));
7850 if TPSTypeRec(vtemp^).BaseType in NeedFinalization then
7851 FinalizeVariant(Pointer(IPointer(vtemp)+PointerSize), Pointer(vtemp^));
7852 if ((FStack.FCapacity - FStack.FLength) shr 12) > 2 then FStack.AdjustLength;*)
7853 end;
7854 Cm_C: begin
7855 if FCurrentPosition + 3 >= FDataLength then
7856 begin
7857 Cmd_Err(erOutOfRange);
7858 Break;
7859 end;
7860 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
7861 p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
7862 {$else}
7863 p := Cardinal((@FData^[FCurrentPosition])^);
7864 {$endif}
7865 Inc(FCurrentPosition, 4);
7866 if p >= FProcs.Count then begin
7867 CMD_Err(erOutOfProcRange);
7868 break;
7869 end;
7870 u := FProcs.Data^[p];
7871 if u.ClassType = TPSExternalProcRec then begin
7872 try
7873 if not TPSExternalProcRec(u).ProcPtr(Self, TPSExternalProcRec(u), FGlobalVars, FStack) then begin
7874 if ExEx = erNoError then
7875 CMD_Err(erCouldNotCallProc);
7876 Break;
7877 end;
7878 except
7879 {$IFDEF DELPHI6UP}
7880 Tmp := AcquireExceptionObject;
7881 {$ELSE}
7882 if RaiseList <> nil then
7883 begin
7884 Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
7885 PRaiseFrame(RaiseList)^.ExceptObject := nil;
7886 end else
7887 Tmp := nil;
7888 {$ENDIF}
7889 if Tmp <> nil then
7890 begin
7891 if Tmp is EPSException then
7892 begin
7893 ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, tbtString(EPSException(tmp).Message), nil);
7894 Break;
7895 end else
7896 if Tmp is EDivByZero then
7897 begin
7898 CMD_Err3(erDivideByZero, tbtString(Exception(Tmp).Message), Tmp);
7899 Break;
7900 end;
7901 if Tmp is EZeroDivide then
7902 begin
7903 CMD_Err3(erDivideByZero, tbtString(Exception(Tmp).Message), Tmp);
7904 Break;
7905 end;
7906 if Tmp is EMathError then
7907 begin
7908 CMD_Err3(erMathError, tbtString(Exception(Tmp).Message), Tmp);
7909 Break;
7910 end;
7911 end;
7912 if (Tmp <> nil) and (Tmp is Exception) then
7913 CMD_Err3(erException, tbtString(Exception(Tmp).Message), Tmp) else
7914 CMD_Err3(erException, '', Tmp);
7915 Break;
7916 end;
7917 end
7918 else begin
7919 Vtemp := Fstack.PushType(FReturnAddressType);
7920 vd.P := Pointer(IPointer(VTemp)+PointerSize);
7921 vd.aType := pointer(vtemp^);
7922 vd.FreeType := vtNone;
7923 PPSVariantReturnAddress(vtemp).Addr.ProcNo := FCurrProc;
7924 PPSVariantReturnAddress(vtemp).Addr.Position := FCurrentPosition;
7925 PPSVariantReturnAddress(vtemp).Addr.StackBase := FCurrStackBase;
7926
7927 FCurrStackBase := FStack.Count - 1;
7928 FCurrProc := TPSInternalProcRec(u);
7929 FData := FCurrProc.Data;
7930 FDataLength := FCurrProc.Length;
7931 FCurrentPosition := 0;
7932 end;
7933 end;
7934 CM_PG:
7935 begin
7936 FStack.Pop;
7937 if FCurrentPosition + 3 >= FDataLength then
7938 begin
7939 Cmd_Err(erOutOfRange);
7940 Break;
7941 end;
7942 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
7943 p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
7944 {$else}
7945 p := Cardinal((@FData^[FCurrentPosition])^);
7946 {$endif}
7947 Inc(FCurrentPosition, 4);
7948 FCurrentPosition := FCurrentPosition + p;
7949 end;
7950 CM_P2G:
7951 begin
7952 FStack.Pop;
7953 FStack.Pop;
7954 if FCurrentPosition + 3 >= FDataLength then
7955 begin
7956 Cmd_Err(erOutOfRange);
7957 Break;
7958 end;
7959 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
7960 p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
7961 {$else}
7962 p := Cardinal((@FData^[FCurrentPosition])^);
7963 {$endif}
7964 Inc(FCurrentPosition, 4);
7965 FCurrentPosition := FCurrentPosition + p;
7966 end;
7967 Cm_G:
7968 begin
7969 if FCurrentPosition + 3 >= FDataLength then
7970 begin
7971 Cmd_Err(erOutOfRange);
7972 Break;
7973 end;
7974 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
7975 p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
7976 {$else}
7977 p := Cardinal((@FData^[FCurrentPosition])^);
7978 {$endif}
7979 Inc(FCurrentPosition, 4);
7980 FCurrentPosition := FCurrentPosition + p;
7981 end;
7982 Cm_CG:
7983 begin
7984 if FCurrentPosition + 3 >= FDataLength then
7985 begin
7986 Cmd_Err(erOutOfRange);
7987 Break;
7988 end;
7989 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
7990 p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
7991 {$else}
7992 p := Cardinal((@FData^[FCurrentPosition])^);
7993 {$endif}
7994 Inc(FCurrentPosition, 4);
7995 btemp := true;
7996 if not ReadVariable(vs, btemp) then
7997 Break;
7998 case Vs.aType.BaseType of
7999 btU8: btemp := tbtu8(vs.p^) <> 0;
8000 btS8: btemp := tbts8(vs.p^) <> 0;
8001 btU16: btemp := tbtu16(vs.p^) <> 0;
8002 btS16: btemp := tbts16(vs.p^) <> 0;
8003 btU32: btemp := tbtu32(vs.p^) <> 0;
8004 btS32: btemp := tbts32(vs.p^) <> 0;
8005 else begin
8006 CMD_Err(erInvalidType);
8007 if vs.FreeType <> vtNone then
8008 FTempVars.Pop;
8009 break;
8010 end;
8011 end;
8012 if vs.FreeType <> vtNone then
8013 FTempVars.Pop;
8014 if btemp then
8015 FCurrentPosition := FCurrentPosition + p;
8016 end;
8017 Cm_CNG:
8018 begin
8019 if FCurrentPosition + 3 >= FDataLength then
8020 begin
8021 Cmd_Err(erOutOfRange);
8022 Break;
8023 end;
8024 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
8025 p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
8026 {$else}
8027 p := Cardinal((@FData^[FCurrentPosition])^);
8028 {$endif}
8029 Inc(FCurrentPosition, 4);
8030 btemp := true;
8031 if not ReadVariable(vs, BTemp) then
8032 Break;
8033 case Vs.aType.BaseType of
8034 btU8: btemp := tbtu8(vs.p^) = 0;
8035 btS8: btemp := tbts8(vs.p^) = 0;
8036 btU16: btemp := tbtu16(vs.p^) = 0;
8037 btS16: btemp := tbts16(vs.p^) = 0;
8038 btU32: btemp := tbtu32(vs.p^) = 0;
8039 btS32: btemp := tbts32(vs.p^) = 0;
8040 else begin
8041 CMD_Err(erInvalidType);
8042 if vs.FreeType <> vtNone then
8043 FTempVars.Pop;
8044 break;
8045 end;
8046 end;
8047 if vs.FreeType <> vtNone then
8048 FTempVars.Pop;
8049 if btemp then
8050 FCurrentPosition := FCurrentPosition + p;
8051 end;
8052 Cm_R: begin
8053 FExitPoint := FCurrentPosition -1;
8054 P2 := 0;
8055 if FExceptionStack.Count > 0 then
8056 begin
8057 pp := FExceptionStack.Data[FExceptionStack.Count -1];
8058 while (pp.BasePtr = FCurrStackBase) or ((pp.BasePtr > FCurrStackBase) and (pp.BasePtr <> InvalidVal)) do
8059 begin
8060 if pp.StackSize < Cardinal(FStack.Count) then
8061 begin
8062 for p := Longint(FStack.count) -1 downto Longint(pp.StackSize) do
8063 FStack.Pop
8064 end;
8065 FCurrStackBase := pp.BasePtr;
8066 if pp.FinallyOffset <> InvalidVal then
8067 begin
8068 FCurrentPosition := pp.FinallyOffset;
8069 pp.FinallyOffset := InvalidVal;
8070 p2 := 1;
8071 break;
8072 end else if pp.Finally2Offset <> InvalidVal then
8073 begin
8074 FCurrentPosition := pp.Finally2Offset;
8075 pp.Finally2Offset := InvalidVal;
8076 p2 := 1;
8077 break;
8078 end else
8079 begin
8080 pp.Free;
8081 FExceptionStack.DeleteLast;
8082 if FExceptionStack.Count = 0 then break;
8083 pp := FExceptionStack.Data[FExceptionStack.Count -1];
8084 end;
8085 end;
8086 end;
8087 if p2 = 0 then
8088 begin
8089 FExitPoint := InvalidVal;
8090 if FCurrStackBase = InvalidVal then
8091 begin
8092 FStatus := FOldStatus;
8093 break;
8094 end;
8095 for P2 := FStack.Count - 1 downto FCurrStackBase + 1 do
8096 FStack.Pop;
8097 if FCurrStackBase >= FStack.Count then
8098 begin
8099 FStatus := FOldStatus;
8100 break;
8101 end;
8102 vtemp := FStack.Data[FCurrStackBase];
8103 FCurrProc := PPSVariantReturnAddress(vtemp).Addr.ProcNo;
8104 FCurrentPosition := PPSVariantReturnAddress(vtemp).Addr.Position;
8105 FCurrStackBase := PPSVariantReturnAddress(vtemp).Addr.StackBase;
8106 FStack.Pop;
8107 if FCurrProc = nil then begin
8108 FStatus := FOldStatus;
8109 break;
8110 end;
8111 FData := FCurrProc.Data;
8112 FDataLength := FCurrProc.Length;
8113 end;
8114 end;
8115 Cm_Pt: begin
8116 if FCurrentPosition + 3 >= FDataLength then
8117 begin
8118 Cmd_Err(erOutOfRange);
8119 Break;
8120 end;
8121 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
8122 p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
8123 {$else}
8124 p := Cardinal((@FData^[FCurrentPosition])^);
8125 {$endif}
8126 Inc(FCurrentPosition, 4);
8127 if p > FTypes.Count then
8128 begin
8129 CMD_Err(erInvalidType);
8130 break;
8131 end;
8132 FStack.PushType(FTypes.Data^[p]);
8133 end;
8134 cm_bn:
8135 begin
8136 if not ReadVariable(vd, True) then
8137 Break;
8138 if vd.FreeType <> vtNone then
8139 FTempVars.Pop;
8140 if not DoBooleanNot(Vd.P, vd.aType) then
8141 break;
8142 end;
8143 cm_in:
8144 begin
8145 if not ReadVariable(vd, True) then
8146 Break;
8147 if vd.FreeType <> vtNone then
8148 FTempVars.Pop;
8149 if not DoIntegerNot(Vd.P, vd.aType) then
8150 break;
8151 end;
8152 cm_vm:
8153 begin
8154 if not ReadVariable(vd, True) then
8155 Break;
8156 if vd.FreeType <> vtNone then
8157 FTempVars.Pop;
8158 if not DoMinus(Vd.P, vd.aType) then
8159 break;
8160 end;
8161 cm_sf:
8162 begin
8163 if not ReadVariable(vd, True) then
8164 Break;
8165 if FCurrentPosition >= FDataLength then
8166 begin
8167 CMD_Err(erOutOfRange); // Error
8168 if vd.FreeType <> vtNone then
8169 FTempVars.Pop;
8170 break;
8171 end;
8172 p := FData^[FCurrentPosition];
8173 Inc(FCurrentPosition);
8174 case Vd.aType.BaseType of
8175 btU8: FJumpFlag := tbtu8(Vd.p^) <> 0;
8176 btS8: FJumpFlag := tbts8(Vd.p^) <> 0;
8177 btU16: FJumpFlag := tbtu16(Vd.p^) <> 0;
8178 btS16: FJumpFlag := tbts16(Vd.p^) <> 0;
8179 btU32: FJumpFlag := tbtu32(Vd.p^) <> 0;
8180 btS32: FJumpFlag := tbts32(Vd.p^) <> 0;
8181 else begin
8182 CMD_Err(erInvalidType);
8183 if vd.FreeType <> vtNone then
8184 FTempVars.Pop;
8185 break;
8186 end;
8187 end;
8188 if p <> 0 then
8189 FJumpFlag := not FJumpFlag;
8190 if vd.FreeType <> vtNone then
8191 FTempVars.Pop;
8192 end;
8193 cm_fg:
8194 begin
8195 if FCurrentPosition + 3 >= FDataLength then
8196 begin
8197 Cmd_Err(erOutOfRange);
8198 Break;
8199 end;
8200 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
8201 p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
8202 {$else}
8203 p := Cardinal((@FData^[FCurrentPosition])^);
8204 {$endif}
8205 Inc(FCurrentPosition, 4);
8206 if FJumpFlag then
8207 FCurrentPosition := FCurrentPosition + p;
8208 end;
8209 cm_puexh:
8210 begin
8211 pp := TPSExceptionHandler.Create;
8212 pp.CurrProc := FCurrProc;
8213 pp.BasePtr :=FCurrStackBase;
8214 pp.StackSize := FStack.Count;
8215 if not ReadLong(pp.FinallyOffset) then begin
8216 CMD_Err(erOutOfRange);
8217 pp.Free;
8218 Break;
8219 end;
8220 if not ReadLong(pp.ExceptOffset) then begin
8221 CMD_Err(erOutOfRange);
8222 pp.Free;
8223 Break;
8224 end;
8225 if not ReadLong(pp.Finally2Offset) then begin
8226 CMD_Err(erOutOfRange);
8227 pp.Free;
8228 Break;
8229 end;
8230 if not ReadLong(pp.EndOfBlock) then begin
8231 CMD_Err(erOutOfRange);
8232 pp.Free;
8233 Break;
8234 end;
8235 if pp.FinallyOffset <> InvalidVal then
8236 pp.FinallyOffset := pp.FinallyOffset + FCurrentPosition;
8237 if pp.ExceptOffset <> InvalidVal then
8238 pp.ExceptOffset := pp.ExceptOffset + FCurrentPosition;
8239 if pp.Finally2Offset <> InvalidVal then
8240 pp.Finally2Offset := pp.Finally2Offset + FCurrentPosition;
8241 if pp.EndOfBlock <> InvalidVal then
8242 pp.EndOfBlock := pp.EndOfBlock + FCurrentPosition;
8243 if ((pp.FinallyOffset <> InvalidVal) and (pp.FinallyOffset >= FDataLength)) or
8244 ((pp.ExceptOffset <> InvalidVal) and (pp.ExceptOffset >= FDataLength)) or
8245 ((pp.Finally2Offset <> InvalidVal) and (pp.Finally2Offset >= FDataLength)) or
8246 ((pp.EndOfBlock <> InvalidVal) and (pp.EndOfBlock >= FDataLength)) then
8247 begin
8248 CMD_Err(ErOutOfRange);
8249 pp.Free;
8250 Break;
8251 end;
8252 FExceptionStack.Add(pp);
8253 end;
8254 cm_poexh:
8255 begin
8256 if FCurrentPosition >= FDataLength then
8257 begin
8258 CMD_Err(erOutOfRange); // Error
8259 break;
8260 end;
8261 p := FData^[FCurrentPosition];
8262 Inc(FCurrentPosition);
8263 case p of
8264 2:
8265 begin
8266 if (FExceptionStack.Count = 0) then
8267 begin
8268 cmd_err(ErOutOfRange);
8269 Break;
8270 end;
8271 pp := FExceptionStack.Data^[FExceptionStack.Count -1];
8272 if pp = nil then begin
8273 cmd_err(ErOutOfRange);
8274 Break;
8275 end;
8276 pp.ExceptOffset := InvalidVal;
8277 if pp.Finally2Offset <> InvalidVal then
8278 begin
8279 FCurrentPosition := pp.Finally2Offset;
8280 pp.Finally2Offset := InvalidVal;
8281 end else begin
8282 p := pp.EndOfBlock;
8283 pp.Free;
8284 FExceptionStack.DeleteLast;
8285 if FExitPoint <> InvalidVal then
8286 begin
8287 FCurrentPosition := FExitPoint;
8288 end else begin
8289 FCurrentPosition := p;
8290 end;
8291 end;
8292 end;
8293 0:
8294 begin
8295 pp := FExceptionStack.Data^[FExceptionStack.Count -1];
8296 if pp = nil then begin
8297 cmd_err(ErOutOfRange);
8298 Break;
8299 end;
8300 if pp.FinallyOffset <> InvalidVal then
8301 begin
8302 FCurrentPosition := pp.FinallyOffset;
8303 pp.FinallyOffset := InvalidVal;
8304 end else if pp.Finally2Offset <> InvalidVal then
8305 begin
8306 FCurrentPosition := pp.Finally2Offset;
8307 pp.ExceptOffset := InvalidVal;
8308 end else begin
8309 p := pp.EndOfBlock;
8310 pp.Free;
8311 FExceptionStack.DeleteLast;
8312 if ExEx <> eNoError then
8313 begin
8314 Tmp := ExObject;
8315 ExObject := nil;
8316 ExceptionProc(ExProc, ExPos, ExEx, ExParam, Tmp);
8317 end else
8318 if FExitPoint <> InvalidVal then
8319 begin
8320 FCurrentPosition := FExitPoint;
8321 end else begin
8322 FCurrentPosition := p;
8323 end;
8324 end;
8325 end;
8326 1:
8327 begin
8328 pp := FExceptionStack.Data^[FExceptionStack.Count -1];
8329 if pp = nil then begin
8330 cmd_err(ErOutOfRange);
8331 Break;
8332 end;
8333 if (ExEx <> ENoError) and (pp.ExceptOffset <> InvalidVal) and (pp.ExceptOffset <> InvalidVal -1) then
8334 begin
8335 FCurrentPosition := pp.ExceptOffset;
8336 pp.ExceptOffset := Cardinal(InvalidVal -1);
8337 pp.ExceptionData := ExEx;
8338 pp.ExceptionObject := ExObject;
8339 pp.ExceptionParam := ExParam;
8340 ExEx := ErNoError;
8341 ExObject := nil;
8342 end else if (pp.Finally2Offset <> InvalidVal) then
8343 begin
8344 FCurrentPosition := pp.Finally2Offset;
8345 pp.Finally2Offset := InvalidVal;
8346 end else begin
8347 p := pp.EndOfBlock;
8348 pp.Free;
8349 FExceptionStack.DeleteLast;
8350 if (ExEx <> eNoError) and (p <> InvalidVal) then
8351 begin
8352 Tmp := ExObject;
8353 ExObject := nil;
8354 ExceptionProc(ExProc, ExPos, ExEx, ExParam, Tmp);
8355 end else
8356 if FExitPoint <> InvalidVal then
8357 begin
8358 FCurrentPosition := FExitPoint;
8359 end else begin
8360 FCurrentPosition := p;
8361 end;
8362 end;
8363 end;
8364 3:
8365 begin
8366 pp := FExceptionStack.Data^[FExceptionStack.Count -1];
8367 if pp = nil then begin
8368 cmd_err(ErOutOfRange);
8369 Break;
8370 end;
8371 p := pp.EndOfBlock;
8372 pp.Free;
8373 FExceptionStack.DeleteLast;
8374 if ExEx <> eNoError then
8375 begin
8376 Tmp := ExObject;
8377 ExObject := nil;
8378 ExceptionProc(ExProc, ExPos, ExEx, ExParam, Tmp);
8379 end else
8380 if FExitPoint <> InvalidVal then
8381 begin
8382 FCurrentPosition := FExitPoint;
8383 end else begin
8384 FCurrentPosition := p;
8385 end;
8386 end;
8387 end;
8388 end;
8389 cm_spc:
8390 begin
8391 if not ReadVariable(vd, False) then
8392 Break;
8393 if vd.FreeType <> vtNone then
8394 begin
8395 FTempVars.Pop;
8396 CMD_Err(erInvalidOpcodeParameter);
8397 break;
8398 end;
8399 if (Vd.aType.BaseType <> btPointer) then
8400 begin
8401 CMD_Err(erInvalidOpcodeParameter);
8402 break;
8403 end;
8404 if not ReadVariable(vs, False) then
8405 Break;
8406 if Pointer(Pointer(IPointer(vD.P)+PointerSize2)^) <> nil then
8407 DestroyHeapVariant2(Pointer(vD.P^), Pointer(Pointer(IPointer(vd.P)+PointerSize)^));
8408 if vs.aType.BaseType = btPointer then
8409 begin
8410 if Pointer(vs.P^) <> nil then
8411 begin
8412 Pointer(vd.P^) := CreateHeapVariant2(Pointer(Pointer(IPointer(vs.P) + PointerSize)^));
8413 Pointer(Pointer(IPointer(vd.P) + PointerSize)^) := Pointer(Pointer(IPointer(vs.P) + PointerSize)^);
8414 Pointer(Pointer(IPointer(vd.P) + PointerSize2)^) := Pointer(1);
8415 if not CopyArrayContents(Pointer(vd.P^), Pointer(vs.P^), 1, Pointer(Pointer(IPointer(vd.P) + PointerSize)^)) then
8416 begin
8417 if vs.FreeType <> vtNone then
8418 FTempVars.Pop;
8419 CMD_Err(ErTypeMismatch);
8420 break;
8421 end;
8422 end else
8423 begin
8424 Pointer(vd.P^) := nil;
8425 Pointer(Pointer(IPointer(vd.P) + PointerSize)^) := nil;
8426 Pointer(Pointer(IPointer(vd.P) + PointerSize2)^) := nil;
8427 end;
8428 end else begin
8429 Pointer(vd.P^) := CreateHeapVariant2(vs.aType);
8430 Pointer(Pointer(IPointer(vd.P) + PointerSize)^) := vs.aType;
8431 LongBool(Pointer(IPointer(vd.P) + PointerSize2)^) := true;
8432 if not CopyArrayContents(Pointer(vd.P^), vs.P, 1, vs.aType) then
8433 begin
8434 if vs.FreeType <> vtNone then
8435 FTempVars.Pop;
8436 CMD_Err(ErTypeMismatch);
8437 break;
8438 end;
8439 end;
8440 if vs.FreeType <> vtNone then
8441 FTempVars.Pop;
8442
8443 end;
8444 cm_nop:;
8445 cm_dec:
8446 begin
8447 if not ReadVariable(vd, True) then
8448 Break;
8449 if vd.FreeType <> vtNone then
8450 begin
8451 FTempVars.Pop;
8452 CMD_Err(erInvalidOpcodeParameter);
8453 break;
8454 end;
8455 case vd.aType.BaseType of
8456 btu8: dec(tbtu8(vd.P^));
8457 bts8: dec(tbts8(vd.P^));
8458 btu16: dec(tbtu16(vd.P^));
8459 bts16: dec(tbts16(vd.P^));
8460 btu32: dec(tbtu32(vd.P^));
8461 bts32: dec(tbts32(vd.P^));
8462 {$IFNDEF PS_NOINT64}
8463 bts64: dec(tbts64(vd.P^));
8464 {$ENDIF}
8465 else
8466 begin
8467 CMD_Err(ErTypeMismatch);
8468 Break;
8469 end;
8470 end;
8471 end;
8472 cm_inc:
8473 begin
8474 if not ReadVariable(vd, True) then
8475 Break;
8476 if vd.FreeType <> vtNone then
8477 begin
8478 FTempVars.Pop;
8479 CMD_Err(erInvalidOpcodeParameter);
8480 break;
8481 end;
8482 case vd.aType.BaseType of
8483 btu8: Inc(tbtu8(vd.P^));
8484 bts8: Inc(tbts8(vd.P^));
8485 btu16: Inc(tbtu16(vd.P^));
8486 bts16: Inc(tbts16(vd.P^));
8487 btu32: Inc(tbtu32(vd.P^));
8488 bts32: Inc(tbts32(vd.P^));
8489 {$IFNDEF PS_NOINT64}
8490 bts64: Inc(tbts64(vd.P^));
8491 {$ENDIF}
8492 else
8493 begin
8494 CMD_Err(ErTypeMismatch);
8495 Break;
8496 end;
8497 end;
8498 end;
8499 cm_sp:
8500 begin
8501 if not ReadVariable(vd, False) then
8502 Break;
8503 if vd.FreeType <> vtNone then
8504 begin
8505 FTempVars.Pop;
8506 CMD_Err(erInvalidOpcodeParameter);
8507 break;
8508 end;
8509 if (Vd.aType.BaseType <> btPointer) then
8510 begin
8511 CMD_Err(erInvalidOpcodeParameter);
8512 break;
8513 end;
8514 if not ReadVariable(vs, False) then
8515 Break;
8516 if vs.FreeType <> vtNone then
8517 begin
8518 FTempVars.Pop;
8519 CMD_Err(erInvalidOpcodeParameter);
8520 break;
8521 end;
8522 if vs.aType.BaseType = btPointer then
8523 begin
8524 Pointer(vd.P^) := Pointer(vs.p^);
8525 Pointer(Pointer(IPointer(vd.P)+PointerSize)^) := Pointer(Pointer(IPointer(vs.P)+PointerSize)^);
8526 end
8527 else
8528 begin
8529 Pointer(vd.P^) := vs.P;
8530 Pointer(Pointer(IPointer(vd.P)+PointerSize)^) := vs.aType;
8531 end;
8532 end;
8533 Cm_cv:
8534 begin
8535 if not ReadVariable(vd, True) then
8536 Break;
8537 if vd.aType.BaseType <> btProcPtr then
8538 begin
8539 if vd.FreeType <> vtNone then
8540 FTempVars.Pop;
8541 CMD_Err(ErTypeMismatch);
8542 break;
8543 end;
8544 p := tbtu32(vd.P^);
8545 if vd.FreeType <> vtNone then
8546 FTempVars.Pop;
8547 if (p = 0) and (Pointer(Pointer(IPointer(vd.p)+PointerSize2)^) <> nil) then
8548 begin
8549 if not InvokeExternalMethod(TPSTypeRec_ProcPtr(vd.aType), Pointer(Pointer(IPointer(vd.p)+PointerSize)^), Pointer(Pointer(IPointer(vd.p)+PointerSize2)^)) then
8550 Break;
8551 end else begin
8552 if (p >= FProcs.Count) or (p = FMainProc) then begin
8553 CMD_Err(erOutOfProcRange);
8554 break;
8555 end;
8556 u := FProcs.Data^[p];
8557 if u.ClassType = TPSExternalProcRec then begin
8558 try
8559 if not TPSExternalProcRec(u).ProcPtr(Self, TPSExternalProcRec(u), FGlobalVars, FStack) then begin
8560 if ExEx = erNoError then
8561 CMD_Err(erCouldNotCallProc);
8562 Break;
8563 end;
8564 except
8565 {$IFDEF DELPHI6UP}
8566 Tmp := AcquireExceptionObject;
8567 {$ELSE}
8568 if RaiseList <> nil then
8569 begin
8570 Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
8571 PRaiseFrame(RaiseList)^.ExceptObject := nil;
8572 end else
8573 Tmp := nil;
8574 {$ENDIF}
8575 if Tmp <> nil then
8576 begin
8577 if Tmp is EPSException then
8578 begin
8579 ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, tbtString(EPSException(tmp).Message), nil);
8580 break;
8581 end else
8582 if Tmp is EDivByZero then
8583 begin
8584 CMD_Err3(erDivideByZero, tbtString(Exception(Tmp).Message), Tmp);
8585 break;
8586 end;
8587 if Tmp is EZeroDivide then
8588 begin
8589 CMD_Err3(erDivideByZero, tbtString(Exception(Tmp).Message), Tmp);
8590 break;
8591 end;
8592 if Tmp is EMathError then
8593 begin
8594 CMD_Err3(erMathError, tbtString(Exception(Tmp).Message), Tmp);
8595 break;
8596 end;
8597 end;
8598 if (Tmp <> nil) and (Tmp is Exception) then
8599 CMD_Err3(erException, tbtString(Exception(Tmp).Message), Tmp) else
8600 CMD_Err3(erException, '', Tmp);
8601 Break;
8602 end;
8603 end
8604 else begin
8605 vtemp := FStack.PushType(FReturnAddressType);
8606 PPSVariantReturnAddress(vtemp).Addr.ProcNo := FCurrProc;
8607 PPSVariantReturnAddress(vtemp).Addr.Position := FCurrentPosition;
8608 PPSVariantReturnAddress(vtemp).Addr.StackBase := FCurrStackBase;
8609 FCurrStackBase := FStack.Count - 1;
8610 FCurrProc := TPSInternalProcRec(u);
8611 FData := FCurrProc.Data;
8612 FDataLength := FCurrProc.Length;
8613 FCurrentPosition := 0;
8614 end;
8615 end;
8616 end;
8617 CM_CO:
8618 begin
8619 if FCurrentPosition >= FDataLength then
8620 begin
8621 CMD_Err(erOutOfRange); // Error
8622 break;
8623 end;
8624 calctype := FData^[FCurrentPosition];
8625 Inc(FCurrentPosition);
8626 if not ReadVariable(v3, True) then
8627 Break;
8628 if v3.FreeType <> vtNone then
8629 begin
8630 if v3.aType.BaseType in NeedFinalization then
8631 FinalizeVariant(v3.P, v3.aType);
8632 p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
8633 Dec(FTempVars.FCount);
8634 {$IFNDEF PS_NOSMARTLIST}
8635 Inc(FTempVars.FCheckCount);
8636 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
8637 {$ENDIF}
8638 FTempVars.FLength := P;
8639 if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
8640 CMD_Err(erInvalidOpcodeParameter);
8641 break;
8642 end;
8643 if not ReadVariable(vs, True) then
8644 Break;
8645 if not ReadVariable(vd, True) then
8646 begin
8647 if vs.FreeType <> vtNone then
8648 begin
8649 if vs.aType.BaseType in NeedFinalization then
8650 FinalizeVariant(vs.P, vs.aType);
8651 p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
8652 Dec(FTempVars.FCount);
8653 {$IFNDEF PS_NOSMARTLIST}
8654 Inc(FTempVars.FCheckCount);
8655 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
8656 {$ENDIF}
8657 FTempVars.FLength := P;
8658 if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
8659 end;
8660 Break;
8661 end;
8662 DoBooleanCalc(Vs.P, Vd.P, v3.P, vs.aType, vd.aType, v3.aType, CalcType);
8663 if vd.FreeType <> vtNone then
8664 begin
8665 if vd.aType.BaseType in NeedFinalization then
8666 FinalizeVariant(vd.P, vd.aType);
8667 p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
8668 Dec(FTempVars.FCount);
8669 {$IFNDEF PS_NOSMARTLIST}
8670 Inc(FTempVars.FCheckCount);
8671 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
8672 {$ENDIF}
8673 FTempVars.FLength := P;
8674 if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
8675 end;
8676 if vs.FreeType <> vtNone then
8677 begin
8678 if vs.aType.BaseType in NeedFinalization then
8679 FinalizeVariant(vs.P, vs.aType);
8680 p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
8681 Dec(FTempVars.FCount);
8682 {$IFNDEF PS_NOSMARTLIST}
8683 Inc(FTempVars.FCheckCount);
8684 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
8685 {$ENDIF}
8686 FTempVars.FLength := P;
8687 if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
8688 end;
8689 end;
8690
8691 else
8692 CMD_Err(erInvalidOpcode); // Error
8693 end;
8694 end;
8695 // if cmd <> invalidval then ProfilerExitProc(Cmd+1);
8696 // if ExEx <> erNoError then FStatus := FOldStatus;
8697 until (FExceptionStack.Count = 0) or (Fstatus <> IsRunning);
8698 if FStatus = isLoaded then begin
8699 for I := Longint(FStack.Count) - 1 downto 0 do
8700 FStack.Pop;
8701 FStack.Clear;
8702 if FCallCleanup then Cleanup;
8703 end;
8704 Result := ExEx = erNoError;
8705 end;
8706
NVarProcnull8707 function NVarProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
8708 var
8709 tmp: TPSVariantIFC;
8710 begin
8711 case Longint(p.Ext1) of
8712 0:
8713 begin
8714 if @Caller.FOnSetNVariant = nil then begin Result := False; exit; end;
8715 tmp := NewTPSVariantIFC(Stack.Items[Stack.Count - 2], True);
8716 if (Tmp.Dta = nil) or (tmp.aType.BaseType <> btVariant) then begin Result := False; exit; end;
8717 Caller.FOnSetNVariant(Caller, Stack.GetAnsiString(-1), Variant(tmp.Dta^));
8718 Result := true;
8719 end;
8720 1:
8721 begin
8722 if @Caller.FOnGetNVariant = nil then begin Result := False; exit; end;
8723 tmp := NewTPSVariantIFC(Stack.Items[Stack.Count - 1], False);
8724 if (Tmp.Dta = nil) or (tmp.aType.BaseType <> btVariant) then begin Result := False; exit; end;
8725 Variant(tmp.Dta^) := Caller.FOnGetNVariant(Caller, Stack.GetAnsiString(-2));
8726 Result := true;
8727 end;
8728 else
8729 Result := False;
8730 end;
8731 end;
8732
DefProcnull8733 function DefProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
8734 var
8735 temp: TPSVariantIFC;
8736 I: Longint;
8737 b: Boolean;
8738 pex: TPSExceptionHandler;
8739 Tmp: TObject;
8740 begin
8741 { The following needs to be in synch in these 3 functions:
8742 -UPSCompiler.TPSPascalCompiler.DefineStandardProcedures
8743 -UPSRuntime.DefProc
8744 -UPSRuntime.TPSExec.RegisterStandardProcs
8745 }
8746 case Longint(p.Ext1) of
8747 0: Stack.SetAnsiString(-1, tbtstring(SysUtils.IntToStr(Stack.{$IFNDEF PS_NOINT64}GetInt64{$ELSE}GetInt{$ENDIF}(-2)))); // inttostr
8748 1: Stack.SetInt(-1, StrToInt(Stack.GetAnsiString(-2))); // strtoint
8749 2: Stack.SetInt(-1, StrToIntDef(Stack.GetAnsiString(-2), Stack.GetInt(-3))); // strtointdef
8750 3:
8751 {$IFNDEF PS_NOWIDESTRING}
8752 if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then
8753 Stack.SetInt(-1, Pos(Stack.GetUnicodeString(-2), Stack.GetUnicodeString(-3)))// pos
8754 else
8755 if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then
8756 Stack.SetInt(-1, Pos(Stack.GetWideString(-2), Stack.GetWideString(-3)))// pos
8757 else{$ENDIF}
8758 Stack.SetInt(-1, Pos(Stack.GetAnsiString(-2), Stack.GetAnsiString(-3)));// pos
8759 4:
8760 {$IFNDEF PS_NOWIDESTRING} if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then
8761 Stack.SetWideString(-1, Copy(Stack.GetWideString(-2), Stack.GetInt(-3), Stack.GetInt(-4))) // copy
8762 else
8763 if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then
8764 Stack.SetUnicodeString(-1, Copy(Stack.GetUnicodeString(-2), Stack.GetInt(-3), Stack.GetInt(-4))) // copy
8765 else{$ENDIF}
8766 Stack.SetAnsiString(-1, Copy(Stack.GetAnsiString(-2), Stack.GetInt(-3), Stack.GetInt(-4))); // copy
8767 5: //delete
8768 begin
8769 temp := NewTPSVariantIFC(Stack[Stack.Count -1], True);
8770 {$IFNDEF PS_NOWIDESTRING}
8771 if (temp.Dta <> nil) and (temp.aType.BaseType = btUnicodeString) then
8772 begin
8773 Delete(tbtUnicodeString(temp.Dta^), Stack.GetInt(-2), Stack.GetInt(-3));
8774 end else
8775 if (temp.Dta <> nil) and (temp.aType.BaseType = btWideString) then
8776 begin
8777 Delete(tbtwidestring(temp.Dta^), Stack.GetInt(-2), Stack.GetInt(-3));
8778 end else {$ENDIF} begin
8779 if (temp.Dta = nil) or (temp.aType.BaseType <> btString) then
8780 begin
8781 Result := False;
8782 exit;
8783 end;
8784 Delete(tbtstring(temp.Dta^), Stack.GetInt(-2), Stack.GetInt(-3));
8785 end;
8786 end;
8787 6: // insert
8788 begin
8789 temp := NewTPSVariantIFC(Stack[Stack.Count -2], True);
8790 {$IFNDEF PS_NOWIDESTRING}
8791 if (temp.Dta <> nil) and (temp.aType.BaseType = btUnicodeString) then begin
8792 Insert(Stack.GetUnicodeString(-1), tbtUnicodeString(temp.Dta^), Stack.GetInt(-3));
8793 end else if (temp.Dta <> nil) and (temp.aType.BaseType = btWideString) then begin
8794 Insert(Stack.GetWideString(-1), tbtwidestring(temp.Dta^), Stack.GetInt(-3));
8795 end else {$ENDIF} begin
8796 if (temp.Dta = nil) or (temp.aType.BaseType <> btString) then
8797 begin
8798 Result := False;
8799 exit;
8800 end;
8801 Insert(Stack.GetAnsiString(-1), tbtstring(temp.Dta^), Stack.GetInt(-3));
8802 end;
8803 end;
8804 7: // StrGet
8805 begin
8806 temp := NewTPSVariantIFC(Stack[Stack.Count -2], True);
8807 if (temp.Dta = nil) or not (temp.aType.BaseType in [btString, btUnicodeString]) then
8808 begin
8809 Result := False;
8810 exit;
8811 end;
8812 I := Stack.GetInt(-3);
8813 if (i<1) or (i>length(tbtstring(temp.Dta^))) then
8814 begin
8815 Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange));
8816 Result := False;
8817 exit;
8818 end;
8819 Stack.SetInt(-1,Ord(tbtstring(temp.Dta^)[i]));
8820 end;
8821 8: // StrSet
8822 begin
8823 temp := NewTPSVariantIFC(Stack[Stack.Count -3], True);
8824 if (temp.Dta = nil) or not (temp.aType.BaseType in [btString, btUnicodeString]) then
8825 begin
8826 Result := False;
8827 exit;
8828 end;
8829 I := Stack.GetInt(-2);
8830 if (i<1) or (i>length(tbtstring(temp.Dta^))) then
8831 begin
8832 Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange));
8833 Result := True;
8834 exit;
8835 end;
8836 tbtstring(temp.Dta^)[i] := tbtchar(Stack.GetInt(-1));
8837 end;
8838 10:
8839 {$IFNDEF PS_NOWIDESTRING}
8840 {$IFDEF DELPHI2009UP}
8841 if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then
8842 Stack.SetUnicodeString(-1, UpperCase(Stack.GetUnicodeString(-2))) // Uppercase
8843 else
8844 {$ENDIF}
8845 if (Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString) or
8846 (Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString) then
8847 Stack.SetWideString(-1, WideUpperCase(Stack.GetWideString(-2))) // Uppercase
8848 else
8849 {$ENDIF}
8850 Stack.SetAnsiString(-1, FastUppercase(Stack.GetAnsiString(-2))); // Uppercase
8851 11:
8852 {$IFNDEF PS_NOWIDESTRING}
8853 {$IFDEF DELPHI2009UP}
8854 if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then
8855 Stack.SetUnicodeString(-1, LowerCase(Stack.GetUnicodeString(-2))) // Uppercase
8856 else
8857 {$ENDIF}
8858 if (Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString) or
8859 (Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString) then
8860 Stack.SetWideString(-1, WideLowerCase(Stack.GetWideString(-2))) // Uppercase
8861 else
8862 {$ENDIF}
8863 Stack.SetAnsiString(-1, FastLowercase(Stack.GetAnsiString(-2)));// LowerCase
8864 12:
8865 {$IFNDEF PS_NOWIDESTRING}
8866 if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then
8867 Stack.SetUnicodeString(-1, SysUtils.Trim(Stack.GetUnicodestring(-2))) // Trim
8868 else if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then
8869 Stack.SetWideString(-1, SysUtils.Trim(Stack.GetWideString(-2))) // Trim
8870 else
8871 {$ENDIF}
8872 Stack.SetAnsiString(-1, AnsiString(SysUtils.Trim(String(Stack.GetAnsiString(-2)))));// Trim
8873 13: Stack.SetInt(-1, Length(Stack.GetAnsiString(-2))); // Length
8874 14: // SetLength
8875 begin
8876 temp := NewTPSVariantIFC(Stack[Stack.Count -1], True);
8877 if (temp.Dta = nil) or (temp.aType.BaseType <> btString) then
8878 begin
8879 Result := False;
8880 exit;
8881 end;
8882 SetLength(tbtstring(temp.Dta^), STack.GetInt(-2));
8883 end;
8884 15: Stack.SetReal(-1, Sin(Stack.GetReal(-2))); // Sin
8885 16: Stack.SetReal(-1, Cos(Stack.GetReal(-2))); // Cos
8886 17: Stack.SetReal(-1, SQRT(Stack.GetReal(-2))); // Sqrt
8887 18: Stack.SetInt(-1, Round(Stack.GetReal(-2))); // Round
8888 19: Stack.SetInt(-1, Trunc(Stack.GetReal(-2))); // Trunc
8889 20: Stack.SetReal(-1, Int(Stack.GetReal(-2))); // Int
8890 21: Stack.SetReal(-1, Pi); // Pi
8891 22: Stack.SetReal(-1, Abs(Stack.GetReal(-2))); // Abs
8892 23: Stack.SetReal(-1, StrToFloat(Stack.GetAnsiString(-2))); // StrToFloat
8893 24: Stack.SetAnsiString(-1, FloatToStr(Stack.GetReal(-2)));// FloatToStr
8894 25:
8895 {$IFNDEF PS_NOWIDESTRING}
8896 if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then
8897 Stack.SetUnicodeString(-1, upadL(Stack.GetUnicodeString(-2), Stack.GetInt(-3))) // PadL
8898 else
8899 if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then
8900 Stack.SetWideString(-1, wPadL(Stack.GetWideString(-2), Stack.GetInt(-3))) // PadL
8901 else{$ENDIF}
8902 Stack.SetAnsiString(-1, PadL(Stack.GetAnsiString(-2), Stack.GetInt(-3))); // PadL
8903 26:
8904 {$IFNDEF PS_NOWIDESTRING}
8905 if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then
8906 Stack.SetUnicodeString(-1, uPadR(Stack.GetUnicodeString(-2), Stack.GetInt(-3))) // PadR
8907 else
8908 if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then
8909 Stack.SetWideString(-1, wPadR(Stack.GetWideString(-2), Stack.GetInt(-3))) // PadR
8910 else{$ENDIF}
8911 Stack.SetAnsiString(-1, PadR(Stack.GetAnsiString(-2), Stack.GetInt(-3))); // PadR
8912 27:
8913 {$IFNDEF PS_NOWIDESTRING}
8914 if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then
8915 Stack.SetUnicodeString(-1, uPadZ(Stack.GetUnicodeString(-2), Stack.GetInt(-3)))// PadZ
8916 else
8917 if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then
8918 Stack.SetWideString(-1, wPadZ(Stack.GetWideString(-2), Stack.GetInt(-3)))// PadZ
8919 else{$ENDIF}
8920 Stack.SetAnsiString(-1, PadZ(Stack.GetAnsiString(-2), Stack.GetInt(-3)));// PadZ
8921 28: Stack.SetAnsiString(-1, StringOfChar(tbtChar(Stack.GetInt(-2)), Stack.GetInt(-3))); // Replicate/StrOfChar
8922 29: // Assigned
8923 begin
8924 temp := NewTPSVariantIFC(Stack[Stack.Count -2], True);
8925 if Temp.dta = nil then
8926 begin
8927 Result := False;
8928 exit;
8929 end;
8930 case temp.aType.BaseType of
8931 btU8, btS8: b := tbtu8(temp.dta^) <> 0;
8932 btU16, btS16: b := tbtu16(temp.dta^) <> 0;
8933 btU32, btS32: b := tbtu32(temp.dta^) <> 0;
8934 btString, btPChar: b := tbtstring(temp.dta^) <> '';
8935 {$IFNDEF PS_NOWIDESTRING}
8936 btWideString: b := tbtwidestring(temp.dta^)<> '';
8937 btUnicodeString: b := tbtUnicodeString(temp.dta^)<> '';
8938 {$ENDIF}
8939 btArray, btClass{$IFNDEF PS_NOINTERFACES}, btInterface{$ENDIF}: b := Pointer(temp.dta^) <> nil;
8940 else
8941 Result := False;
8942 Exit;
8943 end;
8944 if b then
8945 Stack.SetInt(-1, 1)
8946 else
8947 Stack.SetInt(-1, 0);
8948 end;
8949 30:
8950 begin {RaiseLastException}
8951 if (Caller.FExceptionStack.Count > 0) then begin
8952 pex := Caller.FExceptionStack.Data[Caller.fExceptionStack.Count -1];
8953 if pex.ExceptOffset = Cardinal(InvalidVal -1) then begin
8954 Tmp := pex.ExceptionObject;
8955 pex.ExceptionObject := nil;
8956 Caller.ExceptionProc(Caller.ExProc, pex.ExceptOffset, pex.ExceptionData, pex.ExceptionParam, tmp);
8957 end;
8958 end;
8959 end;
8960 31: Caller.CMD_Err2(TPSError(Stack.GetInt(-1)), Stack.GetAnsiString(-2)); {RaiseExeption}
8961 32: Stack.SetInt(-1, Ord(Caller.LastEx)); {ExceptionType}
8962 33: Stack.SetAnsiString(-1, Caller.LastExParam); {ExceptionParam}
8963 34: Stack.SetInt(-1, Caller.LastExProc); {ExceptionProc}
8964 35: Stack.SetInt(-1, Caller.LastExPos); {ExceptionPos}
8965 36: Stack.SetAnsiString(-1, PSErrorToString(TPSError(Stack.GetInt(-2)), Stack.GetAnsiString(-3))); {ExceptionToString}
8966 37: Stack.SetAnsiString(-1, tbtString(AnsiUpperCase(string(Stack.GetAnsiString(-2))))); // AnsiUppercase
8967 38: Stack.SetAnsiString(-1, tbtString(AnsiLowercase(string(Stack.GetAnsiString(-2))))); // AnsiLowerCase
8968 {$IFNDEF PS_NOINT64}
8969 39: Stack.SetInt64(-1, StrToInt64(string(Stack.GetAnsiString(-2)))); // StrToInt64
8970 40: Stack.SetAnsiString(-1, tbtstring(SysUtils.IntToStr(Stack.GetInt64(-2))));// Int64ToStr
8971 41: Stack.SetInt64(-1, StrToInt64Def(string(Stack.GetAnsiString(-2)), Stack.GetInt64(-3))); // StrToInt64Def
8972 {$ENDIF}
8973 42: // sizeof
8974 begin
8975 temp := NewTPSVariantIFC(Stack[Stack.Count -2], False);
8976 if Temp.aType = nil then
8977 Stack.SetInt(-1, 0)
8978 else
8979 Stack.SetInt(-1, Temp.aType.RealSize)
8980 end;
8981 {$IFNDEF PS_NOWIDESTRING}
8982 43: // WStrGet
8983 begin
8984 temp := NewTPSVariantIFC(Stack[Stack.Count -2], True);
8985 if temp.dta = nil then begin
8986 result := false;
8987 exit;
8988 end;
8989 case temp.aType.BaseType of
8990 btWideString:
8991 begin
8992 I := Stack.GetInt(-3);
8993 if (i<1) or (i>length(tbtwidestring(temp.Dta^))) then
8994 begin
8995 Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange));
8996 Result := False;
8997 exit;
8998 end;
8999 Stack.SetInt(-1,Ord(tbtwidestring(temp.Dta^)[i]));
9000 end;
9001 btUnicodeString:
9002 begin
9003 I := Stack.GetInt(-3);
9004 if (i<1) or (i>length(tbtUnicodeString(temp.Dta^))) then
9005 begin
9006 Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange));
9007 Result := False;
9008 exit;
9009 end;
9010 Stack.SetInt(-1,Ord(tbtUnicodeString(temp.Dta^)[i]));
9011 end;
9012
9013 else
9014 begin
9015 Result := False;
9016 exit;
9017 end;
9018 end;
9019 end;
9020 44: // WStrSet
9021 begin
9022 temp := NewTPSVariantIFC(Stack[Stack.Count -3], True);
9023 if (temp.Dta = nil) then
9024 begin
9025 Result := False;
9026 exit;
9027 end;
9028 case temp.aType.BaseType of
9029 btWideString:
9030 begin
9031 I := Stack.GetInt(-2);
9032 if (i<1) or (i>length(tbtWidestring(temp.Dta^))) then
9033 begin
9034 Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange));
9035 Result := True;
9036 exit;
9037 end;
9038 tbtWidestring(temp.Dta^)[i] := WideChar(Stack.GetInt(-1));
9039 end;
9040
9041 btUnicodeString:
9042 begin
9043 I := Stack.GetInt(-2);
9044 if (i<1) or (i>length(tbtunicodestring(temp.Dta^))) then
9045 begin
9046 Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange));
9047 Result := True;
9048 exit;
9049 end;
9050 tbtunicodestring(temp.Dta^)[i] := WideChar(Stack.GetInt(-1));
9051 end;
9052 else
9053 begin
9054 Result := False;
9055 exit;
9056 end;
9057 end;
9058 end;
9059 {$ENDIF}
9060 else
9061 begin
9062 Result := False;
9063 exit;
9064 end;
9065 end;
9066 Result := True;
9067 end;
GetArrayLengthnull9068 function GetArrayLength(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
9069 var
9070 arr: TPSVariantIFC;
9071 begin
9072 Arr := NewTPSVariantIFC(Stack[Stack.Count-2], True);
9073 if (arr.aType.BaseType <> btStaticArray) and ((arr.Dta = nil) or (arr.aType.BaseType <> btArray)) then
9074 begin
9075 Result := false;
9076 exit;
9077 end;
9078 if arr.aType.BaseType = btStaticArray then
9079 Stack.SetInt(-1, TPSTypeRec_StaticArray(arr.aType).Size)
9080 else
9081 Stack.SetInt(-1, PSDynArrayGetLength(Pointer(arr.Dta^), arr.aType));
9082 Result := True;
9083 end;
9084
SetArrayLengthnull9085 function SetArrayLength(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
9086 var
9087 arr: TPSVariantIFC;
9088 begin
9089 Arr := NewTPSVariantIFC(Stack[Stack.Count-1], True);
9090 if (arr.Dta = nil) or (arr.aType.BaseType <> btArray) then
9091 begin
9092 Result := false;
9093 exit;
9094 end;
9095 PSDynArraySetLength(Pointer(arr.Dta^), arr.aType, Stack.GetInt(-2));
9096 Result := True;
9097 end;
9098
9099
9100 function InterfaceProc(Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean; forward;
9101
9102 procedure RegisterInterfaceLibraryRuntime(Se: TPSExec);
9103 begin
9104 SE.AddSpecialProcImport('intf', InterfaceProc, nil);
9105 end;
9106
9107 {$IFNDEF DELPHI6UP}
Nullnull9108 function Null: Variant;
9109 begin
9110 Result := System.Null;
9111 end;
9112
Unassignednull9113 function Unassigned: Variant;
9114 begin
9115 Result := System.Unassigned;
9116 end;
9117 {$ENDIF}
Length_null9118 function Length_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
9119 var
9120 arr: TPSVariantIFC;
9121 begin
9122 arr:=NewTPSVariantIFC(Stack[Stack.Count-2],false);
9123 case arr.aType.BaseType of
9124 btArray:
9125 begin
9126 Stack.SetInt(-1,PSDynArrayGetLength(Pointer(arr.Dta^),arr.aType));
9127 Result:=true;
9128 end;
9129 btStaticArray:
9130 begin
9131 Stack.SetInt(-1,TPSTypeRec_StaticArray(arr.aType).Size);
9132 Result:=true;
9133 end;
9134 btString:
9135 begin
9136 Stack.SetInt(-1,length(tbtstring(arr.Dta^)));
9137 Result:=true;
9138 end;
9139 btChar:
9140 begin
9141 Stack.SetInt(-1, 1);
9142 Result:=true;
9143 end;
9144 {$IFNDEF PS_NOWIDESTRING}
9145 btWideString:
9146 begin
9147 Stack.SetInt(-1,length(tbtWidestring(arr.Dta^)));
9148 Result:=true;
9149 end;
9150 btUnicodeString:
9151 begin
9152 Stack.SetInt(-1,length(tbtUnicodeString(arr.Dta^)));
9153 Result:=true;
9154 end;
9155 {$ENDIF}
9156 btvariant:
9157 begin
9158 Stack.SetInt(-1,length(Variant(arr.Dta^)));
9159 Result:=true;
9160 end;
9161 else
9162 begin
9163 Caller.CMD_Err(ErTypeMismatch);
9164 result := true;
9165 end;
9166 end;
9167 end;
9168
9169
SetLength_null9170 function SetLength_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
9171 var
9172 arr: TPSVariantIFC;
9173 begin
9174 Result:=false;
9175 arr:=NewTPSVariantIFC(Stack[Stack.Count-1],true);
9176 if arr.aType.BaseType=btArray then
9177 begin
9178 PSDynArraySetLength(Pointer(arr.Dta^),arr.aType,Stack.GetInt(-2));
9179 Result:=true;
9180 end else
9181 if arr.aType.BaseType=btString then
9182 begin
9183 SetLength(tbtstring(arr.Dta^),STack.GetInt(-2));
9184 Result:=true;
9185 {$IFNDEF PS_NOWIDESTRING}
9186 end else
9187 if arr.aType.BaseType=btWideString then
9188 begin
9189 SetLength(tbtwidestring(arr.Dta^),STack.GetInt(-2));
9190 Result:=true;
9191 end else
9192 if arr.aType.BaseType=btUnicodeString then
9193 begin
9194 SetLength(tbtUnicodeString(arr.Dta^),STack.GetInt(-2));
9195 Result:=true;
9196 {$ENDIF}
9197 end;
9198 end;
9199
Low_null9200 function Low_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
9201 var
9202 arr: TPSVariantIFC;
9203 begin
9204 Result:=true;
9205 arr:=NewTPSVariantIFC(Stack[Stack.Count-2],false);
9206 case arr.aType.BaseType of
9207 btArray : Stack.SetInt(-1,0);
9208 btStaticArray: Stack.SetInt(-1,TPSTypeRec_StaticArray(arr.aType).StartOffset);
9209 btString : Stack.SetInt(-1,1);
9210 btU8 : Stack.SetInt(-1,Low(Byte)); //Byte: 0
9211 btS8 : Stack.SetInt(-1,Low(ShortInt)); //ShortInt: -128
9212 btU16 : Stack.SetInt(-1,Low(Word)); //Word: 0
9213 btS16 : Stack.SetInt(-1,Low(SmallInt)); //SmallInt: -32768
9214 btU32 : Stack.SetInt(-1,Low(Cardinal)); //Cardinal/LongWord: 0
9215 btS32 : Stack.SetInt(-1,Low(Integer)); //Integer/LongInt: -2147483648
9216 {$IFNDEF PS_NOINT64}
9217 btS64 : Stack.SetInt64(-1,Low(Int64)); //Int64: -9223372036854775808
9218 {$ENDIF}
9219 else Result:=false;
9220 end;
9221 end;
9222
High_null9223 function High_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
9224 var
9225 arr: TPSVariantIFC;
9226 begin
9227 Result:=true;
9228 arr:=NewTPSVariantIFC(Stack[Stack.Count-2],false);
9229 case arr.aType.BaseType of
9230 btArray : Stack.SetInt(-1,PSDynArrayGetLength(Pointer(arr.Dta^),arr.aType)-1);
9231 btStaticArray: Stack.SetInt(-1,TPSTypeRec_StaticArray(arr.aType).StartOffset+TPSTypeRec_StaticArray(arr.aType).Size-1);
9232 btString : Stack.SetInt(-1,Length(tbtstring(arr.Dta^)));
9233 btU8 : Stack.SetInt(-1,High(Byte)); //Byte: 255
9234 btS8 : Stack.SetInt(-1,High(ShortInt)); //ShortInt: 127
9235 btU16 : Stack.SetInt(-1,High(Word)); //Word: 65535
9236 btS16 : Stack.SetInt(-1,High(SmallInt)); //SmallInt: 32767
9237 btU32 : Stack.SetUInt(-1,High(Cardinal)); //Cardinal/LongWord: 4294967295
9238 btS32 : Stack.SetInt(-1,High(Integer)); //Integer/LongInt: 2147483647
9239 {$IFNDEF PS_NOINT64}
9240 btS64 : Stack.SetInt64(-1,High(Int64)); //Int64: 9223372036854775807
9241 {$ENDIF}
9242 else Result:=false;
9243 end;
9244 end;
9245
Dec_null9246 function Dec_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
9247 var
9248 arr: TPSVariantIFC;
9249 begin
9250 Result:=true;
9251 arr:=NewTPSVariantIFC(Stack[Stack.Count-1],true);
9252 case arr.aType.BaseType of
9253 btU8 : Stack.SetInt(-1,Tbtu8(arr.dta^)-1); //Byte
9254 btS8 : Stack.SetInt(-1,Tbts8(arr.dta^)-1); //ShortInt
9255 btU16 : Stack.SetInt(-1,Tbtu16(arr.dta^)-1); //Word
9256 btS16 : Stack.SetInt(-1,Tbts16(arr.dta^)-1); //SmallInt
9257 btU32 : Stack.SetInt(-1,Tbtu32(arr.dta^)-1); //Cardinal/LongWord
9258 btS32 : Stack.SetInt(-1,Tbts32(arr.dta^)-1); //Integer/LongInt
9259 {$IFNDEF PS_NOINT64}
9260 btS64 : Stack.SetInt64(-1,Tbts64(arr.dta^)-1);
9261 {$ENDIF}
9262 else Result:=false;
9263 end;
9264 end;
9265
Inc_null9266 function Inc_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
9267 var
9268 arr: TPSVariantIFC;
9269 begin
9270 Result:=true;
9271 arr:=NewTPSVariantIFC(Stack[Stack.Count-1],true);
9272 case arr.aType.BaseType of
9273 btU8 : Stack.SetInt(-1,Tbtu8(arr.dta^)+1); //Byte
9274 btS8 : Stack.SetInt(-1,Tbts8(arr.dta^)+1); //ShortInt
9275 btU16 : Stack.SetInt(-1,Tbtu16(arr.dta^)+1); //Word
9276 btS16 : Stack.SetInt(-1,Tbts16(arr.dta^)+1); //SmallInt
9277 btU32 : Stack.SetInt(-1,Tbtu32(arr.dta^)+1); //Cardinal/LongWord
9278 btS32 : Stack.SetInt(-1,Tbts32(arr.dta^)+1); //Integer/LongInt
9279 {$IFNDEF PS_NOINT64}
9280 btS64 : Stack.SetInt64(-1,Tbts64(arr.dta^)+1);
9281 {$ENDIF}
9282 else Result:=false;
9283 end;
9284 end;
9285
Include_null9286 function Include_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
9287 var
9288 TheSet, NewMember: TPSVariantIFC;
9289 SetData: PByteArray;
9290 Val: Tbtu8;
9291 begin
9292 TheSet:=NewTPSVariantIFC(Stack[Stack.Count-1],true);
9293 NewMember:=NewTPSVariantIFC(Stack[Stack.Count-2],false);
9294 Result := (TheSet.aType.BaseType = btSet) and (NewMember.aType.BaseType = btU8);
9295 if not Result then Exit;
9296 SetData := TheSet.Dta;
9297 Val := Tbtu8(NewMember.dta^);
9298 SetData^[Val shr 3] := SetData^[Val shr 3] or (1 shl (Val and 7));
9299 end;
9300
Exclude_null9301 function Exclude_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
9302 var
9303 TheSet, NewMember: TPSVariantIFC;
9304 SetData: PByteArray;
9305 Val: Tbtu8;
9306 begin
9307 TheSet:=NewTPSVariantIFC(Stack[Stack.Count-1],true);
9308 NewMember:=NewTPSVariantIFC(Stack[Stack.Count-2],false);
9309 Result := (TheSet.aType.BaseType = btSet) and (NewMember.aType.BaseType = btU8);
9310 if not Result then Exit;
9311 SetData := TheSet.Dta;
9312 Val := Tbtu8(NewMember.dta^);
9313 SetData^[Val shr 3] := SetData^[Val shr 3] and not (1 shl (Val and 7));
9314 end;
9315
9316
9317 {$IFNDEF DELPHI6UP}
_VarArrayGetnull9318 function _VarArrayGet(var S : Variant; I : Integer) : Variant;
9319 begin
9320 result := VarArrayGet(S, [I]);
9321 end;
9322
9323 procedure _VarArraySet(const c : Variant; I : Integer; var s : Variant);
9324 begin
9325 VarArrayPut(s, c, [i]);
9326 end;
9327 {$ENDIF}
9328
9329 procedure TPSExec.RegisterStandardProcs;
9330 begin
9331 { The following needs to be in synch in these 3 functions:
9332 -UPSCompiler.TPSPascalCompiler.DefineStandardProcedures
9333 -UPSRuntime.DefProc
9334 -UPSRuntime.TPSExec.RegisterStandardProcs
9335 }
9336 RegisterFunctionName('!NOTIFICATIONVARIANTSET', NVarProc, Pointer(0), nil);
9337 RegisterFunctionName('!NOTIFICATIONVARIANTGET', NVarProc, Pointer(1), nil);
9338
9339 RegisterFunctionName('IntToStr', DefProc, Pointer(0), nil);
9340 RegisterFunctionName('StrToInt', DefProc, Pointer(1), nil);
9341 RegisterFunctionName('StrToIntDef', DefProc, Pointer(2), nil);
9342 RegisterFunctionName('Pos', DefProc, Pointer(3), nil);
9343 RegisterFunctionName('Copy', DefProc, Pointer(4), nil);
9344 RegisterFunctionName('Delete', DefProc, Pointer(5), nil);
9345 RegisterFunctionName('Insert', DefProc, Pointer(6), nil);
9346
9347 RegisterFunctionName('StrGet', DefProc, Pointer(7), nil);
9348 RegisterFunctionName('StrSet', DefProc, Pointer(8), nil);
9349 RegisterFunctionName('UpperCase', DefProc, Pointer(10), nil);
9350 RegisterFunctionName('LowerCase', DefProc, Pointer(11), nil);
9351 RegisterFunctionName('Trim', DefProc, Pointer(12), nil);
9352
9353 RegisterFunctionName('Length',Length_,nil,nil);
9354 RegisterFunctionName('SetLength',SetLength_,nil,nil);
9355 RegisterFunctionName('Low',Low_,nil,nil);
9356 RegisterFunctionName('High',High_,nil,nil);
9357 RegisterFunctionName('Dec',Dec_,nil,nil);
9358 RegisterFunctionName('Inc',Inc_,nil,nil);
9359 RegisterFunctionName('Include',Include_,nil,nil);
9360 RegisterFunctionName('Exclude',Exclude_,nil,nil);
9361
9362 RegisterFunctionName('Sin', DefProc, Pointer(15), nil);
9363 RegisterFunctionName('Cos', DefProc, Pointer(16), nil);
9364 RegisterFunctionName('Sqrt', DefProc, Pointer(17), nil);
9365 RegisterFunctionName('Round', DefProc, Pointer(18), nil);
9366 RegisterFunctionName('Trunc', DefProc, Pointer(19), nil);
9367 RegisterFunctionName('Int', DefProc, Pointer(20), nil);
9368 RegisterFunctionName('Pi', DefProc, Pointer(21), nil);
9369 RegisterFunctionName('Abs', DefProc, Pointer(22), nil);
9370 RegisterFunctionName('StrToFloat', DefProc, Pointer(23), nil);
9371 RegisterFunctionName('FloatToStr', DefProc, Pointer(24), nil);
9372 RegisterFunctionName('PadL', DefProc, Pointer(25), nil);
9373 RegisterFunctionName('PadR', DefProc, Pointer(26), nil);
9374 RegisterFunctionName('PadZ', DefProc, Pointer(27), nil);
9375 RegisterFunctionName('Replicate', DefProc, Pointer(28), nil);
9376 RegisterFunctionName('StringOfChar', DefProc, Pointer(28), nil);
9377 RegisterFunctionName('!ASSIGNED', DefProc, Pointer(29), nil);
9378
Unassignednull9379 RegisterDelphiFunction(@Unassigned, 'Unassigned', cdRegister);
VarIsEmptynull9380 RegisterDelphiFunction(@VarIsEmpty, 'VarIsEmpty', cdRegister);
9381 {$IFDEF DELPHI7UP}
VarIsClearnull9382 RegisterDelphiFunction(@VarIsClear, 'VarIsClear', cdRegister);
9383 {$ENDIF}
Nullnull9384 RegisterDelphiFunction(@Null, 'Null', cdRegister);
VarIsNullnull9385 RegisterDelphiFunction(@VarIsNull, 'VarIsNull', cdRegister);
9386 RegisterDelphiFunction(@{$IFDEF FPC}variants.{$ENDIF}VarType, 'VarType', cdRegister);
9387 {$IFNDEF PS_NOIDISPATCH}
IDispatchInvokenull9388 RegisterDelphiFunction(@IDispatchInvoke, 'IdispatchInvoke', cdregister);
9389 {$ENDIF}
9390
9391
9392 RegisterFunctionName('GetArrayLength', GetArrayLength, nil, nil);
9393 RegisterFunctionName('SetArrayLength', SetArrayLength, nil, nil);
9394
9395 RegisterFunctionName('RaiseLastException', DefPRoc, Pointer(30), nil);
9396 RegisterFunctionName('RaiseException', DefPRoc, Pointer(31), nil);
9397 RegisterFunctionName('ExceptionType', DefPRoc, Pointer(32), nil);
9398 RegisterFunctionName('ExceptionParam', DefPRoc, Pointer(33), nil);
9399 RegisterFunctionName('ExceptionProc', DefPRoc, Pointer(34), nil);
9400 RegisterFunctionName('ExceptionPos', DefPRoc, Pointer(35), nil);
9401 RegisterFunctionName('ExceptionToString', DefProc, Pointer(36), nil);
9402 RegisterFunctionName('AnsiUpperCase', DefProc, Pointer(37), nil);
9403 RegisterFunctionName('AnsiLowerCase', DefProc, Pointer(38), nil);
9404
9405 {$IFNDEF PS_NOINT64}
9406 RegisterFunctionName('StrToInt64', DefProc, Pointer(39), nil);
9407 RegisterFunctionName('Int64ToStr', DefProc, Pointer(40), nil);
9408 RegisterFunctionName('StrToInt64Def', DefProc, Pointer(41), nil);
9409 {$ENDIF}
9410 RegisterFunctionName('SizeOf', DefProc, Pointer(42), nil);
9411
9412 {$IFNDEF PS_NOWIDESTRING}
9413 RegisterFunctionName('WStrGet', DefProc, Pointer(43), nil);
9414 RegisterFunctionName('WStrSet', DefProc, Pointer(44), nil);
9415
9416 {$ENDIF}
9417 {$IFNDEF DELPHI6UP}
_VarArrayGetnull9418 RegisterDelphiFunction(@_VarArrayGet, 'VarArrayGet', cdRegister);
_VarArraySetnull9419 RegisterDelphiFunction(@_VarArraySet, 'VarArraySet', cdRegister);
9420 {$ENDIF}
9421 RegisterInterfaceLibraryRuntime(Self);
9422 end;
9423
9424
ToStringnull9425 function ToString(p: PansiChar): tbtString;
9426 begin
9427 SetString(Result, p, StrLen(p));
9428 end;
9429
IntPIFVariantToVariantnull9430 function IntPIFVariantToVariant(Src: pointer; aType: TPSTypeRec; var Dest: Variant): Boolean;
BuildArraynull9431 function BuildArray(P: Pointer; aType: TPSTypeRec; Len: Longint): Boolean;
9432 var
9433 i, elsize: Longint;
9434 v: variant;
9435 begin
9436 elsize := aType.RealSize;
9437 Dest := VarArrayCreate([0, Len-1], varVariant);
9438 for i := 0 to Len -1 do
9439 begin
9440 if not IntPIFVariantToVariant(p, aType, v) then
9441 begin
9442 result := false;
9443 exit;
9444 end;
9445 Dest[i] := v;
9446 p := Pointer(IPointer(p) + Cardinal(elSize));
9447 end;
9448 result := true;
9449 end;
9450 begin
9451 if aType = nil then
9452 begin
9453 Dest := null;
9454 Result := True;
9455 exit;
9456 end;
9457 if aType.BaseType = btPointer then
9458 begin
9459 aType := TPSTypeRec(Pointer(IPointer(src)+PointerSize)^);
9460 Src := Pointer(Pointer(Src)^);
9461 end;
9462
9463 case aType.BaseType of
9464 btVariant: Dest := variant(src^);
9465 btArray: if not BuildArray(Pointer(Src^), TPSTypeRec_Array(aType).ArrayType, PSDynArrayGetLength(Pointer(src^), aType)) then begin result := false; exit; end;
9466 btStaticArray: if not BuildArray(Pointer(Src), TPSTypeRec_StaticArray(aType).ArrayType, PSDynArrayGetLength(Pointer(src^), aType)) then begin result := false; exit; end;
9467 btU8:
9468 if aType.ExportName = 'BOOLEAN' then
9469 Dest := boolean(tbtu8(Src^) <> 0)
9470 else
9471 Dest := tbtu8(Src^);
9472 btS8: Dest := tbts8(Src^);
9473 btU16: Dest := tbtu16(Src^);
9474 btS16: Dest := tbts16(Src^);
9475 btU32: Dest := {$IFDEF DELPHI6UP}tbtu32{$ELSE}tbts32{$ENDIF}(Src^);
9476 btS32: Dest := tbts32(Src^);
9477 btSingle: Dest := tbtsingle(Src^);
9478 btCurrency: Dest:=tbtCurrency(Src^);
9479 btDouble:
9480 begin
9481 if aType.ExportName = 'TDATETIME' then
9482 Dest := TDateTime(tbtDouble(Src^))
9483 else
9484 Dest := tbtDouble(Src^);
9485 end;
9486 btExtended: Dest := tbtExtended(Src^);
9487 btString: Dest := tbtString(Src^);
9488 btPChar: Dest := ToString(PansiChar(Src^));
9489 {$IFNDEF PS_NOINT64}
9490 {$IFDEF DELPHI6UP} btS64: Dest := tbts64(Src^); {$ELSE} bts64: begin Result := False; exit; end; {$ENDIF}
9491 {$ENDIF}
9492 btChar: Dest := tbtString(tbtchar(src^));
9493 {$IFNDEF PS_NOWIDESTRING}
9494 btWideString: Dest := tbtWideString(src^);
9495 btWideChar: Dest := tbtwidestring(tbtwidechar(src^));
9496 btUnicodeString: Dest := tbtUnicodeString(src^);
9497 {$ENDIF}
9498 else
9499 begin
9500 Result := False;
9501 exit;
9502 end;
9503 end;
9504 Result := True;
9505 end;
9506
PIFVariantToVariantnull9507 function PIFVariantToVariant(Src: PIFVariant; var Dest: Variant): Boolean;
9508 begin
9509 Result := IntPIFVariantToVariant(@PPSVariantData(src).Data, Src.FType, Dest);
9510 end;
9511
VariantToPIFVariantnull9512 function VariantToPIFVariant(Exec: TPSExec; const Src: Variant; Dest: PIFVariant): Boolean;
9513 var
9514 TT: PIFTypeRec;
9515 begin
9516 if Dest = nil then begin Result := false; exit; end;
9517 tt := Exec.FindType2(btVariant);
9518 if tt = nil then begin Result := false; exit; end;
9519 if Dest.FType.BaseType = btPointer then
9520 Result := Exec.SetVariantValue(PPSVariantPointer(Dest).DataDest, @Src, PPSVariantPointer(Dest).DestType, tt)
9521 else
9522 Result := Exec.SetVariantValue(@PPSVariantData(Dest).Data, @Src, Dest.FType, tt);
9523 end;
9524
9525 type
9526 POpenArray = ^TOpenArray;
9527 TOpenArray = record
9528 AType: Byte; {0}
9529 OrgVar: PPSVariantIFC;
9530 FreeIt: Boolean;
9531 ElementSize,
9532 ItemCount: Longint;
9533 Data: Pointer;
9534 VarParam: Boolean;
9535 end;
CreateOpenArraynull9536 function CreateOpenArray(VarParam: Boolean; Sender: TPSExec; val: PPSVariantIFC): POpenArray;
9537 var
9538 datap, p: Pointer;
9539 ctype: TPSTypeRec;
9540 cp: Pointer;
9541 i: Longint;
9542 begin
9543 if (Val.aType.BaseType <> btArray) and (val.aType.BaseType <> btStaticArray) then
9544 begin
9545 Result := nil;
9546 exit;
9547 end;
9548 New(Result);
9549 Result.AType := 0;
9550 Result.OrgVar := Val;
9551 Result.VarParam := VarParam;
9552
9553 if val.aType.BaseType = btStaticArray then
9554 begin
9555 Result^.ItemCount := TPSTypeRec_StaticArray(val.aType).Size;
9556 datap := Val.Dta;
9557 end else
9558 begin
9559 Result^.ItemCount := PSDynArrayGetLength(Pointer(Val.Dta^), val.aType);
9560 datap := Pointer(Val.Dta^);
9561 end;
9562 if TPSTypeRec_Array(Val.aType).ArrayType.BaseType <> btPointer then
9563 begin
9564 Result.FreeIt := False;
9565 result.ElementSize := 0;
9566 Result.Data := datap;
9567 exit;
9568 end;
9569 Result.FreeIt := True;
9570 Result.ElementSize := sizeof(TVarRec);
9571 GetMem(Result.Data, Result.ItemCount * Result.ElementSize);
9572 P := Result.Data;
9573 FillChar(p^, Result^.ItemCount * Result^.ElementSize, 0);
9574 for i := 0 to Result^.ItemCount -1 do
9575 begin
9576 ctype := Pointer(Pointer(IPointer(datap)+PointerSize)^);
9577 cp := Pointer(Datap^);
9578 if cp = nil then
9579 begin
9580 tvarrec(p^).VType := vtPointer;
9581 tvarrec(p^).VPointer := nil;
9582 end else begin
9583 case ctype.BaseType of
9584 btVariant: begin
9585 tvarrec(p^).VType := vtVariant;
9586 tvarrec(p^).VVariant := cp;
9587 end;
9588 btchar: begin
9589 tvarrec(p^).VType := vtChar;
9590 tvarrec(p^).VChar := tbtChar(tbtchar(cp^));
9591 end;
9592 btSingle:
9593 begin
9594 tvarrec(p^).VType := vtExtended;
9595 New(tvarrec(p^).VExtended);
9596 tvarrec(p^).VExtended^ := tbtsingle(cp^);
9597 end;
9598 btExtended:
9599 begin
9600 tvarrec(p^).VType := vtExtended;
9601 New(tvarrec(p^).VExtended);
9602 tvarrec(p^).VExtended^ := tbtextended(cp^);;
9603 end;
9604 btDouble:
9605 begin
9606 tvarrec(p^).VType := vtExtended;
9607 New(tvarrec(p^).VExtended);
9608 tvarrec(p^).VExtended^ := tbtdouble(cp^);
9609 end;
9610 {$IFNDEF PS_NOWIDESTRING}
9611 btwidechar: begin
9612 tvarrec(p^).VType := vtWideChar;
9613 tvarrec(p^).VWideChar := tbtwidechar(cp^);
9614 end;
9615 {$IFDEF DELPHI2009UP}
9616 btUnicodeString: begin
9617 tvarrec(p^).VType := vtUnicodeString;
9618 tbtunicodestring(TVarRec(p^).VUnicodeString) := tbtunicodestring(cp^);
9619 end;
9620 {$ELSE}
9621 btUnicodeString,
9622 {$ENDIF}
9623 btwideString: begin
9624 tvarrec(p^).VType := vtWideString;
9625 tbtwidestring(TVarRec(p^).VWideString) := tbtwidestring(cp^);
9626 end;
9627 {$ENDIF}
9628 btU8: begin
9629 tvarrec(p^).VType := vtInteger;
9630 tvarrec(p^).VInteger := tbtu8(cp^);
9631 end;
9632 btS8: begin
9633 tvarrec(p^).VType := vtInteger;
9634 tvarrec(p^).VInteger := tbts8(cp^);
9635 end;
9636 btU16: begin
9637 tvarrec(p^).VType := vtInteger;
9638 tvarrec(p^).VInteger := tbtu16(cp^);
9639 end;
9640 btS16: begin
9641 tvarrec(p^).VType := vtInteger;
9642 tvarrec(p^).VInteger := tbts16(cp^);
9643 end;
9644 btU32: begin
9645 tvarrec(p^).VType := vtInteger;
9646 tvarrec(p^).VInteger := tbtu32(cp^);
9647 end;
9648 btS32: begin
9649 tvarrec(p^).VType := vtInteger;
9650 tvarrec(p^).VInteger := tbts32(cp^);
9651 end;
9652 {$IFNDEF PS_NOINT64}
9653 btS64: begin
9654 tvarrec(p^).VType := vtInt64;
9655 New(tvarrec(p^).VInt64);
9656 tvarrec(p^).VInt64^ := tbts64(cp^);
9657 end;
9658 {$ENDIF}
9659 btString: begin
9660 tvarrec(p^).VType := vtAnsiString;
9661 tbtString(TVarRec(p^).VAnsiString) := tbtstring(cp^);
9662 end;
9663 btPChar:
9664 begin
9665 tvarrec(p^).VType := vtPchar;
9666 TVarRec(p^).VPChar := pointer(cp^);
9667 end;
9668 btClass:
9669 begin
9670 tvarrec(p^).VType := vtObject;
9671 tvarrec(p^).VObject := Pointer(cp^);
9672 end;
9673 {$IFNDEF PS_NOINTERFACES}
9674 {$IFDEF Delphi3UP}
9675 btInterface:
9676 begin
9677 tvarrec(p^).VType := vtInterface;
9678 IUnknown(tvarrec(p^).VInterface) := IUnknown(cp^);
9679 end;
9680
9681 {$ENDIF}
9682 {$ENDIF}
9683 end;
9684 end;
9685 datap := Pointer(IPointer(datap)+ (3*sizeof(Pointer)));
9686 p := PansiChar(p) + Result^.ElementSize;
9687 end;
9688 end;
9689
9690 procedure DestroyOpenArray(Sender: TPSExec; V: POpenArray);
9691 var
9692 cp, datap: pointer;
9693 ctype: TPSTypeRec;
9694 p: PVarRec;
9695 i: Longint;
9696 begin
9697 if v.FreeIt then // basetype = btPointer
9698 begin
9699 p := v^.Data;
9700 if v.OrgVar.aType.BaseType = btStaticArray then
9701 datap := v.OrgVar.Dta
9702 else
9703 datap := Pointer(v.OrgVar.Dta^);
9704 for i := 0 to v^.ItemCount -1 do
9705 begin
9706 ctype := Pointer(Pointer(IPointer(datap)+PointerSize)^);
9707 cp := Pointer(Datap^);
9708 case ctype.BaseType of
9709 btU8:
9710 begin
9711 if v^.varParam then
9712 tbtu8(cp^) := tvarrec(p^).VInteger
9713 end;
9714 btS8: begin
9715 if v^.varParam then
9716 tbts8(cp^) := tvarrec(p^).VInteger
9717 end;
9718 btU16: begin
9719 if v^.varParam then
9720 tbtu16(cp^) := tvarrec(p^).VInteger
9721 end;
9722 btS16: begin
9723 if v^.varParam then
9724 tbts16(cp^) := tvarrec(p^).VInteger
9725 end;
9726 btU32: begin
9727 if v^.varParam then
9728 tbtu32(cp^) := tvarrec(p^).VInteger
9729 end;
9730 btS32: begin
9731 if v^.varParam then
9732 tbts32(cp^) := tvarrec(p^).VInteger
9733 end;
9734 btChar: begin
9735 if v^.VarParam then
9736 tbtchar(cp^) := tbtChar(tvarrec(p^).VChar)
9737 end;
9738 btSingle: begin
9739 if v^.VarParam then
9740 tbtsingle(cp^) := tvarrec(p^).vextended^;
9741 dispose(tvarrec(p^).vextended);
9742 end;
9743 btDouble: begin
9744 if v^.VarParam then
9745 tbtdouble(cp^) := tvarrec(p^).vextended^;
9746 dispose(tvarrec(p^).vextended);
9747 end;
9748 btExtended: begin
9749 if v^.VarParam then
9750 tbtextended(cp^) := tvarrec(p^).vextended^;
9751 dispose(tvarrec(p^).vextended);
9752 end;
9753 {$IFNDEF PS_NOINT64}
9754 btS64: begin
9755 if v^.VarParam then
9756 tbts64(cp^) := tvarrec(p^).vInt64^;
9757 dispose(tvarrec(p^).VInt64);
9758 end;
9759 {$ENDIF}
9760 {$IFNDEF PS_NOWIDESTRING}
9761 btWideChar: begin
9762 if v^.varParam then
9763 tbtwidechar(cp^) := tvarrec(p^).VWideChar;
9764 end;
9765 {$IFDEF DELPHI2009UP}
9766 btUnicodeString:
9767 begin
9768 if v^.VarParam then
9769 tbtunicodestring(cp^) := tbtunicodestring(TVarRec(p^).VUnicodeString);
9770 finalize(tbtunicodestring(TVarRec(p^).VUnicodeString));
9771 end;
9772 {$ELSE}
9773 btUnicodeString,
9774 {$ENDIF}
9775 btWideString:
9776 begin
9777 if v^.VarParam then
9778 tbtwidestring(cp^) := tbtwidestring(TVarRec(p^).VWideString);
9779 finalize(widestring(TVarRec(p^).VWideString));
9780 end;
9781 {$ENDIF}
9782 btString: begin
9783 if v^.VarParam then
9784 tbtstring(cp^) := tbtstring(TVarRec(p^).VString);
9785 finalize(tbtString(TVarRec(p^).VAnsiString));
9786 end;
9787 btClass: begin
9788 if v^.VarParam then
9789 Pointer(cp^) := TVarRec(p^).VObject;
9790 end;
9791 {$IFNDEF PS_NOINTERFACES}
9792 {$IFDEF Delphi3UP}
9793 btInterface: begin
9794 if v^.VarParam then
9795 IUnknown(cp^) := IUnknown(TVarRec(p^).VInterface);
9796 finalize(tbtString(TVarRec(p^).VAnsiString));
9797 end;
9798 {$ENDIF}
9799 {$ENDIF}
9800 end;
9801 datap := Pointer(IPointer(datap)+ (3*sizeof(Pointer)));
9802 p := Pointer(IPointer(p) + Cardinal(v^.ElementSize));
9803 end;
9804 FreeMem(v.Data, v.ElementSize * v.ItemCount);
9805 end;
9806 Dispose(V);
9807 end;
9808
9809
9810 {$ifndef FPC}
9811 {$IFDEF Delphi6UP}
9812 {$IFDEF CPUX64}
9813 {$include x64.inc}
9814 {$ELSE}
9815 {$include x86.inc}
9816 {$ENDIF}
9817 {$ELSE}
9818 {$include x86.inc}
9819 {$ENDIF}
9820 {$else}
9821 {$IFDEF Delphi6UP}
9822 {$if defined(cpu86)}
9823 {$include x86.inc}
9824 {$elseif defined(cpupowerpc)}
9825 {$include powerpc.inc}
9826 {$elseif defined(cpuarm)}
9827 {$include arm.inc}
9828 {$elseif defined(CPUX86_64)}
9829 {$include x64.inc}
9830 {$else}
9831 {$WARNING Pascal Script is not supported for your architecture at the moment!}
TPSExec.InnerfuseCallnull9832 function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean;
9833 begin
9834 raise exception.create('This code is not supported on this CPU at the moment!');
9835 Result := True;
9836 end;
9837 {$ifend}
9838 {$ELSE}
9839 {$include x86.inc}
9840 {$ENDIF}
9841 {$endif}
9842
9843 type
9844 PScriptMethodInfo = ^TScriptMethodInfo;
9845 TScriptMethodInfo = record
9846 Se: TPSExec;
9847 ProcNo: Cardinal;
9848 end;
9849
9850
MkMethodnull9851 function MkMethod(FSE: TPSExec; No: Cardinal): TMethod;
9852 begin
9853 if (no = 0) or (no = InvalidVal) then
9854 begin
9855 Result.Code := nil;
9856 Result.Data := nil;
9857 end else begin
9858 Result.Code := @MyAllMethodsHandler;
9859 Result.Data := GetMethodInfoRec(FSE, No);
9860 end;
9861 end;
9862
9863
9864 procedure PFree(Sender: TPSExec; P: PScriptMethodInfo);
9865 begin
9866 Dispose(p);
9867 end;
9868
GetMethodInfoRecnull9869 function GetMethodInfoRec(SE: TPSExec; ProcNo: Cardinal): Pointer;
9870 var
9871 I: Longint;
9872 pp: PScriptMethodInfo;
9873 begin
9874 if (ProcNo = 0) or (ProcNo = InvalidVal) then
9875 begin
9876 Result := nil;
9877 exit;
9878 end;
9879 I := 2147483647;
9880 repeat
9881 pp := Se.FindProcResource2(@PFree, I);
9882 if (i <> -1) and (pp^.ProcNo = ProcNo) then
9883 begin
9884 Result := Pp;
9885 exit;
9886 end;
9887 until i = -1;
9888 New(pp);
9889 pp^.Se := TPSExec(Se);
9890 pp^.ProcNo := Procno;
9891 Se.AddResource(@PFree, pp);
9892 Result := pp;
9893 end;
9894
9895
9896
9897
9898
9899 type
9900 TPtrArr = array[0..1000] of Pointer;
9901 PPtrArr = ^TPtrArr;
9902 TByteArr = array[0..1000] of byte;
9903 PByteArr = ^TByteArr;
9904 PPointer = ^Pointer;
9905
9906
VirtualMethodPtrToPtrnull9907 function VirtualMethodPtrToPtr(Ptr, FSelf: Pointer): Pointer;
9908 {$IFDEF FPC}
9909 var
9910 x : PPtrArr;
9911 {$ENDIF}
9912 begin
9913 {$IFDEF FPC}
9914 x := Pointer(TObject(FSelf).ClassType) + vmtMethodStart;
9915 Result := x^[Longint(Ptr)];
9916 {$ELSE}
9917 Result := PPtrArr(PPointer(FSelf)^)^[Longint(Ptr)];
9918 {$ENDIF}
9919 end;
9920
VirtualClassMethodPtrToPtrnull9921 function VirtualClassMethodPtrToPtr(Ptr, FSelf: Pointer): Pointer;
9922 {$IFDEF FPC}
9923 var
9924 x : PPtrArr;
9925 {$ENDIF}
9926 begin
9927 {$IFDEF FPC}
9928 x := Pointer(FSelf) + vmtMethodStart;
9929 Result := x^[Longint(Ptr)];
9930 {$ELSE}
9931 Result := PPtrArr(FSelf)^[Longint(Ptr)];
9932 {$ENDIF}
9933 end;
9934
9935
9936 procedure CheckPackagePtr(var P: PByteArr);
9937 begin
9938 {$ifdef Win32}
9939 if (word((@p[0])^) = $25FF) and (word((@p[6])^)=$C08B)then
9940 begin
9941 p := PPointer((@p[2])^)^;
9942 end;
9943 {$endif}
9944 {$ifdef Win64}
9945 if (word((@p[0])^) = $25FF) {and (word((@p[6])^)=$C08B)}then
9946 begin
9947 p := PPointer(NativeUInt(@P[0]) + Cardinal((@p[2])^) + 6{Instruction Size})^
9948 end;
9949 {$endif}
9950 end;
9951
9952 {$IFDEF VER90}{$DEFINE NO_vmtSelfPtr}{$ENDIF}
9953 {$IFDEF FPC}{$DEFINE NO_vmtSelfPtr}{$ENDIF}
9954
9955 {$IFNDEF FPC}
9956
FindVirtualMethodPtrnull9957 function FindVirtualMethodPtr(Ret: TPSRuntimeClass; FClass: TClass; Ptr: Pointer): Pointer;
9958 // Idea of getting the number of VMT items from GExperts
9959 var
9960 p: PPtrArr;
9961 I: Longint;
9962 begin
9963 p := Pointer(FClass);
9964 CheckPackagePtr(PByteArr(Ptr));
9965 if Ret.FEndOfVMT = MaxInt then
9966 begin
9967 I := {$IFDEF NO_vmtSelfPtr}-48{$ELSE}vmtSelfPtr{$ENDIF} div SizeOf(Pointer) + 1;
9968 while I < 0 do
9969 begin
9970 if I < 0 then
9971 begin
9972 if I <> ({$IFDEF VER90}-44{$ELSE}vmtTypeInfo{$ENDIF} div SizeOf(Pointer)) then
9973 begin // from GExperts code
9974 if (IPointer(p^[I]) > IPointer(p)) and ((IPointer(p^[I]) - IPointer(p))
9975 div
9976 //PointerSize < Ret.FEndOfVMT) then
9977 PointerSize < Cardinal(Ret.FEndOfVMT)) then
9978 begin
9979 Ret.FEndOfVMT := (IPointer(p^[I]) - IPointer(p)) div SizeOf(Pointer);
9980 end;
9981 end;
9982 end;
9983 Inc(I);
9984 end;
9985 if Ret.FEndOfVMT = MaxInt then
9986 begin
9987 Ret.FEndOfVMT := 0; // cound not find EndOfVMT
9988 Result := nil;
9989 exit;
9990 end;
9991 end;
9992 I := 0;
9993 while I < Ret.FEndOfVMT do
9994 begin
9995 if p^[I] = Ptr then
9996 begin
9997 Result := Pointer(I);
9998 exit;
9999 end;
10000 I := I + 1;
10001 end;
10002 Result := nil;
10003 end;
10004
10005 {$ELSE}
10006
FindVirtualMethodPtrnull10007 function FindVirtualMethodPtr(Ret: TPSRuntimeClass; FClass: TClass; Ptr: Pointer): Pointer;
10008 var
10009 x,p: PPtrArr;
10010 I: Longint;
10011 t : Pointer;
10012 begin
10013 p := Pointer(FClass) + vmtMethodStart;
10014 I := 0;
10015 while (p^[I]<>nil) and (I < 10000) do
10016 begin
10017 if p^[I] = Ptr then
10018 begin
10019 Result := Pointer(I);
10020 x := Pointer(FClass) + vmtMethodStart;
10021 t := x^[I];
10022 Assert(t=Ptr,'Computation of virtual method pointer fail : t<>Ptr');
10023 exit;
10024 end;
10025 I := I + 1;
10026 end;
10027 Result := nil;
10028 end;
10029
10030 {$ENDIF}
10031
10032
NewTPSVariantIFCnull10033 function NewTPSVariantIFC(avar: PPSVariant; varparam: boolean): TPSVariantIFC;
10034 begin
10035 Result.VarParam := varparam;
10036 if avar = nil then
10037 begin
10038 Result.aType := nil;
10039 result.Dta := nil;
10040 end else
10041 begin
10042 Result.aType := avar.FType;
10043 result.Dta := @PPSVariantData(avar).Data;
10044 if Result.aType.BaseType = btPointer then
10045 begin
10046 Result.aType := Pointer(Pointer(IPointer(result.dta)+ PointerSize)^);
10047 Result.Dta := Pointer(Result.dta^);
10048 end;
10049 end;
10050 end;
10051
NewTPSVariantRecordIFCnull10052 function NewTPSVariantRecordIFC(avar: PPSVariant; Fieldno: Longint): TPSVariantIFC;
10053 var
10054 offs: Cardinal;
10055 begin
10056 Result := NewTPSVariantIFC(avar, false);
10057 if Result.aType.BaseType = btRecord then
10058 begin
10059 Offs := Cardinal(TPSTypeRec_Record(Result.aType).RealFieldOffsets[FieldNo]);
10060 Result.Dta := Pointer(IPointer(Result.dta) + Offs);
10061 Result.aType := TPSTypeRec_Record(Result.aType).FieldTypes[FieldNo];
10062 end else
10063 begin
10064 Result.Dta := nil;
10065 Result.aType := nil;
10066 end;
10067 end;
10068
PSGetArrayFieldnull10069 function PSGetArrayField(const avar: TPSVariantIFC; Fieldno: Longint): TPSVariantIFC;
10070 var
10071 offs: Cardinal;
10072 n: Longint;
10073 begin
10074 Result := aVar;
10075 case Result.aType.BaseType of
10076 btStaticArray, btArray:
10077 begin
10078 if Result.aType.BaseType = btStaticArray then
10079 n := TPSTypeRec_StaticArray(Result.aType).Size
10080 else
10081 n := PSDynArrayGetLength(Pointer(Result.Dta^), Result.aType);
10082 if (FieldNo <0) or (FieldNo >= n) then
10083 begin
10084 Result.Dta := nil;
10085 Result.aType := nil;
10086 exit;
10087 end;
10088 Offs := TPSTypeRec_Array(Result.aType).ArrayType.RealSize * Cardinal(FieldNo);
10089 if Result.aType.BaseType = btStaticArray then
10090 Result.Dta := Pointer(IPointer(Result.dta) + Offs)
10091 else
10092 Result.Dta := Pointer(IPointer(Result.dta^) + Offs);
10093 Result.aType := TPSTypeRec_Array(Result.aType).ArrayType;
10094 end
10095 else
10096 Result.Dta := nil;
10097 Result.aType := nil;
10098 end;
10099 end;
10100
PSGetRecFieldnull10101 function PSGetRecField(const avar: TPSVariantIFC; Fieldno: Longint): TPSVariantIFC;
10102 var
10103 offs: Cardinal;
10104 begin
10105 Result := aVar;
10106 if Result.aType.BaseType = btRecord then
10107 begin
10108 Offs := Cardinal(TPSTypeRec_Record(Result.aType).RealFieldOffsets[FieldNo]);
10109 Result.aType := TPSTypeRec_Record(Result.aType).FieldTypes[FieldNo];
10110 Result.Dta := Pointer(IPointer(Result.dta) + Offs);
10111 end else
10112 begin
10113 Result.Dta := nil;
10114 Result.aType := nil;
10115 end;
10116 end;
10117
NewPPSVariantIFCnull10118 function NewPPSVariantIFC(avar: PPSVariant; varparam: boolean): PPSVariantIFC;
10119 begin
10120 New(Result);
10121 Result^ := NewTPSVariantIFC(avar, varparam);
10122 end;
10123
10124
10125 procedure DisposePPSVariantIFC(aVar: PPSVariantIFC);
10126 begin
10127 if avar <> nil then
10128 Dispose(avar);
10129 end;
10130
10131 procedure DisposePPSVariantIFCList(list: TPSList);
10132 var
10133 i: Longint;
10134 begin
10135 for i := list.Count -1 downto 0 do
10136 DisposePPSVariantIFC(list[i]);
10137 list.free;
10138 end;
10139
ClassCallProcMethodnull10140 function ClassCallProcMethod(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
10141 var
10142 i: Integer;
10143 MyList: TPSList;
10144 n: PIFVariant;
10145 v: PPSVariantIFC;
10146 FSelf: Pointer;
10147 CurrStack: Cardinal;
10148 cc: TPSCallingConvention;
10149 s: tbtString;
10150 begin
10151 s := p.Decl;
10152 if length(S) < 2 then
10153 begin
10154 Result := False;
10155 exit;
10156 end;
10157 cc := TPSCallingConvention(s[1]);
10158 Delete(s, 1, 1);
10159 if s[1] = #0 then
10160 n := Stack[Stack.Count -1]
10161 else
10162 n := Stack[Stack.Count -2];
10163 if (n = nil) or (n^.FType.BaseType <> btClass)or (PPSVariantClass(n).Data = nil) then
10164 begin
10165 Caller.CMD_Err(erNullPointerException);
10166 result := false;
10167 exit;
10168 end;
10169 FSelf := PPSVariantClass(n).Data;
10170 CurrStack := Cardinal(Stack.Count) - Cardinal(length(s)) -1;
10171 if s[1] = #0 then inc(CurrStack);
10172 MyList := TPSList.Create;
10173 for i := 2 to length(s) do
10174 begin
10175 MyList.Add(nil);
10176 end;
10177 for i := length(s) downto 2 do
10178 begin
10179 n := Stack[CurrStack];
10180 MyList[i - 2] := NewPPSVariantIFC(n, s[i] <> #0);
10181 inc(CurrStack);
10182 end;
10183 if s[1] <> #0 then
10184 begin
10185 v := NewPPSVariantIFC(Stack[CurrStack + 1], True);
10186 end else v := nil;
10187 try
10188 if p.Ext2 = nil then
10189 Result := Caller.InnerfuseCall(FSelf, p.Ext1, cc, MyList, v)
10190 else
10191 Result := Caller.InnerfuseCall(FSelf, VirtualMethodPtrToPtr(p.Ext1, FSelf), cc, MyList, v);
10192 finally
10193 DisposePPSVariantIFC(v);
10194 DisposePPSVariantIFCList(mylist);
10195 end;
10196 end;
10197
ClassCallProcConstructornull10198 function ClassCallProcConstructor(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
10199 var
10200 i, h: Longint;
10201 v: PPSVariantIFC;
10202 MyList: TPSList;
10203 n: PIFVariant;
10204 FSelf: Pointer;
10205 CurrStack: Cardinal;
10206 cc: TPSCallingConvention;
10207 s: tbtString;
10208 FType: PIFTypeRec;
10209 x: TPSRuntimeClass;
10210 IntVal: PIFVariant;
10211 begin
10212 n := Stack[Stack.Count -2];
10213 if (n = nil) or (n^.FType.BaseType <> btU32) then
10214 begin
10215 result := false;
10216 exit;
10217 end;
10218 FType := Caller.GetTypeNo(PPSVariantU32(N).Data);
10219 if (FType = nil) then
10220 begin
10221 Result := False;
10222 exit;
10223 end;
10224 h := MakeHash(FType.ExportName);
10225 FSelf := nil;
10226 for i := 0 to TPSRuntimeClassImporter(p.Ext2).FClasses.Count -1 do
10227 begin
10228 x:= TPSRuntimeClassImporter(p.Ext2).FClasses[i];
10229 if (x.FClassNameHash = h) and (x.FClassName = FType.ExportName) then
10230 begin
10231 FSelf := x.FClass;
10232 end;
10233 end;
10234 if FSelf = nil then begin
10235 Result := False;
10236 exit;
10237 end;
10238 s := p.Decl;
10239 if length(S) < 2 then
10240 begin
10241 Result := False;
10242 exit;
10243 end;
10244 cc := TPSCallingConvention(s[1]);
10245 Delete(s, 1, 1);
10246 CurrStack := Cardinal(Stack.Count) - Cardinal(length(s)) -1;
10247 if s[1] = #0 then inc(CurrStack);
10248 {$IFDEF CPU64}
10249 IntVal := CreateHeapVariant(Caller.FindType2(btS64));
10250 {$ELSE}
10251 IntVal := CreateHeapVariant(Caller.FindType2(btU32));
10252 {$ENDIF}
10253 if IntVal = nil then
10254 begin
10255 Result := False;
10256 exit;
10257 end;
10258 {$IFDEF FPC}
10259 // under FPC a constructor it's called with self=0 (EAX) and
10260 // the VMT class pointer in EDX so they are effectively swaped
10261 // using register calling convention
10262 {$IFDEF CPU64}
10263 PPSVariantS64(IntVal).Data := Int64(FSelf);
10264 {$ELSE}
10265 PPSVariantU32(IntVal).Data := Cardinal(FSelf);
10266 {$ENDIF}
10267 FSelf := pointer(1);
10268 {$ELSE}
10269 PPSVariantU32(IntVal).Data := 1;
10270 {$ENDIF}
10271 MyList := TPSList.Create;
10272 MyList.Add(NewPPSVariantIFC(intval, false));
10273 for i := 2 to length(s) do
10274 begin
10275 MyList.Add(nil);
10276 end;
10277 for i := length(s) downto 2 do
10278 begin
10279 n :=Stack[CurrStack];
10280 // if s[i] <> #0 then
10281 // begin
10282 // MyList[i - 2] := NewPPSVariantIFC(n, s[i] <> #0);
10283 // end;
10284 MyList[i - 1] := NewPPSVariantIFC(n, s[i] <> #0);
10285 inc(CurrStack);
10286 end;
10287 if s[1] <> #0 then
10288 begin
10289 v := NewPPSVariantIFC(Stack[CurrStack + 1], True);
10290 end else v := nil;
10291 try
10292 Result := Caller.InnerfuseCall(FSelf, p.Ext1, {$IFDEF FPC}TPSCallingConvention(Integer(cc) or 64){$ELSE}cc{$ENDIF}, MyList, v);
10293 finally
10294 DisposePPSVariantIFC(v);
10295 DisposePPSVariantIFCList(mylist);
10296 DestroyHeapVariant(intval);
10297 end;
10298 end;
10299
10300
10301 function ClassCallProcVirtualConstructor(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
10302 var
10303 i, h: Longint;
10304 v: PPSVariantIFC;
10305 MyList: TPSList;
10306 n: PIFVariant;
10307 FSelf: Pointer;
10308 CurrStack: Cardinal;
10309 cc: TPSCallingConvention;
10310 s: tbtString;
10311 FType: PIFTypeRec;
10312 x: TPSRuntimeClass;
10313 IntVal: PIFVariant;
10314 begin
10315 n := Stack[Stack.Count -2];
10316 if (n = nil) or (n^.FType.BaseType <> btU32) then
10317 begin
10318 Caller.CMD_Err(erNullPointerException);
10319 result := false;
10320 exit;
10321 end;
10322 FType := Caller.GetTypeNo(PPSVariantU32(N).Data);
10323 if (FType = nil) then
10324 begin
10325 Caller.CMD_Err(erNullPointerException);
10326 Result := False;
10327 exit;
10328 end;
10329 h := MakeHash(FType.ExportName);
10330 FSelf := nil;
10331 for i := 0 to TPSRuntimeClassImporter(p.Ext2).FClasses.Count -1 do
10332 begin
10333 x:= TPSRuntimeClassImporter(p.Ext2).FClasses[i];
10334 if (x.FClassNameHash = h) and (x.FClassName = FType.ExportName) then
10335 begin
10336 FSelf := x.FClass;
10337 end;
10338 end;
10339 if FSelf = nil then begin
10340 Result := False;
10341 exit;
10342 end;
10343 s := p.Decl;
10344 if length(S) < 2 then
10345 begin
10346 Result := False;
10347 exit;
10348 end;
10349 cc := TPSCallingConvention(s[1]);
10350 delete(s, 1, 1);
10351 CurrStack := Cardinal(Stack.Count) - Cardinal(length(s)) -1;
10352 if s[1] = #0 then inc(CurrStack);
10353 IntVal := CreateHeapVariant(Caller.FindType2(btU32));
10354 if IntVal = nil then
10355 begin
10356 Result := False;
10357 exit;
10358 end;
10359 PPSVariantU32(IntVal).Data := 1;
10360 MyList := TPSList.Create;
10361 MyList.Add(NewPPSVariantIFC(intval, false));
10362 for i := 2 to length(s) do
10363 begin
10364 MyList.Add(nil);
10365 end;
10366 for i := length(s) downto 2 do
10367 begin
10368 n :=Stack[CurrStack];
10369 MyList[i - 1] := NewPPSVariantIFC(n, s[i] <> #0);
10370 inc(CurrStack);
10371 end;
10372 if s[1] <> #0 then
10373 begin
10374 v := NewPPSVariantIFC(Stack[CurrStack + 1], True);
10375 end else v := nil;
10376 try
10377 Result := Caller.InnerfuseCall(FSelf, VirtualClassMethodPtrToPtr(p.Ext1, FSelf), {$IFDEF FPC}TPSCallingConvention(Integer(cc) or 128){$ELSE}cc{$ENDIF}, MyList, v);
10378 finally
10379 DisposePPSVariantIFC(v);
10380 DisposePPSVariantIFCList(mylist);
10381 DestroyHeapVariant(intval);
10382 end;
10383 end;
10384
10385 function CastProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
10386 var
10387 TypeNo, InVar, ResVar: TPSVariantIFC;
10388 FSelf: TClass;
10389 FType: PIFTypeRec;
10390 H, I: Longint;
10391 x: TPSRuntimeClass;
10392 begin
10393 TypeNo := NewTPSVariantIFC(Stack[Stack.Count-3], false);
10394 InVar := NewTPSVariantIFC(Stack[Stack.Count-2], false);
10395 ResVar := NewTPSVariantIFC(Stack[Stack.Count-1], true);
10396 if (TypeNo.Dta = nil) or (InVar.Dta = nil) or (ResVar.Dta = nil) or
10397 (TypeNo.aType.BaseType <> btu32) or (resvar.aType <> Caller.FTypes[tbtu32(Typeno.dta^)])
10398 then
10399 begin
10400 Result := False;
10401 Exit;
10402 end;
10403 {$IFNDEF PS_NOINTERFACES}
10404 if (invar.atype.BaseType = btInterface) and (resvar.aType.BaseType = btInterface) then
10405 begin
10406 {$IFNDEF Delphi3UP}
10407 if IUnknown(resvar.Dta^) <> nil then
10408 IUnknown(resvar.Dta^).Release;
10409 {$ENDIF}
10410 IUnknown(resvar.Dta^) := nil;
10411 if (IUnknown(invar.Dta^) = nil) or (IUnknown(invar.Dta^).QueryInterface(TPSTypeRec_Interface(ResVar.aType).Guid, IUnknown(resvar.Dta^)) <> 0) then
10412 begin
10413 Caller.CMD_Err2(erCustomError, tbtString(RPS_CannotCastInterface));
10414 Result := False;
10415 exit;
10416 end;
10417 {$IFDEF Delphi3UP}
10418 end else if (Invar.aType.BaseType = btclass) and (resvar.aType.BaseType = btInterface) then
10419 begin
10420 {$IFNDEF Delphi3UP}
10421 if IUnknown(resvar.Dta^) <> nil then
10422 IUnknown(resvar.Dta^).Release;
10423 {$ENDIF}
10424 IUnknown(resvar.Dta^) := nil;
10425 if (TObject(invar.Dta^)= nil) or (not TObject(invar.dta^).GetInterface(TPSTypeRec_Interface(ResVar.aType).Guid, IUnknown(resvar.Dta^))) then
10426 begin
10427 Caller.CMD_Err2(erCustomError, tbtString(RPS_CannotCastInterface));
10428 Result := False;
10429 exit;
10430 end;
10431 {$ENDIF}
10432 end else {$ENDIF}if (invar.aType.BaseType = btclass) and (resvar.aType.BaseType = btclass ) then
10433 begin
10434 FType := Caller.GetTypeNo(tbtu32(TypeNo.Dta^));
10435 if (FType = nil) then
10436 begin
10437 Result := False;
10438 exit;
10439 end;
10440 h := MakeHash(FType.ExportName);
10441 FSelf := nil;
10442 for i := 0 to TPSRuntimeClassImporter(p.Ext2).FClasses.Count -1 do
10443 begin
10444 x:= TPSRuntimeClassImporter(p.Ext2).FClasses[i];
10445 if (x.FClassNameHash = h) and (x.FClassName = FType.ExportName) then
10446 begin
10447 FSelf := x.FClass;
10448 end;
10449 end;
10450 if FSelf = nil then begin
10451 Result := False;
10452 exit;
10453 end;
10454
10455 try
10456 TObject(ResVar.Dta^) := TObject(InVar.Dta^) as FSelf;
10457 except
10458 Result := False;
10459 Caller.CMD_Err2(erCustomError, tbtString(RPS_CannotCastObject));
10460 exit;
10461 end;
10462 end else
10463 begin
10464 Result := False;
10465 exit;
10466 end;
10467 result := True;
10468 end;
10469
10470
10471 function NilProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
10472 var
10473 n: TPSVariantIFC;
10474 begin
10475 n := NewTPSVariantIFC(Stack[Stack.Count-1], True);
10476 if (n.Dta = nil) or ((n.aType.BaseType <> btClass) and (n.aType.BaseType <> btInterface)) then
10477 begin
10478 Result := False;
10479 Caller.CMD_Err(erNullPointerException);
10480 Exit;
10481 end;
10482 {$IFNDEF PS_NOINTERFACES}
10483 if n.aType.BaseType = btInterface then
10484 begin
10485 {$IFNDEF Delphi3UP}
10486 if IUnknown(n.Dta^) <> nil then
10487 IUnknown(n.Dta^).Release;
10488 {$ENDIF}
10489 IUnknown(n.Dta^) := nil;
10490 end else
10491 {$ENDIF}
10492 Pointer(n.Dta^) := nil;
10493 result := True;
10494 end;
10495 function IntfCallProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
10496 var
10497 i: Integer;
10498 MyList: TPSList;
10499 n: TPSVariantIFC;
10500 n2: PPSVariantIFC;
10501 FSelf: Pointer;
10502 CurrStack: Cardinal;
10503 cc: TPSCallingConvention;
10504 s: tbtString;
10505 begin
10506 s := p.Decl;
10507 if length(S) < 2 then
10508 begin
10509 Result := False;
10510 exit;
10511 end;
10512 cc := TPSCallingConvention(s[1]);
10513 Delete(s, 1, 1);
10514 if s[1] = #0 then
10515 n := NewTPSVariantIFC(Stack[Stack.Count -1], false)
10516 else
10517 n := NewTPSVariantIFC(Stack[Stack.Count -2], false);
10518 if (n.dta = nil) or (n.atype.BaseType <> btInterface) or (Pointer(n.Dta^) = nil) then
10519 begin
10520 Caller.CMD_Err(erNullPointerException);
10521 result := false;
10522 exit;
10523 end;
10524 FSelf := Pointer(n.dta^);
10525 CurrStack := Cardinal(Stack.Count) - Cardinal(length(s)) -1;
10526 if s[1] = #0 then inc(CurrStack);
10527 MyList := TPSList.Create;
10528 for i := 2 to length(s) do
10529 begin
10530 MyList.Add(nil);
10531 end;
10532 for i := length(s) downto 2 do
10533 begin
10534 MyList[i - 2] := NewPPSVariantIFC(Stack[CurrStack], s[i] <> #0);
10535 inc(CurrStack);
10536 end;
10537 if s[1] <> #0 then
10538 begin
10539 n2 := NewPPSVariantIFC(Stack[CurrStack + 1], True);
10540 end else n2 := nil;
10541 try
10542 Caller.InnerfuseCall(FSelf, Pointer(Pointer(IPointer(FSelf^) + (Cardinal(p.Ext1) * Sizeof(Pointer)))^), cc, MyList, n2);
10543 result := true;
10544 finally
10545 DisposePPSVariantIFC(n2);
10546 DisposePPSVariantIFCList(MyList);
10547 end;
10548 end;
10549
10550
10551 function InterfaceProc(Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean;
10552 var
10553 s: tbtString;
10554 begin
10555 s := p.Decl;
10556 delete(s,1,5); // delete 'intf:'
10557 if s = '' then
10558 begin
10559 Result := False;
10560 exit;
10561 end;
10562 if s[1] = '.'then
10563 begin
10564 Delete(s,1,1);
10565 if length(S) < 6 then
10566 begin
10567 Result := False;
10568 exit;
10569 end;
10570 p.ProcPtr := IntfCallProc;
10571 p.Ext1 := Pointer((@s[1])^); // Proc Offset
10572 Delete(s,1,4);
10573 P.Decl := s;
10574 Result := True;
10575 end else Result := False;
10576 end;
10577
10578
10579 function getMethodNo(P: TMethod; SE: TPSExec): Cardinal;
10580 begin
10581 if (p.Code <> @MyAllMethodsHandler) or (p.Data = nil)or (PScriptMethodInfo(p.Data)^.Se <> se) then
10582 Result := 0
10583 else
10584 begin
10585 Result := PScriptMethodInfo(p.Data)^.ProcNo;
10586 end;
10587 end;
10588
10589 function ClassCallProcProperty(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
10590 var
10591 n: TPSVariantIFC;
10592 ltemp: Longint;
10593 FSelf: Pointer;
10594 m: TMethod;
10595 begin
10596 try
10597 if p.Ext2 = Pointer(0) then
10598 begin
10599 n := NewTPSVariantIFC(Stack[Stack.Count -1], False);
10600 if (n.Dta = nil) or (n.aType.BaseType <> btclass) then
10601 begin
10602 result := false;
10603 Caller.CMD_Err(erNullPointerException);
10604 exit;
10605 end;
10606 FSelf := Pointer(n.dta^);
10607 if FSelf = nil then
10608 begin
10609 Caller.CMD_Err(erCouldNotCallProc);
10610 Result := False;
10611 exit;
10612 end;
10613 n := NewTPSVariantIFC(Stack[Stack.Count -2], false);
10614 if (PPropInfo(p.Ext1)^.PropType^.Kind = tkMethod) and ((n.aType.BaseType = btu32) or (n.aType.BaseType = btProcPtr))then
10615 begin
10616 SetMethodProp(TObject(FSelf), PPropInfo(p.Ext1), MkMethod(Caller, tbtu32(n.dta^)));
10617 end else
10618 case n.aType.BaseType of
10619 btSet:
10620 begin
10621 ltemp := 0;
10622 move(Byte(n.Dta^), ltemp, TPSTypeRec_Set(n.aType).aByteSize);
10623 SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), ltemp);
10624 end;
10625 btChar, btU8: SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), tbtu8(n.Dta^));
10626 btS8: SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), tbts8(n.Dta^));
10627 {$IFNDEF PS_NOWIDESTRING}btwidechar, {$ENDIF}btU16: SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), tbtu16(n.Dta^));
10628 btS16: SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), tbts16(n.Dta^));
10629 btU32: SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), tbtu32(n.Dta^));
10630 btS32: SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), tbts32(n.Dta^));
10631 btSingle: SetFloatProp(TObject(FSelf), p.Ext1, tbtsingle(n.Dta^));
10632 btDouble: SetFloatProp(TObject(FSelf), p.Ext1, tbtdouble(n.Dta^));
10633 btExtended: SetFloatProp(TObject(FSelf), p.Ext1, tbtextended(n.Dta^));
10634 btString: SetStrProp(TObject(FSelf), p.Ext1, string(tbtString(n.Dta^)));
10635 btPChar: SetStrProp(TObject(FSelf), p.Ext1, string(pansichar(n.Dta^)));
10636 btClass: SetOrdProp(TObject(FSelf), P.Ext1, Longint(n.Dta^));
10637 {$IFDEF DELPHI6UP}
10638 {$IFNDEF PS_NOWIDESTRING}
10639 {$IFNDEF DELPHI2009UP}btUnicodeString,{$ENDIF}
10640 btWideString: SetWideStrProp(TObject(FSelf), P.Ext1, tbtWidestring(n.dta^));
10641 {$IFDEF DELPHI2009UP}
10642 btUnicodeString: SetUnicodeStrProp(TObject(FSelf), P.Ext1, tbtUnicodestring(n.dta^));
10643 {$ENDIF}
10644 {$ENDIF}
10645 {$ENDIF}
10646 else
10647 begin
10648 Result := False;
10649 exit;
10650 end;
10651 end;
10652 Result := true;
10653 end else begin
10654 n := NewTPSVariantIFC(Stack[Stack.Count -2], False);
10655 if (n.dta = nil) or (n.aType.BaseType <> btClass)then
10656 begin
10657 result := false;
10658 Caller.CMD_Err(erNullPointerException);
10659 exit;
10660 end;
10661 FSelf := Pointer(n.dta^);
10662 if FSelf = nil then
10663 begin
10664 Caller.CMD_Err(erCouldNotCallProc);
10665 Result := False;
10666 exit;
10667 end;
10668 n := NewTPSVariantIFC(Stack[Stack.Count -1], false);
10669 if (PPropInfo(p.Ext1)^.PropType^.Kind = tkMethod) and ((n.aType.BaseType = btu32) or (n.aType.BaseType = btprocptr)) then
10670 begin
10671 m := GetMethodProp(TObject(FSelf), PPropInfo(p.Ext1));
10672 Cardinal(n.Dta^) := GetMethodNo(m, Caller);
10673 if Cardinal(n.dta^) = 0 then
10674 begin
10675 Pointer(Pointer((IPointer(n.dta)+PointerSize))^) := m.Data;
10676 Pointer(Pointer((IPointer(n.dta)+PointerSize2))^) := m.Code;
10677 end;
10678 end else
10679 case n.aType.BaseType of
10680 btSet:
10681 begin
10682 ltemp := GetOrdProp(TObject(FSelf), PPropInfo(p.Ext1));
10683 move(ltemp, Byte(n.Dta^), TPSTypeRec_Set(n.aType).aByteSize);
10684 end;
10685 btU8: tbtu8(n.Dta^) := GetOrdProp(TObject(FSelf), p.Ext1);
10686 btS8: tbts8(n.Dta^) := GetOrdProp(TObject(FSelf), p.Ext1);
10687 btU16: tbtu16(n.Dta^) := GetOrdProp(TObject(FSelf), p.Ext1);
10688 btS16: tbts16(n.Dta^) := GetOrdProp(TObject(FSelf), p.Ext1);
10689 btU32: tbtu32(n.Dta^) := GetOrdProp(TObject(FSelf), p.Ext1);
10690 btS32: tbts32(n.Dta^) := GetOrdProp(TObject(FSelf), p.Ext1);
10691 btSingle: tbtsingle(n.Dta^) := GetFloatProp(TObject(FSelf), p.Ext1);
10692 btDouble: tbtdouble(n.Dta^) := GetFloatProp(TObject(FSelf), p.Ext1);
10693 btExtended: tbtextended(n.Dta^) := GetFloatProp(TObject(FSelf), p.Ext1);
10694 btString: tbtString(n.Dta^) := tbtString(GetStrProp(TObject(FSelf), p.Ext1));
10695 btClass: Longint(n.dta^) := GetOrdProp(TObject(FSelf), p.Ext1);
10696 {$IFDEF DELPHI6UP}
10697 {$IFNDEF PS_NOWIDESTRING}
10698 {$IFDEF DELPHI2009UP}
10699 btUnicodeString: tbtUnicodeString(n.dta^) := GetUnicodeStrProp(TObject(FSelf), P.Ext1);
10700 {$ELSE}
10701 btUnicodeString,
10702 {$ENDIF}
10703 btWideString: tbtWidestring(n.dta^) := GetWideStrProp(TObject(FSelf), P.Ext1);
10704 {$ENDIF}
10705 {$ENDIF}
10706 else
10707 begin
10708 Result := False;
10709 exit;
10710 end;
10711 end;
10712 Result := True;
10713 end;
10714 finally
10715 end;
10716 end;
10717
10718 function ClassCallProcPropertyHelper(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
10719 var
10720 I, ParamCount: Longint;
10721 Params: TPSList;
10722 n: TPSVariantIFC;
10723 FSelf: Pointer;
10724 begin
10725 if Length(P.Decl) < 4 then begin
10726 Result := False;
10727 exit;
10728 end;
10729 ParamCount := Longint((@P.Decl[1])^);
10730 if Longint(Stack.Count) < ParamCount +1 then begin
10731 Result := False;
10732 exit;
10733 end;
10734 Dec(ParamCount);
10735 if p.Ext1 <> nil then // read
10736 begin
10737 n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 2], False);
10738 if (n.Dta = nil) or (n.aType.BaseType <> btClass) then
10739 begin
10740 result := false;
10741 Caller.CMD_Err(erNullPointerException);
10742 exit;
10743 end;
10744 FSelf := pointer(n.Dta^);
10745 if FSelf = nil then
10746 begin
10747 Caller.CMD_Err(erCouldNotCallProc);
10748 Result := False;
10749 exit;
10750 end;
10751 Params := TPSList.Create;
10752 Params.Add(NewPPSVariantIFC(Stack[Longint(Stack.Count) - 1], True));
10753 for i := Stack.Count -3 downto Longint(Stack.Count) - ParamCount -2 do
10754 begin
10755 Params.Add(NewPPSVariantIFC(Stack[I], False));
10756 end;
10757 try
10758 Result := Caller.InnerfuseCall(FSelf, p.Ext1, cdRegister, Params, nil);
10759 finally
10760 DisposePPSVariantIFCList(Params);
10761 end;
10762 end else begin
10763 n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 1], False);
10764 if (n.Dta = nil) or (n.aType.BaseType <> btClass) then
10765 begin
10766 result := false;
10767 Caller.CMD_Err(erNullPointerException);
10768 exit;
10769 end;
10770 FSelf := pointer(n.Dta^);
10771 if FSelf = nil then
10772 begin
10773 Caller.CMD_Err(erCouldNotCallProc);
10774 Result := False;
10775 exit;
10776 end;
10777 Params := TPSList.Create;
10778 Params.Add(NewPPSVariantIFC(Stack[Longint(Stack.Count) - ParamCount - 2], False));
10779
10780 for i := Stack.Count -2 downto Longint(Stack.Count) - ParamCount -1 do
10781 begin
10782 Params.Add(NewPPSVariantIFC(Stack[I], False));
10783 end;
10784 try
10785 Result := Caller.InnerfuseCall(FSelf, p.Ext2, cdregister, Params, nil);
10786 finally
10787 DisposePPSVariantIFCList(Params);
10788 end;
10789 end;
10790 end;
10791
10792 function ClassCallProcPropertyHelperName(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
10793 var
10794 I, ParamCount: Longint;
10795 Params: TPSList;
10796 tt: PIFVariant;
10797 n: TPSVariantIFC;
10798 FSelf: Pointer;
10799 begin
10800 if Length(P.Decl) < 4 then begin
10801 Result := False;
10802 exit;
10803 end;
10804 ParamCount := Longint((@P.Decl[1])^);
10805 if Longint(Stack.Count) < ParamCount +1 then begin
10806 Result := False;
10807 exit;
10808 end;
10809 Dec(ParamCount);
10810 if p.Ext1 <> nil then // read
10811 begin
10812 n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 2], false);
10813 if (n.Dta = nil) or (n.aType.BaseType <> btClass) then
10814 begin
10815 result := false;
10816 Caller.CMD_Err(erNullPointerException);
10817 exit;
10818 end;
10819 FSelf := Tobject(n.dta^);
10820 Params := TPSList.Create;
10821 Params.Add(NewPPSVariantIFC(Stack[Longint(Stack.Count) - 1], True));
10822 for i := Stack.Count -3 downto Longint(Stack.Count) - ParamCount -2 do
10823 Params.Add(NewPPSVariantIFC(Stack[I], False));
10824 tt := CreateHeapVariant(Caller.FindType2(btString));
10825 if tt <> nil then
10826 begin
10827 PPSVariantAString(tt).Data := p.Name;
10828 Params.Add(NewPPSVariantIFC(tt, false));
10829 end;
10830 try
10831 Result := Caller.InnerfuseCall(FSelf, p.Ext1, cdRegister, Params, nil);
10832 finally
10833 DestroyHeapVariant(tt);
10834 DisposePPSVariantIFCList(Params);
10835 end;
10836 end else begin
10837 n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 1], false);
10838 if (n.Dta = nil) or (n.aType.BaseType <> btClass) then
10839 begin
10840 result := false;
10841 Caller.CMD_Err(erNullPointerException);
10842 exit;
10843 end;
10844 FSelf := Tobject(n.dta^);
10845 Params := TPSList.Create;
10846 Params.Add(NewPPSVariantIFC(Stack[Longint(Stack.Count) - 2], True));
10847
10848 for i := Stack.Count -2 downto Longint(Stack.Count) - ParamCount -1 do
10849 begin
10850 Params.Add(NewPPSVariantIFC(Stack[I], false));
10851 end;
10852 tt := CreateHeapVariant(Caller.FindType2(btString));
10853 if tt <> nil then
10854 begin
10855 PPSVariantAString(tt).Data := p.Name;
10856 Params.Add(NewPPSVariantIFC(tt, false));
10857 end;
10858 try
10859 Result := Caller.InnerfuseCall(FSelf, p.Ext2, cdregister, Params, nil);
10860 finally
10861 DestroyHeapVariant(tt);
10862 DisposePPSVariantIFCList(Params);
10863 end;
10864 end;
10865 end;
10866
10867
10868
10869 function ClassCallProcEventPropertyHelper(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
10870 {Event property helper}
10871 var
10872 I, ParamCount: Longint;
10873 Params: TPSList;
10874 n: TPSVariantIFC;
10875 data: TMethod;
10876 n2: PIFVariant;
10877 FSelf: Pointer;
10878 begin
10879 if Length(P.Decl) < 4 then begin
10880 Result := False;
10881 exit;
10882 end;
10883 ParamCount := Longint((@P.Decl[1])^);
10884 if Longint(Stack.Count) < ParamCount +1 then begin
10885 Result := False;
10886 exit;
10887 end;
10888 Dec(ParamCount);
10889 if p.Ext1 <> nil then // read
10890 begin
10891 n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 2], false);
10892 if (n.Dta = nil) or (n.aType.BaseType <> btClass) then
10893 begin
10894 result := false;
10895 Caller.CMD_Err(erNullPointerException);
10896 exit;
10897 end;
10898 FSelf := Tobject(n.dta^);
10899 n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 1], True); // Result
10900 if (n.aType.BaseType <> btU32) and (n.aType.BaseType <> btProcPtr) then
10901 begin
10902 Result := False;
10903 Caller.CMD_Err(erNullPointerException);
10904 exit;
10905 end;
10906 n2 := CreateHeapVariant(Caller.FindType2(btPChar));
10907 if n2 = nil then
10908 begin
10909 Result := False;
10910 exit;
10911 end;
10912 Params := TPSList.Create;
10913 //{$IFDEF CPU64}
10914 //{$ELSE}
10915 data.Code := nil;
10916 data.Data := nil;
10917 //{$ENDIF}
10918 PPSVariantDynamicArray(n2)^.Data:= @data;
10919 Params.Add(NewPPSVariantIFC(n2, false));
10920 for i := Stack.Count -3 downto Longint(Stack.Count) - ParamCount -2 do
10921 Params.Add(NewPPSVariantIFC(Stack[i], False));
10922 try
10923 Result := Caller.InnerfuseCall(FSelf, p.Ext1, cdRegister, Params, nil);
10924 finally
10925 Cardinal(n.Dta^) := getMethodNo(data, Caller);
10926 if Cardinal(n.Dta^) = 0 then
10927 begin
10928 Pointer(Pointer((IPointer(n.dta)+PointerSize))^) := data.Data;
10929 Pointer(Pointer((IPointer(n.dta)+PointerSize2))^) := data.Code;
10930 end;
10931 DestroyHeapVariant(n2);
10932 DisposePPSVariantIFCList(Params);
10933 end;
10934 end else begin
10935 n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 1], false);
10936 if (n.Dta = nil) or (n.aType.BaseType <> btClass) then
10937 begin
10938 result := false;
10939 Caller.CMD_Err(erNullPointerException);
10940 exit;
10941 end;
10942 FSelf := Tobject(n.dta^);
10943 n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 2], false);
10944 if (n.Dta = nil) or ((n.aType.BaseType <> btu32) and (n.aType.BaseType <> btProcPtr)) then
10945 begin
10946 result := false;
10947 Caller.CMD_Err(erNullPointerException);
10948 exit;
10949 end;
10950 (*n2 := CreateHeapVariant(Caller.FindType2(btPchar));
10951 if n2 = nil then
10952 begin
10953 Result := False;
10954 exit;
10955 end; *)
10956
10957 //if (n.aType.BaseType = btProcPtr) and (cardinal(n.dta^) = 0) then
10958 // data := TMethod(Pointer(IPointer(n.dta^)+4)^)
10959 //else
10960 // data := MkMethod(Caller, cardinal(n.dta^));
10961
10962 Params := TPSList.Create;
10963 Params.Add(@n);
10964
10965 // for i := Stack.Count -2 downto Longint(Stack.Count) - ParamCount -1 do
10966 // begin
10967 // Params.Add(NewPPSVariantIFC(Stack[I], False));
10968 // end;
10969 try
10970 Result := Caller.InnerfuseCall(FSelf, p.Ext2, cdregister, Params, nil);
10971 finally
10972 Params.Clear;
10973 //DestroyHeapVariant(n2);
10974 DisposePPSVariantIFCList(Params);
10975 end;
10976 end;
10977 end;
10978
10979
10980 {'class:'+CLASSNAME+'|'+FUNCNAME+'|'+chr(CallingConv)+chr(hasresult)+params
10981
10982 For property write functions there is an '@' after the funcname.
10983 }
10984 function SpecImport(Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean;
10985 var
10986 H, I: Longint;
10987 S, s2: tbtString;
10988 CL: TPSRuntimeClass;
10989 Px: PClassItem;
10990 pp: PPropInfo;
10991 IsRead: Boolean;
10992 begin
10993 s := p.Decl;
10994 delete(s, 1, 6);
10995 if s = '-' then {nil function}
10996 begin
10997 p.ProcPtr := NilProc;
10998 Result := True;
10999 exit;
11000 end;
11001 if s = '+' then {cast function}
11002 begin
11003 p.ProcPtr := CastProc;
11004 p.Ext2 := Tag;
11005 Result := True;
11006 exit;
11007 end;
11008 s2 := copy(S, 1, pos(tbtchar('|'), s)-1);
11009 delete(s, 1, length(s2) + 1);
11010 H := MakeHash(s2);
11011 ISRead := False;
11012 cl := nil;
11013 for I := TPSRuntimeClassImporter(Tag).FClasses.Count -1 downto 0 do
11014 begin
11015 Cl := TPSRuntimeClassImporter(Tag).FClasses[I];
11016 if (Cl.FClassNameHash = h) and (cl.FClassName = s2) then
11017 begin
11018 IsRead := True;
11019 break;
11020 end;
11021 end;
11022 if not isRead then begin
11023 Result := False;
11024 exit;
11025 end;
11026 s2 := copy(S, 1, pos(tbtchar('|'), s)-1);
11027 delete(s, 1, length(s2) + 1);
11028 if (s2 <> '') and (s2[length(s2)] = '@') then
11029 begin
11030 IsRead := False;
11031 Delete(S2, length(s2), 1);
11032 end else
11033 isRead := True;
11034 p.Name := s2;
11035 H := MakeHash(s2);
11036 for i := cl.FClassItems.Count -1 downto 0 do
11037 begin
11038 px := cl.FClassItems[I];
11039 if (px^.FNameHash = h) and (px^.FName = s2) then
11040 begin
11041 p.Decl := s;
11042 case px^.b of
11043 {0: ext1=ptr}
11044 {1: ext1=pointerinlist}
11045 {2: ext1=propertyinfo}
11046 {3: ext1=readfunc; ext2=writefunc}
11047 4:
11048 begin
11049 p.ProcPtr := ClassCallProcConstructor;
11050 p.Ext1 := px^.Ptr;
11051 if p.Ext1 = nil then begin result := false; exit; end;
11052 p.Ext2 := Tag;
11053 end;
11054 5:
11055 begin
11056 p.ProcPtr := ClassCallProcVirtualConstructor;
11057 p.Ext1 := px^.Ptr;
11058 if p.Ext1 = nil then begin result := false; exit; end;
11059 p.Ext2 := Tag;
11060 end;
11061 6:
11062 begin
11063 p.ProcPtr := ClassCallProcEventPropertyHelper;
11064 if IsRead then
11065 begin
11066 p.Ext1 := px^.FReadFunc;
11067 if p.Ext1 = nil then begin result := false; exit; end;
11068 p.Ext2 := nil;
11069 end else
11070 begin
11071 p.Ext1 := nil;
11072 p.Ext2 := px^.FWriteFunc;
11073 if p.Ext2 = nil then begin result := false; exit; end;
11074 end;
11075 end;
11076 0:
11077 begin
11078 p.ProcPtr := ClassCallProcMethod;
11079 p.Ext1 := px^.Ptr;
11080 if p.Ext1 = nil then begin result := false; exit; end;
11081 p.Ext2 := nil;
11082 end;
11083 1:
11084 begin
11085 p.ProcPtr := ClassCallProcMethod;
11086 p.Ext1 := px^.PointerInList;
11087 //if p.Ext1 = nil then begin result := false; exit; end;
11088 p.ext2 := pointer(1);
11089 end;
11090 3:
11091 begin
11092 p.ProcPtr := ClassCallProcPropertyHelper;
11093 if IsRead then
11094 begin
11095 p.Ext1 := px^.FReadFunc;
11096 if p.Ext1 = nil then begin result := false; exit; end;
11097 p.Ext2 := nil;
11098 end else
11099 begin
11100 p.Ext1 := nil;
11101 p.Ext2 := px^.FWriteFunc;
11102 if p.Ext2 = nil then begin result := false; exit; end;
11103 end;
11104 end;
11105 7:
11106 begin
11107 p.ProcPtr := ClassCallProcPropertyHelperName;
11108 if IsRead then
11109 begin
11110 p.Ext1 := px^.FReadFunc;
11111 if p.Ext1 = nil then begin result := false; exit; end;
11112 p.Ext2 := nil;
11113 end else
11114 begin
11115 p.Ext1 := nil;
11116 p.Ext2 := px^.FWriteFunc;
11117 if p.Ext2 = nil then begin result := false; exit; end;
11118 end;
11119 end;
11120 else
11121 begin
11122 result := false;
11123 exit;
11124 end;
11125 end;
11126 Result := true;
11127 exit;
11128 end;
11129 end;
11130 if cl.FClass.ClassInfo <> nil then
11131 begin
11132 pp := GetPropInfo(cl.FClass.ClassInfo, string(s2));
11133 if pp <> nil then
11134 begin
11135 p.ProcPtr := ClassCallProcProperty;
11136 p.Ext1 := pp;
11137 if IsRead then
11138 p.Ext2 := Pointer(1)
11139 else
11140 p.Ext2 := Pointer(0);
11141 Result := True;
11142 end else
11143 result := false;
11144 end else
11145 Result := False;
11146 end;
11147
11148 procedure RegisterClassLibraryRuntime(SE: TPSExec; Importer: TPSRuntimeClassImporter);
11149 begin
11150 SE.AddSpecialProcImport('class', SpecImport, Importer);
11151 end;
11152
11153
11154 procedure TPSExec.ClearspecialProcImports;
11155 var
11156 I: Longint;
11157 P: PSpecialProc;
11158 begin
11159 for I := FSpecialProcList.Count -1 downto 0 do
11160 begin
11161 P := FSpecialProcList[I];
11162 Dispose(p);
11163 end;
11164 FSpecialProcList.Clear;
11165 end;
11166
11167 procedure TPSExec.RaiseCurrentException;
11168 var
11169 ExObj: TObject;
11170 begin
11171 if ExEx = erNoError then exit; // do nothing
11172 ExObj := Self.ExObject;
11173 if ExObj <> nil then
11174 begin
11175 Self.ExObject := nil;
11176 raise ExObj;
11177 end;
11178 raise EPSException.Create(PSErrorToString(ExceptionCode, ExceptionString), Self, ExProc, ExPos);
11179 end;
11180
11181 procedure TPSExec.CMD_Err2(EC: TPSError; const Param: tbtString);
11182 begin
11183 CMD_Err3(EC, Param, Nil);
11184 end;
11185
GetProcAsMethodnull11186 function TPSExec.GetProcAsMethod(const ProcNo: Cardinal): TMethod;
11187 begin
11188 Result := MkMethod(Self, ProcNo);
11189 end;
11190
GetProcAsMethodNnull11191 function TPSExec.GetProcAsMethodN(const ProcName: tbtString): TMethod;
11192 var
11193 procno: Cardinal;
11194 begin
11195 Procno := GetProc(ProcName);
11196 if Procno = InvalidVal then
11197 begin
11198 Result.Code := nil;
11199 Result.Data := nil;
11200 end
11201 else
11202 Result := MkMethod(Self, procno)
11203 end;
11204
11205
11206 procedure TPSExec.RegisterAttributeType(useproc: TPSAttributeUseProc;
11207 const TypeName: tbtString);
11208 var
11209 att: TPSAttributeType;
11210 begin
11211 att := TPSAttributeType.Create;
11212 att.TypeName := TypeName;
11213 att.TypeNameHash := MakeHash(TypeName);
11214 att.UseProc := UseProc;
11215 FAttributeTypes.Add(att);
11216 end;
11217
GetProcCountnull11218 function TPSExec.GetProcCount: Cardinal;
11219 begin
11220 Result := FProcs.Count;
11221 end;
11222
GetTypeCountnull11223 function TPSExec.GetTypeCount: Longint;
11224 begin
11225 Result := FTypes.Count;
11226 end;
11227
GetVarCountnull11228 function TPSExec.GetVarCount: Longint;
11229 begin
11230 Result := FGlobalVars.Count;
11231 end;
11232
FindSpecialProcImportnull11233 function TPSExec.FindSpecialProcImport(
11234 P: TPSOnSpecialProcImport): pointer;
11235 var
11236 i: Longint;
11237 pr: PSpecialProc;
11238 begin
11239 for i := FSpecialProcList.Count -1 downto 0 do
11240 begin
11241 pr := FSpecialProcList[i];
11242 if @pr.P = @p then
11243 begin
11244 Result := pr.tag;
11245 exit;
11246 end;
11247 end;
11248 result := nil;
11249 end;
11250
InvokeExternalMethodnull11251 function TPSExec.InvokeExternalMethod(At: TPSTypeRec_ProcPtr; Slf,
11252 Ptr: Pointer): Boolean;
11253 var
11254 res: PPSVariantIFC;
11255 s: tbtString;
11256 CurrStack, i: Longint;
11257 n: PPSVariant;
11258 MyList: TPSList;
11259 begin
11260 s := TPSTypeRec_ProcPtr(at).ParamInfo;
11261 CurrStack := Cardinal(FStack.Count) - Cardinal(length(s));
11262 if s[1] = #0 then inc(CurrStack);
11263 MyList := TPSList.Create;
11264 for i := 2 to length(s) do
11265 begin
11266 MyList.Add(nil);
11267 end;
11268 for i := length(s) downto 2 do
11269 begin
11270 n := FStack[CurrStack];
11271 MyList[i - 2] := NewPPSVariantIFC(n, s[i] <> #0);
11272 inc(CurrStack);
11273 end;
11274 if s[1] <> #0 then
11275 begin
11276 res := NewPPSVariantIFC(FStack[CurrStack + 1], True);
11277 end else res := nil;
11278 Result := InnerfuseCall(Slf, Ptr, cdRegister, MyList, Res);
11279
11280 DisposePPSVariantIFC(res);
11281 DisposePPSVariantIFCList(mylist);
11282 end;
11283
LastExnull11284 function TPSExec.LastEx: TPSError;
11285 var
11286 pp: TPSExceptionHandler;
11287 begin
11288 if FExceptionStack.Count = 0 then begin
11289 result := ExEx;
11290 exit;
11291 end;
11292 pp := fExceptionStack[fExceptionStack.Count-1];
11293 result := pp.ExceptionData;
11294 end;
11295
LastExParamnull11296 function TPSExec.LastExParam: tbtString;
11297 var
11298 pp: TPSExceptionHandler;
11299 begin
11300 if FExceptionStack.Count = 0 then begin
11301 result := ExParam;
11302 exit;
11303 end;
11304 pp := fExceptionStack[fExceptionStack.Count-1];
11305 result := pp.ExceptionParam;
11306 end;
11307
LastExPosnull11308 function TPSExec.LastExPos: Integer;
11309 var
11310 pp: TPSExceptionHandler;
11311 begin
11312 if FExceptionStack.Count = 0 then begin
11313 result := ExPos;
11314 exit;
11315 end;
11316 pp := fExceptionStack[fExceptionStack.Count-1];
11317 result := pp.ExceptOffset;
11318
11319 end;
11320
LastExProcnull11321 function TPSExec.LastExProc: Integer;
11322 var
11323 pp: TPSExceptionHandler;
11324 begin
11325 if FExceptionStack.Count = 0 then begin
11326 result := ExProc;
11327 exit;
11328 end;
11329 pp := fExceptionStack[fExceptionStack.Count-1];
11330 result := FProcs.IndexOf(pp.CurrProc);
11331 end;
11332
LastExObjectnull11333 function TPSExec.LastExObject: TObject;
11334 var
11335 pp: TPSExceptionHandler;
11336 begin
11337 if FExceptionStack.Count = 0 then begin
11338 result := ExObject;
11339 exit;
11340 end;
11341 pp := fExceptionStack[fExceptionStack.Count-1];
11342 result := pp.ExceptionObject;
11343 end;
11344
11345 { TPSRuntimeClass }
11346
11347 constructor TPSRuntimeClass.Create(aClass: TClass; const AName: tbtString);
11348 begin
11349 inherited Create;
11350 FClass := AClass;
11351 if AName = '' then
11352 begin
11353 FClassName := FastUpperCase(tbtString(aClass.ClassName));
11354 FClassNameHash := MakeHash(FClassName);
11355 end else begin
11356 FClassName := FastUppercase(AName);
11357 FClassNameHash := MakeHash(FClassName);
11358 end;
11359 FClassItems:= TPSList.Create;
11360 FEndOfVmt := MaxInt;
11361 end;
11362
11363 destructor TPSRuntimeClass.Destroy;
11364 var
11365 I: Longint;
11366 P: PClassItem;
11367 begin
11368 for i:= FClassItems.Count -1 downto 0 do
11369 begin
11370 P := FClassItems[I];
11371 Dispose(p);
11372 end;
11373 FClassItems.Free;
11374 inherited Destroy;
11375 end;
11376
11377 procedure TPSRuntimeClass.RegisterVirtualAbstractMethod(ClassDef: TClass;
11378 ProcPtr: Pointer; const Name: tbtString);
11379 var
11380 P: PClassItem;
11381 begin
11382 New(P);
11383 p^.FName := FastUppercase(Name);
11384 p^.FNameHash := MakeHash(p^.FName);
11385 p^.b := 1;
11386 p^.PointerInList := FindVirtualMethodPtr(Self, ClassDef, ProcPtr);
11387 FClassItems.Add(p);
11388 end;
11389
11390 procedure TPSRuntimeClass.RegisterConstructor(ProcPtr: Pointer;
11391 const Name: tbtString);
11392 var
11393 P: PClassItem;
11394 begin
11395 New(P);
11396 p^.FName := FastUppercase(Name);
11397 p^.FNameHash := MakeHash(p^.FName);
11398 p^.b := 4;
11399 p^.Ptr := ProcPtr;
11400 FClassItems.Add(p);
11401 end;
11402
11403 procedure TPSRuntimeClass.RegisterMethod(ProcPtr: Pointer; const Name: tbtString);
11404 var
11405 P: PClassItem;
11406 begin
11407 New(P);
11408 p^.FName := FastUppercase(Name);
11409 p^.FNameHash := MakeHash(p^.FName);
11410 p^.b := 0;
11411 p^.Ptr := ProcPtr;
11412 FClassItems.Add(p);
11413 end;
11414
11415
11416 procedure TPSRuntimeClass.RegisterPropertyHelper(ReadFunc,
11417 WriteFunc: Pointer; const Name: tbtString);
11418 var
11419 P: PClassItem;
11420 begin
11421 New(P);
11422 p^.FName := FastUppercase(Name);
11423 p^.FNameHash := MakeHash(p^.FName);
11424 p^.b := 3;
11425 p^.FReadFunc := ReadFunc;
11426 p^.FWriteFunc := WriteFunc;
11427 FClassItems.Add(p);
11428 end;
11429
11430 procedure TPSRuntimeClass.RegisterVirtualConstructor(ProcPtr: Pointer;
11431 const Name: tbtString);
11432 var
11433 P: PClassItem;
11434 begin
11435 New(P);
11436 p^.FName := FastUppercase(Name);
11437 p^.FNameHash := MakeHash(p^.FName);
11438 p^.b := 5;
11439 p^.PointerInList := FindVirtualMethodPtr(Self, FClass, ProcPtr);
11440 FClassItems.Add(p);
11441 end;
11442
11443 procedure TPSRuntimeClass.RegisterVirtualMethod(ProcPtr: Pointer; const Name: tbtString);
11444 var
11445 P: PClassItem;
11446 begin
11447 New(P);
11448 p^.FName := FastUppercase(Name);
11449 p^.FNameHash := MakeHash(p^.FName);
11450 p^.b := 1;
11451 p^.PointerInList := FindVirtualMethodPtr(Self, FClass, ProcPtr);
11452 FClassItems.Add(p);
11453 end;
11454
11455 procedure TPSRuntimeClass.RegisterEventPropertyHelper(ReadFunc,
11456 WriteFunc: Pointer; const Name: tbtString);
11457 var
11458 P: PClassItem;
11459 begin
11460 New(P);
11461 p^.FName := FastUppercase(Name);
11462 p^.FNameHash := MakeHash(p^.FName);
11463 p^.b := 6;
11464 p^.FReadFunc := ReadFunc;
11465 p^.FWriteFunc := WriteFunc;
11466 FClassItems.Add(p);
11467 end;
11468
11469
11470 procedure TPSRuntimeClass.RegisterPropertyHelperName(ReadFunc,
11471 WriteFunc: Pointer; const Name: tbtString);
11472 var
11473 P: PClassItem;
11474 begin
11475 New(P);
11476 p^.FName := FastUppercase(Name);
11477 p^.FNameHash := MakeHash(p^.FName);
11478 p^.b := 7;
11479 p^.FReadFunc := ReadFunc;
11480 p^.FWriteFunc := WriteFunc;
11481 FClassItems.Add(p);
11482 end;
11483
11484 { TPSRuntimeClassImporter }
11485
Addnull11486 function TPSRuntimeClassImporter.Add(aClass: TClass): TPSRuntimeClass;
11487 begin
11488 Result := FindClass(tbtstring(aClass.ClassName));
11489 if Result <> nil then exit;
11490 Result := TPSRuntimeClass.Create(aClass, '');
11491 FClasses.Add(Result);
11492 end;
11493
Add2null11494 function TPSRuntimeClassImporter.Add2(aClass: TClass;
11495 const Name: tbtString): TPSRuntimeClass;
11496 begin
11497 Result := FindClass(Name);
11498 if Result <> nil then exit;
11499 Result := TPSRuntimeClass.Create(aClass, Name);
11500 FClasses.Add(Result);
11501 end;
11502
11503 procedure TPSRuntimeClassImporter.Clear;
11504 var
11505 I: Longint;
11506 begin
11507 for i := 0 to FClasses.Count -1 do
11508 begin
11509 TPSRuntimeClass(FClasses[I]).Free;
11510 end;
11511 FClasses.Clear;
11512 end;
11513
11514 constructor TPSRuntimeClassImporter.Create;
11515 begin
11516 inherited Create;
11517 FClasses := TPSList.Create;
11518
11519 end;
11520
11521 constructor TPSRuntimeClassImporter.CreateAndRegister(Exec: TPSExec;
11522 AutoFree: Boolean);
11523 begin
11524 inherited Create;
11525 FClasses := TPSList.Create;
11526 RegisterClassLibraryRuntime(Exec, Self);
11527 if AutoFree then
11528 Exec.AddResource(@RCIFreeProc, Self);
11529 end;
11530
11531 destructor TPSRuntimeClassImporter.Destroy;
11532 begin
11533 Clear;
11534 FClasses.Free;
11535 inherited Destroy;
11536 end;
11537
11538 {$IFNDEF PS_NOINTERFACES}
11539 procedure SetVariantToInterface(V: PIFVariant; Cl: IUnknown);
11540 begin
11541 if (v <> nil) and (v.FType.BaseType = btInterface) then
11542 begin
11543 PPSVariantinterface(v).Data := cl;
11544 {$IFNDEF Delphi3UP}
11545 if PPSVariantinterface(v).Data <> nil then
11546 PPSVariantinterface(v).Data.AddRef;
11547 {$ENDIF}
11548 end;
11549 end;
11550 {$ENDIF}
11551
11552 procedure SetVariantToClass(V: PIFVariant; Cl: TObject);
11553 begin
11554 if (v <> nil) and (v.FType.BaseType = btClass) then
11555 begin
11556 PPSVariantclass(v).Data := cl;
11557 end;
11558 end;
11559
11560 function BGRFW(var s: tbtString): tbtString;
11561 var
11562 l: Longint;
11563 begin
11564 l := Length(s);
11565 while l >0 do
11566 begin
11567 if s[l] = ' ' then
11568 begin
11569 Result := copy(s, l + 1, Length(s) - l);
11570 Delete(s, l, Length(s) - l + 1);
11571 exit;
11572 end;
11573 Dec(l);
11574 end;
11575 Result := s;
11576 s := '';
11577 end;
11578
11579 {$ifdef CPUX64}
11580
11581 {.$DEFINE empty_methods_handler}
11582 {$ENDIF}
11583
11584 {$ifdef fpc}
11585 {$if defined(cpu86)} // Has MyAllMethodsHandler
11586 {$else}
11587 // {$if defined(cpupowerpc) or defined(cpuarm) or defined(cpu64)}
11588 {$define empty_methods_handler}
11589 {$ifend}
11590 {$endif}
11591
11592 {$ifdef empty_methods_handler}
11593 procedure MyAllMethodsHandler;
11594 begin
11595 end;
11596 {$else}
11597
11598
11599 function MyAllMethodsHandler2(Self: PScriptMethodInfo; const Stack: PPointer; _EDX, _ECX: Pointer): Integer; forward;
11600
11601 procedure MyAllMethodsHandler;
11602 {$ifdef CPUX64}
11603 // On entry:
11604 // RCX = Self pointer
11605 // RDX, R8, R9 = param1 .. param3
11606 // STACK = param4... paramcount
11607 asm
11608 PUSH R9
11609 MOV R9,R8 // R9:=_ECX
11610 MOV R8,RDX // R8:=_EDX
11611 MOV RDX, RSP // RDX:=Stack
11612 SUB RSP, 20h
11613 CALL MyAllMethodsHandler2
11614 ADD RSP, 20h //Restore stack
11615 POP R9
11616 end;
11617 {$else}
11618 // On entry:
11619 // EAX = Self pointer
11620 // EDX, ECX = param1 and param2
11621 // STACK = param3... paramcount
11622 asm
11623 push 0
11624 push ecx
11625 push edx
11626 mov edx, esp
11627 add edx, 16 // was 12
11628 pop ecx
11629 call MyAllMethodsHandler2
11630 pop ecx
11631 mov edx, [esp]
11632 add esp, eax
11633 mov [esp], edx
11634 mov eax, ecx
11635 end;
11636 {$endif}
11637
11638 function ResultAsRegister(b: TPSTypeRec): Boolean;
11639 begin
11640 case b.BaseType of
11641 btSingle,
11642 btDouble,
11643 btExtended,
11644 btU8,
11645 bts8,
11646 bts16,
11647 btu16,
11648 bts32,
11649 btu32,
11650 {$IFDEF PS_FPCSTRINGWORKAROUND}
11651 btString,
11652 {$ENDIF}
11653 {$IFNDEF PS_NOINT64}
11654 bts64,
11655 {$ENDIF}
11656 btPChar,
11657 {$IFNDEF PS_NOWIDESTRING}
11658 btWideChar,
11659 {$ENDIF}
11660 btChar,
11661 btclass,
11662 btEnum: Result := true;
11663 btSet: Result := b.RealSize <= PointerSize;
11664 btStaticArray: Result := b.RealSize <= PointerSize;
11665 else
11666 Result := false;
11667 end;
11668 end;
11669
11670 function SupportsRegister(b: TPSTypeRec): Boolean;
11671 begin
11672 case b.BaseType of
11673 btU8,
11674 bts8,
11675 bts16,
11676 btu16,
11677 bts32,
11678 btu32,
11679 btstring,
11680 btclass,
11681 {$IFNDEF PS_NOINTERFACES}
11682 btinterface,
11683 {$ENDIF}
11684 btPChar,
11685 {$IFNDEF PS_NOWIDESTRING}
11686 btwidestring,
11687 btUnicodeString,
11688 btWideChar,
11689 {$ENDIF}
11690 btChar,
11691 btArray,
11692 btEnum: Result := true;
11693 btSet: Result := b.RealSize <= PointerSize;
11694 btStaticArray: Result := b.RealSize <= PointerSize;
11695 else
11696 Result := false;
11697 end;
11698 end;
11699
11700 function AlwaysAsVariable(aType: TPSTypeRec): Boolean;
11701 begin
11702 case atype.BaseType of
11703 btVariant: Result := true;
11704 btSet: Result := atype.RealSize > PointerSize;
11705 btRecord: Result := atype.RealSize > PointerSize;
11706 btStaticArray: Result := atype.RealSize > PointerSize;
11707 else
11708 Result := false;
11709 end;
11710 end;
11711
11712
11713 procedure PutOnFPUStackExtended(ft: extended);
11714 asm
11715 // fstp tbyte ptr [ft]
11716 fld tbyte ptr [ft]
11717
11718 end;
11719
11720
11721 function MyAllMethodsHandler2(Self: PScriptMethodInfo; const Stack: PPointer; _EDX, _ECX: Pointer): Integer;
11722 var
11723 Decl: tbtString;
11724 I, C, regno: Integer;
11725 Params: TPSList;
11726 Res, Tmp: PIFVariant;
11727 cpt: PIFTypeRec;
11728 fmod: tbtchar;
11729 s,e: tbtString;
11730 FStack: pointer;
11731 ex: TPSExceptionHandler;
11732
11733
11734 begin
11735 Decl := TPSInternalProcRec(Self^.Se.FProcs[Self^.ProcNo]).ExportDecl;
11736
11737 FStack := Stack;
11738 Params := TPSList.Create;
11739 s := decl;
11740 grfw(s);
11741 while s <> '' do
11742 begin
11743 Params.Add(nil);
11744 grfw(s);
11745 end;
11746 c := Params.Count;
11747 regno := 0;
11748 Result := 0;
11749 s := decl;
11750 grfw(s);
11751 for i := c-1 downto 0 do
11752 begin
11753 e := grfw(s);
11754 fmod := e[1];
11755 delete(e, 1, 1);
11756 cpt := Self.Se.GetTypeNo(StrToInt(e));
11757 if ((fmod = '%') or (fmod = '!') or (AlwaysAsVariable(cpt))) and (RegNo < 2) then
11758 begin
11759 tmp := CreateHeapVariant(self.Se.FindType2(btPointer));
11760 PPSVariantPointer(tmp).DestType := cpt;
11761 Params[i] := tmp;
11762 case regno of
11763 0: begin
11764 PPSVariantPointer(tmp).DataDest := Pointer(_EDX);
11765 inc(regno);
11766 end;
11767 1: begin
11768 PPSVariantPointer(tmp).DataDest := Pointer(_ECX);
11769 inc(regno);
11770 end;
11771 (* else begin
11772 PPSVariantPointer(tmp).DataDest := Pointer(FStack^);
11773 FStack := Pointer(IPointer(FStack) + 4);
11774 end;*)
11775 end;
11776 end
11777 else if SupportsRegister(cpt) and (RegNo < 2) then
11778 begin
11779 tmp := CreateHeapVariant(cpt);
11780 Params[i] := tmp;
11781 case regno of
11782 0: begin
11783 CopyArrayContents(@PPSVariantData(tmp)^.Data, @_EDX, 1, cpt);
11784 inc(regno);
11785 end;
11786 1: begin
11787 CopyArrayContents(@PPSVariantData(tmp)^.Data, @_ECX, 1, cpt);
11788 inc(regno);
11789 end;
11790 (* else begin
11791 CopyArrayContents(@PPSVariantData(tmp)^.Data, Pointer(FStack), 1, cpt);
11792 FStack := Pointer(IPointer(FStack) + 4);
11793 end;*)
11794 end;
11795 (* end else
11796 begin
11797 tmp := CreateHeapVariant(cpt);
11798 Params[i] := tmp;
11799 CopyArrayContents(@PPSVariantData(tmp)^.Data, Pointer(FStack), 1, cpt);
11800 FStack := Pointer(IPointer(FStack) + cpt.RealSize + 3 and not 3);*)
11801 end;
11802 end;
11803 s := decl;
11804 e := grfw(s);
11805
11806 if e <> '-1' then
11807 begin
11808 cpt := Self.Se.GetTypeNo(StrToInt(e));
11809 if not ResultAsRegister(cpt) then
11810 begin
11811 Res := CreateHeapVariant(Self.Se.FindType2(btPointer));
11812 PPSVariantPointer(Res).DestType := cpt;
11813 Params.Add(Res);
11814 case regno of
11815 0: begin
11816 PPSVariantPointer(Res).DataDest := Pointer(_EDX);
11817 end;
11818 1: begin
11819 PPSVariantPointer(Res).DataDest := Pointer(_ECX);
11820 end;
11821 else begin
11822 PPSVariantPointer(Res).DataDest := Pointer(FStack^);
11823 Inc(Result, PointerSize);
11824 end;
11825 end;
11826 end else
11827 begin
11828 Res := CreateHeapVariant(cpt);
11829 Params.Add(Res);
11830 end;
11831 end else Res := nil;
11832 s := decl;
11833 grfw(s);
11834 for i := 0 to c -1 do
11835 begin
11836 e := grlw(s);
11837 fmod := e[1];
11838 delete(e, 1, 1);
11839 if Params[i] <> nil then Continue;
11840 cpt := Self.Se.GetTypeNo(StrToInt(e));
11841 if (fmod = '%') or (fmod = '!') or (AlwaysAsVariable(cpt)) then
11842 begin
11843 tmp := CreateHeapVariant(self.Se.FindType2(btPointer));
11844 PPSVariantPointer(tmp).DestType := cpt;
11845 Params[i] := tmp;
11846 PPSVariantPointer(tmp).DataDest := Pointer(FStack^);
11847 FStack := Pointer(IPointer(FStack) + PointerSize);
11848 Inc(Result, PointerSize);
11849 end
11850 (* else if SupportsRegister(cpt) then
11851 begin
11852 tmp := CreateHeapVariant(cpt);
11853 Params[i] := tmp;
11854 CopyArrayContents(@PPSVariantData(tmp)^.Data, Pointer(FStack), 1, cpt);
11855 FStack := Pointer(IPointer(FStack) + 4);
11856 end;
11857 end *)else
11858 begin
11859 tmp := CreateHeapVariant(cpt);
11860 Params[i] := tmp;
11861 CopyArrayContents(@PPSVariantData(tmp)^.Data, Pointer(FStack), 1, cpt);
11862 FStack := Pointer((IPointer(FStack) + cpt.RealSize + 3) and not 3);
11863 Inc(Result, (cpt.RealSize + 3) and not 3);
11864 end;
11865 end;
11866 ex := TPSExceptionHandler.Create;
11867 ex.FinallyOffset := InvalidVal;
11868 ex.ExceptOffset := InvalidVal;
11869 ex.Finally2Offset := InvalidVal;
11870 ex.EndOfBlock := InvalidVal;
11871 ex.CurrProc := nil;
11872 ex.BasePtr := Self.Se.FCurrStackBase;
11873 Ex.StackSize := Self.Se.FStack.Count;
11874 i := Self.Se.FExceptionStack.Add(ex);
11875 Self.Se.RunProc(Params, Self.ProcNo);
11876 if Self.Se.FExceptionStack[i] = ex then
11877 begin
11878 Self.Se.FExceptionStack.Remove(ex);
11879 ex.Free;
11880 end;
11881
11882 if (Res <> nil) then
11883 begin
11884 Params.DeleteLast;
11885 if (ResultAsRegister(Res.FType)) then
11886 begin
11887 if (res^.FType.BaseType = btSingle) or (res^.FType.BaseType = btDouble) or
11888 (res^.FType.BaseType = btCurrency) or (res^.Ftype.BaseType = btExtended) then
11889 begin
11890 case Res^.FType.BaseType of
11891 btSingle: PutOnFPUStackExtended(PPSVariantSingle(res).Data);
11892 btDouble: PutOnFPUStackExtended(PPSVariantDouble(res).Data);
11893 btExtended: PutOnFPUStackExtended(PPSVariantExtended(res).Data);
11894 btCurrency: PutOnFPUStackExtended(PPSVariantCurrency(res).Data);
11895 end;
11896 DestroyHeapVariant(Res);
11897 Res := nil;
11898 end else
11899 begin
11900 {$IFNDEF PS_NOINT64}
11901 if res^.FType.BaseType <> btS64 then
11902 {$ENDIF}
11903 //CopyArrayContents(Pointer(Longint(Stack)-PointerSize2), @PPSVariantData(res)^.Data, 1, Res^.FType);
11904 CopyArrayContents(Pointer(Longint(Stack)-Longint(PointerSize2)), @PPSVariantData(res)^.Data, 1, Res^.FType);
11905 end;
11906 end;
11907 DestroyHeapVariant(res);
11908 end;
11909 for i := 0 to Params.Count -1 do
11910 DestroyHeapVariant(Params[i]);
11911 Params.Free;
11912 if Self.Se.ExEx <> erNoError then
11913 begin
11914 if Self.Se.ExObject <> nil then
11915 begin
11916 FStack := Self.Se.ExObject;
11917 Self.Se.ExObject := nil;
11918 raise TObject(FStack);
11919 end else
11920 raise EPSException.Create(PSErrorToString(Self.SE.ExceptionCode, Self.Se.ExceptionString), Self.Se, Self.Se.ExProc, Self.Se.ExPos);
11921 end;
11922 end;
11923 {$endif}
FindClassnull11924 function TPSRuntimeClassImporter.FindClass(const Name: tbtString): TPSRuntimeClass;
11925 var
11926 h, i: Longint;
11927 lName: tbtstring;
11928 p: TPSRuntimeClass;
11929 begin
11930 lName := FastUpperCase(Name);
11931 h := MakeHash(lName);
11932 for i := FClasses.Count -1 downto 0 do
11933 begin
11934 p := FClasses[i];
11935 if (p.FClassNameHash = h) and (p.FClassName = lName) then
11936 begin
11937 Result := P;
11938 exit;
11939 end;
11940 end;
11941 Result := nil;
11942 end;
11943
11944 function DelphiFunctionProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack; CC: TPSCallingConvention): Boolean;
11945 var
11946 i: Integer;
11947 MyList: TPSList;
11948 n: PPSVariantIFC;
11949 CurrStack: Cardinal;
11950 s: tbtString;
11951 begin
11952 s := P.Decl;
11953 if length(s) = 0 then begin Result := False; exit; end;
11954 CurrStack := Cardinal(Stack.Count) - Cardinal(length(s));
11955 if s[1] = #0 then inc(CurrStack);
11956 MyList := TPSList.Create;
11957
11958 for i := 2 to length(s) do
11959 begin
11960 MyList.Add(nil);
11961 end;
11962 for i := length(s) downto 2 do
11963 begin
11964 MyList[i - 2] := NewPPSVariantIFC(Stack[CurrStack], s[i] <> #0);
11965 inc(CurrStack);
11966 end;
11967 if s[1] <> #0 then
11968 begin
11969 n := NewPPSVariantIFC(Stack[CurrStack], True);
11970 end else n := nil;
11971 try
11972 result := Caller.InnerfuseCall(p.Ext2, p.Ext1, cc, MyList, n);
11973 finally
11974 DisposePPSVariantIFC(n);
11975 DisposePPSVariantIFCList(mylist);
11976 end;
11977 end;
11978
11979 function DelphiFunctionProc_CDECL(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
11980 begin
11981 Result := DelphiFunctionProc(Caller, p, Global, Stack, cdCdecl);
11982 end;
11983 function DelphiFunctionProc_Register(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
11984 begin
11985 Result := DelphiFunctionProc(Caller, p, Global, Stack, cdRegister);
11986 end;
11987 function DelphiFunctionProc_Pascal(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
11988 begin
11989 Result := DelphiFunctionProc(Caller, p, Global, Stack, cdPascal);
11990 end;
11991 function DelphiFunctionProc_Stdcall(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
11992 begin
11993 Result := DelphiFunctionProc(Caller, p, Global, Stack, cdStdCall);
11994 end;
11995 function DelphiFunctionProc_Safecall(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
11996 begin
11997 Result := DelphiFunctionProc(Caller, p, Global, Stack, cdSafeCall);
11998 end;
11999
12000 procedure TPSExec.RegisterDelphiFunction(ProcPtr: Pointer;
12001 const Name: tbtString; CC: TPSCallingConvention);
12002 begin
12003 RegisterDelphiMethod(nil, ProcPtr, FastUppercase(Name), CC);
12004 end;
12005
12006 procedure TPSExec.RegisterDelphiMethod(Slf, ProcPtr: Pointer;
12007 const Name: tbtString; CC: TPSCallingConvention);
12008 begin
12009 case cc of
12010 cdRegister: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_Register, ProcPtr, Slf);
12011 cdPascal: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_Pascal, ProcPtr, Slf);
12012 cdStdCall: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_Stdcall, ProcPtr, Slf);
12013 cdSafeCall: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_Safecall, ProcPtr, Slf);
12014 cdCdecl: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_CDECL, ProcPtr, Slf);
12015 end;
12016 end;
12017
12018 { EPSException }
12019
12020 constructor EPSException.Create(const Error: tbtString; Exec: TPSExec;
12021 Procno, ProcPos: Cardinal);
12022 begin
12023 inherited Create(string(Error));
12024 FExec := Exec;
12025 FProcNo := Procno;
12026 FProcPos := ProcPos;
12027 end;
12028
12029 { TPSRuntimeAttribute }
12030
AddValuenull12031 function TPSRuntimeAttribute.AddValue(aType: TPSTypeRec): PPSVariant;
12032 begin
12033 Result := FValues.PushType(aType);
12034 end;
12035
12036 procedure TPSRuntimeAttribute.AdjustSize;
12037 begin
12038 FValues.Capacity := FValues.Length;
12039 end;
12040
12041 constructor TPSRuntimeAttribute.Create(Owner: TPSRuntimeAttributes);
12042 begin
12043 inherited Create;
12044 FOwner := Owner;
12045 FValues := TPSStack.Create;
12046 end;
12047
12048 procedure TPSRuntimeAttribute.DeleteValue(i: Longint);
12049 begin
12050 if Cardinal(i) <> Cardinal(FValues.Count -1) then
12051 raise Exception.Create(RPS_CanOnlySendLastItem);
12052 FValues.Pop;
12053 end;
12054
12055 destructor TPSRuntimeAttribute.Destroy;
12056 begin
12057 FValues.Free;
12058 inherited Destroy;
12059 end;
12060
GetValuenull12061 function TPSRuntimeAttribute.GetValue(I: Longint): PIFVariant;
12062 begin
12063 Result := FValues[i];
12064 end;
12065
GetValueCountnull12066 function TPSRuntimeAttribute.GetValueCount: Longint;
12067 begin
12068 Result := FValues.Count;
12069 end;
12070
12071 { TPSRuntimeAttributes }
12072
Addnull12073 function TPSRuntimeAttributes.Add: TPSRuntimeAttribute;
12074 begin
12075 Result := TPSRuntimeAttribute.Create(Self);
12076 FAttributes.Add(Result);
12077 end;
12078
12079 constructor TPSRuntimeAttributes.Create(AOwner: TPSExec);
12080 begin
12081 inherited Create;
12082 FAttributes := TPSList.Create;
12083 FOwner := AOwner;
12084 end;
12085
12086 procedure TPSRuntimeAttributes.Delete(I: Longint);
12087 begin
12088 TPSRuntimeAttribute(FAttributes[i]).Free;
12089 FAttributes.Delete(i);
12090 end;
12091
12092 destructor TPSRuntimeAttributes.Destroy;
12093 var
12094 i: Longint;
12095 begin
12096 for i := FAttributes.Count -1 downto 0 do
12097 TPSRuntimeAttribute(FAttributes[i]).Free;
12098 FAttributes.Free;
12099 inherited Destroy;
12100 end;
12101
FindAttributenull12102 function TPSRuntimeAttributes.FindAttribute(
12103 const Name: tbtString): TPSRuntimeAttribute;
12104 var
12105 n: tbtString;
12106 i, h: Longint;
12107 begin
12108 n := FastUpperCase(Name);
12109 h := MakeHash(n);
12110 for i := 0 to FAttributes.Count -1 do
12111 begin
12112 Result := FAttributes[i];
12113 if (Result.AttribTypeHash = h) and (Result.AttribType = n) then
12114 exit;
12115 end;
12116 Result := nil;
12117 end;
12118
GetCountnull12119 function TPSRuntimeAttributes.GetCount: Longint;
12120 begin
12121 Result := FAttributes.Count;
12122 end;
12123
GetItemnull12124 function TPSRuntimeAttributes.GetItem(I: Longint): TPSRuntimeAttribute;
12125 begin
12126 Result := FAttributes[i];
12127 end;
12128
12129 { TPSInternalProcRec }
12130
12131 destructor TPSInternalProcRec.Destroy;
12132 begin
12133 if FData <> nil then
12134 Freemem(Fdata, FLength);
12135 inherited Destroy;
12136 end;
12137
12138 { TPsProcRec }
12139
12140 constructor TPSProcRec.Create(Owner: TPSExec);
12141 begin
12142 inherited Create;
12143 FAttributes := TPSRuntimeAttributes.Create(Owner);
12144 end;
12145
12146 destructor TPSProcRec.Destroy;
12147 begin
12148 FAttributes.Free;
12149 inherited Destroy;
12150 end;
12151
12152 { TPSTypeRec_Array }
12153
12154 procedure TPSTypeRec_Array.CalcSize;
12155 begin
12156 FrealSize := PointerSize;
12157 end;
12158
12159 { TPSTypeRec_StaticArray }
12160
12161 procedure TPSTypeRec_StaticArray.CalcSize;
12162 begin
12163 FrealSize := Cardinal(FArrayType.RealSize) * Cardinal(Size);
12164 end;
12165
12166 { TPSTypeRec_Set }
12167
12168 procedure TPSTypeRec_Set.CalcSize;
12169 begin
12170 FrealSize := FByteSize;
12171 end;
12172
12173 const
12174 MemDelta = 4096;
12175
12176 { TPSStack }
12177
12178 procedure TPSStack.AdjustLength;
12179 var
12180 MyLen: Longint;
12181 begin
12182 MyLen := ((FLength shr 12) + 1) shl 12;
12183 if fCapacity < MyLen then
12184 SetCapacity(((MyLen + MemDelta) div MemDelta) * MemDelta);
12185 end;
12186
12187 procedure TPSStack.Clear;
12188 var
12189 v: Pointer;
12190 i: Longint;
12191 begin
12192 for i := Count -1 downto 0 do
12193 begin
12194 v := Data[i];
12195 if TPSTypeRec(v^).BaseType in NeedFinalization then
12196 FinalizeVariant(Pointer(IPointer(v)+PointerSize), TPSTypeRec(v^));
12197 end;
12198 inherited Clear;
12199 FLength := 0;
12200 SetCapacity(0);
12201 end;
12202
12203 constructor TPSStack.Create;
12204 begin
12205 inherited Create;
12206 GetMem(FDataPtr, MemDelta);
12207 FCapacity := MemDelta;
12208 FLength := 0;
12209 end;
12210
12211 destructor TPSStack.Destroy;
12212 var
12213 v: Pointer;
12214 i: Longint;
12215 begin
12216 for i := Count -1 downto 0 do
12217 begin
12218 v := Data[i];
12219 if TPSTypeRec(v^).BaseType in NeedFinalization then
12220 FinalizeVariant(Pointer(IPointer(v)+PointerSize), Pointer(v^));
12221 end;
12222 FreeMem(FDataPtr, FCapacity);
12223 inherited Destroy;
12224 end;
12225
GetBoolnull12226 function TPSStack.GetBool(ItemNo: Longint): Boolean;
12227 var
12228 val: PPSVariant;
12229 begin
12230 if ItemNo < 0 then
12231 val := Items[Longint(ItemNo) + Longint(Count)]
12232 else
12233 val := Items[ItemNo];
12234 Result := PSGetUInt(@PPSVariantData(val).Data, val.FType) <> 0;
12235 end;
12236
GetClassnull12237 function TPSStack.GetClass(ItemNo: Longint): TObject;
12238 var
12239 val: PPSVariant;
12240 begin
12241 if ItemNo < 0 then
12242 val := Items[Longint(ItemNo) + Longint(Count)]
12243 else
12244 val := Items[ItemNo];
12245 Result := PSGetObject(@PPSVariantData(val).Data, val.FType);
12246 end;
12247
GetCurrencynull12248 function TPSStack.GetCurrency(ItemNo: Longint): Currency;
12249 var
12250 val: PPSVariant;
12251 begin
12252 if ItemNo < 0 then
12253 val := Items[Longint(ItemNo) + Longint(Count)]
12254 else
12255 val := Items[ItemNo];
12256 Result := PSGetCurrency(@PPSVariantData(val).Data, val.FType);
12257 end;
12258
GetIntnull12259 function TPSStack.GetInt(ItemNo: Longint): Longint;
12260 var
12261 val: PPSVariant;
12262 begin
12263 if ItemNo < 0 then
12264 val := items[Longint(ItemNo) + Longint(Count)]
12265 else
12266 val := items[ItemNo];
12267 Result := PSGetInt(@PPSVariantData(val).Data, val.FType);
12268 end;
12269
12270 {$IFNDEF PS_NOINT64}
GetInt64null12271 function TPSStack.GetInt64(ItemNo: Longint): Int64;
12272 var
12273 val: PPSVariant;
12274 begin
12275 if ItemNo < 0 then
12276 val := items[Longint(ItemNo) + Longint(Count)]
12277 else
12278 val := items[ItemNo];
12279 Result := PSGetInt64(@PPSVariantData(val).Data, val.FType);
12280 end;
12281 {$ENDIF}
12282
GetItemnull12283 function TPSStack.GetItem(I: Longint): PPSVariant;
12284 begin
12285 if Cardinal(I) >= Cardinal(Count) then
12286 Result := nil
12287 else
12288 Result := Data[i];
12289 end;
12290
GetRealnull12291 function TPSStack.GetReal(ItemNo: Longint): Extended;
12292 var
12293 val: PPSVariant;
12294 begin
12295 if ItemNo < 0 then
12296 val := items[Longint(ItemNo) + Longint(Count)]
12297 else
12298 val := items[ItemNo];
12299 Result := PSGetreal(@PPSVariantData(val).Data, val.FType);
12300 end;
12301
GetAnsiStringnull12302 function TPSStack.GetAnsiString(ItemNo: Longint): tbtString;
12303 var
12304 val: PPSVariant;
12305 begin
12306 if ItemNo < 0 then
12307 val := items[Longint(ItemNo) + Longint(Count)]
12308 else
12309 val := items[ItemNo];
12310 Result := PSGetAnsiString(@PPSVariantData(val).Data, val.FType);
12311 end;
12312
GetStringnull12313 function TPSStack.GetString(ItemNo: Longint): string; // calls the native method
12314 begin
12315 result := {$IFNDEF PS_NOWIDESTRING}{$IFDEF DELPHI2009UP}GetUnicodeString(ItemNo){$ELSE}GetAnsiString(ItemNo){$ENDIF}{$ELSE}GetAnsiString(ItemNo){$ENDIF};
12316 end;
12317
GetUIntnull12318 function TPSStack.GetUInt(ItemNo: Longint): Cardinal;
12319 var
12320 val: PPSVariant;
12321 begin
12322 if ItemNo < 0 then
12323 val := items[Longint(ItemNo) + Longint(Count)]
12324 else
12325 val := items[ItemNo];
12326 Result := PSGetUInt(@PPSVariantData(val).Data, val.FType);
12327 end;
12328
12329 {$IFNDEF PS_NOWIDESTRING}
GetUnicodeStringnull12330 function TPSStack.GetUnicodeString(ItemNo: Integer): tbtunicodestring;
12331 var
12332 val: PPSVariant;
12333 begin
12334 if ItemNo < 0 then
12335 val := items[Longint(ItemNo) + Longint(Count)]
12336 else
12337 val := items[ItemNo];
12338 Result := PSGetUnicodeString(@PPSVariantData(val).Data, val.FType);
12339 end;
12340
GetWideStringnull12341 function TPSStack.GetWideString(ItemNo: Longint): tbtWideString;
12342 var
12343 val: PPSVariant;
12344 begin
12345 if ItemNo < 0 then
12346 val := items[Longint(ItemNo) + Longint(Count)]
12347 else
12348 val := items[ItemNo];
12349 Result := PSGetWideString(@PPSVariantData(val).Data, val.FType);
12350 end;
12351 {$ENDIF}
12352
12353 procedure TPSStack.Pop;
12354 var
12355 p1: Pointer;
12356 c: Longint;
12357 begin
12358 c := count -1;
12359 p1 := Data[c];
12360 DeleteLast;
12361 FLength := IPointer(p1) - IPointer(FDataPtr);
12362 if TPSTypeRec(p1^).BaseType in NeedFinalization then
12363 FinalizeVariant(Pointer(IPointer(p1)+PointerSize), Pointer(p1^));
12364 if ((FCapacity - FLength) shr 12) > 2 then AdjustLength;
12365 end;
12366
Pushnull12367 function TPSStack.Push(TotalSize: Longint): PPSVariant;
12368 var
12369 o: Cardinal;
12370 p: Pointer;
12371 begin
12372 o := FLength;
12373 FLength := (FLength + TotalSize);
12374 //if FLength mod PointerSize <> 0 then
12375 if FLength mod Longint(PointerSize) <> 0 then
12376 //FLength := FLength + (PointerSize - (FLength mod PointerSize));
12377 FLength := FLength + (Longint(PointerSize) - Longint((FLength mod Longint(PointerSize))));
12378 if FLength > FCapacity then AdjustLength;
12379 p := Pointer(IPointer(FDataPtr) + IPointer(o));
12380 Add(p);
12381 Result := P;
12382 end;
12383
PushTypenull12384 function TPSStack.PushType(aType: TPSTypeRec): PPSVariant;
12385 begin
12386 Result := Push(aType.RealSize + Sizeof(Pointer));
12387 Result.FType := aType;
12388 InitializeVariant(Pointer(IPointer(Result)+PointerSize), aType);
12389 end;
12390
12391 procedure TPSStack.SetBool(ItemNo: Longint; const Data: Boolean);
12392 var
12393 val: PPSVariant;
12394 ok: Boolean;
12395 begin
12396 if ItemNo < 0 then
12397 val := items[Longint(ItemNo) + Longint(Count)]
12398 else
12399 val := items[ItemNo];
12400 ok := true;
12401 if Data then
12402 PSSetUInt(@PPSVariantData(val).Data, val.FType, ok, 1)
12403 else
12404 PSSetUInt(@PPSVariantData(val).Data, val.FType, ok, 0);
12405 if not ok then raise Exception.Create(RPS_TypeMismatch);
12406 end;
12407
12408 procedure TPSStack.SetCapacity(const Value: Longint);
12409 var
12410 p: Pointer;
12411 OOFS: IPointer;
12412 I: Longint;
12413 begin
12414 if Value < FLength then raise Exception.Create(RPS_CapacityLength);
12415 if Value = 0 then
12416 begin
12417 if FDataPtr <> nil then
12418 begin
12419 FreeMem(FDataPtr, FCapacity);
12420 FDataPtr := nil;
12421 end;
12422 FCapacity := 0;
12423 end;
12424 GetMem(p, Value);
12425 if FDataPtr <> nil then
12426 begin
12427 if FLength > FCapacity then
12428 OOFS := FCapacity
12429 else
12430 OOFS := FLength;
12431 Move(FDataPtr^, p^, OOFS);
12432 OOFS := IPointer(P) - IPointer(FDataPtr);
12433
12434 for i := Count -1 downto 0 do begin
12435 Data[i] := Pointer(IPointer(Data[i]) + OOFS);
12436 if Items[i].FType.FBaseType = btPointer then begin // check if pointer points to moved stack data
12437 if (IPointer(PPSVariantPointer(Data[i]).DataDest) >= IPointer(FDataPtr)) and
12438 (IPointer(PPSVariantPointer(Data[i]).DataDest) < IPointer(FDataPtr)+IPointer(FLength)) then
12439 PPSVariantPointer(Data[i]).DataDest := Pointer(IPointer(PPSVariantPointer(Data[i]).DataDest) + OOFS);
12440 end;
12441 end;
12442
12443 FreeMem(FDataPtr, FCapacity);
12444 end;
12445 FDataPtr := p;
12446 FCapacity := Value;
12447 end;
12448
12449 procedure TPSStack.SetClass(ItemNo: Longint; const Data: TObject);
12450 var
12451 val: PPSVariant;
12452 ok: Boolean;
12453 begin
12454 if ItemNo < 0 then
12455 val := items[Longint(ItemNo) + Longint(Count)]
12456 else
12457 val := items[ItemNo];
12458 ok := true;
12459 PSSetObject(@PPSVariantData(val).Data, val.FType, ok, Data);
12460 if not ok then raise Exception.Create(RPS_TypeMismatch);
12461 end;
12462
12463 procedure TPSStack.SetCurrency(ItemNo: Longint; const Data: Currency);
12464 var
12465 val: PPSVariant;
12466 ok: Boolean;
12467 begin
12468 if ItemNo < 0 then
12469 val := items[Longint(ItemNo) + Longint(Count)]
12470 else
12471 val := items[ItemNo];
12472 ok := true;
12473 PSSetCurrency(@PPSVariantData(val).Data, val.FType, ok, Data);
12474 if not ok then raise Exception.Create(RPS_TypeMismatch);
12475 end;
12476
12477 procedure TPSStack.SetInt(ItemNo: Longint; const Data: Longint);
12478 var
12479 val: PPSVariant;
12480 ok: Boolean;
12481 begin
12482 if ItemNo < 0 then
12483 val := items[Longint(ItemNo) + Longint(Count)]
12484 else
12485 val := items[ItemNo];
12486 ok := true;
12487 PSSetInt(@PPSVariantData(val).Data, val.FType, ok, Data);
12488 if not ok then raise Exception.Create(RPS_TypeMismatch);
12489 end;
12490
12491 {$IFNDEF PS_NOINT64}
12492 procedure TPSStack.SetInt64(ItemNo: Longint; const Data: Int64);
12493 var
12494 val: PPSVariant;
12495 ok: Boolean;
12496 begin
12497 if ItemNo < 0 then
12498 val := items[Longint(ItemNo) + Longint(Count)]
12499 else
12500 val := items[ItemNo];
12501 ok := true;
12502 PSSetInt64(@PPSVariantData(val).Data, val.FType, ok, Data);
12503 if not ok then raise Exception.Create(RPS_TypeMismatch);
12504 end;
12505 {$ENDIF}
12506
12507 procedure TPSStack.SetReal(ItemNo: Longint; const Data: Extended);
12508 var
12509 val: PPSVariant;
12510 ok: Boolean;
12511 begin
12512 if ItemNo < 0 then
12513 val := items[Longint(ItemNo) + Longint(Count)]
12514 else
12515 val := items[ItemNo];
12516 ok := true;
12517 PSSetReal(@PPSVariantData(val).Data, val.FType, ok, Data);
12518 if not ok then raise Exception.Create(RPS_TypeMismatch);
12519 end;
12520
12521 procedure TPSStack.SetAnsiString(ItemNo: Longint; const Data: tbtString);
12522 var
12523 val: PPSVariant;
12524 ok: Boolean;
12525 begin
12526 if ItemNo < 0 then
12527 val := items[Longint(ItemNo) + Longint(Count)]
12528 else
12529 val := items[ItemNo];
12530 ok := true;
12531 PSSetAnsiString(@PPSVariantData(val).Data, val.FType, ok, Data);
12532 if not ok then raise Exception.Create(RPS_TypeMismatch);
12533 end;
12534
12535 procedure TPSStack.SetString(ItemNo: Longint; const Data: string);
12536 begin
12537 {$IFNDEF PS_NOWIDESTRING}
12538 {$IFDEF DELPHI2009UP}
12539 SetUnicodeString(ItemNo, Data);
12540 {$ELSE}
12541 SetAnsiString(ItemNo, Data);
12542 {$ENDIF}
12543 {$ELSE}
12544 SetAnsiString(ItemNo, Data);
12545 {$ENDIF}
12546 end;
12547
12548
12549 procedure TPSStack.SetUInt(ItemNo: Longint; const Data: Cardinal);
12550 var
12551 val: PPSVariant;
12552 ok: Boolean;
12553 begin
12554 if ItemNo < 0 then
12555 val := items[Longint(ItemNo) + Longint(Count)]
12556 else
12557 val := items[ItemNo];
12558 ok := true;
12559 PSSetUInt(@PPSVariantData(val).Data, val.FType, ok, Data);
12560 if not ok then raise Exception.Create(RPS_TypeMismatch);
12561 end;
12562
12563
12564 {$IFNDEF PS_NOWIDESTRING}
12565 procedure TPSStack.SetUnicodeString(ItemNo: Integer;
12566 const Data: tbtunicodestring);
12567 var
12568 val: PPSVariant;
12569 ok: Boolean;
12570 begin
12571 if ItemNo < 0 then
12572 val := items[Longint(ItemNo) + Longint(Count)]
12573 else
12574 val := items[ItemNo];
12575 ok := true;
12576 PSSetUnicodeString(@PPSVariantData(val).Data, val.FType, ok, Data);
12577 end;
12578
12579 procedure TPSStack.SetWideString(ItemNo: Longint;
12580 const Data: tbtWideString);
12581 var
12582 val: PPSVariant;
12583 ok: Boolean;
12584 begin
12585 if ItemNo < 0 then
12586 val := items[Longint(ItemNo) + Longint(Count)]
12587 else
12588 val := items[ItemNo];
12589 ok := true;
12590 PSSetWideString(@PPSVariantData(val).Data, val.FType, ok, Data);
12591 if not ok then raise Exception.Create(RPS_TypeMismatch);
12592 end;
12593 {$ENDIF}
12594
12595
12596 {$IFNDEF PS_NOIDISPATCH}
12597 var
12598 DispPropertyPut: Integer = DISPID_PROPERTYPUT;
12599 const
12600 LOCALE_SYSTEM_DEFAULT = 2 shl 10; // Delphi 2 doesn't define this
12601
12602 function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: tbtString; const Par: array of Variant): Variant;
12603 var
12604 Param: Word;
12605 i, ArgErr: Longint;
12606 DispatchId: Longint;
12607 DispParam: TDispParams;
12608 ExceptInfo: TExcepInfo;
12609 aName: PWideChar;
12610 WSFreeList: TPSList;
12611 begin
12612 if Self = nil then begin
12613 raise EPSException.Create('Variant is null, cannot invoke', nil, 0, 0);
12614 end;
12615 FillChar(ExceptInfo, SizeOf(ExceptInfo), 0);
12616 if Name='' then begin
12617 DispatchId:=0;
12618 end else begin
12619 aName := StringToOleStr(Name);
12620 try
12621 if Self = nil then
12622 raise Exception.Create(RPS_NILInterfaceException);
12623 if Self.GetIDsOfNames(GUID_NULL, @aName, 1, LOCALE_SYSTEM_DEFAULT, @DispatchId) <> S_OK then
12624 raise Exception.Create(RPS_UnknownMethod);
12625 finally
12626 SysFreeString(aName);
12627 end;
12628 end;
12629 DispParam.cNamedArgs := 0;
12630 DispParam.rgdispidNamedArgs := nil;
12631 DispParam.cArgs := (High(Par) + 1);
12632
12633 if PropertySet then
12634 begin
12635 Param := DISPATCH_PROPERTYPUT;
12636 DispParam.cNamedArgs := 1;
12637 DispParam.rgdispidNamedArgs := @DispPropertyPut;
12638 end else
12639 Param := DISPATCH_METHOD or DISPATCH_PROPERTYGET;
12640
12641 WSFreeList := TPSList.Create;
12642 try
12643 GetMem(DispParam.rgvarg, sizeof(TVariantArg) * (High(Par) + 1));
12644 FillCHar(DispParam.rgvarg^, sizeof(TVariantArg) * (High(Par) + 1), 0);
12645 try
12646 for i := 0 to High(Par) do
12647 begin
12648 if PVarData(@Par[High(Par)-i]).VType = varString then
12649 begin
12650 DispParam.rgvarg[i].vt := VT_BSTR;
12651 DispParam.rgvarg[i].bstrVal := StringToOleStr(AnsiString(Par[High(Par)-i]));
12652 WSFreeList.Add(DispParam.rgvarg[i].bstrVal);
12653 {$IFDEF UNICODE}
12654 end else if (PVarData(@Par[High(Par)-i]).VType = varOleStr) or (PVarData(@Par[High(Par)-i]).VType = varUString) then
12655 begin
12656 DispParam.rgvarg[i].vt := VT_BSTR;
12657 DispParam.rgvarg[i].bstrVal := StringToOleStr(UnicodeString(Par[High(Par)-i]));
12658 WSFreeList.Add(DispParam.rgvarg[i].bstrVal);
12659 {$ENDIF}
12660 end else
12661 begin
12662 DispParam.rgvarg[i].vt := VT_VARIANT or VT_BYREF;
12663 New(
12664 {$IFDEF DELPHI4UP}
12665 POleVariant
12666 {$ELSE}
12667 PVariant{$ENDIF}
12668 (DispParam.rgvarg[i].pvarVal));
12669
12670 (*
12671 {$IFDEF DELPHI4UP}
12672 POleVariant
12673 {$ELSE}
12674 PVariant
12675 {$ENDIF}
12676 (DispParam.rgvarg[i].pvarVal)^ := Par[High(Par)-i];
12677 *)
12678 Move(Par[High(Par)-i],Pointer(DispParam.rgvarg[i].pvarVal)^,
12679 Sizeof({$IFDEF DELPHI4UP}OleVariant{$ELSE}Variant{$ENDIF}));
12680
12681 end;
12682 end;
12683 i :=Self.Invoke(DispatchId, GUID_NULL, LOCALE_SYSTEM_DEFAULT, Param, DispParam, @Result, @ExceptInfo, @ArgErr);
12684 {$IFNDEF Delphi3UP}
12685 try
12686 if not Succeeded(i) then
12687 begin
12688 if i = DISP_E_EXCEPTION then
12689 raise Exception.Create(OleStrToString(ExceptInfo.bstrSource)+': '+OleStrToString(ExceptInfo.bstrDescription))
12690 else
12691 raise Exception.Create(SysErrorMessage(i));
12692 end;
12693 finally
12694 SysFreeString(ExceptInfo.bstrSource);
12695 SysFreeString(ExceptInfo.bstrDescription);
12696 SysFreeString(ExceptInfo.bstrHelpFile);
12697 end;
12698 {$ELSE}
12699 if not Succeeded(i) then
12700 begin
12701 if i = DISP_E_EXCEPTION then
12702 {$IFDEF FPC}
12703 raise Exception.Create(ExceptInfo.Source+': '+ExceptInfo.Description)
12704 {$ELSE}
12705 raise Exception.Create(ExceptInfo.bstrSource+': '+ExceptInfo.bstrDescription)
12706 {$ENDIF}
12707 else
12708 raise Exception.Create(SysErrorMessage(i));
12709 end;
12710 {$ENDIF}
12711 finally
12712 for i := 0 to High(Par) do
12713 begin
12714 if DispParam.rgvarg[i].vt = (VT_VARIANT or VT_BYREF) then
12715 begin
12716 if{$IFDEF DELPHI4UP}POleVariant{$ELSE}PVariant{$ENDIF}
12717 (DispParam.rgvarg[i].pvarVal) <> nil then
12718 Dispose(
12719 {$IFDEF DELPHI4UP}
12720 POleVariant
12721 {$ELSE}
12722 PVariant
12723 {$ENDIF}
12724 (DispParam.rgvarg[i].pvarVal));
12725 end;
12726 end;
12727 FreeMem(DispParam.rgvarg, sizeof(TVariantArg) * (High(Par) + 1));
12728 end;
12729 finally
12730 for i := WSFreeList.Count -1 downto 0 do
12731 SysFreeString(WSFreeList[i]);
12732 WSFreeList.Free;
12733 end;
12734 end;
12735 {$ENDIF}
12736
12737
12738 { TPSTypeRec_ProcPtr }
12739
12740 procedure TPSTypeRec_ProcPtr.CalcSize;
12741 begin
12742 FRealSize := 3 * sizeof(Pointer);
12743 end;
12744
12745 end.
12746
12747