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 8: (ProcPtr: TPSProcPtr; Ext1, Ext2: Pointer);
515 9: (ReadProcPtr, WriteProcPtr: TPSProcPtr; ExtRead1, ExtRead2, ExtWrite1, ExtWrite2: Pointer); {Property Helper}
516 end;
517
518
519 PPSVariantIFC = ^TPSVariantIFC;
520 {Temporary variant into record}
521 TPSVariantIFC = packed record
522 Dta: Pointer;
523 aType: TPSTypeRec;
524 VarParam: Boolean;
525 end;
526 PIFPSVariantIFC = PPSVariantIFC;
527 TIFPSVariantIFC = TPSVariantIFC;
528
529 TPSRuntimeAttribute = class(TObject)
530 private
531 FValues: TPSStack;
532 FAttribType: tbtstring;
533 FOwner: TPSRuntimeAttributes;
534 FAttribTypeHash: Longint;
GetValuenull535 function GetValue(I: Longint): PIFVariant;
GetValueCountnull536 function GetValueCount: Longint;
537 public
538
539 property Owner: TPSRuntimeAttributes read FOwner;
540
541 property AttribType: tbtstring read FAttribType write FAttribType;
542
543 property AttribTypeHash: Longint read FAttribTypeHash write FAttribTypeHash;
544
545 property ValueCount: Longint read GetValueCount;
546
547 property Value[I: Longint]: PIFVariant read GetValue;
548
AddValuenull549 function AddValue(aType: TPSTypeRec): PPSVariant;
550
551 procedure DeleteValue(i: Longint);
552
553 procedure AdjustSize;
554
555
556 constructor Create(Owner: TPSRuntimeAttributes);
557
558 destructor Destroy; override;
559 end;
560
561 TPSRuntimeAttributes = class(TObject)
562 private
563 FAttributes: TPSList;
564 FOwner: TPSExec;
GetCountnull565 function GetCount: Longint;
GetItemnull566 function GetItem(I: Longint): TPSRuntimeAttribute;
567 public
568
569 property Owner: TPSExec read FOwner;
570
571 property Count: Longint read GetCount;
572
573 property Items[I: Longint]: TPSRuntimeAttribute read GetItem; default;
574
575 procedure Delete(I: Longint);
576
Addnull577 function Add: TPSRuntimeAttribute;
578
FindAttributenull579 function FindAttribute(const Name: tbtstring): TPSRuntimeAttribute;
580
581
582 constructor Create(AOwner: TPSExec);
583
584 destructor Destroy; override;
585 end;
586 TPSOnGetNVariant = function (Sender: TPSExec; const Name: tbtstring): Variant;
587 TPSOnSetNVariant = procedure (Sender: TPSExec; const Name: tbtstring; V: Variant);
588
589 TPSOnLineEvent = procedure(Sender: TPSExec);
590
591 TPSOnSpecialProcImport = function (Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean;
592
593 TPSOnException = procedure (Sender: TPSExec; ExError: TPSError; const ExParam: tbtstring; ExObject: TObject; ProcNo, Position: Cardinal);
594
595 TPSExec = class(TObject)
596 Private
597 FOnGetNVariant: TPSOnGetNVariant;
598 FOnSetNVariant: TPSOnSetNVariant;
599 FId: Pointer;
600 FJumpFlag: Boolean;
601 FCallCleanup: Boolean;
602 FOnException: TPSOnException;
ReadDatanull603 function ReadData(var Data; Len: Cardinal): Boolean;
ReadLongnull604 function ReadLong(var b: Cardinal): Boolean;
DoCalcnull605 function DoCalc(var1, Var2: Pointer; var1Type, var2type: TPSTypeRec; CalcType: Cardinal): Boolean;
DoBooleanCalcnull606 function DoBooleanCalc(var1, Var2, into: Pointer; var1Type, var2type, intotype: TPSTypeRec; Cmd: Cardinal): Boolean;
SetVariantValuenull607 function SetVariantValue(dest, Src: Pointer; desttype, srctype: TPSTypeRec): Boolean;
ReadVariablenull608 function ReadVariable(var Dest: TPSResultData; UsePointer: Boolean): Boolean;
DoBooleanNotnull609 function DoBooleanNot(Dta: Pointer; aType: TPSTypeRec): Boolean;
DoMinusnull610 function DoMinus(Dta: Pointer; aType: TPSTypeRec): Boolean;
DoIntegerNotnull611 function DoIntegerNot(Dta: Pointer; aType: TPSTypeRec): Boolean;
612 procedure RegisterStandardProcs;
613 Protected
614
615 FReturnAddressType: TPSTypeRec;
616
617 FVariantType: TPSTypeRec;
618
619 FVariantArrayType: TPSTypeRec;
620
621 FAttributeTypes: TPSList;
622
623 FExceptionStack: TPSList;
624
625 FResources: TPSList;
626
627 FExportedVars: TPSList;
628
629 FTypes: TPSList;
630
631 FProcs: TPSList;
632
633 FGlobalVars: TPSStack;
634
635 FTempVars: TPSStack;
636
637 FStack: TPSStack;
638
639 FMainProc: Cardinal;
640
641 FStatus: TPSStatus;
642
643 FCurrProc: TPSInternalProcRec;
644
645 FData: PByteArray;
646
647 FDataLength: Cardinal;
648
649 FCurrentPosition: Cardinal;
650
651 FCurrStackBase: Cardinal;
652
653 FOnRunLine: TPSOnLineEvent;
654
655 FSpecialProcList: TPSList;
656
657 FRegProcs: TPSList;
658
659 ExObject: TObject;
660
661 ExProc: Cardinal;
662
663 ExPos: Cardinal;
664
665 ExEx: TPSError;
666
667 ExParam: tbtstring;
668
InvokeExternalMethodnull669 function InvokeExternalMethod(At: TPSTypeRec_ProcPtr; Slf, Ptr: Pointer): Boolean;
670
InnerfuseCallnull671 function InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean;
672
673 procedure RunLine; virtual;
674
ImportProcnull675 function ImportProc(const Name: ShortString; proc: TPSExternalProcRec): Boolean; Virtual;
676
677 procedure ExceptionProc(proc, Position: Cardinal; Ex: TPSError; const s: tbtstring; NewObject: TObject); Virtual;
678
FindSpecialProcImportnull679 function FindSpecialProcImport(P: TPSOnSpecialProcImport): pointer;
680 Public
LastExnull681 function LastEx: TPSError;
LastExParamnull682 function LastExParam: tbtstring;
LastExProcnull683 function LastExProc: Integer;
LastExPosnull684 function LastExPos: Integer;
LastExObjectnull685 function LastExObject: TObject;
686 procedure CMD_Err(EC: TPSError);
687
688 procedure CMD_Err2(EC: TPSError; const Param: tbtstring);
689
690 procedure CMD_Err3(EC: TPSError; const Param: tbtstring; ExObject: TObject);
691
692 property Id: Pointer read FID write FID;
693
Aboutnull694 class function About: tbtstring;
695
RunProcnull696 function RunProc(Params: TPSList; ProcNo: Cardinal): Boolean;
697
RunProcPnull698 function RunProcP(const Params: array of Variant; const Procno: Cardinal): Variant;
RunProcPVarnull699 function RunProcPVar(var Params: array of Variant; const Procno: Cardinal): Variant;
700
RunProcPNnull701 function RunProcPN(const Params: array of Variant; const ProcName: tbtstring): Variant;
702
FindTypenull703 function FindType(StartAt: Cardinal; BaseType: TPSBaseType; var l: Cardinal): PIFTypeRec;
704
FindType2null705 function FindType2(BaseType: TPSBaseType): PIFTypeRec;
706
GetTypeNonull707 function GetTypeNo(l: Cardinal): PIFTypeRec;
708
GetTypenull709 function GetType(const Name: tbtstring): Cardinal;
710
GetProcnull711 function GetProc(const Name: tbtstring): Cardinal;
712
GetVarnull713 function GetVar(const Name: tbtstring): Cardinal;
714
GetVar2null715 function GetVar2(const Name: tbtstring): PIFVariant;
716
GetVarNonull717 function GetVarNo(C: Cardinal): PIFVariant;
718
GetProcNonull719 function GetProcNo(C: Cardinal): PIFProcRec;
720
GetProcCountnull721 function GetProcCount: Cardinal;
722
GetVarCountnull723 function GetVarCount: Longint;
724
GetTypeCountnull725 function GetTypeCount: Longint;
726
727
728 constructor Create;
729
730 destructor Destroy; Override;
731
732
RunScriptnull733 function RunScript: Boolean;
734
735
LoadDatanull736 function LoadData(const s: tbtstring): Boolean; virtual;
737
738 procedure Clear; Virtual;
739
740 procedure Cleanup; Virtual;
741
742 procedure Stop; Virtual;
743
744 procedure Pause; Virtual;
745
746 property CallCleanup: Boolean read FCallCleanup write FCallCleanup;
747
748 property Status: TPSStatus Read FStatus;
749
750 property OnRunLine: TPSOnLineEvent Read FOnRunLine Write FOnRunLine;
751
752 procedure ClearspecialProcImports;
753
754 procedure AddSpecialProcImport(const FName: tbtstring; P: TPSOnSpecialProcImport; Tag: Pointer);
755
RegisterFunctionNamenull756 function RegisterFunctionName(const Name: tbtstring; ProcPtr: TPSProcPtr;
757 Ext1, Ext2: Pointer): PProcRec;
758
759 procedure RegisterDelphiFunction(ProcPtr: Pointer; const Name: tbtstring; CC: TPSCallingConvention);
760
761 procedure RegisterDelphiMethod(Slf, ProcPtr: Pointer; const Name: tbtstring; CC: TPSCallingConvention);
762
GetProcAsMethodnull763 function GetProcAsMethod(const ProcNo: Cardinal): TMethod;
764
GetProcAsMethodNnull765 function GetProcAsMethodN(const ProcName: tbtstring): TMethod;
766
767 procedure RegisterAttributeType(useproc: TPSAttributeUseProc; const TypeName: tbtstring);
768
769 procedure ClearFunctionList;
770
771 property ExceptionProcNo: Cardinal Read ExProc;
772
773 property ExceptionPos: Cardinal Read ExPos;
774
775 property ExceptionCode: TPSError Read ExEx;
776
777 property ExceptionString: tbtstring read ExParam;
778
779 property ExceptionObject: TObject read ExObject write ExObject;
780
781 procedure AddResource(Proc, P: Pointer);
782
IsValidResourcenull783 function IsValidResource(Proc, P: Pointer): Boolean;
784
785 procedure DeleteResource(P: Pointer);
786
FindProcResourcenull787 function FindProcResource(Proc: Pointer): Pointer;
788
FindProcResource2null789 function FindProcResource2(Proc: Pointer; var StartAt: Longint): Pointer;
790
791 procedure RaiseCurrentException;
792
793 property OnException: TPSOnException read FOnException write FOnException;
794 property OnGetNVariant: TPSOnGetNVariant read FOnGetNVariant write FOnGetNVariant;
795 property OnSetNVariant: TPSOnSetNVariant read FOnSetNVariant write FOnSetNVariant;
796 end;
797
798 TPSStack = class(TPSList)
799 private
800 FDataPtr: Pointer;
801 FCapacity,
802 FLength: Longint;
GetItemnull803 function GetItem(I: Longint): PPSVariant;
804 procedure SetCapacity(const Value: Longint);
805 procedure AdjustLength;
806 public
807
808 property DataPtr: Pointer read FDataPtr;
809
810 property Capacity: Longint read FCapacity write SetCapacity;
811
812 property Length: Longint read FLength;
813
814
815 constructor Create;
816
817 destructor Destroy; override;
818
819 procedure Clear; {$IFDEF DELPHI5UP} reintroduce;{$ELSE} override; {$ENDIF}
820
Pushnull821 function Push(TotalSize: Longint): PPSVariant;
822
PushTypenull823 function PushType(aType: TPSTypeRec): PPSVariant;
824
825 procedure Pop;
GetIntnull826 function GetInt(ItemNo: Longint): Longint;
GetUIntnull827 function GetUInt(ItemNo: Longint): Cardinal;
828 {$IFNDEF PS_NOINT64}
GetInt64null829 function GetInt64(ItemNo: Longint): Int64;
830 {$ENDIF}
GetStringnull831 function GetString(ItemNo: Longint): string; // calls the native method
GetAnsiStringnull832 function GetAnsiString(ItemNo: Longint): tbtstring;
833 {$IFNDEF PS_NOWIDESTRING}
GetWideStringnull834 function GetWideString(ItemNo: Longint): tbtWideString;
GetUnicodeStringnull835 function GetUnicodeString(ItemNo: Longint): tbtunicodestring;
836 {$ENDIF}
GetRealnull837 function GetReal(ItemNo: Longint): Extended;
GetCurrencynull838 function GetCurrency(ItemNo: Longint): Currency;
GetBoolnull839 function GetBool(ItemNo: Longint): Boolean;
GetClassnull840 function GetClass(ItemNo: Longint): TObject;
841
842 procedure SetInt(ItemNo: Longint; const Data: Longint);
843 procedure SetUInt(ItemNo: Longint; const Data: Cardinal);
844 {$IFNDEF PS_NOINT64}
845 procedure SetInt64(ItemNo: Longint; const Data: Int64);
846 {$ENDIF}
847 procedure SetString(ItemNo: Longint; const Data: string);
848 procedure SetAnsiString(ItemNo: Longint; const Data: tbtstring);
849 {$IFNDEF PS_NOWIDESTRING}
850 procedure SetWideString(ItemNo: Longint; const Data: tbtWideString);
851 procedure SetUnicodeString(ItemNo: Longint; const Data: tbtunicodestring);
852 {$ENDIF}
853 procedure SetReal(ItemNo: Longint; const Data: Extended);
854 procedure SetCurrency(ItemNo: Longint; const Data: Currency);
855 procedure SetBool(ItemNo: Longint; const Data: Boolean);
856 procedure SetClass(ItemNo: Longint; const Data: TObject);
857
858 property Items[I: Longint]: PPSVariant read GetItem; default;
859 end;
860
861
PSErrorToStringnull862 function PSErrorToString(x: TPSError; const Param: tbtstring): tbtstring;
TIFErrorToStringnull863 function TIFErrorToString(x: TPSError; const Param: tbtstring): tbtstring;
CreateHeapVariantnull864 function CreateHeapVariant(aType: TPSTypeRec): PPSVariant;
865 procedure DestroyHeapVariant(v: PPSVariant);
866
867 procedure FreePIFVariantList(l: TPSList);
868 procedure FreePSVariantList(l: TPSList);
869
870 const
871 ENoError = ERNoError;
872
873
PIFVariantToVariantnull874 function PIFVariantToVariant(Src: PIFVariant; var Dest: Variant): Boolean;
VariantToPIFVariantnull875 function VariantToPIFVariant(Exec: TPSExec; const Src: Variant; Dest: PIFVariant): Boolean;
876
PSGetRecFieldnull877 function PSGetRecField(const avar: TPSVariantIFC; Fieldno: Longint): TPSVariantIFC;
PSGetArrayFieldnull878 function PSGetArrayField(const avar: TPSVariantIFC; Fieldno: Longint): TPSVariantIFC;
NewTPSVariantRecordIFCnull879 function NewTPSVariantRecordIFC(avar: PPSVariant; Fieldno: Longint): TPSVariantIFC;
880
NewTPSVariantIFCnull881 function NewTPSVariantIFC(avar: PPSVariant; varparam: boolean): TPSVariantIFC;
882
NewPPSVariantIFCnull883 function NewPPSVariantIFC(avar: PPSVariant; varparam: boolean): PPSVariantIFC;
884
885 procedure DisposePPSVariantIFC(aVar: PPSVariantIFC);
886
887 procedure DisposePPSVariantIFCList(list: TPSList);
888
889
PSGetObjectnull890 function PSGetObject(Src: Pointer; aType: TPSTypeRec): TObject;
PSGetUIntnull891 function PSGetUInt(Src: Pointer; aType: TPSTypeRec): Cardinal;
892 {$IFNDEF PS_NOINT64}
PSGetInt64null893 function PSGetInt64(Src: Pointer; aType: TPSTypeRec): Int64;
894 {$ENDIF}
PSGetRealnull895 function PSGetReal(Src: Pointer; aType: TPSTypeRec): Extended;
PSGetCurrencynull896 function PSGetCurrency(Src: Pointer; aType: TPSTypeRec): Currency;
PSGetIntnull897 function PSGetInt(Src: Pointer; aType: TPSTypeRec): Longint;
PSGetStringnull898 function PSGetString(Src: Pointer; aType: TPSTypeRec): string;
PSGetAnsiStringnull899 function PSGetAnsiString(Src: Pointer; aType: TPSTypeRec): tbtString;
900 {$IFNDEF PS_NOWIDESTRING}
PSGetWideStringnull901 function PSGetWideString(Src: Pointer; aType: TPSTypeRec): tbtWideString;
PSGetUnicodeStringnull902 function PSGetUnicodeString(Src: Pointer; aType: TPSTypeRec): tbtunicodestring;
903 {$ENDIF}
904
905 procedure PSSetObject(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; Const val: TObject);
906 procedure PSSetUInt(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Cardinal);
907 {$IFNDEF PS_NOINT64}
908 procedure PSSetInt64(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Int64);
909 {$ENDIF}
910 procedure PSSetReal(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Extended);
911 procedure PSSetCurrency(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Currency);
912 procedure PSSetInt(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Longint);
913 procedure PSSetString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: String);
914 procedure PSSetAnsiString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtString);
915 {$IFNDEF PS_NOWIDESTRING}
916 procedure PSSetWideString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtWideString);
917 procedure PSSetUnicodeString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtunicodestring);
918 {$ENDIF}
919
920 procedure VNSetPointerTo(const Src: TPSVariantIFC; Data: Pointer; aType: TPSTypeRec);
921
VNGetUIntnull922 function VNGetUInt(const Src: TPSVariantIFC): Cardinal;
923 {$IFNDEF PS_NOINT64}
VNGetInt64null924 function VNGetInt64(const Src: TPSVariantIFC): Int64;
925 {$ENDIF}
VNGetRealnull926 function VNGetReal(const Src: TPSVariantIFC): Extended;
VNGetCurrencynull927 function VNGetCurrency(const Src: TPSVariantIFC): Currency;
VNGetIntnull928 function VNGetInt(const Src: TPSVariantIFC): Longint;
VNGetStringnull929 function VNGetString(const Src: TPSVariantIFC): String;
VNGetAnsiStringnull930 function VNGetAnsiString(const Src: TPSVariantIFC): tbtString;
931 {$IFNDEF PS_NOWIDESTRING}
VNGetWideStringnull932 function VNGetWideString(const Src: TPSVariantIFC): tbtWideString;
VNGetUnicodeStringnull933 function VNGetUnicodeString(const Src: TPSVariantIFC): tbtunicodestring;
934 {$ENDIF}
935
936 procedure VNSetUInt(const Src: TPSVariantIFC; const Val: Cardinal);
937 {$IFNDEF PS_NOINT64}
938 procedure VNSetInt64(const Src: TPSVariantIFC; const Val: Int64);
939 {$ENDIF}
940 procedure VNSetReal(const Src: TPSVariantIFC; const Val: Extended);
941 procedure VNSetCurrency(const Src: TPSVariantIFC; const Val: Currency);
942 procedure VNSetInt(const Src: TPSVariantIFC; const Val: Longint);
943 procedure VNSetString(const Src: TPSVariantIFC; const Val: String);
944 procedure VNSetAnsiString(const Src: TPSVariantIFC; const Val: tbtString);
945 {$IFNDEF PS_NOWIDESTRING}
946 procedure VNSetWideString(const Src: TPSVariantIFC; const Val: tbtWideString);
947 procedure VNSetUnicodeString(const Src: TPSVariantIFC; const Val: tbtunicodestring);
948 {$ENDIF}
949
VGetUIntnull950 function VGetUInt(const Src: PIFVariant): Cardinal;
951 {$IFNDEF PS_NOINT64}
VGetInt64null952 function VGetInt64(const Src: PIFVariant): Int64;
953 {$ENDIF}
VGetRealnull954 function VGetReal(const Src: PIFVariant): Extended;
VGetCurrencynull955 function VGetCurrency(const Src: PIFVariant): Currency;
VGetIntnull956 function VGetInt(const Src: PIFVariant): Longint;
VGetStringnull957 function VGetString(const Src: PIFVariant): String;
VGetAnsiStringnull958 function VGetAnsiString(const Src: PIFVariant): tbtString;
959 {$IFNDEF PS_NOWIDESTRING}
VGetWideStringnull960 function VGetWideString(const Src: PIFVariant): tbtWideString;
VGetUnicodeStringnull961 function VGetUnicodeString(const Src: PIFVariant): tbtunicodestring;
962 {$ENDIF}
963
964 procedure VSetPointerTo(const Src: PIFVariant; Data: Pointer; aType: TPSTypeRec);
965 procedure VSetUInt(const Src: PIFVariant; const Val: Cardinal);
966 {$IFNDEF PS_NOINT64}
967 procedure VSetInt64(const Src: PIFVariant; const Val: Int64);
968 {$ENDIF}
969 procedure VSetReal(const Src: PIFVariant; const Val: Extended);
970 procedure VSetCurrency(const Src: PIFVariant; const Val: Currency);
971 procedure VSetInt(const Src: PIFVariant; const Val: Longint);
972 procedure VSetString(const Src: PIFVariant; const Val: string);
973 procedure VSetAnsiString(const Src: PIFVariant; const Val: tbtString);
974 {$IFNDEF PS_NOWIDESTRING}
975 procedure VSetWideString(const Src: PIFVariant; const Val: tbtWideString);
976 procedure VSetUnicodeString(const Src: PIFVariant; const Val: tbtunicodestring);
977 {$ENDIF}
978
979 type
980
981 EPSException = class(Exception)
982 private
983 FProcPos: Cardinal;
984 FProcNo: Cardinal;
985 FExec: TPSExec;
986 public
987
988 constructor Create(const Error: tbtstring; Exec: TPSExec; Procno, ProcPos: Cardinal);
989
990 property ProcNo: Cardinal read FProcNo;
991
992 property ProcPos: Cardinal read FProcPos;
993
994 property Exec: TPSExec read FExec;
995 end;
996
997 { TPSRuntimeClass }
998
999 TPSRuntimeClass = class
1000 protected
1001 FClassName: tbtstring;
1002 FClassNameHash: Longint;
1003
1004 FClassItems: TPSList;
1005 FClass: TClass;
1006
1007 FEndOfVmt: Longint;
1008 public
1009
1010 procedure RegisterConstructor(ProcPtr: Pointer; const Name: tbtstring);
1011
1012 procedure RegisterVirtualConstructor(ProcPtr: Pointer; const Name: tbtstring);
1013
1014 procedure RegisterMethod(ProcPtr: Pointer; const Name: tbtstring);
1015
1016 procedure RegisterMethodName(const Name: tbtstring; ProcPtr: TPSProcPtr; Ext1, Ext2: Pointer);
1017
1018 procedure RegisterVirtualMethod(ProcPtr: Pointer; const Name: tbtstring);
1019
1020 procedure RegisterVirtualAbstractMethod(ClassDef: TClass; ProcPtr: Pointer; const Name: tbtstring);
1021
1022 procedure RegisterPropertyHelper(ReadFunc, WriteFunc: Pointer; const Name: tbtstring);
1023
1024 procedure RegisterPropertyHelperName(ReadFunc, WriteFunc: Pointer; const Name: tbtstring);
1025
1026 procedure RegisterPropertyNameHelper(const Name: tbtstring; ProcPtr: TPSProcPtr;
1027 ExtRead1, ExtRead2, ExtWrite1, ExtWrite2: Pointer); overload;
1028
1029 procedure RegisterPropertyNameHelper(const Name: tbtstring; ProcReadPtr, ProcWritePtr: TPSProcPtr;
1030 ExtRead1, ExtRead2, ExtWrite1, ExtWrite2: Pointer); overload;
1031
1032 procedure RegisterEventPropertyHelper(ReadFunc, WriteFunc: Pointer; const Name: tbtstring);
1033
1034 constructor Create(aClass: TClass; const AName: tbtstring);
1035
1036 destructor Destroy; override;
1037 end;
1038
1039 TPSRuntimeClassImporter = class
1040 private
1041 FClasses: TPSList;
1042 public
1043
1044 constructor Create;
1045
1046 constructor CreateAndRegister(Exec: TPSExec; AutoFree: Boolean);
1047
1048 destructor Destroy; override;
1049
Addnull1050 function Add(aClass: TClass): TPSRuntimeClass;
1051
Add2null1052 function Add2(aClass: TClass; const Name: tbtstring): TPSRuntimeClass;
1053
1054 procedure Clear;
1055
FindClassnull1056 function FindClass(const Name: tbtstring): TPSRuntimeClass;
1057 end;
1058 TIFPSRuntimeClassImporter = TPSRuntimeClassImporter;
1059 TPSResourceFreeProc = procedure (Sender: TPSExec; P: TPSRuntimeClassImporter);
1060
1061
1062 procedure RegisterClassLibraryRuntime(SE: TPSExec; Importer: TPSRuntimeClassImporter);
1063
1064 procedure SetVariantToClass(V: PIFVariant; Cl: TObject);
1065 {$IFNDEF PS_NOINTERFACES}
1066 procedure SetVariantToInterface(V: PIFVariant; Cl: IUnknown);
1067 {$ENDIF}
1068
1069 procedure MyAllMethodsHandler;
1070
GetMethodInfoRecnull1071 function GetMethodInfoRec(SE: TPSExec; ProcNo: Cardinal): Pointer;
1072
MkMethodnull1073 function MkMethod(FSE: TPSExec; No: Cardinal): TMethod;
1074
1075 type
1076 TIFInternalProcRec = TPSInternalProcRec;
1077 TIFError = TPSError;
1078 TIFStatus = TPSStatus;
1079 TIFPSExec = TPSExec;
1080 TIFPSStack = TPSStack;
1081 TIFTypeRec = TPSTypeRec;
1082
1083
1084 TPSCallingConvention = uPSUtils.TPSCallingConvention;
1085 const
1086
1087 cdRegister = uPSUtils.cdRegister;
1088
1089 cdPascal = uPSUtils.cdPascal;
1090
1091 cdCdecl = uPSUtils.cdCdecl;
1092
1093 cdStdCall = uPSUtils.cdStdCall;
1094
1095 InvalidVal = Cardinal(-1);
1096
PSDynArrayGetLengthnull1097 function PSDynArrayGetLength(arr: Pointer; aType: TPSTypeRec): Longint;
1098 procedure PSDynArraySetLength(var arr: Pointer; aType: TPSTypeRec; NewLength: Longint);
1099
GetPSArrayLengthnull1100 function GetPSArrayLength(Arr: PIFVariant): Longint;
1101 procedure SetPSArrayLength(Arr: PIFVariant; NewLength: Longint);
1102
PSVariantToStringnull1103 function PSVariantToString(const p: TPSVariantIFC; const ClassProperties: tbtstring): tbtstring;
MakeStringnull1104 function MakeString(const s: tbtstring): tbtstring;
1105 {$IFNDEF PS_NOWIDESTRING}
MakeWStringnull1106 function MakeWString(const s: tbtunicodestring): tbtstring;
1107 {$ENDIF}
1108
1109 {$IFNDEF PS_NOIDISPATCH}
IDispatchInvokenull1110 function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: tbtString; const Par: array of Variant): Variant;
1111 {$ENDIF}
1112
1113
1114 implementation
1115 uses
1116 TypInfo {$IFDEF DELPHI3UP}{$IFNDEF FPC}{$IFNDEF KYLIX} , ComObj {$ENDIF}{$ENDIF}{$ENDIF}{$IFDEF PS_FPC_HAS_COM}, ComObj{$ENDIF} {$IFDEF DELPHI_TOKYO_UP}, AnsiStrings{$ENDIF};
1117
1118 {$IFDEF DELPHI3UP }
1119 resourceString
1120 {$ELSE }
1121 const
1122 {$ENDIF }
1123
1124 RPS_UnknownIdentifier = 'Unknown Identifier';
1125 RPS_Exception = 'Exception: %s';
1126 RPS_Invalid = '[Invalid]';
1127
1128 //- PSErrorToString
1129 RPS_NoError = 'No Error';
1130 RPS_CannotImport = 'Cannot Import %s';
1131 RPS_InvalidType = 'Invalid Type';
1132 RPS_InternalError = 'Internal error';
1133 RPS_InvalidHeader = 'Invalid Header';
1134 RPS_InvalidOpcode = 'Invalid Opcode';
1135 RPS_InvalidOpcodeParameter = 'Invalid Opcode Parameter';
1136 RPS_NoMainProc = 'no Main Proc';
1137 RPS_OutOfGlobalVarsRange = 'Out of Global Vars range';
1138 RPS_OutOfProcRange = 'Out of Proc Range';
1139 RPS_OutOfRange = 'Out Of Range';
1140 RPS_OutOfStackRange = 'Out Of Stack Range';
1141 RPS_TypeMismatch = 'Type Mismatch';
1142 RPS_UnexpectedEof = 'Unexpected End Of File';
1143 RPS_VersionError = 'Version error';
1144 RPS_DivideByZero = 'divide by Zero';
1145 RPS_MathError = 'Math error';
1146 RPS_CouldNotCallProc = 'Could not call proc';
1147 RPS_OutofRecordRange = 'Out of Record Fields Range';
1148 RPS_NullPointerException = 'Null Pointer Exception';
1149 RPS_NullVariantError = 'Null variant error';
1150 RPS_OutOfMemory = 'Out Of Memory';
1151 RPS_InterfaceNotSupported = 'Interface not supported';
1152 RPS_UnknownError = 'Unknown error';
1153
1154
1155 RPS_InvalidVariable = 'Invalid variable';
1156 RPS_InvalidArray = 'Invalid array';
1157 RPS_OLEError = 'OLE error %.8x';
1158 RPS_UnknownProcedure = 'Unknown procedure';
1159 RPS_NotEnoughParameters = 'Not enough parameters';
1160 RPS_InvalidParameter = 'Invalid parameter';
1161 RPS_TooManyParameters = 'Too many parameters';
1162 RPS_OutOfStringRange = 'Out of string range';
1163 RPS_CannotCastInterface = 'Cannot cast an interface';
1164 RPS_CannotCastObject = 'Cannot cast an object';
1165 RPS_CapacityLength = 'Capacity < Length';
1166 RPS_CanOnlySendLastItem = 'Can only remove last item from stack';
1167 RPS_NILInterfaceException = 'Nil interface';
1168 RPS_UnknownMethod = 'Unknown method';
1169
1170
1171
1172 type
1173 PPSExportedVar = ^TPSExportedVar;
1174 TPSExportedVar = record
1175 FName: tbtstring;
1176 FNameHash: Longint;
1177 FVarNo: Cardinal;
1178 end;
1179 PRaiseFrame = ^TRaiseFrame;
1180 TRaiseFrame = record
1181 NextRaise: PRaiseFrame;
1182 ExceptAddr: Pointer;
1183 ExceptObject: TObject;
1184 ExceptionRecord: Pointer;
1185 end;
1186 TPSExceptionHandler = class
1187 CurrProc: TPSInternalProcRec;
1188 BasePtr, StackSize: Cardinal;
1189 FinallyOffset, ExceptOffset, Finally2Offset, EndOfBlock: Cardinal;
1190 ExceptionData: TPSError;
1191 ExceptionObject: TObject;
1192 ExceptionParam: tbtString;
1193 destructor Destroy; override;
1194 end;
1195 TPSHeader = packed record
1196 HDR: Cardinal;
1197 PSBuildNo: Cardinal;
1198 TypeCount: Cardinal;
1199 ProcCount: Cardinal;
1200 VarCount: Cardinal;
1201 MainProcNo: Cardinal;
1202 ImportTableSize: Cardinal;
1203 end;
1204
1205 TPSExportItem = packed record
1206 ProcNo: Cardinal;
1207 NameLength: Cardinal;
1208 DeclLength: Cardinal;
1209 end;
1210
1211 TPSType = packed record
1212 BaseType: TPSBaseType;
1213 end;
1214 TPSProc = packed record
1215 Flags: Byte;
1216 end;
1217
1218 TPSVar = packed record
1219 TypeNo: Cardinal;
1220 Flags: Byte;
1221 end;
1222 PSpecialProc = ^TSpecialProc;
1223 TSpecialProc = record
1224 P: TPSOnSpecialProcImport;
1225 namehash: Longint;
1226 Name: tbtstring;
1227 tag: pointer;
1228 end;
1229
1230 destructor TPSExceptionHandler.Destroy;
1231 begin
1232 ExceptionObject.Free;
1233 inherited;
1234 end;
1235
1236 procedure P_CM_A; begin end;
1237 procedure P_CM_CA; begin end;
1238 procedure P_CM_P; begin end;
1239 procedure P_CM_PV; begin end;
1240 procedure P_CM_PO; begin end;
1241 procedure P_CM_C; begin end;
1242 procedure P_CM_G; begin end;
1243 procedure P_CM_CG; begin end;
1244 procedure P_CM_CNG; begin end;
1245 procedure P_CM_R; begin end;
1246 procedure P_CM_ST; begin end;
1247 procedure P_CM_PT; begin end;
1248 procedure P_CM_CO; begin end;
1249 procedure P_CM_CV; begin end;
1250 procedure P_CM_SP; begin end;
1251 procedure P_CM_BN; begin end;
1252 procedure P_CM_VM; begin end;
1253 procedure P_CM_SF; begin end;
1254 procedure P_CM_FG; begin end;
1255 procedure P_CM_PUEXH; begin end;
1256 procedure P_CM_POEXH; begin end;
1257 procedure P_CM_IN; begin end;
1258 procedure P_CM_SPB; begin end;
1259 procedure P_CM_INC; begin end;
1260 procedure P_CM_DEC; begin end;
1261
1262 function IntPIFVariantToVariant(Src: pointer; aType: TPSTypeRec; var Dest: Variant): Boolean; forward;
1263
1264
1265 procedure Set_Union(Dest, Src: PByteArray; ByteSize: Integer);
1266 var
1267 i: Longint;
1268 begin
1269 for i := ByteSize -1 downto 0 do
1270 Dest^[i] := Dest^[i] or Src^[i];
1271 end;
1272
1273 procedure Set_Diff(Dest, Src: PByteArray; ByteSize: Integer);
1274 var
1275 i: Longint;
1276 begin
1277 for i := ByteSize -1 downto 0 do
1278 Dest^[i] := Dest^[i] and not Src^[i];
1279 end;
1280
1281 procedure Set_Intersect(Dest, Src: PByteArray; ByteSize: Integer);
1282 var
1283 i: Longint;
1284 begin
1285 for i := ByteSize -1 downto 0 do
1286 Dest^[i] := Dest^[i] and Src^[i];
1287 end;
1288
1289 procedure Set_Subset(Dest, Src: PByteArray; ByteSize: Integer; var Val: Boolean);
1290 var
1291 i: Integer;
1292 begin
1293 for i := ByteSize -1 downto 0 do
1294 begin
1295 if not (Src^[i] and Dest^[i] = Dest^[i]) then
1296 begin
1297 Val := False;
1298 exit;
1299 end;
1300 end;
1301 Val := True;
1302 end;
1303
1304 procedure Set_Equal(Dest, Src: PByteArray; ByteSize: Integer; var Val: Boolean);
1305 var
1306 i: Longint;
1307 begin
1308 for i := ByteSize -1 downto 0 do
1309 begin
1310 if Dest^[i] <> Src^[i] then
1311 begin
1312 Val := False;
1313 exit;
1314 end;
1315 end;
1316 val := True;
1317 end;
1318
1319 procedure Set_membership(Item: Longint; Src: PByteArray; var Val: Boolean);
1320 begin
1321 Val := (Src^[Item shr 3] and (1 shl (Item and 7))) <> 0;
1322 end;
1323
1324
1325 procedure RCIFreeProc(Sender: TPSExec; P: TPSRuntimeClassImporter);
1326 begin
1327 p.Free;
1328 end;
1329
Trimnull1330 function Trim(const s: tbtstring): tbtstring;
1331 begin
1332 Result := s;
1333 while (Length(result) > 0) and (Result[1] = #32) do Delete(Result, 1, 1);
1334 while (Length(result) > 0) and (Result[Length(Result)] = #32) do Delete(Result, Length(Result), 1);
1335 end;
1336 (*function FloatToStr(E: Extended): tbtstring;
1337 begin
1338 Result := Sysutils.FloatToStr(e);
1339 end;*)
1340
1341 //-------------------------------------------------------------------
1342
Padlnull1343 function Padl(s: tbtstring; i: longInt): tbtstring;
1344 begin
1345 result := StringOfChar(tbtchar(' '), i - length(s)) + s;
1346 end;
1347 //-------------------------------------------------------------------
1348
Padznull1349 function Padz(s: tbtString; i: longInt): tbtString;
1350 begin
1351 result := StringOfChar(tbtchar('0'), i - length(s)) + s;
1352 end;
1353 //-------------------------------------------------------------------
1354
Padrnull1355 function Padr(s: tbtString; i: longInt): tbtString;
1356 begin
1357 result := s + StringOfChar(tbtchar(' '), i - Length(s));
1358 end;
1359 //-------------------------------------------------------------------
1360
1361 {$IFNDEF PS_NOWIDESTRING}
wPadlnull1362 function wPadl(s: tbtwidestring; i: longInt): tbtwidestring;
1363 begin
1364 result := StringOfChar(tbtwidechar(' '), i - length(s)) + s;
1365 end;
1366 //-------------------------------------------------------------------
1367
wPadznull1368 function wPadz(s: tbtwidestring; i: longInt): tbtwidestring;
1369 begin
1370 result := StringOfChar(tbtwidechar('0'), i - length(s)) + s;
1371 end;
1372 //-------------------------------------------------------------------
1373
wPadrnull1374 function wPadr(s: tbtwidestring; i: longInt): tbtwidestring;
1375 begin
1376 result := s + StringOfChar(tbtwidechar(' '), i - Length(s));
1377 end;
1378
uPadlnull1379 function uPadl(s: tbtunicodestring; i: longInt): tbtunicodestring;
1380 begin
1381 result := StringOfChar(tbtwidechar(' '), i - length(s)) + s;
1382 end;
1383 //-------------------------------------------------------------------
1384
uPadznull1385 function uPadz(s: tbtunicodestring; i: longInt): tbtunicodestring;
1386 begin
1387 result := StringOfChar(tbtwidechar('0'), i - length(s)) + s;
1388 end;
1389 //-------------------------------------------------------------------
1390
uPadrnull1391 function uPadr(s: tbtunicodestring; i: longInt): tbtunicodestring;
1392 begin
1393 result := s + StringOfChar(tbtwidechar(' '), i - Length(s));
1394 end;
1395
1396 {$ENDIF}
1397 {$IFNDEF PS_NOWIDESTRING}
MakeWStringnull1398 function MakeWString(const s: tbtunicodestring): tbtString;
1399 var
1400 i: Longint;
1401 e: tbtString;
1402 b: boolean;
1403 begin
1404 Result := tbtString(s);
1405 i := 1;
1406 b := false;
1407 while i <= length(result) do
1408 begin
1409 if Result[i] = '''' then
1410 begin
1411 if not b then
1412 begin
1413 b := true;
1414 Insert('''', Result, i);
1415 inc(i);
1416 end;
1417 Insert('''', Result, i);
1418 inc(i, 2);
1419 end else if (Result[i] < #32) or (Result[i] > #255) then
1420 begin
1421 e := '#'+inttostr(ord(Result[i]));
1422 Delete(Result, i, 1);
1423 if b then
1424 begin
1425 b := false;
1426 Insert('''', Result, i);
1427 inc(i);
1428 end;
1429 Insert(e, Result, i);
1430 inc(i, length(e));
1431 end else begin
1432 if not b then
1433 begin
1434 b := true;
1435 Insert('''', Result, i);
1436 inc(i, 2);
1437 end else
1438 inc(i);
1439 end;
1440 end;
1441 if b then
1442 begin
1443 Result := Result + '''';
1444 end;
1445 if Result = '' then
1446 Result := '''''';
1447 end;
1448 {$ENDIF}
MakeStringnull1449 function MakeString(const s: tbtString): tbtString;
1450 var
1451 i: Longint;
1452 e: tbtString;
1453 b: boolean;
1454 begin
1455 Result := s;
1456 i := 1;
1457 b := false;
1458 while i <= length(result) do
1459 begin
1460 if Result[i] = '''' then
1461 begin
1462 if not b then
1463 begin
1464 b := true;
1465 Insert('''', Result, i);
1466 inc(i);
1467 end;
1468 Insert('''', Result, i);
1469 inc(i, 2);
1470 end else if (Result[i] < #32) then
1471 begin
1472 e := '#'+inttostr(ord(Result[i]));
1473 Delete(Result, i, 1);
1474 if b then
1475 begin
1476 b := false;
1477 Insert('''', Result, i);
1478 inc(i);
1479 end;
1480 Insert(e, Result, i);
1481 inc(i, length(e));
1482 end else begin
1483 if not b then
1484 begin
1485 b := true;
1486 Insert('''', Result, i);
1487 inc(i, 2);
1488 end else
1489 inc(i);
1490 end;
1491 end;
1492 if b then
1493 begin
1494 Result := Result + '''';
1495 end;
1496 if Result = '' then
1497 Result := '''''';
1498 end;
1499
SafeStrnull1500 function SafeStr(const s: tbtString): tbtString;
1501 var
1502 i : Longint;
1503 begin
1504 Result := s;
1505 for i := 1 to length(s) do
1506 begin
1507 if s[i] in [#0..#31] then
1508 begin
1509 Result := Copy(s, 1, i-1);
1510 exit;
1511 end;
1512 end;
1513
1514 end;
1515
PropertyToStringnull1516 function PropertyToString(Instance: TObject; PName: tbtString): tbtString;
1517 var
1518 s: tbtString;
1519 i: Longint;
1520 PP: PPropInfo;
1521 begin
1522 if PName = '' then
1523 begin
1524 Result := tbtString(Instance.ClassName);
1525 exit;
1526 end;
1527 while Length(PName) > 0 do
1528 begin
1529 i := pos(tbtChar('.'), pname);
1530 if i = 0 then
1531 begin
1532 s := Trim(PNAme);
1533 pname := '';
1534 end else begin
1535 s := trim(Copy(PName, 1, i-1));
1536 Delete(PName, 1, i);
1537 end;
1538 pp := GetPropInfo(PTypeInfo(Instance.ClassInfo), string(s));
1539 if pp = nil then begin Result := tbtstring(RPS_UnknownIdentifier); exit; end;
1540
1541
1542 case pp^.PropType^.Kind of
1543 tkInteger: begin Result := IntToStr(GetOrdProp(Instance, pp)); exit; end;
1544 tkChar: begin Result := '#'+IntToStr(GetOrdProp(Instance, pp)); exit; end;
1545 tkEnumeration: begin Result := tbtstring(GetEnumName(pp^.PropType{$IFNDEF FPC}{$IFDEF DELPHI3UP}^{$ENDIF}{$ENDIF}, GetOrdProp(Instance, pp))); exit; end;
1546 tkFloat: begin Result := FloatToStr(GetFloatProp(Instance, PP)); exit; end;
1547 tkString, tkLString: begin Result := ''''+tbtString(GetStrProp(Instance, PP))+''''; exit; end;
1548 tkSet: begin Result := '[Set]'; exit; end;
1549 tkClass: begin Instance := TObject(GetOrdProp(Instance, pp)); end;
1550 tkMethod: begin Result := '[Method]'; exit; end;
1551 tkVariant: begin Result := '[Variant]'; exit; end;
1552 {$IFDEF DELPHI6UP}
1553 {$IFNDEF PS_NOWIDESTRING}
1554 tkWString: begin Result := ''''+tbtString(GetWideStrProp(Instance, pp))+''''; exit; end;
1555 {$IFDEF DELPHI2009UP}
1556 tkUString: begin Result := ''''+tbtString({$IFDEF DELPHI_TOKYO_UP}GetStrProp{$ELSE}GetUnicodeStrProp{$ENDIF}(Instance, pp))+''''; exit; end;
1557 {$ENDIF}
1558 {$ENDIF}
1559 {$ENDIF}
1560 else begin Result := '[Unknown]'; exit; end;
1561 end;
1562 if Instance = nil then begin result := 'nil'; exit; end;
1563 end;
1564 Result := tbtstring(Instance.ClassName);
1565 end;
1566
ClassVariantInfonull1567 function ClassVariantInfo(const pvar: TPSVariantIFC; const PropertyName: tbtString): tbtString;
1568 begin
1569 if pvar.aType.BaseType = btClass then
1570 begin
1571 if TObject(pvar.Dta^) = nil then
1572 Result := 'nil'
1573 else
1574 Result := PropertyToString(TObject(pvar.Dta^), PropertyName);
1575 end else if pvar.atype.basetype = btInterface then
1576 Result := 'Interface'
1577 else Result := tbtstring(RPS_InvalidType);
1578 end;
1579
PSVariantToStringnull1580 function PSVariantToString(const p: TPSVariantIFC; const ClassProperties: tbtString): tbtString;
1581 var
1582 i, n: Longint;
1583 begin
1584 if p.Dta = nil then
1585 begin
1586 Result := 'nil';
1587 exit;
1588 end;
1589 if (p.aType.BaseType = btVariant) then
1590 begin
1591 try
1592 if TVarData(p.Dta^).VType = varDispatch then
1593 Result := 'Variant(IDispatch)'
1594 else if TVarData(p.Dta^).VType = varNull then
1595 REsult := 'Null'
1596 else if (TVarData(p.Dta^).VType = varOleStr) then
1597 {$IFDEF PS_NOWIDESTRING}
1598 Result := MakeString(Variant(p.Dta^))
1599 {$ELSE}
1600 Result := MakeWString(variant(p.dta^))
1601 {$ENDIF}
1602 else if TVarData(p.Dta^).VType = varString then
1603 Result := MakeString(tbtstring(variant(p.Dta^)))
1604 else
1605 Result := tbtstring(Variant(p.Dta^));
1606 except
1607 on e: Exception do
1608 Result := tbtstring(Format (RPS_Exception, [e.Message]));
1609 end;
1610 exit;
1611 end;
1612 case p.aType.BaseType of
1613 btProcptr: begin Result := 'Proc: '+inttostr(tbtu32(p.Dta^)); end;
1614 btU8: str(tbtu8(p.dta^), Result);
1615 btS8: str(tbts8(p.dta^), Result);
1616 btU16: str(tbtu16(p.dta^), Result);
1617 btS16: str(tbts16(p.dta^), Result);
1618 btU32: str(tbtu32(p.dta^), Result);
1619 btS32: str(tbts32(p.dta^), Result);
1620 btSingle: str(tbtsingle(p.dta^), Result);
1621 btDouble: str(tbtdouble(p.dta^), Result);
1622 btExtended: str(tbtextended(p.dta^), Result);
1623 btString: Result := makestring(tbtString(p.dta^));
1624 btPChar:
1625 begin
1626 if PansiChar(p.dta^) = nil then
1627 Result := 'nil'
1628 else
1629 Result := MakeString(PAnsiChar(p.dta^));
1630 end;
1631 btchar: Result := MakeString(tbtchar(p.dta^));
1632 {$IFNDEF PS_NOWIDESTRING}
1633 btwidechar: Result := MakeWString(tbtwidechar(p.dta^));
1634 btWideString: Result := MakeWString(tbtwidestring(p.dta^));
1635 btUnicodeString: Result := MakeWString(tbtUnicodeString(p.dta^));
1636 {$ENDIF}
1637 {$IFNDEF PS_NOINT64}btS64: str(tbts64(p.dta^), Result);{$ENDIF}
1638 btStaticArray, btArray:
1639 begin
1640 Result := '';
1641 if p.aType.BaseType = btStaticArray then
1642 n := TPSTypeRec_StaticArray(p.aType).Size
1643 else
1644 n := PSDynArrayGetLength(Pointer(p.dta^), p.aType);
1645 for i := 0 to n-1 do begin
1646 if Result <> '' then
1647 Result := Result + ', ';
1648 Result := Result + PSVariantToString(PSGetArrayField(p, i), '');
1649 end;
1650 Result := '[' + Result + ']';
1651 end;
1652 btRecord:
1653 begin
1654 Result := '';
1655 n := TPSTypeRec_Record(p.aType).FFieldTypes.Count;
1656 for i := 0 to n-1 do begin
1657 if Result <> '' then
1658 Result := Result + ', ';
1659 Result := Result + PSVariantToString(PSGetRecField(p, i), '');
1660 end;
1661 Result := '(' + Result + ')';
1662 end;
1663 btPointer: Result := 'Nil';
1664 btClass, btInterface:
1665 begin
1666 Result := ClassVariantInfo(p, ClassProperties)
1667 end;
1668 else
1669 Result := tbtString(RPS_Invalid);
1670 end;
1671 end;
1672
1673
1674
TIFErrorToStringnull1675 function TIFErrorToString(x: TPSError; const Param: tbtString): tbtString;
1676 begin
1677 Result := PSErrorToString(x,param);
1678 end;
1679
PSErrorToStringnull1680 function PSErrorToString(x: TPSError; const Param: tbtString): tbtString;
1681 begin
1682 case x of
1683 ErNoError: Result := tbtString(RPS_NoError);
1684 erCannotImport: Result := tbtString(Format (RPS_CannotImport, [Safestr(Param)]));
1685 erInvalidType: Result := tbtString(RPS_InvalidType);
1686 ErInternalError: Result := tbtString(RPS_InternalError);
1687 erInvalidHeader: Result := tbtString(RPS_InvalidHeader);
1688 erInvalidOpcode: Result := tbtString(RPS_InvalidOpcode);
1689 erInvalidOpcodeParameter: Result := tbtString(RPS_InvalidOpcodeParameter);
1690 erNoMainProc: Result := tbtString(RPS_NoMainProc);
1691 erOutOfGlobalVarsRange: Result := tbtString(RPS_OutOfGlobalVarsRange);
1692 erOutOfProcRange: Result := tbtString(RPS_OutOfProcRange);
1693 ErOutOfRange: Result := tbtString(RPS_OutOfRange);
1694 erOutOfStackRange: Result := tbtString(RPS_OutOfStackRange);
1695 ErTypeMismatch: Result := tbtString(RPS_TypeMismatch);
1696 erUnexpectedEof: Result := tbtString(RPS_UnexpectedEof);
1697 erVersionError: Result := tbtString(RPS_VersionError);
1698 ErDivideByZero: Result := tbtString(RPS_DivideByZero);
1699 erMathError: Result := tbtString(RPS_MathError);
1700 erCouldNotCallProc: begin Result := tbtString(RPS_CouldNotCallProc); if (Param <> '') then Result := result +' ('+Param+')'; end;
1701 erOutofRecordRange: Result := tbtString(RPS_OutofRecordRange);
1702 erNullPointerException: Result := tbtString(RPS_NullPointerException);
1703 erNullVariantError: Result := tbtString(RPS_NullVariantError);
1704 erOutOfMemory: Result := tbtString(RPS_OutOfMemory);
1705 erException: Result := tbtString(Format (RPS_Exception, [Param]));
1706 erInterfaceNotSupported: Result := tbtString(RPS_InterfaceNotSupported);
1707 erCustomError: Result := Param;
1708 else
1709 Result := tbtString(RPS_UnknownError);
1710 end;
1711 //
1712 end;
1713
1714
1715 procedure TPSTypeRec.CalcSize;
1716 begin
1717 case BaseType of
1718 btVariant: FRealSize := sizeof(Variant);
1719 btChar, bts8, btU8: FrealSize := 1 ;
1720 {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}bts16, btU16: FrealSize := 2;
1721 {$IFNDEF PS_NOWIDESTRING}btWideString,
1722 btUnicodeString,
1723 {$ENDIF}{$IFNDEF PS_NOINTERFACES}btInterface, {$ENDIF}
1724 btclass, btPChar, btString: FrealSize := PointerSize;
1725 btSingle, bts32, btU32: FRealSize := 4;
1726 btProcPtr: FRealSize := 3 * sizeof(Pointer);
1727 btCurrency: FrealSize := Sizeof(Currency);
1728 btPointer: FRealSize := 3 * sizeof(Pointer); // ptr, type, freewhendone
1729 btDouble{$IFNDEF PS_NOINT64}, bts64{$ENDIF}: FrealSize := 8;
1730 btExtended: FrealSize := SizeOf(Extended);
1731 btReturnAddress: FrealSize := Sizeof(TBTReturnAddress);
1732 else
1733 FrealSize := 0;
1734 end;
1735 end;
1736
1737 constructor TPSTypeRec.Create(Owner: TPSExec);
1738 begin
1739 inherited Create;
1740 FAttributes := TPSRuntimeAttributes.Create(Owner);
1741 end;
1742
1743 destructor TPSTypeRec.Destroy;
1744 begin
1745 FAttributes.Free;
1746 inherited destroy;
1747 end;
1748
1749 { TPSTypeRec_Record }
1750
1751 procedure TPSTypeRec_Record.CalcSize;
1752 begin
1753 inherited;
1754 FrealSize := TPSTypeRec(FFieldTypes[FFieldTypes.Count-1]).RealSize +
1755 IPointer(RealFieldOffsets[RealFieldOffsets.Count -1]);
1756 end;
1757
1758 constructor TPSTypeRec_Record.Create(Owner: TPSExec);
1759 begin
1760 inherited Create(Owner);
1761 FRealFieldOffsets := TPSList.Create;
1762 FFieldTypes := TPSList.Create;
1763 end;
1764
1765 destructor TPSTypeRec_Record.Destroy;
1766 begin
1767 FFieldTypes.Free;
1768 FRealFieldOffsets.Free;
1769 inherited Destroy;
1770 end;
1771
1772
1773 const
1774 RTTISize = sizeof(TPSVariant);
1775
1776 procedure InitializeVariant(p: Pointer; aType: TPSTypeRec);
1777 var
1778 t: TPSTypeRec;
1779 i: Longint;
1780 begin
1781 case aType.BaseType of
1782 btChar, bts8, btU8: tbtu8(p^) := 0;
1783 {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}bts16, btU16: tbtu16(p^) := 0;
1784 btSingle: TbtSingle(P^) := 0;
1785 bts32, btU32: TbtU32(P^) := 0;
1786 btPChar, btString, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF}btClass,
1787 btInterface, btArray: Pointer(P^) := nil;
1788 btPointer:
1789 begin
1790 Pointer(p^) := nil;
1791 Pointer(Pointer(IPointer(p)+PointerSize)^) := nil;
1792 Pointer(Pointer(IPointer(p)+(2*PointerSize))^) := nil;
1793 end;
1794 btProcPtr:
1795 begin
1796 Longint(p^) := 0;
1797 Pointer(Pointer(IPointer(p)+PointerSize)^) := nil;
1798 Pointer(Pointer(IPointer(p)+(2*PointerSize))^) := nil;
1799 end;
1800 btCurrency: tbtCurrency(P^) := 0;
1801 btDouble{$IFNDEF PS_NOINT64}, bts64{$ENDIF}: {$IFNDEF PS_NOINT64}tbtS64(P^) := 0{$ELSE}tbtdouble(p^) := 0 {$ENDIF};
1802 btExtended: tbtExtended(p^) := 0;
1803 btVariant: Initialize(Variant(p^));
1804 btReturnAddress:; // there is no point in initializing a return address
1805 btRecord:
1806 begin
1807 for i := 0 to TPSTypeRec_Record(aType).FFieldTypes.Count -1 do
1808 begin
1809 t := TPSTypeRec_Record(aType).FieldTypes[i];
1810 InitializeVariant(P, t);
1811 p := Pointer(IPointer(p) + t.FrealSize);
1812 end;
1813 end;
1814 btStaticArray:
1815 begin
1816 t := TPSTypeRec_Array(aType).ArrayType;
1817 for i := 0 to TPSTypeRec_StaticArray(aType).Size -1 do
1818 begin
1819 InitializeVariant(p, t);
1820 p := Pointer(IPointer(p) + t.RealSize);
1821 end;
1822 end;
1823 btSet:
1824 begin
1825 FillChar(p^, TPSTypeRec_Set(aType).RealSize, 0);
1826 end;
1827 end;
1828 end;
1829
1830 procedure DestroyHeapVariant2(v: Pointer; aType: TPSTypeRec); forward;
1831
1832 const
1833 NeedFinalization = [btStaticArray, btRecord, btArray, btPointer, btVariant {$IFNDEF PS_NOINTERFACES}, btInterface{$ENDIF}, btString {$IFNDEF PS_NOWIDESTRING}, btUnicodestring,btWideString{$ENDIF}];
1834
1835 type
1836 TDynArrayRecHeader = packed record
1837 {$ifdef FPC}
1838 refCnt : ptrint;
1839 high : tdynarrayindex;
1840 {$else}
1841 {$ifdef CPUX64}
1842 _Padding: LongInt; // Delphi XE2+ expects 16 byte align
1843 {$endif}
1844 /// dynamic array reference count (basic garbage memory mechanism)
1845 refCnt: Longint;
1846 /// length in element count
1847 // - size in bytes = length*ElemSize
1848 length: IPointer;
1849 {$endif}
1850 end;
1851 TDynArrayRec = packed record
1852 header : TDynArrayRecHeader;
1853 datas : pointer;
1854 end;
1855 PDynArrayRec = ^TDynArrayRec;
1856
1857 procedure FinalizeVariant(p: Pointer; aType: TPSTypeRec);
1858 var
1859 t: TPSTypeRec;
1860 elsize: Cardinal;
1861 i, l: Longint;
1862 darr: PDynArrayRec;
1863 begin
1864 case aType.BaseType of
1865 btString: tbtString(p^) := '';
1866 {$IFNDEF PS_NOWIDESTRING}
1867 btWideString: tbtwidestring(p^) := '';
1868 btUnicodeString: tbtunicodestring(p^) := '';
1869 {$ENDIF}
1870 {$IFNDEF PS_NOINTERFACES}btInterface:
1871 begin
1872 {$IFNDEF DELPHI3UP}
1873 if IUnknown(p^) <> nil then
1874 IUnknown(p^).Release;
1875 {$ENDIF}
1876 IUnknown(p^) := nil;
1877 end; {$ENDIF}
1878 btVariant:
1879 begin
1880 try
1881 Finalize(Variant(p^));
1882 except
1883 end;
1884 end;
1885 btPointer:
1886 if Pointer(Pointer(IPointer(p)+PointerSize2)^) <> nil then
1887 begin
1888 DestroyHeapVariant2(Pointer(p^), Pointer(Pointer(IPointer(p)+PointerSize)^));
1889 Pointer(p^) := nil;
1890 end;
1891 btArray:
1892 begin
1893 if IPointer(P^) = 0 then exit;
1894 darr := PDynArrayRec(IPointer(p^) - sizeof(TDynArrayRecHeader));
1895 if darr^.header.refCnt < 0 then exit;// refcount < 0 means don't free
1896 Dec(darr^.header.refCnt);
1897 if darr^.header.refCnt <> 0 then exit;
1898 t := TPSTypeRec_Array(aType).ArrayType;
1899 elsize := t.RealSize;
1900 {$IFDEF FPC}
1901 l := darr^.header.high + 1;
1902 {$ELSE}
1903 l := darr^.header.length;
1904 {$ENDIF FPC}
1905 darr := @darr^.datas;
1906 case t.BaseType of
1907 btString, {$IFNDEF PS_NOWIDESTRING}
1908 btUnicodeString, btWideString, {$ENDIF}{$IFNDEF PS_NOINTERFACES}btInterface, {$ENDIF}btArray, btStaticArray,
1909 btRecord, btPointer, btVariant:
1910 begin
1911 for i := 0 to l -1 do
1912 begin
1913 FinalizeVariant(darr, t);
1914 darr := Pointer(IPointer(darr) + elsize);
1915 end;
1916 end;
1917 end;
1918 FreeMem(Pointer(IPointer(p^) - SizeOf(TDynArrayRecHeader)), IPointer(Cardinal(l) * elsize) + SizeOf(TDynArrayRecHeader));
1919 Pointer(P^) := nil;
1920 end;
1921 btRecord:
1922 begin
1923 for i := 0 to TPSTypeRec_Record(aType).FFieldTypes.Count -1 do
1924 begin
1925 t := TPSTypeRec_Record(aType).FieldTypes[i];
1926 case t.BaseType of
1927 btString, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF}{$IFNDEF PS_NOINTERFACES}btInterface, {$ENDIF}btArray, btStaticArray,
1928 btRecord: FinalizeVariant(p, t);
1929 end;
1930 p := Pointer(IPointer(p) + t.FrealSize);
1931 end;
1932 end;
1933 btStaticArray:
1934 begin
1935 t := TPSTypeRec_Array(aType).ArrayType;
1936 case t.BaseType of
1937 btString, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF}{$IFNDEF PS_NOINTERFACES}btInterface, {$ENDIF}btArray, btStaticArray,
1938 btRecord: ;
1939 else Exit;
1940 end;
1941 for i := 0 to TPSTypeRec_StaticArray(aType).Size -1 do
1942 begin
1943 FinalizeVariant(p, t);
1944 p := Pointer(IPointer(p) + t.RealSize);
1945 end;
1946 end;
1947 end;
1948 end;
1949
1950 function CreateHeapVariant2(aType: TPSTypeRec): Pointer;
1951 begin
1952 GetMem(Result, aType.RealSize);
1953 InitializeVariant(Result, aType);
1954 end;
1955
1956 procedure DestroyHeapVariant2(v: Pointer; aType: TPSTypeRec);
1957 begin
1958 if v = nil then exit;
1959 if atype.BaseType in NeedFinalization then
1960 FinalizeVariant(v, aType);
1961 FreeMem(v, aType.RealSize);
1962 end;
1963
1964
1965 function CreateHeapVariant(aType: TPSTypeRec): PPSVariant;
1966 var
1967 aSize: Longint;
1968 begin
1969 aSize := aType.RealSize + RTTISize;
1970 GetMem(Result, aSize);
1971 Result.FType := aType;
1972 InitializeVariant(Pointer(IPointer(Result)+PointerSize), aType);
1973 end;
1974
1975 procedure DestroyHeapVariant(v: PPSVariant);
1976 begin
1977 if v = nil then exit;
1978 if v.FType.BaseType in NeedFinalization then
1979 FinalizeVariant(Pointer(IPointer(v)+PointerSize), v.FType);
1980 FreeMem(v, v.FType.RealSize + RTTISize);
1981 end;
1982
1983 procedure FreePSVariantList(l: TPSList);
1984 var
1985 i: Longint;
1986 begin
1987 for i:= l.count -1 downto 0 do
1988 DestroyHeapVariant(l[i]);
1989 l.free;
1990 end;
1991
1992 procedure FreePIFVariantList(l: TPSList);
1993 begin
1994 FreePsVariantList(l);
1995 end;
1996
1997 { TPSExec }
1998
1999 procedure TPSExec.ClearFunctionList;
2000 var
2001 x: PProcRec;
2002 l: Longint;
2003 begin
2004 for l := FAttributeTypes.Count -1 downto 0 do
2005 begin
2006 TPSAttributeType(FAttributeTypes.Data^[l]).Free;
2007 end;
2008 FAttributeTypes.Clear;
2009
2010 for l := 0 to FRegProcs.Count - 1 do
2011 begin
2012 x := FRegProcs.Data^[l];
2013 if @x^.FreeProc <> nil then x^.FreeProc(Self, x);
2014 Dispose(x);
2015 end;
2016 FRegProcs.Clear;
2017 RegisterStandardProcs;
2018 end;
2019
2020 class function TPSExec.About: tbtString;
2021 begin
2022 Result := 'RemObjects Pascal Script. Copyright (c) 2004-2010 by RemObjects Software';
2023 end;
2024
2025 procedure TPSExec.Cleanup;
2026 var
2027 I: Longint;
2028 p: Pointer;
2029 begin
2030 if FStatus <> isLoaded then
2031 exit;
2032 FStack.Clear;
2033 FTempVars.Clear;
2034 for I := Longint(FGlobalVars.Count) - 1 downto 0 do
2035 begin
2036 p := FGlobalVars.Items[i];
2037 if PIFTypeRec(P^).BaseType in NeedFinalization then
2038 FinalizeVariant(Pointer(IPointer(p)+PointerSize), Pointer(P^));
2039 InitializeVariant(Pointer(IPointer(p)+PointerSize), Pointer(P^));
2040 end;
2041 end;
2042
2043 procedure TPSExec.Clear;
2044 var
2045 I: Longint;
2046 temp: PPSResource;
2047 Proc: TPSResourceFreeProc;
2048 pp: TPSExceptionHandler;
2049 begin
2050 for i := Longint(FExceptionStack.Count) -1 downto 0 do
2051 begin
2052 pp := FExceptionStack.Data^[i];
2053 pp.Free;
2054 end;
2055 for i := Longint(FResources.Count) -1 downto 0 do
2056 begin
2057 Temp := FResources.Data^[i];
2058 Proc := Temp^.Proc;
2059 Proc(Self, Temp^.P);
2060 Dispose(Temp);
2061 end;
2062 for i := Longint(FExportedVars.Count) -1 downto 0 do
2063 Dispose(PPSExportedVar(FExportedVars.Data^[I]));
2064 for I := Longint(FProcs.Count) - 1downto 0 do
2065 TPSProcRec(FProcs.Data^[i]).Destroy;
2066 FProcs.Clear;
2067 FGlobalVars.Clear;
2068 FStack.Clear;
2069 for I := Longint(FTypes.Count) - 1downto 0 do
2070 TPSTypeRec(FTypes.Data^[i]).Free;
2071 FTypes.Clear;
2072 FStatus := isNotLoaded;
2073 FResources.Clear;
2074 FExportedVars.Clear;
2075 FExceptionStack.Clear;
2076 FCurrStackBase := InvalidVal;
2077 end;
2078
2079 constructor TPSExec.Create;
2080 begin
2081 inherited Create;
2082 FAttributeTypes := TPSList.Create;
2083 FExceptionStack := TPSList.Create;
2084 FCallCleanup := False;
2085 FResources := TPSList.Create;
2086 FTypes := TPSList.Create;
2087 FProcs := TPSList.Create;
2088 FGlobalVars := TPSStack.Create;
2089 FTempVars := TPSStack.Create;
2090 FMainProc := 0;
2091 FStatus := isNotLoaded;
2092 FRegProcs := TPSList.Create;
2093 FExportedVars := TPSList.create;
2094 FSpecialProcList := TPSList.Create;
2095 RegisterStandardProcs;
2096 FReturnAddressType := TPSTypeRec.Create(self);
2097 FReturnAddressType.BaseType := btReturnAddress;
2098 FReturnAddressType.CalcSize;
2099 FVariantType := TPSTypeRec.Create(self);
2100 FVariantType.BaseType := btVariant;
2101 FVariantType.CalcSize;
2102 FVariantArrayType := TPSTypeRec_Array.Create(self);
2103 FVariantArrayType.BaseType := btArray;
2104 FVariantArrayType.CalcSize;
2105 TPSTypeRec_Array(FVariantArrayType).ArrayType := FVariantType;
2106 FStack := TPSStack.Create;
2107 end;
2108
2109 destructor TPSExec.Destroy;
2110 var
2111 I: Longint;
2112 x: PProcRec;
2113 P: PSpecialProc;
2114 begin
2115 Clear;
2116 FReturnAddressType.Free;
2117 FVariantType.Free;
2118 FVariantArrayType.Free;
2119
2120 if ExObject <> nil then ExObject.Free;
2121 for I := FSpecialProcList.Count -1 downto 0 do
2122 begin
2123 P := FSpecialProcList.Data^[I];
2124 Dispose(p);
2125 end;
2126 FResources.Free;
2127 FExportedVars.Free;
2128 FTempVars.Free;
2129 FStack.Free;
2130 FGlobalVars.Free;
2131 FProcs.Free;
2132 FTypes.Free;
2133 FSpecialProcList.Free;
2134 for i := FRegProcs.Count - 1 downto 0 do
2135 begin
2136 x := FRegProcs.Data^[i];
2137 if @x^.FreeProc <> nil then x^.FreeProc(Self, x);
2138 Dispose(x);
2139 end;
2140 FRegProcs.Free;
2141 FExceptionStack.Free;
2142 for i := FAttributeTypes.Count -1 downto 0 do
2143 begin
2144 TPSAttributeType(FAttributeTypes[i]).Free;
2145 end;
2146 FAttributeTypes.Free;
2147 inherited Destroy;
2148 end;
2149
2150 procedure TPSExec.ExceptionProc(proc, Position: Cardinal; Ex: TPSError; const s: tbtString; NewObject: TObject);
2151 var
2152 d, l: Longint;
2153 pp: TPSExceptionHandler;
2154 begin
2155 ExProc := proc;
2156 ExPos := Position;
2157 ExEx := Ex;
2158 ExParam := s;
2159 if ExObject <> nil then
2160 ExObject.Free;
2161 ExObject := NewObject;
2162 if Ex = eNoError then Exit;
2163 for d := FExceptionStack.Count -1 downto 0 do
2164 begin
2165 pp := FExceptionStack[d];
2166 if Cardinal(FStack.Count) > pp.StackSize then
2167 begin
2168 for l := Longint(FStack.count) -1 downto Longint(pp.StackSize) do
2169 FStack.Pop;
2170 end;
2171 if pp.CurrProc = nil then // no point in continuing
2172 begin
2173 pp.Free;
2174 FExceptionStack.DeleteLast;
2175
2176 FCurrStackBase := InvalidVal;
2177 FStatus := isPaused;
2178 exit;
2179 end;
2180 FCurrProc := pp.CurrProc;
2181 FData := FCurrProc.Data;
2182 FDataLength := FCurrProc.Length;
2183
2184 FCurrStackBase := pp.BasePtr;
2185 if pp.FinallyOffset <> InvalidVal then
2186 begin
2187 FCurrentPosition := pp.FinallyOffset;
2188 pp.FinallyOffset := InvalidVal;
2189 Exit;
2190 end else if (pp.ExceptOffset <> InvalidVal) and (pp.ExceptOffset <> Cardinal(InvalidVal -1)) then
2191 begin
2192 FCurrentPosition := pp.ExceptOffset;
2193 pp.ExceptOffset := Cardinal(InvalidVal -1);
2194 pp.ExceptionObject := ExObject;
2195 pp.ExceptionData := ExEx;
2196 pp.ExceptionParam := ExParam;
2197 ExObject := nil;
2198 ExEx := ENoError;
2199 Exit;
2200 end else if pp.Finally2Offset <> InvalidVal then
2201 begin
2202 FCurrentPosition := pp.Finally2Offset;
2203 pp.Finally2Offset := InvalidVal;
2204 Exit;
2205 end;
2206 pp.Free;
2207 FExceptionStack.DeleteLast;
2208 end;
2209 if FStatus <> isNotLoaded then
2210 FStatus := isPaused;
2211 end;
2212
2213 function LookupProc(List: TPSList; const Name: ShortString): PProcRec;
2214 var
2215 h, l: Longint;
2216 p: PProcRec;
2217 begin
2218 h := MakeHash(Name);
2219 for l := List.Count - 1 downto 0 do
2220 begin
2221 p := List.Data^[l];
2222 if (p^.Hash = h) and (p^.Name = Name) then
2223 begin
2224 Result := List[l];
2225 exit;
2226 end;
2227 end;
2228 Result := nil;
2229 end;
2230
ImportProcnull2231 function TPSExec.ImportProc(const Name: ShortString; proc: TPSExternalProcRec): Boolean;
2232 var
2233 u: PProcRec;
2234 fname: tbtString;
2235 I, fnh: Longint;
2236 P: PSpecialProc;
2237
2238 begin
2239 if name = '' then
2240 begin
2241 fname := proc.Decl;
2242 fname := copy(fname, 1, pos(tbtchar(':'), fname)-1);
2243 fnh := MakeHash(fname);
2244 for I := FSpecialProcList.Count -1 downto 0 do
2245 begin
2246 p := FSpecialProcList[I];
2247 IF (p^.name = '') or ((p^.namehash = fnh) and (p^.name = fname)) then
2248 begin
2249 if p^.P(Self, Proc, p^.tag) then
2250 begin
2251 Result := True;
2252 exit;
2253 end;
2254 end;
2255 end;
2256 Result := FAlse;
2257 exit;
2258 end;
2259 u := LookupProc(FRegProcs, Name);
2260 if u = nil then begin
2261 Result := False;
2262 exit;
2263 end;
2264 proc.ProcPtr := u^.ProcPtr;
2265 proc.Ext1 := u^.Ext1;
2266 proc.Ext2 := u^.Ext2;
2267 Result := True;
2268 end;
2269
RegisterFunctionNamenull2270 function TPSExec.RegisterFunctionName(const Name: tbtString; ProcPtr: TPSProcPtr; Ext1, Ext2: Pointer): PProcRec;
2271 var
2272 p: PProcRec;
2273 s: tbtString;
2274 begin
2275 s := FastUppercase(Name);
2276 New(p);
2277 p^.Name := s;
2278 p^.Hash := MakeHash(s);
2279 p^.ProcPtr := ProcPtr;
2280 p^.FreeProc := nil;
2281 p^.Ext1 := Ext1;
2282 p^.Ext2 := Ext2;
2283 FRegProcs.Add(p);
2284 Result := P;
2285 end;
2286
LoadDatanull2287 function TPSExec.LoadData(const s: tbtString): Boolean;
2288 var
2289 HDR: TPSHeader;
2290 Pos: Cardinal;
2291
2292 function read(var Data; Len: Cardinal): Boolean;
2293 begin
2294 if Longint(Pos + Len) <= Length(s) then begin
2295 Move(s[Pos + 1], Data, Len);
2296 Pos := Pos + Len;
2297 read := True;
2298 end
2299 else
2300 read := False;
2301 end;
2302 function ReadAttributes(Dest: TPSRuntimeAttributes): Boolean;
2303 var
2304 Count: Cardinal;
2305 i: Integer;
2306
2307 function ReadAttrib: Boolean;
2308 var
2309 NameLen: Longint;
2310 Name: tbtString;
2311 TypeNo: Cardinal;
2312 i, h, FieldCount: Longint;
2313 att: TPSRuntimeAttribute;
2314 varp: PIFVariant;
2315
2316 begin
2317 if (not Read(NameLen, 4)) or (NameLen > Length(s) - Longint(Pos)) then
2318 begin
2319 CMD_Err(ErOutOfRange);
2320 Result := false;
2321 exit;
2322 end;
2323 SetLength(Name, NameLen);
2324 if not Read(Name[1], NameLen) then
2325 begin
2326 CMD_Err(ErOutOfRange);
2327 Result := false;
2328 exit;
2329 end;
2330 if not Read(FieldCount, 4) then
2331 begin
2332 CMD_Err(ErOutOfRange);
2333 Result := false;
2334 exit;
2335 end;
2336 att := Dest.Add;
2337 att.AttribType := Name;
2338 att.AttribTypeHash := MakeHash(att.AttribType);
2339 for i := 0 to FieldCount -1 do
2340 begin
2341 if (not Read(TypeNo, 4)) or (TypeNo >= Cardinal(FTypes.Count)) then
2342 begin
2343 CMD_Err(ErOutOfRange);
2344 Result := false;
2345 exit;
2346 end;
2347
2348 varp := att.AddValue(FTypes[TypeNo]);
2349 case VarP^.FType.BaseType of
2350 btSet:
2351 begin
2352 if not read(PPSVariantSet(varp).Data, TPSTypeRec_Set(varp.FType).aByteSize) then
2353 begin
2354 CMD_Err(erOutOfRange);
2355
2356 DestroyHeapVariant(VarP);
2357 Result := False;
2358 exit;
2359 end;
2360 end;
2361 bts8, btchar, btU8: if not read(PPSVariantU8(VarP)^.data, 1) then
2362 begin
2363 CMD_Err(erOutOfRange);
2364 DestroyHeapVariant(VarP);
2365 Result := False;
2366 exit;
2367 end;
2368 bts16, {$IFNDEF PS_NOWIDESTRING}btwidechar,{$ENDIF} btU16: if not read(PPSVariantU16(Varp)^.Data, SizeOf(TbtU16)) then begin
2369 CMD_Err(ErOutOfRange);
2370 DestroyHeapVariant(VarP);
2371 Result := False;
2372 exit;
2373 end;
2374 bts32, btU32:
2375 begin
2376 if FCurrentPosition + 3 >= FDataLength then
2377 begin
2378 Cmd_Err(erOutOfRange);
2379 DestroyHeapVariant(VarP);
2380 Result := False;
2381 exit;;
2382 end;
2383 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
2384 PPSVariantU32(varp)^.Data := unaligned(Cardinal((@FData^[FCurrentPosition])^));
2385 {$else}
2386 PPSVariantU32(varp)^.Data := Cardinal((@FData^[FCurrentPosition])^);
2387 {$endif}
2388 Inc(FCurrentPosition, 4);
2389 end;
2390 btProcPtr:
2391 begin
2392 if FCurrentPosition + 3 >= FDataLength then
2393 begin
2394 Cmd_Err(erOutOfRange);
2395 DestroyHeapVariant(VarP);
2396 Result := False;
2397 exit;;
2398 end;
2399 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
2400 PPSVariantU32(varp)^.Data := unaligned(Cardinal((@FData^[FCurrentPosition])^));
2401 {$else}
2402 PPSVariantU32(varp)^.Data := Cardinal((@FData^[FCurrentPosition])^);
2403 {$endif}
2404 if PPSVariantU32(varp)^.Data = 0 then
2405 begin
2406 PPSVariantProcPtr(varp)^.Ptr := nil;
2407 PPSVariantProcPtr(varp)^.Self := nil;
2408 end;
2409 Inc(FCurrentPosition, 4);
2410 end;
2411 {$IFNDEF PS_NOINT64}
2412 bts64: if not read(PPSVariantS64(VarP)^.Data, sizeof(tbts64)) then
2413 begin
2414 CMD_Err(erOutOfRange);
2415 DestroyHeapVariant(VarP);
2416 Result := False;
2417 exit;
2418 end;
2419 {$ENDIF}
2420 btSingle: if not read(PPSVariantSingle(VarP)^.Data, SizeOf(TbtSingle))
2421 then begin
2422 CMD_Err(erOutOfRange);
2423 DestroyHeapVariant(VarP);
2424 Result := False;
2425 exit;
2426 end;
2427 btDouble: if not read(PPSVariantDouble(varp)^.Data, SizeOf(TbtDouble))
2428 then begin
2429 CMD_Err(erOutOfRange);
2430 DestroyHeapVariant(VarP);
2431 Result := False;
2432 exit;
2433 end;
2434 btExtended: if not read(PPSVariantExtended(varp)^.Data, SizeOf(TbtExtended))
2435 then begin
2436 CMD_Err(erOutOfRange);
2437 DestroyHeapVariant(VarP);
2438 Result := False;
2439 exit;
2440 end;
2441 btCurrency: if not read(PPSVariantExtended(varp)^.Data, SizeOf(tbtCurrency))
2442 then begin
2443 CMD_Err(erOutOfRange);
2444 DestroyHeapVariant(VarP);
2445 Result := False;
2446 exit;
2447 end;
2448 btPchar, btString:
2449 begin
2450 if not read(NameLen, 4) then
2451 begin
2452 Cmd_Err(erOutOfRange);
2453 DestroyHeapVariant(VarP);
2454 Result := False;
2455 exit;
2456 end;
2457 Inc(FCurrentPosition, 4);
2458 SetLength(PPSVariantAString(varp)^.Data, NameLen);
2459 if not read(PPSVariantAString(varp)^.Data[1], NameLen) then begin
2460 CMD_Err(erOutOfRange);
2461 DestroyHeapVariant(VarP);
2462 Result := False;
2463 exit;
2464 end;
2465 end;
2466 {$IFNDEF PS_NOWIDESTRING}
2467 btWidestring:
2468 begin
2469 if not read(NameLen, 4) then
2470 begin
2471 Cmd_Err(erOutOfRange);
2472 DestroyHeapVariant(VarP);
2473 Result := False;
2474 exit;
2475 end;
2476 Inc(FCurrentPosition, 4);
2477 SetLength(PPSVariantWString(varp).Data, NameLen);
2478 if not read(PPSVariantWString(varp).Data[1], NameLen*2) then begin
2479 CMD_Err(erOutOfRange);
2480 DestroyHeapVariant(VarP);
2481 Result := False;
2482 exit;
2483 end;
2484 end;
2485 btUnicodeString:
2486 begin
2487 if not read(NameLen, 4) then
2488 begin
2489 Cmd_Err(erOutOfRange);
2490 DestroyHeapVariant(VarP);
2491 Result := False;
2492 exit;
2493 end;
2494 Inc(FCurrentPosition, 4);
2495 SetLength(PPSVariantUString(varp).Data, NameLen);
2496 if not read(PPSVariantUString(varp).Data[1], NameLen*2) then begin
2497 CMD_Err(erOutOfRange);
2498 DestroyHeapVariant(VarP);
2499 Result := False;
2500 exit;
2501 end;
2502 end;
2503 {$ENDIF}
2504 else begin
2505 CMD_Err(erInvalidType);
2506 DestroyHeapVariant(VarP);
2507 Result := False;
2508 exit;
2509 end;
2510 end;
2511 end;
2512 h := MakeHash(att.AttribType);
2513 for i := FAttributeTypes.Count -1 downto 0 do
2514 begin
2515 if (TPSAttributeType(FAttributeTypes.Data^[i]).TypeNameHash = h) and
2516 (TPSAttributeType(FAttributeTypes.Data^[i]).TypeName = att.AttribType) then
2517 begin
2518 if not TPSAttributeType(FAttributeTypes.Data^[i]).UseProc(Self, att.AttribType, Att) then
2519 begin
2520 Result := False;
2521 exit;
2522 end;
2523 end;
2524 end;
2525 Result := True;
2526 end;
2527
2528
2529 begin
2530 if not Read(Count, 4) then
2531 begin
2532 CMD_Err(erOutofRange);
2533 Result := false;
2534 exit;
2535 end;
2536 for i := 0 to Count -1 do
2537 begin
2538 if not ReadAttrib then
2539 begin
2540 Result := false;
2541 exit;
2542 end;
2543 end;
2544 Result := True;
2545 end;
2546
2547 {$PUSH}
2548 {$WARNINGS OFF}
2549
2550 function LoadTypes: Boolean;
2551 var
2552 currf: TPSType;
2553 Curr: PIFTypeRec;
2554 fe: Boolean;
2555 l2, l: Longint;
2556 d: Cardinal;
2557
2558 function resolve(Dta: TPSTypeRec_Record): Boolean;
2559 var
2560 offs, l: Longint;
2561 begin
2562 offs := 0;
2563 for l := 0 to Dta.FieldTypes.Count -1 do
2564 begin
2565 Dta.RealFieldOffsets.Add(Pointer(offs));
2566 offs := offs + TPSTypeRec(Dta.FieldTypes[l]).RealSize;
2567 end;
2568 Result := True;
2569 end;
2570 begin
2571 LoadTypes := True;
2572 for l := 0 to HDR.TypeCount - 1 do begin
2573 if not read(currf, SizeOf(currf)) then begin
2574 cmd_err(erUnexpectedEof);
2575 LoadTypes := False;
2576 exit;
2577 end;
2578 if (currf.BaseType and 128) <> 0 then begin
2579 fe := True;
2580 currf.BaseType := currf.BaseType - 128;
2581 end else
2582 fe := False;
2583 case currf.BaseType of
2584 {$IFNDEF PS_NOINT64}bts64, {$ENDIF}
2585 btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btCurrency,
2586 btExtended, btString, btPointer, btPChar,
2587 btVariant, btChar{$IFNDEF PS_NOWIDESTRING}, btUnicodeString, btWideString, btWideChar{$ENDIF}: begin
2588 curr := TPSTypeRec.Create(self);
2589 Curr.BaseType := currf.BaseType;
2590 FTypes.Add(Curr);
2591 end;
2592 btClass:
2593 begin
2594 Curr := TPSTypeRec_Class.Create(self);
2595 if (not Read(d, 4)) or (d > 255) then
2596 begin
2597 curr.Free;
2598 cmd_err(erUnexpectedEof);
2599 LoadTypes := False;
2600 exit;
2601 end;
2602 setlength(TPSTypeRec_Class(Curr).FCN, d);
2603 if not Read(TPSTypeRec_Class(Curr).FCN[1], d) then
2604 begin
2605 curr.Free;
2606 cmd_err(erUnexpectedEof);
2607 LoadTypes := False;
2608 exit;
2609 end;
2610 Curr.BaseType := currf.BaseType;
2611 FTypes.Add(Curr);
2612 end;
2613 btProcPtr:
2614 begin
2615 Curr := TPSTypeRec_ProcPtr.Create(self);
2616 if (not Read(d, 4)) or (d > 255) then
2617 begin
2618 curr.Free;
2619 cmd_err(erUnexpectedEof);
2620 LoadTypes := False;
2621 exit;
2622 end;
2623 setlength(TPSTypeRec_ProcPtr(Curr).FParamInfo, d);
2624 if not Read(TPSTypeRec_ProcPtr(Curr).FParamInfo[1], d) then
2625 begin
2626 curr.Free;
2627 cmd_err(erUnexpectedEof);
2628 LoadTypes := False;
2629 exit;
2630 end;
2631 Curr.BaseType := currf.BaseType;
2632 FTypes.Add(Curr);
2633 end;
2634 {$IFNDEF PS_NOINTERFACES}
2635 btInterface:
2636 begin
2637 Curr := TPSTypeRec_Interface.Create(self);
2638 if not Read(TPSTypeRec_Interface(Curr).FGUID, Sizeof(TGuid)) then
2639 begin
2640 curr.Free;
2641 cmd_err(erUnexpectedEof);
2642 LoadTypes := False;
2643 exit;
2644 end;
2645 Curr.BaseType := currf.BaseType;
2646 FTypes.Add(Curr);
2647 end;
2648 {$ENDIF}
2649 btSet:
2650 begin
2651 Curr := TPSTypeRec_Set.Create(self);
2652 if not Read(d, 4) then
2653 begin
2654 curr.Free;
2655 cmd_err(erUnexpectedEof);
2656 LoadTypes := False;
2657 exit;
2658 end;
2659 if (d > 256) then
2660 begin
2661 curr.Free;
2662 cmd_err(erTypeMismatch);
2663 LoadTypes := False;
2664 exit;
2665 end;
2666
2667 TPSTypeRec_Set(curr).aBitSize := d;
2668 TPSTypeRec_Set(curr).aByteSize := TPSTypeRec_Set(curr).aBitSize shr 3;
2669 if (TPSTypeRec_Set(curr).aBitSize and 7) <> 0 then inc(TPSTypeRec_Set(curr).fbytesize);
2670 Curr.BaseType := currf.BaseType;
2671 FTypes.Add(Curr);
2672 end;
2673 btStaticArray:
2674 begin
2675 curr := TPSTypeRec_StaticArray.Create(self);
2676 if not Read(d, 4) then
2677 begin
2678 curr.Free;
2679 cmd_err(erUnexpectedEof);
2680 LoadTypes := False;
2681 exit;
2682 end;
2683 if (d >= FTypes.Count) then
2684 begin
2685 curr.Free;
2686 cmd_err(erTypeMismatch);
2687 LoadTypes := False;
2688 exit;
2689 end;
2690 TPSTypeRec_StaticArray(curr).ArrayType := FTypes[d];
2691 if not Read(d, 4) then
2692 begin
2693 curr.Free;
2694 cmd_err(erUnexpectedEof);
2695 LoadTypes := False;
2696 exit;
2697 end;
2698 if d > (MaxInt div 4) then
2699 begin
2700 curr.Free;
2701 cmd_err(erUnexpectedEof);
2702 LoadTypes := False;
2703 exit;
2704 end;
2705 TPSTypeRec_StaticArray(curr).Size := d;
2706 if not Read(d,4) then //<-additional StartOffset
2707 begin
2708 curr.Free;
2709 cmd_err(erUnexpectedEof);
2710 LoadTypes:=false;
2711 Exit;
2712 end;
2713 TPSTypeRec_StaticArray(curr).StartOffset:=d;
2714
2715 Curr.BaseType := currf.BaseType;
2716 FTypes.Add(Curr);
2717 end;
2718 btArray: begin
2719 Curr := TPSTypeRec_Array.Create(self);
2720 if not read(d, 4) then
2721 begin // Read type
2722 curr.Free;
2723 cmd_err(erUnexpectedEof);
2724 LoadTypes := False;
2725 exit;
2726 end;
2727 if (d >= FTypes.Count) then
2728 begin
2729 curr.Free;
2730 cmd_err(erTypeMismatch);
2731 LoadTypes := False;
2732 exit;
2733 end;
2734 Curr.BaseType := currf.BaseType;
2735 TPSTypeRec_Array(curr).ArrayType := FTypes[d];
2736 FTypes.Add(Curr);
2737 end;
2738 btRecord:
2739 begin
2740 curr := TPSTypeRec_Record.Create(self);
2741 if not read(d, 4) or (d = 0) then
2742 begin
2743 curr.Free;
2744 cmd_err(erUnexpectedEof);
2745 LoadTypes := false;
2746 exit;
2747 end;
2748 while d > 0 do
2749 begin
2750 if not Read(l2, 4) then
2751 begin
2752 curr.Free;
2753 cmd_err(erUnexpectedEof);
2754 LoadTypes := false;
2755 exit;
2756 end;
2757 if Cardinal(l2) >= FTypes.Count then
2758 begin
2759 curr.Free;
2760 cmd_err(ErOutOfRange);
2761 LoadTypes := false;
2762 exit;
2763 end;
2764 TPSTypeRec_Record(curR).FFieldTypes.Add(FTypes[l2]);
2765 Dec(D);
2766 end;
2767 if not resolve(TPSTypeRec_Record(curr)) then
2768 begin
2769 curr.Free;
2770 cmd_err(erInvalidType);
2771 LoadTypes := False;
2772 exit;
2773 end;
2774 Curr.BaseType := currf.BaseType;
2775 FTypes.Add(Curr);
2776 end;
2777 else begin
2778 LoadTypes := False;
2779 CMD_Err(erInvalidType);
2780 exit;
2781 end;
2782 end;
2783 if fe then begin
2784 if not read(d, 4) then begin
2785 cmd_err(erUnexpectedEof);
2786 LoadTypes := False;
2787 exit;
2788 end;
2789 if d > PSAddrNegativeStackStart then
2790 begin
2791 cmd_err(erInvalidType);
2792 LoadTypes := False;
2793 exit;
2794 end;
2795 SetLength(Curr.FExportName, d);
2796 if not read(Curr.fExportName[1], d) then
2797 begin
2798 cmd_err(erUnexpectedEof);
2799 LoadTypes := False;
2800 exit;
2801 end;
2802 Curr.ExportNameHash := MakeHash(Curr.ExportName);
2803 end;
2804 curr.CalcSize;
2805 if HDR.PSBuildNo >= 21 then // since build 21 we support attributes
2806 begin
2807 if not ReadAttributes(Curr.Attributes) then
2808 begin
2809 LoadTypes := False;
2810 exit;
2811 end;
2812 end;
2813 end;
2814 end;
2815
2816 function LoadProcs: Boolean;
2817 var
2818 Rec: TPSProc;
2819 n: tbtString;
2820 b: Byte;
2821 l, L2, L3: Longint;
2822 Curr: TPSProcRec;
2823 begin
2824 LoadProcs := True;
2825 for l := 0 to HDR.ProcCount - 1 do begin
2826 if not read(Rec, SizeOf(Rec)) then begin
2827 cmd_err(erUnexpectedEof);
2828 LoadProcs := False;
2829 exit;
2830 end;
2831 if (Rec.Flags and 1) <> 0 then
2832 begin
2833 Curr := TPSExternalProcRec.Create(Self);
2834 if not read(b, 1) then begin
2835 Curr.Free;
2836 cmd_err(erUnexpectedEof);
2837 LoadProcs := False;
2838 exit;
2839 end;
2840 SetLength(n, b);
2841 if not read(n[1], b) then begin
2842 Curr.Free;
2843 cmd_err(erUnexpectedEof);
2844 LoadProcs := False;
2845 exit;
2846 end;
2847 TPSExternalProcRec(Curr).Name := n;
2848 if (Rec.Flags and 3 = 3) then
2849 begin
2850 if (not Read(L2, 4)) or (L2 > Length(s) - Pos) then
2851 begin
2852 Curr.Free;
2853 cmd_err(erUnexpectedEof);
2854 LoadProcs := False;
2855 exit;
2856 end;
2857 SetLength(n, L2);
2858 Read(n[1], L2); // no check is needed
2859 TPSExternalProcRec(Curr).FDecl := n;
2860 end;
2861 if not ImportProc(TPSExternalProcRec(Curr).Name, TPSExternalProcRec(Curr)) then begin
2862 if TPSExternalProcRec(Curr).Name <> '' then
2863 CMD_Err2(erCannotImport, TPSExternalProcRec(Curr).Name)
2864 else
2865 CMD_Err2(erCannotImport, TPSExternalProcRec(curr).Decl);
2866 Curr.Free;
2867 LoadProcs := False;
2868 exit;
2869 end;
2870 end else begin
2871 Curr := TPSInternalProcRec.Create(Self);
2872 if not read(L2, 4) then begin
2873 Curr.Free;
2874 cmd_err(erUnexpectedEof);
2875 LoadProcs := False;
2876 exit;
2877 end;
2878 if not read(L3, 4) then begin
2879 Curr.Free;
2880 cmd_err(erUnexpectedEof);
2881 LoadProcs := False;
2882 exit;
2883 end;
2884 if (L2 < 0) or (L2 >= Length(s)) or (L2 + L3 > Length(s)) or (L3 = 0) then begin
2885 Curr.Free;
2886 cmd_err(erUnexpectedEof);
2887 LoadProcs := False;
2888 exit;
2889 end;
2890
2891 GetMem(TPSInternalProcRec(Curr).FData, L3);
2892 Move(s[L2 + 1], TPSInternalProcRec(Curr).FData^, L3);
2893 TPSInternalProcRec(Curr).FLength := L3;
2894 if (Rec.Flags and 2) <> 0 then begin // exported
2895 if not read(L3, 4) then begin
2896 Curr.Free;
2897 cmd_err(erUnexpectedEof);
2898 LoadProcs := False;
2899 exit;
2900 end;
2901 if L3 > PSAddrNegativeStackStart then begin
2902 Curr.Free;
2903 cmd_err(erUnexpectedEof);
2904 LoadProcs := False;
2905 exit;
2906 end;
2907 SetLength(TPSInternalProcRec(Curr).FExportName, L3);
2908 if not read(TPSInternalProcRec(Curr).FExportName[1], L3) then begin
2909 Curr.Free;
2910 cmd_err(erUnexpectedEof);
2911 LoadProcs := False;
2912 exit;
2913 end;
2914 if not read(L3, 4) then begin
2915 Curr.Free;
2916 cmd_err(erUnexpectedEof);
2917 LoadProcs := False;
2918 exit;
2919 end;
2920 if L3 > PSAddrNegativeStackStart then begin
2921 Curr.Free;
2922 cmd_err(erUnexpectedEof);
2923 LoadProcs := False;
2924 exit;
2925 end;
2926 SetLength(TPSInternalProcRec(Curr).FExportDecl, L3);
2927 if not read(TPSInternalProcRec(Curr).FExportDecl[1], L3) then begin
2928 Curr.Free;
2929 cmd_err(erUnexpectedEof);
2930 LoadProcs := False;
2931 exit;
2932 end;
2933 TPSInternalProcRec(Curr).FExportNameHash := MakeHash(TPSInternalProcRec(Curr).ExportName);
2934 end;
2935 end;
2936 if (Rec.Flags and 4) <> 0 then
2937 begin
2938 if not ReadAttributes(Curr.Attributes) then
2939 begin
2940 Curr.Free;
2941 LoadProcs := False;
2942 exit;
2943 end;
2944 end;
2945 FProcs.Add(Curr);
2946 end;
2947 end;
2948 {$POP}
2949
2950 function LoadVars: Boolean;
2951 var
2952 l, n: Longint;
2953 e: PPSExportedVar;
2954 Rec: TPSVar;
2955 Curr: PIfVariant;
2956 begin
2957 LoadVars := True;
2958 for l := 0 to HDR.VarCount - 1 do begin
2959 if not read(Rec, SizeOf(Rec)) then begin
2960 cmd_err(erUnexpectedEof);
2961 LoadVars := False;
2962 exit;
2963 end;
2964 if Rec.TypeNo >= HDR.TypeCount then begin
2965 cmd_err(erInvalidType);
2966 LoadVars := False;
2967 exit;
2968 end;
2969 Curr := FGlobalVars.PushType(FTypes.Data^[Rec.TypeNo]);
2970 if Curr = nil then begin
2971 cmd_err(erInvalidType);
2972 LoadVars := False;
2973 exit;
2974 end;
2975 if (Rec.Flags and 1) <> 0 then
2976 begin
2977 if not read(n, 4) then begin
2978 cmd_err(erUnexpectedEof);
2979 LoadVars := False;
2980 exit;
2981 end;
2982 new(e);
2983 try
2984 SetLength(e^.FName, n);
2985 if not Read(e^.FName[1], n) then
2986 begin
2987 dispose(e);
2988 cmd_err(erUnexpectedEof);
2989 LoadVars := False;
2990 exit;
2991 end;
2992 e^.FNameHash := MakeHash(e^.FName);
2993 e^.FVarNo := FGlobalVars.Count;
2994 FExportedVars.Add(E);
2995 except
2996 dispose(e);
2997 cmd_err(erInvalidType);
2998 LoadVars := False;
2999 exit;
3000 end;
3001 end;
3002 end;
3003 end;
3004
3005 begin
3006 Clear;
3007 Pos := 0;
3008 LoadData := False;
3009 if not read(HDR, SizeOf(HDR)) then
3010 begin
3011 CMD_Err(erInvalidHeader);
3012 exit;
3013 end;
3014 if HDR.HDR <> PSValidHeader then
3015 begin
3016 CMD_Err(erInvalidHeader);
3017 exit;
3018 end;
3019 if (HDR.PSBuildNo > PSCurrentBuildNo) or (HDR.PSBuildNo < PSLowBuildSupport) then begin
3020 CMD_Err(erInvalidHeader);
3021 exit;
3022 end;
3023 if not LoadTypes then
3024 begin
3025 Clear;
3026 exit;
3027 end;
3028 if not LoadProcs then
3029 begin
3030 Clear;
3031 exit;
3032 end;
3033 if not LoadVars then
3034 begin
3035 Clear;
3036 exit;
3037 end;
3038 if (HDR.MainProcNo >= FProcs.Count) and (HDR.MainProcNo <> InvalidVal)then begin
3039 CMD_Err(erNoMainProc);
3040 Clear;
3041 exit;
3042 end;
3043 // Load Import Table
3044 FMainProc := HDR.MainProcNo;
3045 FStatus := isLoaded;
3046 Result := True;
3047 end;
3048
3049
3050 procedure TPSExec.Pause;
3051 begin
3052 if FStatus = isRunning then
3053 FStatus := isPaused;
3054 end;
3055
ReadDatanull3056 function TPSExec.ReadData(var Data; Len: Cardinal): Boolean;
3057 begin
3058 if FCurrentPosition + Len <= FDataLength then begin
3059 Move(FData^[FCurrentPosition], Data, Len);
3060 FCurrentPosition := FCurrentPosition + Len;
3061 Result := True;
3062 end
3063 else
3064 Result := False;
3065 end;
3066
3067 procedure TPSExec.CMD_Err(EC: TPSError); // Error
3068 begin
3069 CMD_Err3(ec, '', nil);
3070 end;
3071
3072 procedure VNSetPointerTo(const Src: TPSVariantIFC; Data: Pointer; aType: TPSTypeRec);
3073 begin
3074 if Src.aType.BaseType = btPointer then
3075 begin
3076 if atype.BaseType in NeedFinalization then
3077 FinalizeVariant(src.Dta, Src.aType);
3078 Pointer(Src.Dta^) := Data;
3079 Pointer(Pointer(IPointer(Src.Dta)+PointerSize)^) := aType;
3080 Pointer(Pointer(IPointer(Src.Dta)+(2*PointerSize))^) := nil;
3081 end;
3082 end;
3083
3084 function VNGetUInt(const Src: TPSVariantIFC): Cardinal;
3085 begin
3086 Result := PSGetUInt(Src.Dta, Src.aType);
3087 end;
3088
3089 {$IFNDEF PS_NOINT64}
3090 function VNGetInt64(const Src: TPSVariantIFC): Int64;
3091 begin
3092 Result := PSGetInt64(Src.Dta, Src.aType);
3093 end;
3094 {$ENDIF}
3095
3096 function VNGetReal(const Src: TPSVariantIFC): Extended;
3097 begin
3098 Result := PSGetReal(Src.Dta, Src.aType);
3099 end;
3100
3101 function VNGetCurrency(const Src: TPSVariantIFC): Currency;
3102 begin
3103 Result := PSGetCurrency(Src.Dta, Src.aType);
3104 end;
3105
3106 function VNGetInt(const Src: TPSVariantIFC): Longint;
3107 begin
3108 Result := PSGetInt(Src.Dta, Src.aType);
3109 end;
3110
3111 function VNGetAnsiString(const Src: TPSVariantIFC): tbtString;
3112 begin
3113 Result := PSGetAnsiString(Src.Dta, Src.aType);
3114 end;
3115
3116 {$IFNDEF PS_NOWIDESTRING}
3117 function VNGetWideString(const Src: TPSVariantIFC): tbtWideString;
3118 begin
3119 Result := PSGetWideString(Src.Dta, Src.aType);
3120 end;
3121
3122 function VNGetUnicodeString(const Src: TPSVariantIFC): tbtunicodestring;
3123 begin
3124 Result := PSGetUnicodeString(Src.Dta, Src.aType);
3125 end;
3126 {$ENDIF}
3127
3128 procedure VNSetUInt(const Src: TPSVariantIFC; const Val: Cardinal);
3129 var
3130 Dummy: Boolean;
3131 begin
3132 PSSetUInt(Src.Dta, Src.aType, Dummy, Val);
3133 end;
3134
3135 {$IFNDEF PS_NOINT64}
3136 procedure VNSetInt64(const Src: TPSVariantIFC; const Val: Int64);
3137 var
3138 Dummy: Boolean;
3139 begin
3140 PSSetInt64(Src.Dta, Src.aType, Dummy, Val);
3141 end;
3142 {$ENDIF}
3143
3144 procedure VNSetReal(const Src: TPSVariantIFC; const Val: Extended);
3145 var
3146 Dummy: Boolean;
3147 begin
3148 PSSetReal(Src.Dta, Src.aType, Dummy, Val);
3149 end;
3150
3151 procedure VNSetCurrency(const Src: TPSVariantIFC; const Val: Currency);
3152 var
3153 Dummy: Boolean;
3154 begin
3155 PSSetCurrency(Src.Dta, Src.aType, Dummy, Val);
3156 end;
3157
3158 procedure VNSetInt(const Src: TPSVariantIFC; const Val: Longint);
3159 var
3160 Dummy: Boolean;
3161 begin
3162 PSSetInt(Src.Dta, Src.aType, Dummy, Val);
3163 end;
3164
3165 procedure VNSetAnsiString(const Src: TPSVariantIFC; const Val: tbtString);
3166 var
3167 Dummy: Boolean;
3168 begin
3169 PSSetAnsiString(Src.Dta, Src.aType, Dummy, Val);
3170 end;
3171
3172 function VNGetString(const Src: TPSVariantIFC): String;
3173 begin
3174 {$IFNDEF PS_NOWIDESTRING}
3175 {$IFDEF DELPHI2009UP}
3176 Result := VNGetUnicodeString(Src);
3177 {$ELSE}
3178 Result := VNGetAnsiString(Src);
3179 {$ENDIF}
3180 {$ELSE}
3181 Result := VNGetAnsiString(Src);
3182 {$ENDIF}
3183 end;
3184
3185 procedure VNSetString(const Src: TPSVariantIFC; const Val: String);
3186 begin
3187 {$IFNDEF PS_NOWIDESTRING}
3188 {$IFDEF DELPHI2009UP}
3189 VNSetUnicodeString(Src, Val);
3190 {$ELSE}
3191 VNSetAnsiString(Src, Val);
3192 {$ENDIF}
3193 {$ELSE}
3194 VNSetAnsiString(Src, Val);
3195 {$ENDIF}
3196 end;
3197
3198 {$IFNDEF PS_NOWIDESTRING}
3199 procedure VNSetWideString(const Src: TPSVariantIFC; const Val: tbtWideString);
3200 var
3201 Dummy: Boolean;
3202 begin
3203 PSSetWideString(Src.Dta, Src.aType, Dummy, Val);
3204 end;
3205
3206 procedure VNSetUnicodeString(const Src: TPSVariantIFC; const Val: tbtunicodestring);
3207 var
3208 Dummy: Boolean;
3209 begin
3210 PSSetUnicodeString(Src.Dta, Src.aType, Dummy, Val);
3211 end;
3212
3213 {$ENDIF}
3214
3215 function VGetUInt(const Src: PIFVariant): Cardinal;
3216 begin
3217 Result := PSGetUInt(@PPSVariantData(src).Data, src.FType);
3218 end;
3219
3220 {$IFNDEF PS_NOINT64}
3221 function VGetInt64(const Src: PIFVariant): Int64;
3222 begin
3223 Result := PSGetInt64(@PPSVariantData(src).Data, src.FType);
3224 end;
3225 {$ENDIF}
3226
3227 function VGetReal(const Src: PIFVariant): Extended;
3228 begin
3229 Result := PSGetReal(@PPSVariantData(src).Data, src.FType);
3230 end;
3231
3232 function VGetCurrency(const Src: PIFVariant): Currency;
3233 begin
3234 Result := PSGetCurrency(@PPSVariantData(src).Data, src.FType);
3235 end;
3236
3237 function VGetInt(const Src: PIFVariant): Longint;
3238 begin
3239 Result := PSGetInt(@PPSVariantData(src).Data, src.FType);
3240 end;
3241
3242 function VGetAnsiString(const Src: PIFVariant): tbtString;
3243 begin
3244 Result := PSGetAnsiString(@PPSVariantData(src).Data, src.FType);
3245 end;
3246
3247 {$IFNDEF PS_NOWIDESTRING}
3248 function VGetWideString(const Src: PIFVariant): tbtWideString;
3249 begin
3250 Result := PSGetWideString(@PPSVariantData(src).Data, src.FType);
3251 end;
3252
3253 function VGetUnicodeString(const Src: PIFVariant): tbtunicodestring;
3254 begin
3255 Result := PSGetUnicodeString(@PPSVariantData(src).Data, src.FType);
3256 end;
3257
3258 {$ENDIF}
3259
3260
3261 procedure VSetPointerTo(const Src: PIFVariant; Data: Pointer; aType: TPSTypeRec);
3262 var
3263 temp: TPSVariantIFC;
3264 begin
3265 if (Atype = nil) or (Data = nil) or (Src = nil) then raise Exception.Create(RPS_InvalidVariable);
3266 temp.Dta := @PPSVariantData(Src).Data;
3267 temp.aType := Src.FType;
3268 temp.VarParam := false;
3269 VNSetPointerTo(temp, Data, AType);
3270 end;
3271
3272 procedure VSetUInt(const Src: PIFVariant; const Val: Cardinal);
3273 var
3274 Dummy: Boolean;
3275 begin
3276 PSSetUInt(@PPSVariantData(src).Data, src.FType, Dummy, Val);
3277 end;
3278
3279 {$IFNDEF PS_NOINT64}
3280 procedure VSetInt64(const Src: PIFVariant; const Val: Int64);
3281 var
3282 Dummy: Boolean;
3283 begin
3284 PSSetInt64(@PPSVariantData(src).Data, src.FType, Dummy, Val);
3285 end;
3286 {$ENDIF}
3287
3288 procedure VSetReal(const Src: PIFVariant; const Val: Extended);
3289 var
3290 Dummy: Boolean;
3291 begin
3292 PSSetReal(@PPSVariantData(src).Data, src.FType, Dummy, Val);
3293 end;
3294
3295 procedure VSetCurrency(const Src: PIFVariant; const Val: Currency);
3296 var
3297 Dummy: Boolean;
3298 begin
3299 PSSetCurrency(@PPSVariantData(src).Data, src.FType, Dummy, Val);
3300 end;
3301
3302 procedure VSetInt(const Src: PIFVariant; const Val: Longint);
3303 var
3304 Dummy: Boolean;
3305 begin
3306 PSSetInt(@PPSVariantData(src).Data, src.FType, Dummy, Val);
3307 end;
3308
3309 procedure VSetAnsiString(const Src: PIFVariant; const Val: tbtString);
3310 var
3311 Dummy: Boolean;
3312 begin
3313 PSSetAnsiString(@PPSVariantData(src).Data, src.FType, Dummy, Val);
3314 end;
3315
3316 function VGetString(const Src: PIFVariant): String;
3317 begin
3318 {$IFNDEF PS_NOWIDESTRING}
3319 {$IFDEF DELPHI2009UP}
3320 Result := PSGetUnicodeString(@PPSVariantData(src).Data, src.FType);
3321 {$ELSE}
3322 Result := PSGetAnsiString(@PPSVariantData(src).Data, src.FType);
3323 {$ENDIF}
3324 {$ELSE}
3325 Result := PSGetAnsiString(@PPSVariantData(src).Data, src.FType);
3326 {$ENDIF}
3327 end;
3328
3329 procedure VSetString(const Src: PIFVariant; const Val: string);
3330 var
3331 Dummy: Boolean;
3332 begin
3333 {$IFNDEF PS_NOWIDESTRING}
3334 {$IFDEF DELPHI2009UP}
3335 PSSetUnicodeString(@PPSVariantData(src).Data, src.FType, Dummy, Val);
3336 {$ELSE}
3337 PSSetAnsiString(@PPSVariantData(src).Data, src.FType, Dummy, Val);
3338 {$ENDIF}
3339 {$ELSE}
3340 PSSetAnsiString(@PPSVariantData(src).Data, src.FType, Dummy, Val);
3341 {$ENDIF}
3342 end;
3343
3344
3345 {$IFNDEF PS_NOWIDESTRING}
3346 procedure VSetWideString(const Src: PIFVariant; const Val: tbtWideString);
3347 var
3348 Dummy: Boolean;
3349 begin
3350 PSSetWideString(@PPSVariantData(src).Data, src.FType, Dummy, Val);
3351 end;
3352
3353 procedure VSetUnicodeString(const Src: PIFVariant; const Val: tbtunicodestring);
3354 var
3355 Dummy: Boolean;
3356 begin
3357 PSSetUnicodeString(@PPSVariantData(src).Data, src.FType, Dummy, Val);
3358 end;
3359
3360
3361 {$ENDIF}
3362
3363 {$IFNDEF PS_NOWIDESTRING}
3364 function VarToWideStr(const Data: Variant): tbtunicodestring;
3365 begin
3366 if not VarIsNull(Data) then
3367 Result := Data
3368 else
3369 Result := '';
3370 end;
3371 {$ENDIF}
3372
3373 function PSGetUInt(Src: Pointer; aType: TPSTypeRec): Cardinal;
3374 begin
3375 if aType.BaseType = btPointer then
3376 begin
3377 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3378 Src := Pointer(Src^);
3379 if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
3380 end;
3381 case aType.BaseType of
3382 btU8: Result := tbtu8(src^);
3383 btS8: Result := tbts8(src^);
3384 btU16: Result := tbtu16(src^);
3385 btS16: Result := tbts16(src^);
3386 btU32: Result := tbtu32(src^);
3387 btS32: Result := tbts32(src^);
3388 {$IFNDEF PS_NOINT64} btS64: Result := tbts64(src^);
3389 {$ENDIF}
3390 btChar: Result := Ord(tbtchar(Src^));
3391 {$IFNDEF PS_NOWIDESTRING} btWideChar: Result := Ord(tbtwidechar(Src^));{$ENDIF}
3392 btVariant:
3393 case VarType(Variant(Src^)) of
3394 varString:
3395 if Length(VarToStr(Variant(Src^))) = 1 then
3396 Result := Ord(VarToStr(Variant(Src^))[1])
3397 else
3398 raise Exception.Create(RPS_TypeMismatch);
3399 {$IFNDEF PS_NOWIDESTRING}
3400 varOleStr:
3401 if Length(VarToWideStr(Variant(Src^))) = 1 then
3402 Result := Ord(VarToWideStr(Variant(Src^))[1])
3403 else
3404 raise Exception.Create(RPS_TypeMismatch);
3405 {$ENDIF}
3406 else
3407 Result := Variant(src^);
3408 end;
3409 else raise Exception.Create(RPS_TypeMismatch);
3410 end;
3411 end;
3412
3413 function PSGetObject(Src: Pointer; aType: TPSTypeRec): TObject;
3414 begin
3415 if aType.BaseType = btPointer then
3416 begin
3417 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3418 Src := Pointer(Src^);
3419 if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
3420 end;
3421 case aType.BaseType of
3422 btClass: Result := TObject(Src^);
3423 else raise Exception.Create(RPS_TypeMismatch);
3424 end;
3425 end;
3426
3427 procedure PSSetObject(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; Const val: TObject);
3428 begin
3429 if aType.BaseType = btPointer then
3430 begin
3431 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3432 Src := Pointer(Src^);
3433 if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
3434 end;
3435 case aType.BaseType of
3436 btClass: TObject(Src^) := Val;
3437 else raise Exception.Create(RPS_TypeMismatch);
3438 end;
3439 end;
3440
3441
3442 {$IFNDEF PS_NOINT64}
3443 function PSGetInt64(Src: Pointer; aType: TPSTypeRec): Int64;
3444 begin
3445 if aType.BaseType = btPointer then
3446 begin
3447 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3448 Src := Pointer(Src^);
3449 if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
3450 end;
3451 case aType.BaseType of
3452 btU8: Result := tbtu8(src^);
3453 btS8: Result := tbts8(src^);
3454 btU16: Result := tbtu16(src^);
3455 btS16: Result := tbts16(src^);
3456 btU32: Result := tbtu32(src^);
3457 btS32: Result := tbts32(src^);
3458 btS64: Result := tbts64(src^);
3459 btChar: Result := Ord(tbtchar(Src^));
3460 {$IFNDEF PS_NOWIDESTRING}
3461 btWideChar: Result := Ord(tbtwidechar(Src^));
3462 {$ENDIF}
3463 {$IFDEF DELPHI6UP}
3464 btVariant: Result := Variant(src^);
3465 {$ENDIF}
3466 else raise Exception.Create(RPS_TypeMismatch);
3467 end;
3468 end;
3469 {$ENDIF}
3470
3471 function PSGetReal(Src: Pointer; aType: TPSTypeRec): Extended;
3472 begin
3473 if aType.BaseType = btPointer then
3474 begin
3475 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3476 Src := Pointer(Src^);
3477 if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
3478 end;
3479 case aType.BaseType of
3480 btU8: Result := tbtu8(src^);
3481 btS8: Result := tbts8(src^);
3482 btU16: Result := tbtu16(src^);
3483 btS16: Result := tbts16(src^);
3484 btU32: Result := tbtu32(src^);
3485 btS32: Result := tbts32(src^);
3486 {$IFNDEF PS_NOINT64} btS64: Result := tbts64(src^);{$ENDIF}
3487 btSingle: Result := tbtsingle(Src^);
3488 btDouble: Result := tbtdouble(Src^);
3489 btExtended: Result := tbtextended(Src^);
3490 btCurrency: Result := tbtcurrency(Src^);
3491 btVariant: Result := Variant(src^);
3492 else raise Exception.Create(RPS_TypeMismatch);
3493 end;
3494 end;
3495
3496 function PSGetCurrency(Src: Pointer; aType: TPSTypeRec): Currency;
3497 begin
3498 if aType.BaseType = btPointer then
3499 begin
3500 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3501 Src := Pointer(Src^);
3502 if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
3503 end;
3504 case aType.BaseType of
3505 btU8: Result := tbtu8(src^);
3506 btS8: Result := tbts8(src^);
3507 btU16: Result := tbtu16(src^);
3508 btS16: Result := tbts16(src^);
3509 btU32: Result := tbtu32(src^);
3510 btS32: Result := tbts32(src^);
3511 {$IFNDEF PS_NOINT64} btS64: Result := tbts64(src^);{$ENDIF}
3512 btSingle: Result := tbtsingle(Src^);
3513 btDouble: Result := tbtdouble(Src^);
3514 btExtended: Result := tbtextended(Src^);
3515 btCurrency: Result := tbtcurrency(Src^);
3516 btVariant: Result := Variant(src^);
3517 else raise Exception.Create(RPS_TypeMismatch);
3518 end;
3519 end;
3520
3521
3522 function PSGetInt(Src: Pointer; aType: TPSTypeRec): Longint;
3523 begin
3524 if aType.BaseType = btPointer then
3525 begin
3526 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3527 Src := Pointer(Src^);
3528 if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
3529 end;
3530 case aType.BaseType of
3531 btU8: Result := tbtu8(src^);
3532 btS8: Result := tbts8(src^);
3533 btU16: Result := tbtu16(src^);
3534 btS16: Result := tbts16(src^);
3535 btU32: Result := tbtu32(src^);
3536 btS32: Result := tbts32(src^);
3537 {$IFNDEF PS_NOINT64} btS64: Result := tbts64(src^);{$ENDIF}
3538 btChar: Result := Ord(tbtchar(Src^));
3539 {$IFNDEF PS_NOWIDESTRING} btWideChar: Result := Ord(tbtwidechar(Src^));{$ENDIF}
3540 btVariant: Result := Variant(src^);
3541 else raise Exception.Create(RPS_TypeMismatch);
3542 end;
3543 end;
3544
3545
3546 function PSGetAnsiString(Src: Pointer; aType: TPSTypeRec): tbtString;
3547 begin
3548 if aType.BaseType = btPointer then
3549 begin
3550 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3551 Src := Pointer(Src^);
3552 if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
3553 end;
3554 case aType.BaseType of
3555 btU8: Result := tbtchar(tbtu8(src^));
3556 btChar: Result := tbtchar(Src^);
3557 btPchar: Result := pansichar(src^);
3558 {$IFNDEF PS_NOWIDESTRING} btWideChar: Result := tbtString(tbtwidechar(Src^));{$ENDIF}
3559 btString: Result := tbtstring(src^);
3560 {$IFNDEF PS_NOWIDESTRING}
3561 btUnicodeString: result := tbtString(tbtUnicodestring(src^));
3562 btWideString: Result := tbtString(tbtwidestring(src^));{$ENDIF}
3563 btVariant: Result := tbtString(Variant(src^));
3564 else raise Exception.Create(RPS_TypeMismatch);
3565 end;
3566 end;
3567 {$IFNDEF PS_NOWIDESTRING}
3568 function PSGetWideString(Src: Pointer; aType: TPSTypeRec): tbtWideString;
3569 begin
3570 if aType.BaseType = btPointer then
3571 begin
3572 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3573 Src := Pointer(Src^);
3574 if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
3575 end;
3576 case aType.BaseType of
3577 btU8: Result := chr(tbtu8(src^));
3578 btU16: Result := widechar(src^);
3579 btChar: Result := tbtwidestring(tbtchar(Src^));
3580 btPchar: Result := tbtwidestring(pansichar(src^));
3581 btWideChar: Result := tbtwidechar(Src^);
3582 btString: Result := tbtwidestring(tbtstring(src^));
3583 btWideString: Result := tbtwidestring(src^);
3584 btVariant: Result := Variant(src^);
3585 btUnicodeString: result := tbtUnicodeString(src^);
3586 else raise Exception.Create(RPS_TypeMismatch);
3587 end;
3588 end;
3589
3590 function PSGetUnicodeString(Src: Pointer; aType: TPSTypeRec): tbtunicodestring;
3591 begin
3592 if aType.BaseType = btPointer then
3593 begin
3594 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3595 Src := Pointer(Src^);
3596 if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
3597 end;
3598 case aType.BaseType of
3599 btU8: Result := chr(tbtu8(src^));
3600 btU16: Result := widechar(src^);
3601 btChar: Result := tbtunicodestring(tbtchar(Src^));
3602 btPchar: Result := tbtunicodestring(pansichar(src^));
3603 btWideChar: Result := tbtwidechar(Src^);
3604 btString: Result := tbtunicodestring(tbtstring(src^));
3605 btWideString: Result := tbtwidestring(src^);
3606 btVariant: Result := Variant(src^);
3607 btUnicodeString: result := tbtUnicodeString(src^);
3608 else raise Exception.Create(RPS_TypeMismatch);
3609 end;
3610 end;
3611 {$ENDIF}
3612
3613 procedure PSSetUInt(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Cardinal);
3614 begin
3615 if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
3616 if aType.BaseType = btPointer then
3617 begin
3618 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3619 Src := Pointer(Src^);
3620 if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
3621 end;
3622 case aType.BaseType of
3623 btU8: tbtu8(src^) := Val;
3624 btS8: tbts8(src^) := Val;
3625 btU16: tbtu16(src^) := Val;
3626 btS16: tbts16(src^) := Val;
3627 btProcPtr:
3628 begin
3629 tbtu32(src^) := Val;
3630 Pointer(Pointer(IPointer(Src)+PointerSize)^) := nil;
3631 Pointer(Pointer(IPointer(Src)+PointerSize2)^) := nil;
3632 end;
3633 btU32: tbtu32(src^) := Val;
3634 btS32: tbts32(src^) := Val;
3635 {$IFNDEF PS_NOINT64} btS64: tbts64(src^) := Val;{$ENDIF}
3636 btChar: tbtchar(Src^) := tbtChar(Val);
3637 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtwidechar(Src^) := tbtwidechar(Val);{$ENDIF}
3638 btSingle: tbtSingle(src^) := Val;
3639 btDouble: tbtDouble(src^) := Val;
3640 btCurrency: tbtCurrency(src^) := Val;
3641 btExtended: tbtExtended(src^) := Val;
3642 btVariant:
3643 begin
3644 try
3645 Variant(src^) := {$IFDEF DELPHI6UP}val{$ELSE}tbts32(val){$ENDIF};
3646 except
3647 Ok := false;
3648 end;
3649 end;
3650 else ok := false;
3651 end;
3652 end;
3653
3654 {$IFNDEF PS_NOINT64}
3655 procedure PSSetInt64(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Int64);
3656 begin
3657 if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
3658 if aType.BaseType = btPointer then
3659 begin
3660 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3661 Src := Pointer(Src^);
3662 if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
3663 end;
3664 case aType.BaseType of
3665 btU8: tbtu8(src^) := Val;
3666 btS8: tbts8(src^) := Val;
3667 btU16: tbtu16(src^) := Val;
3668 btS16: tbts16(src^) := Val;
3669 btU32: tbtu32(src^) := Val;
3670 btS32: tbts32(src^) := Val;
3671 btS64: tbts64(src^) := Val;
3672 btChar: tbtchar(Src^) := tbtChar(Val);
3673 {$IFNDEF PS_NOWIDESTRING}
3674 btWideChar: tbtwidechar(Src^) := tbtwidechar(Val);
3675 {$ENDIF}
3676 btSingle: tbtSingle(src^) := Val;
3677 btDouble: tbtDouble(src^) := Val;
3678 btCurrency: tbtCurrency(src^) := Val;
3679 btExtended: tbtExtended(src^) := Val;
3680 {$IFDEF DELPHI6UP}
3681 btVariant:
3682 begin
3683 try
3684 Variant(src^) := Val;
3685 except
3686 Ok := false;
3687 end;
3688 end;
3689 {$ENDIF}
3690 else ok := false;
3691 end;
3692 end;
3693 {$ENDIF}
3694
3695 procedure PSSetReal(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Extended);
3696 begin
3697 if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
3698 if aType.BaseType = btPointer then
3699 begin
3700 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3701 Src := Pointer(Src^);
3702 if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
3703 end;
3704 case aType.BaseType of
3705 btSingle: tbtSingle(src^) := Val;
3706 btDouble: tbtDouble(src^) := Val;
3707 btCurrency: tbtCurrency(src^) := Val;
3708 btExtended: tbtExtended(src^) := Val;
3709 btVariant:
3710 begin
3711 try
3712 Variant(src^) := Val;
3713 except
3714 Ok := false;
3715 end;
3716 end;
3717 else ok := false;
3718 end;
3719 end;
3720
3721 procedure PSSetCurrency(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Currency);
3722 begin
3723 if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
3724 if aType.BaseType = btPointer then
3725 begin
3726 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3727 Src := Pointer(Src^);
3728 if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
3729 end;
3730 case aType.BaseType of
3731 btSingle: tbtSingle(src^) := Val;
3732 btDouble: tbtDouble(src^) := Val;
3733 btCurrency: tbtCurrency(src^) := Val;
3734 btExtended: tbtExtended(src^) := Val;
3735 btVariant:
3736 begin
3737 try
3738 Variant(src^) := Val;
3739 except
3740 Ok := false;
3741 end;
3742 end;
3743 else ok := false;
3744 end;
3745 end;
3746
3747 procedure PSSetInt(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Longint);
3748 begin
3749 if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
3750 if aType.BaseType = btPointer then
3751 begin
3752 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3753 Src := Pointer(Src^);
3754 if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
3755 end;
3756 case aType.BaseType of
3757 btU8: tbtu8(src^) := Val;
3758 btS8: tbts8(src^) := Val;
3759 btU16: tbtu16(src^) := Val;
3760 btS16: tbts16(src^) := Val;
3761 btProcPtr:
3762 begin
3763 tbtu32(src^) := Val;
3764 Pointer(Pointer(IPointer(Src)+PointerSize)^) := nil;
3765 Pointer(Pointer(IPointer(Src)+PointerSize2)^) := nil;
3766 end;
3767 btU32: tbtu32(src^) := Val;
3768 btS32: tbts32(src^) := Val;
3769 {$IFNDEF PS_NOINT64} btS64: tbts64(src^) := Val;{$ENDIF}
3770 btChar: tbtchar(Src^) := tbtChar(Val);
3771 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtwidechar(Src^) := tbtwidechar(Val);{$ENDIF}
3772 btSingle: tbtSingle(src^) := Val;
3773 btDouble: tbtDouble(src^) := Val;
3774 btCurrency: tbtCurrency(src^) := Val;
3775 btExtended: tbtExtended(src^) := Val;
3776 btVariant:
3777 begin
3778 try
3779 Variant(src^) := Val;
3780 except
3781 Ok := false;
3782 end;
3783 end;
3784 else ok := false;
3785 end;
3786 end;
3787
3788
3789 procedure PSSetAnsiString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtString);
3790 begin
3791 if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
3792 if aType.BaseType = btPointer then
3793 begin
3794 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3795 Src := Pointer(Src^);
3796 if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
3797 end;
3798 case aType.BaseType of
3799 btString: tbtstring(src^) := val;
3800 btChar: if AnsiString(val) <> '' then tbtchar(src^) := AnsiString(val)[1];
3801 {$IFNDEF PS_NOWIDESTRING}
3802 btUnicodeString: tbtunicodestring(src^) := tbtUnicodeString(AnsiString(val));
3803 btWideString: tbtwidestring(src^) := tbtwidestring(AnsiString(val));
3804 btWideChar: if AnsiString(val) <> '' then tbtwidechar(src^) := tbtwidechar(AnsiString(val)[1]);
3805 {$ENDIF}
3806 btVariant:
3807 begin
3808 try
3809 Variant(src^) := Val;
3810 except
3811 Ok := false;
3812 end;
3813 end;
3814 else ok := false;
3815 end;
3816 end;
3817 {$IFNDEF PS_NOWIDESTRING}
3818 procedure PSSetWideString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtWideString);
3819 begin
3820 if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
3821 if aType.BaseType = btPointer then
3822 begin
3823 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3824 Src := Pointer(Src^);
3825 if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
3826 end;
3827 case aType.BaseType of
3828 btChar: if val <> '' then tbtchar(src^) := tbtChar(val[1]);
3829 btWideChar: if val <> '' then tbtwidechar(src^) := val[1];
3830 btString: tbtstring(src^) := tbtString(val);
3831 btWideString: tbtwidestring(src^) := val;
3832 btUnicodeString: tbtunicodestring(src^) := val;
3833 btVariant:
3834 begin
3835 try
3836 Variant(src^) := Val;
3837 except
3838 Ok := false;
3839 end;
3840 end;
3841 else ok := false;
3842 end;
3843 end;
3844
3845 procedure PSSetUnicodeString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtunicodestring);
3846 begin
3847 if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
3848 if aType.BaseType = btPointer then
3849 begin
3850 atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
3851 Src := Pointer(Src^);
3852 if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
3853 end;
3854 case aType.BaseType of
3855 btString: tbtstring(src^) := tbtString(val);
3856 btWideString: tbtwidestring(src^) := val;
3857 btUnicodeString: tbtunicodestring(src^) := val;
3858 btVariant:
3859 begin
3860 try
3861 Variant(src^) := Val;
3862 except
3863 Ok := false;
3864 end;
3865 end;
3866 else ok := false;
3867 end;
3868 end;
3869 {$ENDIF}
3870
3871 function PSGetString(Src: Pointer; aType: TPSTypeRec): string;
3872 begin
3873 {$IFNDEF PS_NOWIDESTRING}
3874 {$IFDEF DELPHI2009UP}
3875 result := PSGetUnicodeString(Src, aType);
3876 {$ELSE}
3877 result := PSGetAnsiString(Src, aType);
3878 {$ENDIF}
3879 {$ELSE}
3880 result := PSGetAnsiString(Src, aType);
3881 {$ENDIF}
3882 end;
3883
3884 procedure PSSetString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: String);
3885 begin
3886 {$IFNDEF PS_NOWIDESTRING}
3887 {$IFDEF DELPHI2009UP}
3888 PSSetUnicodeString(Src, aType, Ok, Val);
3889 {$ELSE}
3890 PSSetAnsiString(Src, aType, Ok, Val);
3891 {$ENDIF}
3892 {$ELSE}
3893 PSSetAnsiString(Src, aType, Ok, Val);
3894 {$ENDIF}
3895 end;
3896
3897
3898 function CopyArrayContents(dest, src: Pointer; Len: Longint; aType: TPSTypeRec): Boolean; forward;
3899
3900 function CopyRecordContents(dest, src: Pointer; aType: TPSTypeRec_Record): Boolean;
3901 var
3902 o, i: Longint;
3903 begin
3904 for i := 0 to aType.FieldTypes.Count -1 do
3905 begin
3906 o := Longint(atype.RealFieldOffsets[i]);
3907 CopyArrayContents(Pointer(IPointer(Dest)+Cardinal(o)), Pointer(IPointer(Src)+Cardinal(o)), 1, aType.FieldTypes[i]);
3908 end;
3909 Result := true;
3910 end;
3911
3912 function CreateArrayFromVariant(Exec: TPSExec; dest: Pointer; src: Variant; DestType: TPSTypeRec): Boolean;
3913 var
3914 i: Integer;
3915 r: Pointer;
3916 lVarType: TPSTypeRec;
3917 v: variant;
3918 begin
3919 lVarType := Exec.FindType2(btVariant);
3920 if lVarType = nil then begin result := false; exit; end;
3921 PSDynArraySetLength(Pointer(dest^), desttype, VarArrayHighBound(src, 1) - VarArrayLowBound(src, 1) + 1);
3922 r := Pointer(Dest^);
3923 DestType := TPSTypeRec_Array(DestType).ArrayType;
3924 for i := 0 to VarArrayHighBound(src, 1) - VarArrayLowBound(src, 1) do begin
3925 v := src[i + VarArrayLowBound(src, 1)];
3926 if not Exec.SetVariantValue(r, @v, desttype, lVarType) then begin result := false; exit; end;
3927 //r := Pointer(IPointer(r) + Longint(DestType.RealSize));
3928 r := Pointer(IPointer(r) + DestType.RealSize);
3929 end;
3930 Result := true;
3931 end;
3932
3933 function CopyArrayContents(dest, src: Pointer; Len: Longint; aType: TPSTypeRec): Boolean;
3934 var
3935 elsize: Cardinal;
3936 i: Longint;
3937 begin
3938 try
3939 case aType.BaseType of
3940 btU8, btS8, btChar:
3941 for i := 0 to Len -1 do
3942 begin
3943 tbtU8(Dest^) := tbtU8(Src^);
3944 Dest := Pointer(IPointer(Dest) + 1);
3945 Src := Pointer(IPointer(Src) + 1);
3946 end;
3947 btU16, btS16{$IFNDEF PS_NOWIDESTRING}, btWideChar{$ENDIF}:
3948 for i := 0 to Len -1 do
3949 begin
3950 tbtU16(Dest^) := tbtU16(Src^);
3951 Dest := Pointer(IPointer(Dest) + 2);
3952 Src := Pointer(IPointer(Src) + 2);
3953 end;
3954 btProcPtr:
3955 for i := 0 to Len -1 do
3956 begin
3957 tbtU32(Dest^) := tbtU32(Src^);
3958 Dest := Pointer(IPointer(Dest) + PointerSize);
3959 Src := Pointer(IPointer(Src) + PointerSize);
3960 Pointer(Dest^) := Pointer(Src^);
3961 Dest := Pointer(IPointer(Dest) + PointerSize);
3962 Src := Pointer(IPointer(Src) + PointerSize);
3963 Pointer(Dest^) := Pointer(Src^);
3964 Dest := Pointer(IPointer(Dest) + PointerSize);
3965 Src := Pointer(IPointer(Src) + PointerSize);
3966 end;
3967 btClass, btpchar:
3968 for i := 0 to Len -1 do
3969 begin
3970 Pointer(Dest^) := Pointer(Src^);
3971 Dest := Pointer(IPointer(Dest) + PointerSize);
3972 Src := Pointer(IPointer(Src) + PointerSize);
3973 end;
3974 btU32, btS32, btSingle:
3975 for i := 0 to Len -1 do
3976 begin
3977 tbtU32(Dest^) := tbtU32(Src^);
3978 Dest := Pointer(IPointer(Dest) + 4);
3979 Src := Pointer(IPointer(Src) + 4);
3980 end;
3981 btDouble:
3982 for i := 0 to Len -1 do
3983 begin
3984 tbtDouble(Dest^) := tbtDouble(Src^);
3985 Dest := Pointer(IPointer(Dest) + 8);
3986 Src := Pointer(IPointer(Src) + 8);
3987 end;
3988 {$IFNDEF PS_NOINT64}bts64:
3989 for i := 0 to Len -1 do
3990 begin
3991 tbts64(Dest^) := tbts64(Src^);
3992 Dest := Pointer(IPointer(Dest) + 8);
3993 Src := Pointer(IPointer(Src) + 8);
3994 end;{$ENDIF}
3995 btExtended:
3996 for i := 0 to Len -1 do
3997 begin
3998 tbtExtended(Dest^) := tbtExtended(Src^);
3999 Dest := Pointer(IPointer(Dest) + SizeOf(Extended));
4000 Src := Pointer(IPointer(Src) + SizeOf(Extended));
4001 end;
4002 btCurrency:
4003 for i := 0 to Len -1 do
4004 begin
4005 tbtCurrency(Dest^) := tbtCurrency(Src^);
4006 Dest := Pointer(IPointer(Dest) + SizeOf(Currency));
4007 Src := Pointer(IPointer(Src) + SizeOf(Currency));
4008 end;
4009 btVariant:
4010 for i := 0 to Len -1 do
4011 begin
4012 variant(Dest^) := variant(Src^);
4013 Dest := Pointer(IPointer(Dest) + Sizeof(Variant));
4014 Src := Pointer(IPointer(Src) + Sizeof(Variant));
4015 end;
4016 btString:
4017 for i := 0 to Len -1 do
4018 begin
4019 tbtString(Dest^) := tbtString(Src^);
4020 Dest := Pointer(IPointer(Dest) + PointerSize);
4021 Src := Pointer(IPointer(Src) + PointerSize);
4022 end;
4023 {$IFNDEF PS_NOWIDESTRING}
4024 btUnicodeString:
4025 for i := 0 to Len -1 do
4026 begin
4027 tbtunicodestring(Dest^) := tbtunicodestring(Src^);
4028 Dest := Pointer(IPointer(Dest) + PointerSize);
4029 Src := Pointer(IPointer(Src) + PointerSize);
4030 end;
4031 btWideString:
4032 for i := 0 to Len -1 do
4033 begin
4034 tbtWideString(Dest^) := tbtWideString(Src^);
4035 Dest := Pointer(IPointer(Dest) + PointerSize);
4036 Src := Pointer(IPointer(Src) + PointerSize);
4037 end;
4038 {$ENDIF}
4039 btStaticArray:
4040 begin
4041 elSize := aType.RealSize;
4042 for i := 0 to Len -1 do
4043 begin
4044 if not CopyArrayContents(Dest, Src, TPSTypeRec_StaticArray(aType).Size, TPSTypeRec_StaticArray(aType).ArrayType) then
4045 begin
4046 result := false;
4047 exit;
4048 end;
4049 Dest := Pointer(IPointer(Dest) + elsize);
4050 Src := Pointer(IPointer(Src) + elsize);
4051 end;
4052 end;
4053 btArray:
4054 begin
4055 for i := 0 to Len -1 do
4056 begin
4057 if Pointer(Dest^) <> nil then
4058 begin
4059 PSDynArraySetLength(Pointer(Dest^), aType, 0);
4060 end;
4061 Pointer(Dest^) := Pointer(Src^);
4062 if Pointer(Dest^) <> nil then
4063 begin
4064 Inc(PDynArrayRec(PAnsiChar(Dest^) - SizeOf(TDynArrayRecHeader))^.header.refCnt);
4065 end;
4066 Dest := Pointer(IPointer(Dest) + PointerSize);
4067 Src := Pointer(IPointer(Src) + PointerSize);
4068 end;
4069 end;
4070 btRecord:
4071 begin
4072 elSize := aType.RealSize;
4073 for i := 0 to Len -1 do
4074 begin
4075 if not CopyRecordContents(Dest, Src, TPSTypeRec_Record(aType)) then
4076 begin
4077 result := false;
4078 exit;
4079 end;
4080 Dest := Pointer(IPointer(Dest) + elsize);
4081 Src := Pointer(IPointer(Src) + elsize);
4082 end;
4083 end;
4084 btSet:
4085 begin
4086 elSize := aType.RealSize;
4087 for i := 0 to Len -1 do
4088 begin
4089 Move(Src^, Dest^, elSize);
4090 Dest := Pointer(IPointer(Dest) + elsize);
4091 Src := Pointer(IPointer(Src) + elsize);
4092 end;
4093 end;
4094 {$IFNDEF PS_NOINTERFACES}
4095 btInterface:
4096 begin
4097 for i := 0 to Len -1 do
4098 begin
4099 {$IFNDEF DELPHI3UP}
4100 if IUnknown(Dest^) <> nil then
4101 begin
4102 IUnknown(Dest^).Release;
4103 IUnknown(Dest^) := nil;
4104 end;
4105 {$ENDIF}
4106 IUnknown(Dest^) := IUnknown(Src^);
4107 {$IFNDEF DELPHI3UP}
4108 if IUnknown(Dest^) <> nil then
4109 IUnknown(Dest^).AddRef;
4110 {$ENDIF}
4111 Dest := Pointer(IPointer(Dest) + PointerSize);
4112 Src := Pointer(IPointer(Src) + PointerSize);
4113 end;
4114 end;
4115 {$ENDIF}
4116 btPointer:
4117 begin
4118 if (Pointer(Pointer(IPointer(Dest)+PointerSize2)^) = nil) and (Pointer(Pointer(IPointer(Src)+PointerSize2)^) = nil) then
4119 begin
4120 for i := 0 to Len -1 do
4121 begin
4122 Pointer(Dest^) := Pointer(Src^);
4123 Dest := Pointer(IPointer(Dest) + PointerSize);
4124 Src := Pointer(IPointer(Src) + PointerSize);
4125 Pointer(Dest^) := Pointer(Src^);
4126 Dest := Pointer(IPointer(Dest) + PointerSize);
4127 Src := Pointer(IPointer(Src) + PointerSize);
4128 Pointer(Dest^) := nil;
4129 Dest := Pointer(IPointer(Dest) + PointerSize);
4130 Src := Pointer(IPointer(Src) + PointerSize);
4131 end;
4132 end else begin
4133 for i := 0 to Len -1 do
4134 begin
4135 if Pointer(Pointer(IPointer(Dest)+PointerSize2)^) <> nil then
4136 DestroyHeapVariant2(Pointer(Dest^), Pointer(Pointer(IPointer(Dest)+PointerSize)^));
4137 if Pointer(Src^) <> nil then
4138 begin
4139 if not LongBool(Pointer(IPointer(Src) + PointerSize2)^) then
4140 begin
4141 Pointer(Dest^) := Pointer(Src^);
4142 Pointer(Pointer(IPointer(Dest) + PointerSize)^) := Pointer(Pointer(IPointer(Src) + PointerSize)^);
4143 Pointer(Pointer(IPointer(Dest) + PointerSize2)^) := Pointer(Pointer(IPointer(Src) + PointerSize2)^);
4144 end else
4145 begin
4146 Pointer(Dest^) := CreateHeapVariant2(Pointer(Pointer(IPointer(Src) + PointerSize)^));
4147 Pointer(Pointer(IPointer(Dest) + PointerSize)^) := Pointer(Pointer(IPointer(Src) + PointerSize)^);
4148 LongBool(Pointer(IPointer(Dest) + PointerSize2)^) := true;
4149 if not CopyArrayContents(Pointer(Dest^), Pointer(Src^), 1, Pointer(Pointer(IPointer(Dest) + PointerSize)^)) then
4150 begin
4151 Result := false;
4152 exit;
4153 end;
4154 end;
4155 end else
4156 begin
4157 Pointer(Dest^) := nil;
4158 Pointer(Pointer(IPointer(Dest) + PointerSize)^) := nil;
4159 Pointer(Pointer(IPointer(Dest) + PointerSize2)^) := nil;
4160 end;
4161 Dest := Pointer(IPointer(Dest) + PointerSize*3);
4162 Src := Pointer(IPointer(Src) + PointerSize*3);
4163 end;
4164 end;
4165 end;
4166 // btResourcePointer = 15;
4167 // btVariant = 16;
4168 else
4169 Result := False;
4170 exit;
4171 end;
4172 except
4173 Result := False;
4174 exit;
4175 end;
4176 Result := true;
4177 end;
4178
4179 function GetPSArrayLength(Arr: PIFVariant): Longint;
4180 begin
4181 result := PSDynArrayGetLength(PPSVariantDynamicArray(arr).Data, arr.FType);
4182 end;
4183
4184 procedure SetPSArrayLength(Arr: PIFVariant; NewLength: Longint);
4185 begin
4186 PSDynArraySetLength(PPSVariantDynamicArray(arr).Data, arr.FType, NewLength);
4187 end;
4188
4189
4190 function PSDynArrayGetLength(arr: Pointer; aType: TPSTypeRec): Longint;
4191 begin
4192 if aType.BaseType <> btArray then raise Exception.Create(RPS_InvalidArray);
4193 if arr = nil then Result := 0 else result:=PDynArrayRec(PAnsiChar(arr) - SizeOf(TDynArrayRecHeader))^.header.{$IFDEF FPC}high + 1{$ELSE}length{$ENDIF FPC};
4194 end;
4195
4196 procedure PSDynArraySetLength(var arr: Pointer; aType: TPSTypeRec; NewLength: Longint);
4197 var
4198 elSize, i, OldLen: Longint;
4199 darr : PDynArrayRec;
4200 begin
4201 if aType.BaseType <> btArray then raise Exception.Create(RPS_InvalidArray);
4202 OldLen := PSDynArrayGetLength(arr, aType);
4203 elSize := TPSTypeRec_Array(aType).ArrayType.RealSize;
4204 if NewLength<0 then
4205 NewLength:=0;
4206 if (OldLen = 0) and (NewLength = 0) then exit; // already are both 0
4207 if (OldLen = NewLength) then exit; // already same size, noop
4208 darr := PDynArrayRec(PAnsiChar(Arr) - SizeOf(TDynArrayRecHeader));
4209 if (OldLen <> 0) and (darr^.header.refCnt = 1) then // unique copy of this dynamic array
4210 begin
4211 for i := NewLength to OldLen -1 do
4212 begin
4213 if TPSTypeRec_Array(aType).ArrayType.BaseType in NeedFinalization then
4214 FinalizeVariant(Pointer(IPointer(arr) + Cardinal(elsize * i)), TPSTypeRec_Array(aType).ArrayType);
4215 end;
4216 if NewLength <= 0 then
4217 begin
4218 FreeMem(darr);
4219 arr := nil;
4220 exit;
4221 end;
4222 ReallocMem(darr, Longint(NewLength * elSize) + SizeOf(TDynArrayRecHeader));
4223 {$IFDEF FPC}
4224 darr^.header.high := NewLength -1;
4225 {$ELSE}
4226 darr^.header.length := NewLength;
4227 {$ENDIF}
4228 arr := @darr^.datas;
4229 for i := OldLen to NewLength -1 do
4230 begin
4231 InitializeVariant(Pointer(IPointer(arr) + Cardinal(elsize * i)), TPSTypeRec_Array(aType).ArrayType);
4232 end;
4233 end else
4234 begin
4235 if NewLength = 0 then
4236 begin
4237 FinalizeVariant(@arr, aType);
4238 arr := nil;
4239 exit;
4240 end;
4241 GetMem(darr, Longint(NewLength * elSize) + SizeOf(TDynArrayRecHeader));
4242 darr^.header.refCnt:=1;
4243 {$IFDEF FPC}
4244 darr^.header.high := NewLength - 1;
4245 {$ELSE}
4246 {$IFDEF CPUX64}
4247 darr^.header._Padding:=0;
4248 {$ENDIF CPUX64}
4249 darr^.header.length := NewLength;
4250 {$ENDIF FPC}
4251 for i := 0 to NewLength -1 do
4252 begin
4253 InitializeVariant(Pointer(IPointer(@darr^.datas) + Cardinal(elsize * i)), TPSTypeRec_Array(aType).ArrayType);
4254 end;
4255 if OldLen <> 0 then
4256 begin
4257 if OldLen > NewLength then
4258 CopyArrayContents(@darr^.datas, arr, NewLength, TPSTypeRec_Array(aType).ArrayType)
4259 else
4260 CopyArrayContents(@darr^.datas, arr, OldLen, TPSTypeRec_Array(aType).ArrayType);
4261 FinalizeVariant(@arr, aType);
4262 end;
4263 arr := @darr^.datas;
4264 end;
4265 end;
4266
4267
4268 {$IFDEF FPC}
4269
4270 function OleErrorMessage(ErrorCode: HResult): tbtString;
4271 begin
4272 Result := SysErrorMessage(ErrorCode);
4273 if Result = '' then
4274 Result := Format(RPS_OLEError, [ErrorCode]);
4275 end;
4276
4277 procedure OleError(ErrorCode: HResult);
4278 begin
4279 raise Exception.Create(OleErrorMessage(ErrorCode));
4280 end;
4281
4282 procedure OleCheck(Result: HResult);
4283 begin
4284 if Result < 0 then OleError(Result);
4285 end;
4286 {$ENDIF}
4287
4288
4289 {$IFNDEF DELPHI3UP}
4290 function OleErrorMessage(ErrorCode: HResult): tbtString;
4291 begin
4292 Result := SysErrorMessage(ErrorCode);
4293 if Result = '' then
4294 Result := Format(RPS_OLEError, [ErrorCode]);
4295 end;
4296
4297 procedure OleError(ErrorCode: HResult);
4298 begin
4299 raise Exception.Create(OleErrorMessage(ErrorCode));
4300 end;
4301
4302 procedure OleCheck(Result: HResult);
4303 begin
4304 if Result < 0 then OleError(Result);
4305 end;
4306
4307 procedure AssignInterface(var Dest: IUnknown; const Src: IUnknown);
4308 var
4309 OldDest: IUnknown;
4310 begin
4311 { Like Delphi 3+'s _IntfCopy, reference source before releasing old dest.
4312 so that self assignment (I := I) works right }
4313 OldDest := Dest;
4314 Dest := Src;
4315 if Src <> nil then
4316 Src.AddRef;
4317 if OldDest <> nil then
4318 OldDest.Release;
4319 end;
4320
4321 procedure AssignVariantFromIDispatch(var Dest: Variant; const Src: IDispatch);
4322 begin
4323 VarClear(Dest);
4324 TVarData(Dest).VDispatch := Src;
4325 TVarData(Dest).VType := varDispatch;
4326 if Src <> nil then
4327 Src.AddRef;
4328 end;
4329
4330 procedure AssignIDispatchFromVariant(var Dest: IDispatch; const Src: Variant);
4331 const
4332 RPS_InvalidVariantRef = 'Invalid variant ref';
4333 var
4334 NewDest: IDispatch;
4335 begin
4336 case TVarData(Src).VType of
4337 varEmpty: NewDest := nil;
4338 varDispatch: NewDest := TVarData(Src).VDispatch;
4339 varDispatch or varByRef: NewDest := Pointer(TVarData(Src).VPointer^);
4340 else
4341 raise Exception.Create(RPS_InvalidVariantRef);
4342 end;
4343 AssignInterface(IUnknown(Dest), NewDest);
4344 end;
4345 {$ENDIF}
4346
SetVariantValuenull4347 function TPSExec.SetVariantValue(dest, Src: Pointer; desttype, srctype: TPSTypeRec): Boolean;
4348 var
4349 Tmp: TObject;
4350 tt: TPSVariantPointer;
4351 begin
4352 Result := True;
4353 try
4354 case desttype.BaseType of
4355 btSet:
4356 begin
4357 if desttype = srctype then
4358 Move(Src^, Dest^, TPSTypeRec_Set(desttype).aByteSize)
4359 else
4360 Result := False;
4361 end;
4362 btU8: tbtu8(Dest^) := PSGetUInt(Src, srctype);
4363 btS8: tbts8(Dest^) := PSGetInt(Src, srctype);
4364 btU16: tbtu16(Dest^) := PSGetUInt(Src, srctype);
4365 btS16: tbts16(Dest^) := PSGetInt(Src, srctype);
4366 btProcPtr:
4367 begin
4368 if srctype.BaseType = btPointer then
4369 begin
4370 srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
4371 Src := Pointer(Src^);
4372 if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch);
4373 end;
4374 case srctype.BaseType of
4375 btu32:
4376 begin
4377 Pointer(Dest^) := Pointer(Src^);
4378 end;
4379 btProcPtr:
4380 begin
4381 Pointer(Dest^) := Pointer(Src^);
4382 Pointer(Pointer(IPointer(Dest)+PointerSize)^) := Pointer(Pointer(IPointer(Src)+PointerSize)^);
4383 Pointer(Pointer(IPointer(Dest)+PointerSize2)^) := Pointer(Pointer(IPointer(Src)+PointerSize2)^);
4384 end;
4385 else raise Exception.Create(RPS_TypeMismatch);
4386 end;
4387 end;
4388 btU32:
4389 begin
4390 if srctype.BaseType = btPointer then
4391 begin
4392 srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
4393 Src := Pointer(Src^);
4394 if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch);
4395 end;
4396 case srctype.BaseType of
4397 btU8: tbtu32(Dest^) := tbtu8(src^);
4398 btS8: tbtu32(Dest^) := tbts8(src^);
4399 btU16: tbtu32(Dest^) := tbtu16(src^);
4400 btS16: tbtu32(Dest^) := tbts16(src^);
4401 btU32: tbtu32(Dest^) := tbtu32(src^);
4402 btS32: tbtu32(Dest^) := tbts32(src^);
4403 {$IFNDEF PS_NOINT64} btS64: tbtu32(Dest^) := tbts64(src^);{$ENDIF}
4404 btChar: tbtu32(Dest^) := Ord(tbtchar(Src^));
4405 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtu32(Dest^) := Ord(tbtwidechar(Src^));{$ENDIF}
4406 btVariant: tbtu32(Dest^) := Variant(src^);
4407 else raise Exception.Create(RPS_TypeMismatch);
4408 end;
4409 end;
4410 btS32:
4411 begin
4412 if srctype.BaseType = btPointer then
4413 begin
4414 srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
4415 Src := Pointer(Src^);
4416 if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch);
4417 end;
4418 case srctype.BaseType of
4419 btU8: tbts32(Dest^) := tbtu8(src^);
4420 btS8: tbts32(Dest^) := tbts8(src^);
4421 btU16: tbts32(Dest^) := tbtu16(src^);
4422 btS16: tbts32(Dest^) := tbts16(src^);
4423 btU32: tbts32(Dest^) := tbtu32(src^);
4424 btS32: tbts32(Dest^) := tbts32(src^);
4425 {$IFNDEF PS_NOINT64} btS64: tbts32(Dest^) := tbts64(src^);{$ENDIF}
4426 btChar: tbts32(Dest^) := Ord(tbtchar(Src^));
4427 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(Dest^) := Ord(tbtwidechar(Src^));{$ENDIF}
4428 btVariant: tbts32(Dest^) := Variant(src^);
4429 // nx change start - allow assignment of class
4430 btClass: tbtu32(Dest^) := tbtu32(src^);
4431 // nx change start
4432 else raise Exception.Create(RPS_TypeMismatch);
4433 end;
4434 end;
4435 {$IFNDEF PS_NOINT64}
4436 btS64: tbts64(Dest^) := PSGetInt64(Src, srctype);
4437 {$ENDIF}
4438 btSingle:
4439 begin
4440 if srctype.BaseType = btPointer then
4441 begin
4442 srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
4443 Src := Pointer(Src^);
4444 if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch);
4445 end;
4446 case srctype.BaseType of
4447 btU8: tbtsingle(Dest^) := tbtu8(src^);
4448 btS8: tbtsingle(Dest^) := tbts8(src^);
4449 btU16: tbtsingle(Dest^) := tbtu16(src^);
4450 btS16: tbtsingle(Dest^) := tbts16(src^);
4451 btU32: tbtsingle(Dest^) := tbtu32(src^);
4452 btS32: tbtsingle(Dest^) := tbts32(src^);
4453 {$IFNDEF PS_NOINT64} btS64: tbtsingle(Dest^) := tbts64(src^);{$ENDIF}
4454 btSingle: tbtsingle(Dest^) := tbtsingle(Src^);
4455 btDouble: tbtsingle(Dest^) := tbtdouble(Src^);
4456 btExtended: tbtsingle(Dest^) := tbtextended(Src^);
4457 btCurrency: tbtsingle(Dest^) := tbtcurrency(Src^);
4458 btVariant: tbtsingle(Dest^) := Variant(src^);
4459 else raise Exception.Create(RPS_TypeMismatch);
4460 end;
4461 end;
4462 btDouble:
4463 begin
4464 if srctype.BaseType = btPointer then
4465 begin
4466 srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
4467 Src := Pointer(Src^);
4468 if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch);
4469 end;
4470 case srctype.BaseType of
4471 btU8: tbtdouble(Dest^) := tbtu8(src^);
4472 btS8: tbtdouble(Dest^) := tbts8(src^);
4473 btU16: tbtdouble(Dest^) := tbtu16(src^);
4474 btS16: tbtdouble(Dest^) := tbts16(src^);
4475 btU32: tbtdouble(Dest^) := tbtu32(src^);
4476 btS32: tbtdouble(Dest^) := tbts32(src^);
4477 {$IFNDEF PS_NOINT64} btS64: tbtdouble(Dest^) := tbts64(src^);{$ENDIF}
4478 btSingle: tbtdouble(Dest^) := tbtsingle(Src^);
4479 btDouble: tbtdouble(Dest^) := tbtdouble(Src^);
4480 btExtended: tbtdouble(Dest^) := tbtextended(Src^);
4481 btCurrency: tbtdouble(Dest^) := tbtcurrency(Src^);
4482 btVariant: tbtdouble(Dest^) := Variant(src^);
4483 else raise Exception.Create(RPS_TypeMismatch);
4484 end;
4485
4486 end;
4487 btExtended:
4488 begin
4489 if srctype.BaseType = btPointer then
4490 begin
4491 srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
4492 Src := Pointer(Src^);
4493 if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch);
4494 end;
4495 case srctype.BaseType of
4496 btU8: tbtextended(Dest^) := tbtu8(src^);
4497 btS8: tbtextended(Dest^) := tbts8(src^);
4498 btU16: tbtextended(Dest^) := tbtu16(src^);
4499 btS16: tbtextended(Dest^) := tbts16(src^);
4500 btU32: tbtextended(Dest^) := tbtu32(src^);
4501 btS32: tbtextended(Dest^) := tbts32(src^);
4502 {$IFNDEF PS_NOINT64} btS64: tbtextended(Dest^) := tbts64(src^);{$ENDIF}
4503 btSingle: tbtextended(Dest^) := tbtsingle(Src^);
4504 btDouble: tbtextended(Dest^) := tbtdouble(Src^);
4505 btExtended: tbtextended(Dest^) := tbtextended(Src^);
4506 btCurrency: tbtextended(Dest^) := tbtcurrency(Src^);
4507 btVariant: tbtextended(Dest^) := Variant(src^);
4508 else raise Exception.Create(RPS_TypeMismatch);
4509 end;
4510 end;
4511 btCurrency: tbtcurrency(Dest^) := PSGetCurrency(Src, srctype);
4512 btPChar: pansichar(dest^) := pansichar(PSGetAnsiString(Src, srctype));
4513 btString:
4514 tbtstring(dest^) := PSGetAnsiString(Src, srctype);
4515 btChar: tbtchar(dest^) := tbtchar(PSGetUInt(Src, srctype));
4516 {$IFNDEF PS_NOWIDESTRING}
4517 btWideString: tbtwidestring(dest^) := PSGetWideString(Src, srctype);
4518 btUnicodeString: tbtUnicodeString(dest^) := PSGetUnicodeString(Src, srctype);
4519 btWideChar: tbtwidechar(dest^) := widechar(PSGetUInt(Src, srctype));
4520 {$ENDIF}
4521 btStaticArray:
4522 begin
4523 if desttype <> srctype then
4524 Result := False
4525 else
4526 CopyArrayContents(dest, Src, TPSTypeRec_StaticArray(desttype).Size, TPSTypeRec_StaticArray(desttype).ArrayType);
4527 end;
4528 btArray:
4529 begin
4530 if (srctype.BaseType = btStaticArray) and (TPSTypeRec_Array(desttype).ArrayType = TPSTypeRec_Array(srctype).ArrayType) then
4531 begin
4532 PSDynArraySetLength(Pointer(Dest^), desttype, TPSTypeRec_StaticArray(srctype).Size);
4533 CopyArrayContents(Pointer(dest^), Src, TPSTypeRec_StaticArray(srctype).Size, TPSTypeRec_StaticArray(srctype).ArrayType);
4534 end else if (srctype.BaseType = btvariant) and VarIsArray(Variant(src^)) then
4535 Result := CreateArrayFromVariant(Self, dest, Variant(src^), desttype)
4536 else if (desttype <> srctype) and not ((desttype.BaseType = btarray) and (srctype.BaseType = btArray)
4537 and (TPSTypeRec_Array(desttype).ArrayType = TPSTypeRec_Array(srctype).ArrayType)) then
4538 Result := False
4539 else
4540 CopyArrayContents(dest, src, 1, desttype);
4541 end;
4542 btRecord:
4543 begin
4544 if desttype <> srctype then
4545 Result := False
4546 else
4547 CopyArrayContents(dest, Src, 1, desttype);
4548 end;
4549 btVariant:
4550 begin
4551 {$IFNDEF PS_NOINTERFACES}
4552 if srctype.ExportName = 'IDISPATCH' then
4553 begin
4554 {$IFDEF DELPHI3UP}
4555 Variant(Dest^) := IDispatch(Src^);
4556 {$ELSE}
4557 AssignVariantFromIDispatch(Variant(Dest^), IDispatch(Src^));
4558 {$ENDIF}
4559 end else
4560 {$ENDIF}
4561 if srctype.BaseType = btVariant then
4562 variant(Dest^) := variant(src^)
4563 else
4564 begin
4565 tt.VI.FType := FindType2(btPointer);
4566 tt.DestType := srctype;
4567 tt.DataDest := src;
4568 tt.FreeIt := False;
4569 Result := PIFVariantToVariant(@tt, variant(dest^));
4570 end;
4571 end;
4572 btClass:
4573 begin
4574 if srctype.BaseType = btClass then
4575 TObject(Dest^) := TObject(Src^)
4576 else
4577 // nx change start
4578 if (srctype.BaseType in [btS32, btU32]) then
4579 TbtU32(Dest^) := TbtU32(Src^)
4580 else
4581 // nx change end
4582 Result := False;
4583 end;
4584 {$IFNDEF PS_NOINTERFACES}
4585 btInterface:
4586 begin
4587 if Srctype.BaseType = btVariant then
4588 begin
4589 if desttype.ExportName = 'IDISPATCH' then
4590 begin
4591 {$IFDEF Delphi3UP}
4592 IDispatch(Dest^) := IDispatch(Variant(Src^));
4593 {$ELSE}
4594 AssignIDispatchFromVariant(IDispatch(Dest^), Variant(Src^));
4595 {$ENDIF}
4596 end else
4597 Result := False;
4598 {$IFDEF Delphi3UP}
4599 end else
4600 if srctype.BaseType = btClass then
4601 begin
4602 if (TObject(Src^) = nil) or not TObject(Src^).GetInterface(TPSTypeRec_Interface(desttype).Guid, IUnknown(Dest^)) then
4603 begin
4604 Result := false;
4605 Cmd_Err(erInterfaceNotSupported);
4606 exit;
4607 end;
4608 {$ENDIF}
4609 end else if srctype.BaseType = btInterface then
4610 begin
4611 {$IFNDEF Delphi3UP}
4612 if IUnknown(Dest^) <> nil then
4613 begin
4614 IUnknown(Dest^).Release;
4615 IUnknown(Dest^) := nil;
4616 end;
4617 {$ENDIF}
4618 IUnknown(Dest^) := IUnknown(Src^);
4619 {$IFNDEF Delphi3UP}
4620 if IUnknown(Dest^) <> nil then
4621 IUnknown(Dest^).AddRef;
4622 {$ENDIF}
4623 end else
4624 Result := False;
4625 end;
4626 {$ENDIF}
4627 else begin
4628 Result := False;
4629 end;
4630 end;
4631 if Result = False then
4632 CMD_Err(ErTypeMismatch);
4633 except
4634 {$IFDEF DELPHI6UP}
4635 Tmp := AcquireExceptionObject;
4636 {$ELSE}
4637 if RaiseList <> nil then
4638 begin
4639 Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
4640 PRaiseFrame(RaiseList)^.ExceptObject := nil;
4641 end else
4642 Tmp := nil;
4643 {$ENDIF}
4644 if Tmp <> nil then
4645 begin
4646 if Tmp is EPSException then
4647 begin
4648 Result := False;
4649 ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, tbtString(EPSException(tmp).Message), nil);
4650 exit;
4651 end else
4652 if Tmp is EDivByZero then
4653 begin
4654 Result := False;
4655 CMD_Err3(erDivideByZero, tbtString(Exception(Tmp).Message), Tmp);
4656 Exit;
4657 end;
4658 if Tmp is EZeroDivide then
4659 begin
4660 Result := False;
4661 CMD_Err3(erDivideByZero, tbtString(Exception(Tmp).Message), Tmp);
4662 Exit;
4663 end;
4664 if Tmp is EMathError then
4665 begin
4666 Result := False;
4667 CMD_Err3(erMathError, tbtString(Exception(Tmp).Message), Tmp);
4668 Exit;
4669 end;
4670 end;
4671 if (tmp <> nil) and (Tmp is Exception) then
4672 CMD_Err3(erException, tbtString(Exception(Tmp).Message), Tmp)
4673 else
4674 CMD_Err3(erException, '', Tmp);
4675 Result := False;
4676 end;
4677 end;
4678
4679 function SpecImport(Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean; forward;
4680
4681
Class_ISnull4682 function Class_IS(Self: TPSExec; Obj: TObject; var2type: TPSTypeRec): Boolean;
4683 var
4684 R: TPSRuntimeClassImporter;
4685 cc: TPSRuntimeClass;
4686 begin
4687 if Obj = nil then
4688 begin
4689 Result := false;
4690 exit;
4691 end;
4692 r := Self.FindSpecialProcImport(SpecImport);
4693 if R = nil then
4694 begin
4695 Result := false;
4696 exit;
4697 end;
4698 cc := r.FindClass(var2type.ExportName);
4699 if cc = nil then
4700 begin
4701 result := false;
4702 exit;
4703 end;
4704 try
4705 Result := Obj is cc.FClass;
4706 except
4707 Result := false;
4708 end;
4709 end;
4710
4711 type
4712 TVariantArray = array of Variant;
4713 PVariantArray = ^TVariantArray;
VariantInArraynull4714 function VariantInArray(var1: Pointer; var1Type: TPSTypeRec; var2: PVariantArray): Boolean;
4715 var
4716 lDest: Variant;
4717 i: Integer;
4718 begin
4719 IntPIFVariantToVariant(var1, var1Type, lDest);
4720 result := false;
4721 for i := 0 to Length(var2^) -1 do begin
4722 if var2^[i] = lDest then begin
4723 result := true;
4724 break;
4725 end;
4726 end;
4727 end;
4728
4729
DoBooleanCalcnull4730 function TPSExec.DoBooleanCalc(var1, Var2, into: Pointer; var1Type, var2type, intotype: TPSTypeRec; Cmd: Cardinal): Boolean;
4731 var
4732 b: Boolean;
4733 Tmp: TObject;
4734 tvar: Variant;
4735
4736
4737 procedure SetBoolean(b: Boolean; var Ok: Boolean);
4738 begin
4739 Ok := True;
4740 case IntoType.BaseType of
4741 btU8: tbtu8(Into^):= Cardinal(b);
4742 btS8: tbts8(Into^) := Longint(b);
4743 btU16: tbtu16(Into^) := Cardinal(b);
4744 btS16: tbts16(Into^) := Longint(b);
4745 btU32: tbtu32(Into^) := Cardinal(b);
4746 btS32: tbts32(Into^) := Longint(b);
4747 btVariant: Variant(Into^) := b;
4748 else begin
4749 CMD_Err(ErTypeMismatch);
4750 Ok := False;
4751 end;
4752 end;
4753 end;
4754 begin
4755 Result := true;
4756 try
4757 case Cmd of
4758 0: begin { >= }
4759 case var1Type.BaseType of
4760 btU8:
4761 if (var2Type.BaseType = btString) or (Var2Type.BaseType = btPChar) then
4762 b := tbtchar(tbtu8(var1^)) >= PSGetAnsiString(Var2, var2type)
4763 else
4764 b := tbtu8(var1^) >= PSGetUInt(Var2, var2type);
4765 btS8: b := tbts8(var1^) >= PSGetInt(Var2, var2type);
4766 btU16: b := tbtu16(var1^) >= PSGetUInt(Var2, var2type);
4767 btS16: b := tbts16(var1^) >= PSGetInt(Var2, var2type);
4768 btU32: b := tbtu32(var1^) >= PSGetUInt(Var2, var2type);
4769 btS32:
4770 begin
4771 if var2type.BaseType = btPointer then
4772 begin
4773 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
4774 var2 := Pointer(var2^);
4775 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
4776 end;
4777 case var2type.BaseType of
4778 btU8: b := tbts32(var1^) >= tbtu8(Var2^);
4779 btS8: b := tbts32(var1^) >= tbts8(Var2^);
4780 btU16: b := tbts32(var1^) >= tbtu16(Var2^);
4781 btS16: b := tbts32(var1^) >= tbts16(Var2^);
4782 btU32: b := tbts32(var1^) >= Longint(tbtu32(Var2^));
4783 btS32: b := tbts32(var1^) >= tbts32(Var2^);
4784 btDouble: b := PSGetReal(Var1, var1type) >= tbtdouble(var2^);
4785 btSingle: B := psGetReal(Var1, var1Type) >= tbtsingle(var2^);
4786 btExtended: B := psGetReal(Var1, var1Type) >= tbtExtended(var2^);
4787 {$IFNDEF PS_NOINT64} btS64: b := tbts32(var1^) >= tbts64(Var2^);{$ENDIF}
4788 btChar: b := tbts32(var1^) >= Ord(tbtchar(Var2^));
4789 {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbts32(var1^) >= Ord(tbtwidechar(Var2^));{$ENDIF}
4790 btVariant: b := tbts32(var1^) >= Variant(Var2^);
4791 else raise Exception.Create(RPS_TypeMismatch);
4792 end;
4793 end;
4794 btSingle: b := tbtsingle(var1^) >= PSGetReal(Var2, var2type);
4795 btDouble: b := tbtdouble(var1^) >= PSGetReal(Var2, var2type);
4796 btCurrency: b := tbtcurrency(var1^) >= PSGetCurrency(Var2, var2type);
4797 btExtended: b := tbtextended(var1^) >= PSGetReal(Var2, var2type);
4798 {$IFNDEF PS_NOINT64}
4799 btS64: b := tbts64(var1^) >= PSGetInt64(Var2, var2type);
4800 {$ENDIF}
4801 btPChar,btString: b := tbtstring(var1^) >= PSGetAnsiString(Var2, var2type);
4802 btChar: b := tbtchar(var1^) >= PSGetAnsiString(Var2, var2type);
4803 {$IFNDEF PS_NOWIDESTRING}
4804 btWideChar: b := tbtwidechar(var1^) >= PSGetWideString(Var2, var2type);
4805 btWideString: b := tbtwidestring(var1^) >= PSGetWideString(Var2, var2type);
4806 btUnicodeString: b := tbtUnicodestring(var1^) >= PSGetUnicodeString(Var2, var2type);
4807 {$ENDIF}
4808 btVariant:
4809 begin
4810 if not IntPIFVariantToVariant(var2, var2type, tvar) then
4811 begin
4812 Result := false;
4813 end else
4814 b := Variant(var1^) >= tvar;
4815 end;
4816 btSet:
4817 begin
4818 if var1Type = var2Type then
4819 begin
4820 Set_Subset(var2, var1, TPSTypeRec_Set(var1Type).aByteSize, b);
4821 end else result := False;
4822 end;
4823 else begin
4824 CMD_Err(ErTypeMismatch);
4825 exit;
4826 end;
4827 end;
4828 if not Result then begin
4829 CMD_Err(ErTypeMismatch);
4830 exit;
4831 end;
4832 SetBoolean(b, Result);
4833 end;
4834 1: begin { <= }
4835 case var1Type.BaseType of
4836 btU8:
4837 if (var2Type.BaseType = btString) or (Var2Type.BaseType = btPChar) then
4838 b := tbtchar(tbtu8(var1^)) <= PSGetAnsiString(Var2, var2type)
4839 else
4840 b := tbtu8(var1^) <= PSGetUInt(Var2, var2type);
4841 btS8: b := tbts8(var1^) <= PSGetInt(Var2, var2type);
4842 btU16: b := tbtu16(var1^) <= PSGetUInt(Var2, var2type);
4843 btS16: b := tbts16(var1^) <= PSGetInt(Var2, var2type);
4844 btU32: b := tbtu32(var1^) <= PSGetUInt(Var2, var2type);
4845 btS32:
4846 begin
4847 if var2type.BaseType = btPointer then
4848 begin
4849 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
4850 var2 := Pointer(var2^);
4851 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
4852 end;
4853 case var2type.BaseType of
4854 btU8: b := tbts32(var1^) <= tbtu8(Var2^);
4855 btS8: b := tbts32(var1^) <= tbts8(Var2^);
4856 btU16: b := tbts32(var1^) <= tbtu16(Var2^);
4857 btS16: b := tbts32(var1^) <= tbts16(Var2^);
4858 btU32: b := tbts32(var1^) <= Longint(tbtu32(Var2^));
4859 btS32: b := tbts32(var1^) <= tbts32(Var2^);
4860 btDouble: b := PSGetReal(Var1, var1type) <= tbtdouble(var2^);
4861 btSingle: B := psGetReal(Var1, var1Type) <= tbtsingle(var2^);
4862 btExtended: B := psGetReal(Var1, var1Type) <= tbtExtended(var2^);
4863 {$IFNDEF PS_NOINT64} btS64: b := tbts32(var1^) <= tbts64(Var2^);{$ENDIF}
4864 btChar: b := tbts32(var1^) <= Ord(tbtchar(Var2^));
4865 {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbts32(var1^) <= Ord(tbtwidechar(Var2^));{$ENDIF}
4866 btVariant: b := tbts32(var1^) <= Variant(Var2^);
4867 else raise Exception.Create(RPS_TypeMismatch);
4868 end;
4869 end; btSingle: b := tbtsingle(var1^) <= PSGetReal(Var2, var2type);
4870 btCurrency: b := tbtcurrency(var1^) <= PSGetCurrency(Var2, var2type);
4871 btDouble: b := tbtdouble(var1^) <= PSGetReal(Var2, var2type);
4872 btExtended: b := tbtextended(var1^) <= PSGetReal(Var2, var2type);
4873 {$IFNDEF PS_NOINT64}
4874 btS64: b := tbts64(var1^) <= PSGetInt64(Var2, var2type);
4875 {$ENDIF}
4876 btPChar,btString: b := tbtstring(var1^) <= PSGetAnsiString(Var2, var2type);
4877 btChar: b := tbtchar(var1^) <= PSGetAnsiString(Var2, var2type);
4878 {$IFNDEF PS_NOWIDESTRING}
4879 btWideChar: b := tbtwidechar(var1^) <= PSGetWideString(Var2, var2type);
4880 btWideString: b := tbtwidestring(var1^) <= PSGetWideString(Var2, var2type);
4881 btUnicodeString: b := tbtUnicodestring(var1^) <= PSGetUnicodeString(Var2, var2type);
4882 {$ENDIF}
4883 btVariant:
4884 begin
4885 if not IntPIFVariantToVariant(var2, var2type, tvar) then
4886 begin
4887 Result := false;
4888 end else
4889 b := Variant(var1^) <= tvar;
4890 end;
4891 btSet:
4892 begin
4893 if var1Type = var2Type then
4894 begin
4895 Set_Subset(var1, var2, TPSTypeRec_Set(var1Type).aByteSize, b);
4896 end else result := False;
4897 end;
4898 else begin
4899 CMD_Err(ErTypeMismatch);
4900 exit;
4901 end;
4902 end;
4903 if not Result then begin
4904 CMD_Err(erTypeMismatch);
4905 exit;
4906 end;
4907 SetBoolean(b, Result);
4908 end;
4909 2: begin { > }
4910 case var1Type.BaseType of
4911 btU8:
4912 if (var2Type.BaseType = btString) or (Var2Type.BaseType = btPChar) then
4913 b := tbtchar(tbtu8(var1^)) > PSGetAnsiString(Var2, var2type)
4914 else
4915 b := tbtu8(var1^) > PSGetUInt(Var2, var2type);
4916 btS8: b := tbts8(var1^) > PSGetInt(Var2, var2type);
4917 btU16: b := tbtu16(var1^) > PSGetUInt(Var2, var2type);
4918 btS16: b := tbts16(var1^) > PSGetInt(Var2, var2type);
4919 btU32: b := tbtu32(var1^) > PSGetUInt(Var2, var2type);
4920 btS32:
4921 begin
4922 if var2type.BaseType = btPointer then
4923 begin
4924 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
4925 var2 := Pointer(var2^);
4926 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
4927 end;
4928 case var2type.BaseType of
4929 btU8: b := tbts32(var1^) > tbtu8(Var2^);
4930 btS8: b := tbts32(var1^) > tbts8(Var2^);
4931 btU16: b := tbts32(var1^) > tbtu16(Var2^);
4932 btS16: b := tbts32(var1^) > tbts16(Var2^);
4933 btU32: b := tbts32(var1^) > Longint(tbtu32(Var2^));
4934 btS32: b := tbts32(var1^) > tbts32(Var2^);
4935 btDouble: b := PSGetReal(Var1, var1type) > tbtdouble(var2^);
4936 btSingle: B := psGetReal(Var1, var1Type) > tbtsingle(var2^);
4937 btExtended: B := psGetReal(Var1, var1Type) > tbtExtended(var2^);
4938 {$IFNDEF PS_NOINT64} btS64: b := tbts32(var1^) > tbts64(Var2^);{$ENDIF}
4939 btChar: b := tbts32(var1^) > Ord(tbtchar(Var2^));
4940 {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbts32(var1^) = Ord(tbtwidechar(Var2^));{$ENDIF}
4941 btVariant: b := tbts32(var1^) > Variant(Var2^);
4942 else raise Exception.Create(RPS_TypeMismatch);
4943 end;
4944 end; btSingle: b := tbtsingle(var1^) > PSGetReal(Var2, var2type);
4945 btDouble: b := tbtdouble(var1^) > PSGetReal(Var2, var2type);
4946 btExtended: b := tbtextended(var1^) > PSGetReal(Var2, var2type);
4947 btCurrency: b := tbtcurrency(var1^) > PSGetCurrency(Var2, var2type);
4948 {$IFNDEF PS_NOINT64}
4949 btS64: b := tbts64(var1^) > PSGetInt64(Var2, var2type);
4950 {$ENDIF}
4951 btPChar,btString: b := tbtstring(var1^) > PSGetAnsiString(Var2, var2type);
4952 btChar: b := tbtchar(var1^) > PSGetAnsiString(Var2, var2type);
4953 {$IFNDEF PS_NOWIDESTRING}
4954 btWideChar: b := tbtwidechar(var1^) > PSGetWideString(Var2, var2type);
4955 btWideString: b := tbtwidestring(var1^) > PSGetWideString(Var2, var2type);
4956 btUnicodeString: b := tbtUnicodestring(var1^) > PSGetUnicodeString(Var2, var2type);
4957 {$ENDIF}
4958 btVariant:
4959 begin
4960 if not IntPIFVariantToVariant(var2, var2type, tvar) then
4961 begin
4962 Result := false;
4963 end else
4964 b := Variant(var1^) > tvar;
4965 end;
4966 else begin
4967 CMD_Err(erTypeMismatch);
4968 exit;
4969 end;
4970 end;
4971 if not Result then begin
4972 CMD_Err(erTypeMismatch);
4973 exit;
4974 end;
4975 SetBoolean(b, Result);
4976 end;
4977 3: begin { < }
4978 case var1Type.BaseType of
4979 btU8:
4980 if (var2Type.BaseType = btString) or (Var2Type.BaseType = btPChar) then
4981 b := tbtchar(tbtu8(var1^)) < PSGetAnsiString(Var2, var2type)
4982 else
4983 b := tbtu8(var1^) < PSGetUInt(Var2, var2type);
4984 btS8: b := tbts8(var1^) < PSGetInt(Var2, var2type);
4985 btU16: b := tbtu16(var1^) < PSGetUInt(Var2, var2type);
4986 btS16: b := tbts16(var1^) < PSGetInt(Var2, var2type);
4987 btU32: b := tbtu32(var1^) < PSGetUInt(Var2, var2type);
4988 btS32:
4989 begin
4990 if var2type.BaseType = btPointer then
4991 begin
4992 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
4993 var2 := Pointer(var2^);
4994 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
4995 end;
4996 case var2type.BaseType of
4997 btU8: b := tbts32(var1^) < tbtu8(Var2^);
4998 btS8: b := tbts32(var1^) < tbts8(Var2^);
4999 btU16: b := tbts32(var1^) < tbtu16(Var2^);
5000 btS16: b := tbts32(var1^) < tbts16(Var2^);
5001 btU32: b := tbts32(var1^) < Longint(tbtu32(Var2^));
5002 btS32: b := tbts32(var1^) < tbts32(Var2^);
5003 btDouble: b := PSGetReal(Var1, var1type) < tbtdouble(var2^);
5004 btSingle: B := psGetReal(Var1, var1Type) < tbtsingle(var2^);
5005 btExtended: B := psGetReal(Var1, var1Type) < tbtExtended(var2^);
5006 {$IFNDEF PS_NOINT64} btS64: b := tbts32(var1^) < tbts64(Var2^);{$ENDIF}
5007 btChar: b := tbts32(var1^) < Ord(tbtchar(Var2^));
5008 {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbts32(var1^) < Ord(tbtwidechar(Var2^));{$ENDIF}
5009 btVariant: b := tbts32(var1^) < Variant(Var2^);
5010 else raise Exception.Create(RPS_TypeMismatch);
5011 end;
5012 end; btSingle: b := tbtsingle(var1^) < PSGetReal(Var2, var2type);
5013 btDouble: b := tbtdouble(var1^) < PSGetReal(Var2, var2type);
5014 btCurrency: b := tbtcurrency(var1^) < PSGetCurrency(Var2, var2type);
5015 btExtended: b := tbtextended(var1^) < PSGetReal(Var2, var2type);
5016 {$IFNDEF PS_NOINT64}
5017 btS64: b := tbts64(var1^) < PSGetInt64(Var2, var2type);
5018 {$ENDIF}
5019 btPChar,btString: b := tbtstring(var1^) < PSGetAnsiString(Var2, var2type);
5020 btChar: b := tbtchar(var1^) < PSGetAnsiString(Var2, var2type);
5021 {$IFNDEF PS_NOWIDESTRING}
5022 btWideChar: b := tbtwidechar(var1^) < PSGetWideString(Var2, var2type);
5023 btWideString: b := tbtwidestring(var1^) < PSGetWideString(Var2, var2type);
5024 btUnicodeString: b := tbtUnicodestring(var1^) < PSGetUnicodeString(Var2, var2type);
5025 {$ENDIF}
5026 btVariant:
5027 begin
5028 if not IntPIFVariantToVariant(var2, var2type, tvar) then
5029 begin
5030 Result := false;
5031 end else
5032 b := Variant(var1^) < tvar;
5033 end;
5034 else begin
5035 CMD_Err(erTypeMismatch);
5036 exit;
5037 end;
5038 end;
5039 if not Result then begin
5040 CMD_Err(erTypeMismatch);
5041 exit;
5042 end;
5043 SetBoolean(b, Result);
5044 end;
5045 4: begin { <> }
5046 case var1Type.BaseType of
5047 btInterface:
5048 begin
5049 if var2Type.BaseType = btInterface then
5050 b := Pointer(var1^) <> Pointer(var2^) // no need to cast it to IUnknown
5051 else
5052 Result := false;
5053 end;
5054 btClass:
5055 begin
5056 if var2Type.BaseType = btclass then
5057 b := TObject(var1^) <> TObject(var2^)
5058 else
5059 Result := false;
5060 end;
5061 btU8:
5062 if (var2Type.BaseType = btString) or (Var2Type.BaseType = btPChar) then
5063 b := tbtchar(tbtu8(var1^)) <> PSGetAnsiString(Var2, var2type)
5064 else
5065 b := tbtu8(var1^) <> PSGetUInt(Var2, var2type);
5066 btS8: b := tbts8(var1^) <> PSGetInt(Var2, var2type);
5067 btU16: b := tbtu16(var1^) <> PSGetUInt(Var2, var2type);
5068 btS16: b := tbts16(var1^) <> PSGetInt(Var2, var2type);
5069 btProcPtr:
5070 begin
5071 if Pointer(Var1^) = Pointer(Var2^) then
5072 begin
5073 if Longint(Var1^) = 0 then
5074 b := ((Pointer(Pointer(IPointer(Var1)+PointerSize2)^) <> Pointer(Pointer(IPointer(Var2)+PointerSize2)^)) or
5075 (Pointer(Pointer(IPointer(Var1)+PointerSize2)^) <> Pointer(Pointer(IPointer(Var2)+PointerSize2)^)))
5076 else
5077 b := False;
5078 end else b := True;
5079 end;
5080 btU32: b := tbtu32(var1^) <> PSGetUInt(Var2, var2type);
5081 btS32:
5082 begin
5083 if var2type.BaseType = btPointer then
5084 begin
5085 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5086 var2 := Pointer(var2^);
5087 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5088 end;
5089 case var2type.BaseType of
5090 btU8: b := tbts32(var1^) <> tbtu8(Var2^);
5091 btS8: b := tbts32(var1^) <> tbts8(Var2^);
5092 btU16: b := tbts32(var1^) <> tbtu16(Var2^);
5093 btS16: b := tbts32(var1^) <> tbts16(Var2^);
5094 btProcPtr, btU32: b := tbts32(var1^)<> Longint(tbtu32(Var2^));
5095 btS32: b := tbts32(var1^) <> tbts32(Var2^);
5096 btDouble: b := PSGetReal(Var1, var1type) <> tbtdouble(var2^);
5097 btSingle: B := psGetReal(Var1, var1Type) <> tbtsingle(var2^);
5098 btExtended: B := psGetReal(Var1, var1Type) <> tbtExtended(var2^);
5099 {$IFNDEF PS_NOINT64} btS64: b := tbts32(var1^) <> tbts64(Var2^);{$ENDIF}
5100 btChar: b := tbts32(var1^) <> Ord(tbtchar(Var2^));
5101 {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbts32(var1^) <> Ord(tbtwidechar(Var2^));{$ENDIF}
5102 btVariant: b := tbts32(var1^) <> Variant(Var2^);
5103 else raise Exception.Create(RPS_TypeMismatch);
5104 end;
5105 end; btSingle: b := tbtsingle(var1^) <> PSGetReal(Var2, var2type);
5106 btDouble: b := tbtdouble(var1^) <> PSGetReal(Var2, var2type);
5107 btExtended: b := tbtextended(var1^) <> PSGetReal(Var2, var2type);
5108 btCurrency: b := tbtcurrency(var1^) <> PSGetCurrency(Var2, var2type);
5109 btPChar,btString: b := tbtstring(var1^) <> PSGetAnsiString(Var2, var2type);
5110 {$IFNDEF PS_NOINT64}
5111 btS64: b := tbts64(var1^) <> PSGetInt64(Var2, var2type);
5112 {$ENDIF}
5113 btChar: b := tbtchar(var1^) <> PSGetAnsiString(Var2, var2type);
5114 {$IFNDEF PS_NOWIDESTRING}
5115 btWideChar: b := tbtwidechar(var1^) <> PSGetWideString(Var2, var2type);
5116 btWideString: b := tbtwidestring(var1^) <> PSGetWideString(Var2, var2type);
5117 btUnicodeString: b := tbtUnicodeString(var1^) <> PSGetUnicodeString(Var2, var2type);
5118 {$ENDIF}
5119 btVariant:
5120 begin
5121 if not IntPIFVariantToVariant(var2, var2type, tvar) then
5122 begin
5123 Result := false;
5124 end else
5125 b := Variant(var1^) <> tvar;
5126 end;
5127 btSet:
5128 begin
5129 if var1Type = var2Type then
5130 begin
5131 Set_Equal(var1, var2, TPSTypeRec_Set(var1Type).aByteSize, b);
5132 b := not b;
5133 end else result := False;
5134 end;
5135 btRecord:
5136 begin
5137 if var1Type = var2Type then
5138 begin
5139 Set_Equal(var1, var2, TPSTypeRec_Record(var1Type).RealSize, b);
5140 b := not b;
5141 end else result := False;
5142 end
5143
5144 else begin
5145 CMD_Err(erTypeMismatch);
5146 exit;
5147 end;
5148 end;
5149 if not Result then begin
5150 CMD_Err(erTypeMismatch);
5151 exit;
5152 end;
5153 SetBoolean(b, Result);
5154 end;
5155 5: begin { = }
5156 case var1Type.BaseType of
5157 btInterface:
5158 begin
5159 if var2Type.BaseType = btInterface then
5160 b := Pointer(var1^) = Pointer(var2^) // no need to cast it to IUnknown
5161 else
5162 Result := false;
5163 end;
5164 btClass:
5165 begin
5166 if var2Type.BaseType = btclass then
5167 b := TObject(var1^) = TObject(var2^)
5168 else
5169 Result := false;
5170 end;
5171 btU8:
5172 if (var2Type.BaseType = btString) or (Var2Type.BaseType = btPChar) then
5173 b := tbtchar(tbtu8(var1^)) = PSGetAnsiString(Var2, var2type)
5174 else
5175 b := tbtu8(var1^) = PSGetUInt(Var2, var2type);
5176 btS8: b := tbts8(var1^) = PSGetInt(Var2, var2type);
5177 btU16: b := tbtu16(var1^) = PSGetUInt(Var2, var2type);
5178 btS16: b := tbts16(var1^) = PSGetInt(Var2, var2type);
5179 btU32: b := tbtu32(var1^) = PSGetUInt(Var2, var2type);
5180 btProcPtr:
5181 begin
5182 if Pointer(Var1^) = Pointer(Var2^) then
5183 begin
5184 if Longint(Var1^) = 0 then
5185 b := ((Pointer(Pointer(IPointer(Var1)+PointerSize2)^) = Pointer(Pointer(IPointer(Var2)+PointerSize2)^)) and
5186 (Pointer(Pointer(IPointer(Var1)+PointerSize2)^) = Pointer(Pointer(IPointer(Var2)+PointerSize2)^)))
5187 else
5188 b := True;
5189 end else b := False;
5190 end;
5191 btS32:
5192 begin
5193 if var2type.BaseType = btPointer then
5194 begin
5195 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5196 var2 := Pointer(var2^);
5197 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5198 end;
5199 case var2type.BaseType of
5200 btU8: b := tbts32(var1^) = tbtu8(Var2^);
5201 btS8: b := tbts32(var1^) = tbts8(Var2^);
5202 btU16: b := tbts32(var1^) = tbtu16(Var2^);
5203 btS16: b := tbts32(var1^) = tbts16(Var2^);
5204 btProcPtr, btU32: b := tbts32(var1^) = Longint(tbtu32(Var2^));
5205 btS32: b := tbts32(var1^) = tbts32(Var2^);
5206 btDouble: b := PSGetReal(Var1, var1type) = tbtdouble(var2^);
5207 btSingle: B := psGetReal(Var1, var1Type) = tbtsingle(var2^);
5208 btExtended: B := psGetReal(Var1, var1Type) = tbtExtended(var2^);
5209 {$IFNDEF PS_NOINT64} btS64: b := tbts32(var1^) = tbts64(Var2^);{$ENDIF}
5210 btChar: b := tbts32(var1^) = Ord(tbtchar(Var2^));
5211 {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbts32(var1^) = Ord(tbtwidechar(Var2^));{$ENDIF}
5212 btVariant: b := tbts32(var1^) = Variant(Var2^);
5213 else raise Exception.Create(RPS_TypeMismatch);
5214 end;
5215 end; btSingle: b := tbtsingle(var1^) = PSGetReal(Var2, var2type);
5216 btDouble: b := tbtdouble(var1^) = PSGetReal(Var2, var2type);
5217 btExtended: b := tbtextended(var1^) = PSGetReal(Var2, var2type);
5218 btCurrency: b := tbtcurrency(var1^) = PSGetCurrency(Var2, var2type);
5219 btPchar, btString: b := tbtstring(var1^) = PSGetAnsiString(Var2, var2type);
5220 {$IFNDEF PS_NOINT64}
5221 btS64: b := tbts64(var1^) = PSGetInt64(Var2, var2type);
5222 {$ENDIF}
5223 btChar: b := tbtchar(var1^) = PSGetAnsiString(Var2, var2type);
5224 {$IFNDEF PS_NOWIDESTRING}
5225 btWideChar: b := tbtwidechar(var1^) = PSGetWideString(Var2, var2type);
5226 btWideString: b := tbtwidestring(var1^) = PSGetWideString(Var2, var2type);
5227 btUnicodeString: b := tbtUnicodestring(var1^) = PSGetUnicodeString(Var2, var2type);
5228 {$ENDIF}
5229 btVariant:
5230 begin
5231 if not IntPIFVariantToVariant(var2, var2type, tvar) then
5232 begin
5233 Result := false;
5234 end else
5235 b := Variant(var1^) = tvar;
5236 end;
5237 btSet:
5238 begin
5239 if var1Type = var2Type then
5240 begin
5241 Set_Equal(var1, var2, TPSTypeRec_Set(var1Type).aByteSize, b);
5242 end else result := False;
5243 end;
5244 btRecord:
5245 begin
5246 if var1Type = var2Type then
5247 begin
5248 Set_Equal(var1, var2, TPSTypeRec_Record(var1Type).RealSize, b);
5249 end else result := False;
5250 end
5251 else begin
5252 CMD_Err(erTypeMismatch);
5253 exit;
5254 end;
5255 end;
5256 if not Result then begin
5257 CMD_Err(erTypeMismatch);
5258 exit;
5259 end;
5260 SetBoolean(b, Result);
5261 end;
5262 6: begin { in }
5263 if (var2Type.BaseType = btArray) and (TPSTypeRec_Array(var2type).ArrayType.BaseType = btVariant) then
5264 begin
5265 b := VariantInArray(var1, var1Type, var2);
5266 SetBoolean(b, Result);
5267 end else
5268 if var2Type.BaseType = btSet then
5269 begin
5270 Cmd := PSGetUInt(var1, var1type);
5271 if not Result then
5272 begin
5273 CMD_Err(erTypeMismatch);
5274 exit;
5275 end;
5276 if Cmd >= Cardinal(TPSTypeRec_Set(var2Type).aBitSize) then
5277 begin
5278 cmd_Err(erOutofRecordRange);
5279 Result := False;
5280 Exit;
5281 end;
5282 Set_membership(Cmd, var2, b);
5283 SetBoolean(b, Result);
5284 end else
5285 begin
5286 CMD_Err(erTypeMismatch);
5287 exit;
5288 end;
5289 end;
5290 7:
5291 begin // is
5292 case var1Type.BaseType of
5293 btClass:
5294 begin
5295 if var2type.BaseType <> btU32 then
5296 Result := False
5297 else
5298 begin
5299 var2type := FTypes[tbtu32(var2^)];
5300 if (var2type = nil) or (var2type.BaseType <> btClass) then
5301 Result := false
5302 else
5303 begin
5304 Setboolean(Class_IS(Self, TObject(var1^), var2type), Result);
5305 end;
5306 end;
5307 end;
5308 else begin
5309 CMD_Err(erTypeMismatch);
5310 exit;
5311 end;
5312 end;
5313 if not Result then begin
5314 CMD_Err(erTypeMismatch);
5315 exit;
5316 end;
5317 end;
5318 else begin
5319 Result := False;
5320 CMD_Err(erInvalidOpcodeParameter);
5321 exit;
5322 end;
5323 end;
5324 except
5325 {$IFDEF DELPHI6UP}
5326 Tmp := AcquireExceptionObject;
5327 {$ELSE}
5328 if RaiseList <> nil then
5329 begin
5330 Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
5331 PRaiseFrame(RaiseList)^.ExceptObject := nil;
5332 end else
5333 Tmp := nil;
5334 {$ENDIF}
5335 if Tmp <> nil then
5336 begin
5337 if Tmp is EPSException then
5338 begin
5339 Result := False;
5340 ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, tbtString(EPSException(tmp).Message), nil);
5341 exit;
5342 end else
5343 if Tmp is EDivByZero then
5344 begin
5345 Result := False;
5346 CMD_Err3(erDivideByZero, tbtString(Exception(Tmp).Message), Tmp);
5347 Exit;
5348 end;
5349 if Tmp is EZeroDivide then
5350 begin
5351 Result := False;
5352 CMD_Err3(erDivideByZero, tbtString(Exception(Tmp).Message), Tmp);
5353 Exit;
5354 end;
5355 if Tmp is EMathError then
5356 begin
5357 Result := False;
5358 CMD_Err3(erMathError, tbtString(Exception(Tmp).Message), Tmp);
5359 Exit;
5360 end;
5361 end;
5362 if (tmp <> nil) and (Tmp is Exception) then
5363 CMD_Err3(erException, tbtString(Exception(Tmp).Message), Tmp)
5364 else
5365 CMD_Err3(erException, '', Tmp);
5366 Result := False;
5367 end;
5368 end;
5369
VarIsFloatnull5370 function VarIsFloat(const V: Variant): Boolean;
5371 begin
5372 Result := VarType(V) in [varSingle, varDouble, varCurrency];
5373 end;
5374
DoCalcnull5375 function TPSExec.DoCalc(var1, Var2: Pointer; var1Type, var2type: TPSTypeRec; CalcType: Cardinal): Boolean;
5376 { var1=dest, var2=src }
5377 var
5378 Tmp: TObject;
5379 tvar: Variant;
5380 begin
5381 try
5382 Result := True;
5383 case CalcType of
5384 0: begin { + }
5385 case var1Type.BaseType of
5386 btU8: tbtU8(var1^) := tbtU8(var1^) + PSGetUInt(Var2, var2type);
5387 btS8: tbts8(var1^) := tbts8(var1^) + PSGetInt(Var2, var2type);
5388 btU16: tbtU16(var1^) := tbtU16(var1^) + PSGetUInt(Var2, var2type);
5389 btS16: tbts16(var1^) := tbts16(var1^) + PSGetInt(Var2, var2type);
5390 btU32:
5391 begin
5392 if var2type.BaseType = btPointer then
5393 begin
5394 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5395 var2 := Pointer(var2^);
5396 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5397 end;
5398 case var2type.BaseType of
5399 btU8: tbtU32(var1^) := tbtU32(var1^) + tbtu8(var2^);
5400 btS8: tbtU32(var1^) := tbtU32(var1^) + cardinal(longint(tbts8(var2^)));
5401 btU16: tbtU32(var1^) := tbtU32(var1^) + tbtu16(var2^);
5402 btS16: tbtU32(var1^) := tbtU32(var1^) + cardinal(longint(tbts16(var2^)));
5403 btU32: tbtU32(var1^) := tbtU32(var1^) + tbtu32(var2^);
5404 btS32: tbtU32(var1^) := tbtU32(var1^) + cardinal(tbts32(var2^));
5405 {$IFNDEF PS_NOINT64} btS64: tbtU32(var1^) := tbtU32(var1^) + tbts64(var2^);{$ENDIF}
5406 btChar: tbtU32(var1^) := tbtU32(var1^) + Ord(tbtchar(var2^));
5407 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtU32(var1^) := tbtU32(var1^) + Ord(tbtwidechar(var2^));{$ENDIF}
5408 btVariant: tbtU32(var1^) := tbtU32(var1^) + Variant(var2^);
5409 else raise Exception.Create(RPS_TypeMismatch);
5410 end;
5411 end;
5412 btS32:
5413 begin
5414 if var2type.BaseType = btPointer then
5415 begin
5416 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5417 var2 := Pointer(var2^);
5418 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5419 end;
5420 case var2type.BaseType of
5421 btU8: tbts32(var1^) := tbts32(var1^) + tbtu8(var2^);
5422 btS8: tbts32(var1^) := tbts32(var1^) + tbts8(var2^);
5423 btU16: tbts32(var1^) := tbts32(var1^) + tbtu16(var2^);
5424 btS16: tbts32(var1^) := tbts32(var1^) + tbts16(var2^);
5425 btU32: tbts32(var1^) := tbts32(var1^) + Longint(tbtu32(var2^));
5426 btS32: tbts32(var1^) := tbts32(var1^) + tbts32(var2^);
5427 {$IFNDEF PS_NOINT64} btS64: tbts32(var1^) := tbts32(var1^) + tbts64(var2^);{$ENDIF}
5428 btChar: tbts32(var1^) := tbts32(var1^) + Ord(tbtchar(var2^));
5429 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(var1^) := tbts32(var1^) + Ord(tbtwidechar(var2^));{$ENDIF}
5430 btVariant: tbts32(var1^) := tbts32(var1^) + Variant(var2^);
5431 else raise Exception.Create(RPS_TypeMismatch);
5432 end;
5433 end;
5434 {$IFNDEF PS_NOINT64}
5435 btS64: tbts64(var1^) := tbts64(var1^) + PSGetInt64(var2, var2type);
5436 {$ENDIF}
5437 btSingle:
5438 begin
5439 if var2type.BaseType = btPointer then
5440 begin
5441 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5442 var2 := Pointer(var2^);
5443 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5444 end;
5445 case var2type.BaseType of
5446 btU8: tbtsingle(var1^) := tbtsingle(var1^) + tbtu8(var2^);
5447 btS8: tbtsingle(var1^) := tbtsingle(var1^) + tbts8(var2^);
5448 btU16: tbtsingle(var1^) := tbtsingle(var1^) + tbtu16(var2^);
5449 btS16: tbtsingle(var1^) := tbtsingle(var1^) + tbts16(var2^);
5450 btU32: tbtsingle(var1^) := tbtsingle(var1^) + tbtu32(var2^);
5451 btS32: tbtsingle(var1^) := tbtsingle(var1^) + tbts32(var2^);
5452 {$IFNDEF PS_NOINT64} btS64: tbtsingle(var1^) := tbtsingle(var1^) + tbts64(var2^);{$ENDIF}
5453 btSingle: tbtsingle(var1^) := tbtsingle(var1^) + tbtsingle(var2^);
5454 btDouble: tbtsingle(var1^) := tbtsingle(var1^) + tbtdouble(var2^);
5455 btExtended: tbtsingle(var1^) := tbtsingle(var1^) + tbtextended(var2^);
5456 btCurrency: tbtsingle(var1^) := tbtsingle(var1^) + tbtcurrency(var2^);
5457 btVariant: tbtsingle(var1^) := tbtsingle(var1^) + Variant(var2^);
5458 else raise Exception.Create(RPS_TypeMismatch);
5459 end;
5460 end;
5461 btDouble:
5462 begin
5463 if var2type.BaseType = btPointer then
5464 begin
5465 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5466 var2 := Pointer(var2^);
5467 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5468 end;
5469 case var2type.BaseType of
5470 btU8: tbtdouble(var1^) := tbtdouble(var1^) + tbtu8(var2^);
5471 btS8: tbtdouble(var1^) := tbtdouble(var1^) + tbts8(var2^);
5472 btU16: tbtdouble(var1^) := tbtdouble(var1^) + tbtu16(var2^);
5473 btS16: tbtdouble(var1^) := tbtdouble(var1^) + tbts16(var2^);
5474 btU32: tbtdouble(var1^) := tbtdouble(var1^) + tbtu32(var2^);
5475 btS32: tbtdouble(var1^) := tbtdouble(var1^) + tbts32(var2^);
5476 {$IFNDEF PS_NOINT64} btS64: tbtdouble(var1^) := tbtdouble(var1^) + tbts64(var2^);{$ENDIF}
5477 btSingle: tbtdouble(var1^) := tbtdouble(var1^) + tbtsingle(var2^);
5478 btDouble: tbtdouble(var1^) := tbtdouble(var1^) + tbtdouble(var2^);
5479 btExtended: tbtdouble(var1^) := tbtdouble(var1^) + tbtextended(var2^);
5480 btCurrency: tbtdouble(var1^) := tbtdouble(var1^) + tbtcurrency(var2^);
5481 btVariant: tbtdouble(var1^) := tbtdouble(var1^) + Variant(var2^);
5482 else raise Exception.Create(RPS_TypeMismatch);
5483 end;
5484 end;
5485 btCurrency:
5486 begin
5487 if var2type.BaseType = btPointer then
5488 begin
5489 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5490 var2 := Pointer(var2^);
5491 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5492 end;
5493 case var2type.BaseType of
5494 btU8: tbtcurrency(var1^) := tbtcurrency(var1^) + tbtu8(var2^);
5495 btS8: tbtcurrency(var1^) := tbtcurrency(var1^) + tbts8(var2^);
5496 btU16: tbtcurrency(var1^) := tbtcurrency(var1^) + tbtu16(var2^);
5497 btS16: tbtcurrency(var1^) := tbtcurrency(var1^) + tbts16(var2^);
5498 btU32: tbtcurrency(var1^) := tbtdouble(var1^) + tbtu32(var2^);
5499 btS32: tbtcurrency(var1^) := tbtcurrency(var1^) + tbts32(var2^);
5500 {$IFNDEF PS_NOINT64} btS64: tbtcurrency(var1^) := tbtdouble(var1^) + tbts64(var2^);{$ENDIF}
5501 btSingle: tbtcurrency(var1^) := tbtcurrency(var1^) + tbtsingle(var2^);
5502 btDouble: tbtcurrency(var1^) := tbtcurrency(var1^) + tbtdouble(var2^);
5503 btExtended: tbtcurrency(var1^) := tbtcurrency(var1^) + tbtextended(var2^);
5504 btCurrency: tbtcurrency(var1^) := tbtcurrency(var1^) + tbtcurrency(var2^);
5505 btVariant: tbtcurrency(var1^) := tbtcurrency(var1^) + Variant(var2^);
5506 else raise Exception.Create(RPS_TypeMismatch);
5507 end;
5508 end;
5509 btExtended:
5510 begin
5511 if var2type.BaseType = btPointer then
5512 begin
5513 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5514 var2 := Pointer(var2^);
5515 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5516 end;
5517 case var2type.BaseType of
5518 btU8: tbtextended(var1^) := tbtextended(var1^) + tbtu8(var2^);
5519 btS8: tbtextended(var1^) := tbtextended(var1^) + tbts8(var2^);
5520 btU16: tbtextended(var1^) := tbtextended(var1^) + tbtu16(var2^);
5521 btS16: tbtextended(var1^) := tbtextended(var1^) + tbts16(var2^);
5522 btU32: tbtextended(var1^) := tbtextended(var1^) + tbtu32(var2^);
5523 btS32: tbtextended(var1^) := tbtextended(var1^) + tbts32(var2^);
5524 {$IFNDEF PS_NOINT64} btS64: tbtextended(var1^) := tbtextended(var1^) + tbts64(var2^);{$ENDIF}
5525 btSingle: tbtextended(var1^) := tbtextended(var1^) + tbtsingle(var2^);
5526 btDouble: tbtextended(var1^) := tbtextended(var1^) + tbtdouble(var2^);
5527 btExtended: tbtextended(var1^) := tbtextended(var1^) + tbtextended(var2^);
5528 btCurrency: tbtextended(var1^) := tbtextended(var1^) + tbtcurrency(var2^);
5529 btVariant: tbtextended(var1^) := tbtextended(var1^) + Variant(var2^);
5530 else raise Exception.Create(RPS_TypeMismatch);
5531 end;
5532 end;
5533 btPchar, btString: tbtstring(var1^) := tbtstring(var1^) + PSGetAnsiString(Var2, var2type);
5534 btChar: tbtchar(var1^) := tbtchar(ord(tbtchar(var1^)) + PSGetUInt(Var2, var2type));
5535 {$IFNDEF PS_NOWIDESTRING}
5536 btWideChar: tbtwidechar(var1^) := widechar(ord(tbtwidechar(var1^)) + PSGetUInt(Var2, var2type));
5537 btWideString: tbtwidestring(var1^) := tbtwidestring(var1^) + PSGetWideString(Var2, var2type);
5538 btUnicodeString: tbtUnicodestring(var1^) := tbtUnicodestring(var1^) + PSGetUnicodeString(Var2, var2type);
5539 {$ENDIF}
5540 btVariant:
5541 begin
5542 tvar := null;
5543 if not IntPIFVariantToVariant(var2, var2type, tvar) then
5544 begin
5545 Result := false;
5546 end else
5547 Variant(var1^) := Variant(var1^) + tvar;
5548 end;
5549 btSet:
5550 begin
5551 if var1Type = var2Type then
5552 begin
5553 Set_Union(var1, var2, TPSTypeRec_Set(var1Type).aByteSize);
5554 end else result := False;
5555 end;
5556
5557 else begin
5558 CMD_Err(erTypeMismatch);
5559 exit;
5560 end;
5561 end;
5562 if not Result then begin
5563 CMD_Err(erTypeMismatch);
5564 exit;
5565 end;
5566 end;
5567 1: begin { - }
5568 case var1Type.BaseType of
5569 btU8: tbtU8(var1^) := tbtU8(var1^) - PSGetUInt(Var2, var2type);
5570 btS8: tbts8(var1^) := tbts8(var1^) - PSGetInt(Var2, var2type);
5571 btU16: tbtU16(var1^) := tbtU16(var1^) - PSGetUInt(Var2, var2type);
5572 btS16: tbts16(var1^) := tbts16(var1^) - PSGetInt(Var2, var2type);
5573 btU32:
5574 begin
5575 if var2type.BaseType = btPointer then
5576 begin
5577 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5578 var2 := Pointer(var2^);
5579 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5580 end;
5581 case var2type.BaseType of
5582 btU8: tbtU32(var1^) := tbtU32(var1^) - tbtu8(var2^);
5583 btS8: tbtU32(var1^) := tbtU32(var1^) - cardinal(longint(tbts8(var2^)));
5584 btU16: tbtU32(var1^) := tbtU32(var1^) - tbtu16(var2^);
5585 btS16: tbtU32(var1^) := tbtU32(var1^) - cardinal(longint(tbts16(var2^)));
5586 btU32: tbtU32(var1^) := tbtU32(var1^) - tbtu32(var2^);
5587 btS32: tbtU32(var1^) := tbtU32(var1^) - cardinal(tbts32(var2^));
5588 {$IFNDEF PS_NOINT64} btS64: tbtU32(var1^) := tbtU32(var1^) - tbts64(var2^);{$ENDIF}
5589 btChar: tbtU32(var1^) := tbtU32(var1^) - Ord(tbtchar(var2^));
5590 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtU32(var1^) := tbtU32(var1^) - Ord(tbtwidechar(var2^));{$ENDIF}
5591 btVariant: tbtU32(var1^) := tbtU32(var1^) - Variant(var2^);
5592 else raise Exception.Create(RPS_TypeMismatch);
5593 end;
5594 end;
5595 btS32:
5596 begin
5597 if var2type.BaseType = btPointer then
5598 begin
5599 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5600 var2 := Pointer(var2^);
5601 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5602 end;
5603 case var2type.BaseType of
5604 btU8: tbts32(var1^) := tbts32(var1^) - tbtu8(var2^);
5605 btS8: tbts32(var1^) := tbts32(var1^) - tbts8(var2^);
5606 btU16: tbts32(var1^) := tbts32(var1^) - tbtu16(var2^);
5607 btS16: tbts32(var1^) := tbts32(var1^) - tbts16(var2^);
5608 btU32: tbts32(var1^) := tbts32(var1^) - Longint(tbtu32(var2^));
5609 btS32: tbts32(var1^) := tbts32(var1^) - tbts32(var2^);
5610 {$IFNDEF PS_NOINT64} btS64: tbts32(var1^) := tbts32(var1^) - tbts64(var2^);{$ENDIF}
5611 btChar: tbts32(var1^) := tbts32(var1^) - Ord(tbtchar(var2^));
5612 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(var1^) := tbts32(var1^) - Ord(tbtwidechar(var2^));{$ENDIF}
5613 btVariant: tbts32(var1^) := tbts32(var1^) - Variant(var2^);
5614 else raise Exception.Create(RPS_TypeMismatch);
5615 end;
5616 end;
5617 {$IFNDEF PS_NOINT64}
5618 btS64: tbts64(var1^) := tbts64(var1^) - PSGetInt64(var2, var2type);
5619 {$ENDIF}
5620 btSingle:
5621 begin
5622 if var2type.BaseType = btPointer then
5623 begin
5624 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5625 var2 := Pointer(var2^);
5626 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5627 end;
5628 case var2type.BaseType of
5629 btU8: tbtsingle(var1^) := tbtsingle(var1^) - tbtu8(var2^);
5630 btS8: tbtsingle(var1^) := tbtsingle(var1^) - tbts8(var2^);
5631 btU16: tbtsingle(var1^) := tbtsingle(var1^) - tbtu16(var2^);
5632 btS16: tbtsingle(var1^) := tbtsingle(var1^) - tbts16(var2^);
5633 btU32: tbtsingle(var1^) := tbtsingle(var1^) - tbtu32(var2^);
5634 btS32: tbtsingle(var1^) := tbtsingle(var1^) - tbts32(var2^);
5635 {$IFNDEF PS_NOINT64} btS64: tbtsingle(var1^) := tbtsingle(var1^) - tbts64(var2^);{$ENDIF}
5636 btSingle: tbtsingle(var1^) := tbtsingle(var1^) - tbtsingle(var2^);
5637 btDouble: tbtsingle(var1^) := tbtsingle(var1^) - tbtdouble(var2^);
5638 btExtended: tbtsingle(var1^) := tbtsingle(var1^) - tbtextended(var2^);
5639 btCurrency: tbtsingle(var1^) := tbtsingle(var1^) - tbtcurrency(var2^);
5640 btVariant: tbtsingle(var1^) := tbtsingle(var1^) - Variant(var2^);
5641 else raise Exception.Create(RPS_TypeMismatch);
5642 end;
5643 end;
5644 btCurrency:
5645 begin
5646 if var2type.BaseType = btPointer then
5647 begin
5648 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5649 var2 := Pointer(var2^);
5650 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5651 end;
5652 case var2type.BaseType of
5653 btU8: tbtcurrency(var1^) := tbtcurrency(var1^) - tbtu8(var2^);
5654 btS8: tbtcurrency(var1^) := tbtcurrency(var1^) - tbts8(var2^);
5655 btU16: tbtcurrency(var1^) := tbtcurrency(var1^) - tbtu16(var2^);
5656 btS16: tbtcurrency(var1^) := tbtcurrency(var1^) - tbts16(var2^);
5657 btU32: tbtcurrency(var1^) := tbtdouble(var1^) - tbtu32(var2^);
5658 btS32: tbtcurrency(var1^) := tbtcurrency(var1^) - tbts32(var2^);
5659 {$IFNDEF PS_NOINT64} btS64: tbtcurrency(var1^) := tbtdouble(var1^) - tbts64(var2^);{$ENDIF}
5660 btSingle: tbtcurrency(var1^) := tbtcurrency(var1^) - tbtsingle(var2^);
5661 btDouble: tbtcurrency(var1^) := tbtcurrency(var1^) - tbtdouble(var2^);
5662 btExtended: tbtcurrency(var1^) := tbtcurrency(var1^) - tbtextended(var2^);
5663 btCurrency: tbtcurrency(var1^) := tbtcurrency(var1^) - tbtcurrency(var2^);
5664 btVariant: tbtcurrency(var1^) := tbtcurrency(var1^) - Variant(var2^);
5665 else raise Exception.Create(RPS_TypeMismatch);
5666 end;
5667 end;
5668 btDouble:
5669 begin
5670 if var2type.BaseType = btPointer then
5671 begin
5672 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5673 var2 := Pointer(var2^);
5674 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5675 end;
5676 case var2type.BaseType of
5677 btU8: tbtdouble(var1^) := tbtdouble(var1^) - tbtu8(var2^);
5678 btS8: tbtdouble(var1^) := tbtdouble(var1^) - tbts8(var2^);
5679 btU16: tbtdouble(var1^) := tbtdouble(var1^) - tbtu16(var2^);
5680 btS16: tbtdouble(var1^) := tbtdouble(var1^) - tbts16(var2^);
5681 btU32: tbtdouble(var1^) := tbtdouble(var1^) - tbtu32(var2^);
5682 btS32: tbtdouble(var1^) := tbtdouble(var1^) - tbts32(var2^);
5683 {$IFNDEF PS_NOINT64} btS64: tbtdouble(var1^) := tbtdouble(var1^) - tbts64(var2^);{$ENDIF}
5684 btSingle: tbtdouble(var1^) := tbtdouble(var1^) - tbtsingle(var2^);
5685 btDouble: tbtdouble(var1^) := tbtdouble(var1^) - tbtdouble(var2^);
5686 btExtended: tbtdouble(var1^) := tbtdouble(var1^) - tbtextended(var2^);
5687 btCurrency: tbtdouble(var1^) := tbtdouble(var1^) - tbtcurrency(var2^);
5688 btVariant: tbtdouble(var1^) := tbtdouble(var1^) - Variant(var2^);
5689 else raise Exception.Create(RPS_TypeMismatch);
5690 end;
5691 end;
5692 btExtended:
5693 begin
5694 if var2type.BaseType = btPointer then
5695 begin
5696 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5697 var2 := Pointer(var2^);
5698 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5699 end;
5700 case var2type.BaseType of
5701 btU8: tbtextended(var1^) := tbtextended(var1^) - tbtu8(var2^);
5702 btS8: tbtextended(var1^) := tbtextended(var1^) - tbts8(var2^);
5703 btU16: tbtextended(var1^) := tbtextended(var1^) - tbtu16(var2^);
5704 btS16: tbtextended(var1^) := tbtextended(var1^) - tbts16(var2^);
5705 btU32: tbtextended(var1^) := tbtextended(var1^) - tbtu32(var2^);
5706 btS32: tbtextended(var1^) := tbtextended(var1^) - tbts32(var2^);
5707 {$IFNDEF PS_NOINT64} btS64: tbtextended(var1^) := tbtextended(var1^) -+tbts64(var2^);{$ENDIF}
5708 btSingle: tbtextended(var1^) := tbtextended(var1^) - tbtsingle(var2^);
5709 btDouble: tbtextended(var1^) := tbtextended(var1^) - tbtdouble(var2^);
5710 btExtended: tbtextended(var1^) := tbtextended(var1^) - tbtextended(var2^);
5711 btCurrency: tbtextended(var1^) := tbtextended(var1^) - tbtcurrency(var2^);
5712 btVariant: tbtextended(var1^) := tbtextended(var1^) - Variant(var2^);
5713 else raise Exception.Create(RPS_TypeMismatch);
5714 end;
5715 end;
5716 btChar: tbtchar(var1^):= tbtchar(ord(tbtchar(var1^)) - PSGetUInt(Var2, var2type));
5717 {$IFNDEF PS_NOWIDESTRING}
5718 btWideChar: tbtwidechar(var1^) := widechar(ord(tbtwidechar(var1^)) - PSGetUInt(Var2, var2type));
5719 {$ENDIF}
5720 btVariant:
5721 begin
5722 if not IntPIFVariantToVariant(var2, var2type, tvar) then
5723 begin
5724 Result := false;
5725 end else
5726 Variant(var1^) := Variant(var1^) - tvar;
5727 end;
5728 btSet:
5729 begin
5730 if var1Type = var2Type then
5731 begin
5732 Set_Diff(var1, var2, TPSTypeRec_Set(var1Type).aByteSize);
5733 end else result := False;
5734 end;
5735 else begin
5736 CMD_Err(erTypeMismatch);
5737 exit;
5738 end;
5739 end;
5740 if not Result then begin
5741 CMD_Err(erTypeMismatch);
5742 exit;
5743 end;
5744 end;
5745 2: begin { * }
5746 case var1Type.BaseType of
5747 btU8: tbtU8(var1^) := tbtU8(var1^) * PSGetUInt(Var2, var2type);
5748 btS8: tbts8(var1^) := tbts8(var1^) * PSGetInt(Var2, var2type);
5749 btU16: tbtU16(var1^) := tbtU16(var1^) * PSGetUInt(Var2, var2type);
5750 btS16: tbts16(var1^) := tbts16(var1^) * PSGetInt(Var2, var2type);
5751 btU32:
5752 begin
5753 if var2type.BaseType = btPointer then
5754 begin
5755 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5756 var2 := Pointer(var2^);
5757 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5758 end;
5759 case var2type.BaseType of
5760 btU8: tbtU32(var1^) := tbtU32(var1^) * tbtu8(var2^);
5761 btS8: tbtU32(var1^) := tbtU32(var1^) * cardinal(longint(tbts8(var2^)));
5762 btU16: tbtU32(var1^) := tbtU32(var1^) * tbtu16(var2^);
5763 btS16: tbtU32(var1^) := tbtU32(var1^) * cardinal(longint(tbts16(var2^)));
5764 btU32: tbtU32(var1^) := tbtU32(var1^) * tbtu32(var2^);
5765 btS32: tbtU32(var1^) := tbtU32(var1^) * cardinal(tbts32(var2^));
5766 {$IFNDEF PS_NOINT64} btS64: tbtU32(var1^) := tbtU32(var1^) * tbts64(var2^);{$ENDIF}
5767 btChar: tbtU32(var1^) := tbtU32(var1^) * Ord(tbtchar(var2^));
5768 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtU32(var1^) := tbtU32(var1^) * Ord(tbtwidechar(var2^));{$ENDIF}
5769 btVariant: tbtU32(var1^) := tbtU32(var1^) * Variant(var2^);
5770 else raise Exception.Create(RPS_TypeMismatch);
5771 end;
5772 end;
5773 btS32:
5774 begin
5775 if var2type.BaseType = btPointer then
5776 begin
5777 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5778 var2 := Pointer(var2^);
5779 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5780 end;
5781 case var2type.BaseType of
5782 btU8: tbts32(var1^) := tbts32(var1^) * tbtu8(var2^);
5783 btS8: tbts32(var1^) := tbts32(var1^) * tbts8(var2^);
5784 btU16: tbts32(var1^) := tbts32(var1^) * tbtu16(var2^);
5785 btS16: tbts32(var1^) := tbts32(var1^) * tbts16(var2^);
5786 btU32: tbts32(var1^) := tbts32(var1^) * Longint(tbtu32(var2^));
5787 btS32: tbts32(var1^) := tbts32(var1^) * tbts32(var2^);
5788 {$IFNDEF PS_NOINT64} btS64: tbts32(var1^) := tbts32(var1^) * tbts64(var2^);{$ENDIF}
5789 btChar: tbts32(var1^) := tbts32(var1^) * Ord(tbtchar(var2^));
5790 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(var1^) := tbts32(var1^) * Ord(tbtwidechar(var2^));{$ENDIF}
5791 btVariant: tbts32(var1^) := tbts32(var1^) * Variant(var2^);
5792 else raise Exception.Create(RPS_TypeMismatch);
5793 end;
5794 end;
5795 {$IFNDEF PS_NOINT64}
5796 btS64: tbts64(var1^) := tbts64(var1^) * PSGetInt64(var2, var2type);
5797 {$ENDIF}
5798 btCurrency:
5799 begin
5800 if var2type.BaseType = btPointer then
5801 begin
5802 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5803 var2 := Pointer(var2^);
5804 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5805 end;
5806 case var2type.BaseType of
5807 btU8: tbtcurrency(var1^) := tbtcurrency(var1^) * tbtu8(var2^);
5808 btS8: tbtcurrency(var1^) := tbtcurrency(var1^) * tbts8(var2^);
5809 btU16: tbtcurrency(var1^) := tbtcurrency(var1^) * tbtu16(var2^);
5810 btS16: tbtcurrency(var1^) := tbtcurrency(var1^) * tbts16(var2^);
5811 btU32: tbtcurrency(var1^) := tbtdouble(var1^) * tbtu32(var2^);
5812 btS32: tbtcurrency(var1^) := tbtcurrency(var1^) * tbts32(var2^);
5813 {$IFNDEF PS_NOINT64} btS64: tbtcurrency(var1^) := tbtdouble(var1^) * tbts64(var2^);{$ENDIF}
5814 btSingle: tbtcurrency(var1^) := tbtcurrency(var1^) * tbtsingle(var2^);
5815 btDouble: tbtcurrency(var1^) := tbtcurrency(var1^) * tbtdouble(var2^);
5816 btExtended: tbtcurrency(var1^) := tbtcurrency(var1^) * tbtextended(var2^);
5817 btCurrency: tbtcurrency(var1^) := tbtcurrency(var1^) * tbtcurrency(var2^);
5818 btVariant: tbtcurrency(var1^) := tbtcurrency(var1^) * Variant(var2^);
5819 else raise Exception.Create(RPS_TypeMismatch);
5820 end;
5821 end;
5822 btSingle:
5823 begin
5824 if var2type.BaseType = btPointer then
5825 begin
5826 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5827 var2 := Pointer(var2^);
5828 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5829 end;
5830 case var2type.BaseType of
5831 btU8: tbtsingle(var1^) := tbtsingle(var1^) *tbtu8(var2^);
5832 btS8: tbtsingle(var1^) := tbtsingle(var1^) *tbts8(var2^);
5833 btU16: tbtsingle(var1^) := tbtsingle(var1^) *tbtu16(var2^);
5834 btS16: tbtsingle(var1^) := tbtsingle(var1^) *tbts16(var2^);
5835 btU32: tbtsingle(var1^) := tbtsingle(var1^) *tbtu32(var2^);
5836 btS32: tbtsingle(var1^) := tbtsingle(var1^) *tbts32(var2^);
5837 {$IFNDEF PS_NOINT64} btS64: tbtsingle(var1^) := tbtsingle(var1^) *tbts64(var2^);{$ENDIF}
5838 btSingle: tbtsingle(var1^) := tbtsingle(var1^) *tbtsingle(var2^);
5839 btDouble: tbtsingle(var1^) := tbtsingle(var1^) *tbtdouble(var2^);
5840 btExtended: tbtsingle(var1^) := tbtsingle(var1^) *tbtextended(var2^);
5841 btCurrency: tbtsingle(var1^) := tbtsingle(var1^) *tbtcurrency(var2^);
5842 btVariant: tbtsingle(var1^) := tbtsingle(var1^) * Variant(var2^);
5843 else raise Exception.Create(RPS_TypeMismatch);
5844 end;
5845 end;
5846 btDouble:
5847 begin
5848 if var2type.BaseType = btPointer then
5849 begin
5850 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5851 var2 := Pointer(var2^);
5852 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5853 end;
5854 case var2type.BaseType of
5855 btU8: tbtdouble(var1^) := tbtdouble(var1^) *tbtu8(var2^);
5856 btS8: tbtdouble(var1^) := tbtdouble(var1^) *tbts8(var2^);
5857 btU16: tbtdouble(var1^) := tbtdouble(var1^) *tbtu16(var2^);
5858 btS16: tbtdouble(var1^) := tbtdouble(var1^) *tbts16(var2^);
5859 btU32: tbtdouble(var1^) := tbtdouble(var1^) *tbtu32(var2^);
5860 btS32: tbtdouble(var1^) := tbtdouble(var1^) *tbts32(var2^);
5861 {$IFNDEF PS_NOINT64} btS64: tbtdouble(var1^) := tbtdouble(var1^) *tbts64(var2^);{$ENDIF}
5862 btSingle: tbtdouble(var1^) := tbtdouble(var1^) *tbtsingle(var2^);
5863 btDouble: tbtdouble(var1^) := tbtdouble(var1^) *tbtdouble(var2^);
5864 btExtended: tbtdouble(var1^) := tbtdouble(var1^) *tbtextended(var2^);
5865 btCurrency: tbtdouble(var1^) := tbtdouble(var1^) *tbtcurrency(var2^);
5866 btVariant: tbtdouble(var1^) := tbtdouble(var1^) * Variant(var2^);
5867 else raise Exception.Create(RPS_TypeMismatch);
5868 end;
5869 end;
5870 btExtended:
5871 begin
5872 if var2type.BaseType = btPointer then
5873 begin
5874 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5875 var2 := Pointer(var2^);
5876 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5877 end;
5878 case var2type.BaseType of
5879 btU8: tbtextended(var1^) := tbtextended(var1^) *tbtu8(var2^);
5880 btS8: tbtextended(var1^) := tbtextended(var1^) *tbts8(var2^);
5881 btU16: tbtextended(var1^) := tbtextended(var1^) *tbtu16(var2^);
5882 btS16: tbtextended(var1^) := tbtextended(var1^) *tbts16(var2^);
5883 btU32: tbtextended(var1^) := tbtextended(var1^) *tbtu32(var2^);
5884 btS32: tbtextended(var1^) := tbtextended(var1^) *tbts32(var2^);
5885 {$IFNDEF PS_NOINT64} btS64: tbtextended(var1^) := tbtextended(var1^) *tbts64(var2^);{$ENDIF}
5886 btSingle: tbtextended(var1^) := tbtextended(var1^) *tbtsingle(var2^);
5887 btDouble: tbtextended(var1^) := tbtextended(var1^) *tbtdouble(var2^);
5888 btExtended: tbtextended(var1^) := tbtextended(var1^) *tbtextended(var2^);
5889 btCurrency: tbtextended(var1^) := tbtextended(var1^) *tbtcurrency(var2^);
5890 btVariant: tbtextended(var1^) := tbtextended(var1^) * Variant(var2^);
5891 else raise Exception.Create(RPS_TypeMismatch);
5892 end;
5893 end;
5894 btVariant:
5895 begin
5896 if not IntPIFVariantToVariant(var2, var2type, tvar) then
5897 begin
5898 Result := false;
5899 end else
5900 Variant(var1^) := Variant(var1^) * tvar;
5901 end;
5902 btSet:
5903 begin
5904 if var1Type = var2Type then
5905 begin
5906 Set_Intersect(var1, var2, TPSTypeRec_Set(var1Type).aByteSize);
5907 end else result := False;
5908 end;
5909 else begin
5910 CMD_Err(erTypeMismatch);
5911 exit;
5912 end;
5913 end;
5914 if not Result then begin
5915 CMD_Err(erTypeMismatch);
5916 exit;
5917 end;
5918 end;
5919 3: begin { / }
5920 case var1Type.BaseType of
5921 btU8: tbtU8(var1^) := tbtU8(var1^) div PSGetUInt(Var2, var2type);
5922 btS8: tbts8(var1^) := tbts8(var1^) div PSGetInt(Var2, var2type);
5923 btU16: tbtU16(var1^) := tbtU16(var1^) div PSGetUInt(Var2, var2type);
5924 btS16: tbts16(var1^) := tbts16(var1^) div PSGetInt(Var2, var2type);
5925 btU32:
5926 begin
5927 if var2type.BaseType = btPointer then
5928 begin
5929 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5930 var2 := Pointer(var2^);
5931 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5932 end;
5933 case var2type.BaseType of
5934 btU8: tbtU32(var1^) := tbtU32(var1^) div tbtu8(var2^);
5935 btS8: tbtU32(var1^) := tbtU32(var1^) div cardinal(longint(tbts8(var2^)));
5936 btU16: tbtU32(var1^) := tbtU32(var1^) div tbtu16(var2^);
5937 btS16: tbtU32(var1^) := tbtU32(var1^) div cardinal(longint(tbts16(var2^)));
5938 btU32: tbtU32(var1^) := tbtU32(var1^) div tbtu32(var2^);
5939 btS32: tbtU32(var1^) := tbtU32(var1^) div cardinal(tbts32(var2^));
5940 {$IFNDEF PS_NOINT64} btS64: tbtU32(var1^) := tbtU32(var1^) div tbts64(var2^);{$ENDIF}
5941 btChar: tbtU32(var1^) := tbtU32(var1^) div Ord(tbtchar(var2^));
5942 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtU32(var1^) := tbtU32(var1^) div Ord(tbtwidechar(var2^));{$ENDIF}
5943 btVariant: tbtU32(var1^) := tbtU32(var1^) div Variant(var2^);
5944 else raise Exception.Create(RPS_TypeMismatch);
5945 end;
5946 end;
5947 btS32:
5948 begin
5949 if var2type.BaseType = btPointer then
5950 begin
5951 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5952 var2 := Pointer(var2^);
5953 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5954 end;
5955 case var2type.BaseType of
5956 btU8: tbts32(var1^) := tbts32(var1^) div tbtu8(var2^);
5957 btS8: tbts32(var1^) := tbts32(var1^) div tbts8(var2^);
5958 btU16: tbts32(var1^) := tbts32(var1^) div tbtu16(var2^);
5959 btS16: tbts32(var1^) := tbts32(var1^) div tbts16(var2^);
5960 btU32: tbts32(var1^) := tbts32(var1^) div Longint(tbtu32(var2^));
5961 btS32: tbts32(var1^) := tbts32(var1^) div tbts32(var2^);
5962 {$IFNDEF PS_NOINT64} btS64: tbts32(var1^) := tbts32(var1^) div tbts64(var2^);{$ENDIF}
5963 btChar: tbts32(var1^) := tbts32(var1^) div Ord(tbtchar(var2^));
5964 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(var1^) := tbts32(var1^) div Ord(tbtwidechar(var2^));{$ENDIF}
5965 btVariant: tbts32(var1^) := tbts32(var1^) div Variant(var2^);
5966 else raise Exception.Create(RPS_TypeMismatch);
5967 end;
5968 end;
5969 {$IFNDEF PS_NOINT64}
5970 btS64: tbts64(var1^) := tbts64(var1^) div PSGetInt64(var2, var2type);
5971 {$ENDIF}
5972 btSingle:
5973 begin
5974 if var2type.BaseType = btPointer then
5975 begin
5976 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
5977 var2 := Pointer(var2^);
5978 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
5979 end;
5980 case var2type.BaseType of
5981 btU8: tbtsingle(var1^) := tbtsingle(var1^) / tbtu8(var2^);
5982 btS8: tbtsingle(var1^) := tbtsingle(var1^) / tbts8(var2^);
5983 btU16: tbtsingle(var1^) := tbtsingle(var1^) / tbtu16(var2^);
5984 btS16: tbtsingle(var1^) := tbtsingle(var1^) / tbts16(var2^);
5985 btU32: tbtsingle(var1^) := tbtsingle(var1^) / tbtu32(var2^);
5986 btS32: tbtsingle(var1^) := tbtsingle(var1^) / tbts32(var2^);
5987 {$IFNDEF PS_NOINT64} btS64: tbtsingle(var1^) := tbtsingle(var1^) / tbts64(var2^);{$ENDIF}
5988 btSingle: tbtsingle(var1^) := tbtsingle(var1^) / tbtsingle(var2^);
5989 btDouble: tbtsingle(var1^) := tbtsingle(var1^) / tbtdouble(var2^);
5990 btExtended: tbtsingle(var1^) := tbtsingle(var1^) / tbtextended(var2^);
5991 btCurrency: tbtsingle(var1^) := tbtsingle(var1^) / tbtcurrency(var2^);
5992 btVariant: tbtsingle(var1^) := tbtsingle(var1^) / Variant(var2^);
5993 else raise Exception.Create(RPS_TypeMismatch);
5994 end;
5995 end;
5996 btCurrency:
5997 begin
5998 if var2type.BaseType = btPointer then
5999 begin
6000 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
6001 var2 := Pointer(var2^);
6002 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
6003 end;
6004 case var2type.BaseType of
6005 btU8: tbtcurrency(var1^) := tbtcurrency(var1^) / tbtu8(var2^);
6006 btS8: tbtcurrency(var1^) := tbtcurrency(var1^) / tbts8(var2^);
6007 btU16: tbtcurrency(var1^) := tbtcurrency(var1^) / tbtu16(var2^);
6008 btS16: tbtcurrency(var1^) := tbtcurrency(var1^) / tbts16(var2^);
6009 btU32: tbtcurrency(var1^) := tbtdouble(var1^) / tbtu32(var2^);
6010 btS32: tbtcurrency(var1^) := tbtcurrency(var1^) / tbts32(var2^);
6011 {$IFNDEF PS_NOINT64} btS64: tbtcurrency(var1^) := tbtdouble(var1^) / tbts64(var2^);{$ENDIF}
6012 btSingle: tbtcurrency(var1^) := tbtcurrency(var1^) / tbtsingle(var2^);
6013 btDouble: tbtcurrency(var1^) := tbtcurrency(var1^) / tbtdouble(var2^);
6014 btExtended: tbtcurrency(var1^) := tbtcurrency(var1^) / tbtextended(var2^);
6015 btCurrency: tbtcurrency(var1^) := tbtcurrency(var1^) / tbtcurrency(var2^);
6016 btVariant: tbtcurrency(var1^) := tbtcurrency(var1^) / Variant(var2^);
6017 else raise Exception.Create(RPS_TypeMismatch);
6018 end;
6019 end;
6020 btDouble:
6021 begin
6022 if var2type.BaseType = btPointer then
6023 begin
6024 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
6025 var2 := Pointer(var2^);
6026 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
6027 end;
6028 case var2type.BaseType of
6029 btU8: tbtdouble(var1^) := tbtdouble(var1^) / tbtu8(var2^);
6030 btS8: tbtdouble(var1^) := tbtdouble(var1^) / tbts8(var2^);
6031 btU16: tbtdouble(var1^) := tbtdouble(var1^) / tbtu16(var2^);
6032 btS16: tbtdouble(var1^) := tbtdouble(var1^) / tbts16(var2^);
6033 btU32: tbtdouble(var1^) := tbtdouble(var1^) / tbtu32(var2^);
6034 btS32: tbtdouble(var1^) := tbtdouble(var1^) / tbts32(var2^);
6035 {$IFNDEF PS_NOINT64} btS64: tbtdouble(var1^) := tbtdouble(var1^) / tbts64(var2^);{$ENDIF}
6036 btSingle: tbtdouble(var1^) := tbtdouble(var1^) / tbtsingle(var2^);
6037 btDouble: tbtdouble(var1^) := tbtdouble(var1^) / tbtdouble(var2^);
6038 btExtended: tbtdouble(var1^) := tbtdouble(var1^) / tbtextended(var2^);
6039 btCurrency: tbtdouble(var1^) := tbtdouble(var1^) / tbtcurrency(var2^);
6040 btVariant: tbtdouble(var1^) := tbtdouble(var1^) / Variant(var2^);
6041 else raise Exception.Create(RPS_TypeMismatch);
6042 end;
6043 end;
6044 btExtended:
6045 begin
6046 if var2type.BaseType = btPointer then
6047 begin
6048 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
6049 var2 := Pointer(var2^);
6050 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
6051 end;
6052 case var2type.BaseType of
6053 btU8: tbtextended(var1^) := tbtextended(var1^) / tbtu8(var2^);
6054 btS8: tbtextended(var1^) := tbtextended(var1^) / tbts8(var2^);
6055 btU16: tbtextended(var1^) := tbtextended(var1^) / tbtu16(var2^);
6056 btS16: tbtextended(var1^) := tbtextended(var1^) / tbts16(var2^);
6057 btU32: tbtextended(var1^) := tbtextended(var1^) / tbtu32(var2^);
6058 btS32: tbtextended(var1^) := tbtextended(var1^) / tbts32(var2^);
6059 {$IFNDEF PS_NOINT64} btS64: tbtextended(var1^) := tbtextended(var1^) / tbts64(var2^);{$ENDIF}
6060 btSingle: tbtextended(var1^) := tbtextended(var1^) / tbtsingle(var2^);
6061 btDouble: tbtextended(var1^) := tbtextended(var1^) / tbtdouble(var2^);
6062 btExtended: tbtextended(var1^) := tbtextended(var1^) / tbtextended(var2^);
6063 btCurrency: tbtextended(var1^) := tbtextended(var1^) / tbtcurrency(var2^);
6064 btVariant: tbtextended(var1^) := tbtextended(var1^) / Variant(var2^);
6065 else raise Exception.Create(RPS_TypeMismatch);
6066 end;
6067 end;
6068 btVariant:
6069 begin
6070 if not IntPIFVariantToVariant(var2, var2type, tvar) then
6071 begin
6072 Result := false;
6073 end else
6074 begin
6075 if VarIsFloat(variant(var1^)) then
6076 Variant(var1^) := Variant(var1^) / tvar
6077 else
6078 Variant(var1^) := Variant(var1^) div tvar;
6079 end;
6080 end;
6081 else begin
6082 CMD_Err(erTypeMismatch);
6083 exit;
6084 end;
6085 end;
6086 if not Result then begin
6087 CMD_Err(erTypeMismatch);
6088 exit;
6089 end;
6090 end;
6091 4: begin { MOD }
6092 case var1Type.BaseType of
6093 btU8: tbtU8(var1^) := tbtU8(var1^) mod PSGetUInt(Var2, var2type);
6094 btS8: tbts8(var1^) := tbts8(var1^) mod PSGetInt(Var2, var2type);
6095 btU16: tbtU16(var1^) := tbtU16(var1^) mod PSGetUInt(Var2, var2type);
6096 btS16: tbts16(var1^) := tbts16(var1^) mod PSGetInt(Var2, var2type);
6097 btU32:
6098 begin
6099 if var2type.BaseType = btPointer then
6100 begin
6101 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
6102 var2 := Pointer(var2^);
6103 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
6104 end;
6105 case var2type.BaseType of
6106 btU8: tbtU32(var1^) := tbtU32(var1^) mod tbtu8(var2^);
6107 btS8: tbtU32(var1^) := tbtU32(var1^) mod cardinal(longint(tbts8(var2^)));
6108 btU16: tbtU32(var1^) := tbtU32(var1^) mod tbtu16(var2^);
6109 btS16: tbtU32(var1^) := tbtU32(var1^) mod cardinal(longint(tbts16(var2^)));
6110 btU32: tbtU32(var1^) := tbtU32(var1^) mod tbtu32(var2^);
6111 btS32: tbtU32(var1^) := tbtU32(var1^) mod cardinal(tbts32(var2^));
6112 {$IFNDEF PS_NOINT64} btS64: tbtU32(var1^) := tbtU32(var1^) mod tbts64(var2^);{$ENDIF}
6113 btChar: tbtU32(var1^) := tbtU32(var1^) mod Ord(tbtchar(var2^));
6114 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtU32(var1^) := tbtU32(var1^) mod Ord(tbtwidechar(var2^));{$ENDIF}
6115 btVariant: tbtU32(var1^) := tbtU32(var1^) mod Variant(var2^);
6116 else raise Exception.Create(RPS_TypeMismatch);
6117 end;
6118 end;
6119 btS32:
6120 begin
6121 if var2type.BaseType = btPointer then
6122 begin
6123 var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
6124 var2 := Pointer(var2^);
6125 if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
6126 end;
6127 case var2type.BaseType of
6128 btU8: tbts32(var1^) := tbts32(var1^) mod tbtu8(var2^);
6129 btS8: tbts32(var1^) := tbts32(var1^) mod tbts8(var2^);
6130 btU16: tbts32(var1^) := tbts32(var1^) mod tbtu16(var2^);
6131 btS16: tbts32(var1^) := tbts32(var1^) mod tbts16(var2^);
6132 btU32: tbts32(var1^) := tbts32(var1^) mod Longint(tbtu32(var2^));
6133 btS32: tbts32(var1^) := tbts32(var1^) mod tbts32(var2^);
6134 {$IFNDEF PS_NOINT64} btS64: tbts32(var1^) := tbts32(var1^) mod tbts64(var2^);{$ENDIF}
6135 btChar: tbts32(var1^) := tbts32(var1^) mod Ord(tbtchar(var2^));
6136 {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(var1^) := tbts32(var1^) mod Ord(tbtwidechar(var2^));{$ENDIF}
6137 btVariant: tbts32(var1^) := tbts32(var1^) mod Variant(var2^);
6138 else raise Exception.Create(RPS_TypeMismatch);
6139 end;
6140 end;
6141 {$IFNDEF PS_NOINT64}
6142 btS64: tbts64(var1^) := tbts64(var1^) mod PSGetInt64(var2, var2type);
6143 {$ENDIF}
6144 btVariant:
6145 begin
6146 if not IntPIFVariantToVariant(var2, var2type, tvar) then
6147 begin
6148 Result := false;
6149 end else
6150 Variant(var1^) := Variant(var1^) mod tvar;
6151 end;
6152 else begin
6153 CMD_Err(erTypeMismatch);
6154 exit;
6155 end;
6156 end;
6157 if not Result then begin
6158 CMD_Err(erTypeMismatch);
6159 exit;
6160 end;
6161 end;
6162 5: begin { SHL }
6163 case var1Type.BaseType of
6164 btU8: tbtU8(var1^) := tbtU8(var1^) shl PSGetUInt(Var2, var2type);
6165 btS8: tbts8(var1^) := tbts8(var1^) shl PSGetInt(Var2, var2type);
6166 btU16: tbtU16(var1^) := tbtU16(var1^) shl PSGetUInt(Var2, var2type);
6167 btS16: tbts16(var1^) := tbts16(var1^) shl PSGetInt(Var2, var2type);
6168 btU32: tbtU32(var1^) := tbtU32(var1^) shl PSGetUInt(Var2, var2type);
6169 btS32: tbts32(var1^) := tbts32(var1^) shl PSGetInt(Var2, var2type);
6170 {$IFNDEF PS_NOINT64}
6171 btS64: tbts64(var1^) := tbts64(var1^) shl PSGetInt64(var2, var2type);
6172 {$ENDIF}
6173 btVariant:
6174 begin
6175 if not IntPIFVariantToVariant(var2, var2type, tvar) then
6176 begin
6177 Result := false;
6178 end else
6179 Variant(var1^) := Variant(var1^) shl tvar;
6180 end;
6181 else begin
6182 CMD_Err(erTypeMismatch);
6183 exit;
6184 end;
6185 end;
6186 if not Result then begin
6187 CMD_Err(erTypeMismatch);
6188 exit;
6189 end;
6190 end;
6191 6: begin { SHR }
6192 case var1Type.BaseType of
6193 btU8: tbtU8(var1^) := tbtU8(var1^) shr PSGetUInt(Var2, var2type);
6194 btS8: tbts8(var1^) := tbts8(var1^) shr PSGetInt(Var2, var2type);
6195 btU16: tbtU16(var1^) := tbtU16(var1^) shr PSGetUInt(Var2, var2type);
6196 btS16: tbts16(var1^) := tbts16(var1^) shr PSGetInt(Var2, var2type);
6197 btU32: tbtU32(var1^) := tbtU32(var1^) shr PSGetUInt(Var2, var2type);
6198 btS32: tbts32(var1^) := tbts32(var1^) shr PSGetInt(Var2, var2type);
6199 {$IFNDEF PS_NOINT64}
6200 btS64: tbts64(var1^) := tbts64(var1^) shr PSGetInt64(var2, var2type);
6201 {$ENDIF}
6202 btVariant:
6203 begin
6204 if not IntPIFVariantToVariant(var2, var2type, tvar) then
6205 begin
6206 Result := false;
6207 end else
6208 Variant(var1^) := Variant(var1^) shr tvar;
6209 end;
6210 else begin
6211 CMD_Err(erTypeMismatch);
6212 exit;
6213 end;
6214 end;
6215 if not Result then begin
6216 CMD_Err(erTypeMismatch);
6217 exit;
6218 end;
6219 end;
6220 7: begin { AND }
6221 case var1Type.BaseType of
6222 btU8: tbtU8(var1^) := tbtU8(var1^) and PSGetUInt(Var2, var2type);
6223 btS8: tbts8(var1^) := tbts8(var1^) and PSGetInt(Var2, var2type);
6224 btU16: tbtU16(var1^) := tbtU16(var1^) and PSGetUInt(Var2, var2type);
6225 btS16: tbts16(var1^) := tbts16(var1^) and PSGetInt(Var2, var2type);
6226 btU32: tbtU32(var1^) := tbtU32(var1^) and PSGetUInt(Var2, var2type);
6227 btS32: tbts32(var1^) := tbts32(var1^) and PSGetInt(Var2, var2type);
6228 {$IFNDEF PS_NOINT64}
6229 btS64: tbts64(var1^) := tbts64(var1^) and PSGetInt64(var2, var2type);
6230 {$ENDIF}
6231 btVariant:
6232 begin
6233 if not IntPIFVariantToVariant(var2, var2type, tvar) then
6234 begin
6235 Result := false;
6236 end else
6237 Variant(var1^) := Variant(var1^) and tvar;
6238 end;
6239 else begin
6240 CMD_Err(erTypeMismatch);
6241 exit;
6242 end;
6243 end;
6244 if not Result then begin
6245 CMD_Err(erTypeMismatch);
6246 exit;
6247 end;
6248 end;
6249 8: begin { OR }
6250 case var1Type.BaseType of
6251 btU8: tbtU8(var1^) := tbtU8(var1^) or PSGetUInt(Var2, var2type);
6252 btS8: tbts8(var1^) := tbts8(var1^) or PSGetInt(Var2, var2type);
6253 btU16: tbtU16(var1^) := tbtU16(var1^) or PSGetUInt(Var2, var2type);
6254 btS16: tbts16(var1^) := tbts16(var1^) or PSGetInt(Var2, var2type);
6255 btU32: tbtU32(var1^) := tbtU32(var1^) or PSGetUInt(Var2, var2type);
6256 btS32: tbts32(var1^) := tbts32(var1^) or PSGetInt(Var2, var2type);
6257 {$IFNDEF PS_NOINT64}
6258 btS64: tbts64(var1^) := tbts64(var1^) or PSGetInt64(var2, var2type);
6259 {$ENDIF}
6260 btVariant:
6261 begin
6262 if not IntPIFVariantToVariant(var2, var2type, tvar) then
6263 begin
6264 Result := false;
6265 end else
6266 Variant(var1^) := Variant(var1^) or tvar;
6267 end;
6268 else begin
6269 CMD_Err(erTypeMismatch);
6270 exit;
6271 end;
6272 end;
6273 if not Result then begin
6274 CMD_Err(erTypeMismatch);
6275 exit;
6276 end;
6277 end;
6278 9: begin { XOR }
6279 case var1Type.BaseType of
6280 btU8: tbtU8(var1^) := tbtU8(var1^) xor PSGetUInt(Var2, var2type);
6281 btS8: tbts8(var1^) := tbts8(var1^) xor PSGetInt(Var2, var2type);
6282 btU16: tbtU16(var1^) := tbtU16(var1^) xor PSGetUInt(Var2, var2type);
6283 btS16: tbts16(var1^) := tbts16(var1^) xor PSGetInt(Var2, var2type);
6284 btU32: tbtU32(var1^) := tbtU32(var1^) xor PSGetUInt(Var2, var2type);
6285 btS32: tbts32(var1^) := tbts32(var1^) xor PSGetInt(Var2, var2type);
6286 {$IFNDEF PS_NOINT64}
6287 btS64: tbts64(var1^) := tbts64(var1^) xor PSGetInt64(var2, var2type);
6288 {$ENDIF}
6289 btVariant:
6290 begin
6291 if not IntPIFVariantToVariant(var2, var2type, tvar) then
6292 begin
6293 Result := false;
6294 end else
6295 Variant(var1^) := Variant(var1^) xor tvar;
6296 end;
6297 else begin
6298 CMD_Err(erTypeMismatch);
6299 exit;
6300 end;
6301 end;
6302 if not Result then begin
6303 CMD_Err(erTypeMismatch);
6304 exit;
6305 end;
6306 end;
6307 10:
6308 begin // as
6309 case var1Type.BaseType of
6310 btClass:
6311 begin
6312 if var2type.BaseType <> btU32 then
6313 Result := False
6314 else
6315 begin
6316 var2type := FTypes[tbtu32(var2^)];
6317 if (var2type = nil) or (var2type.BaseType <> btClass) then
6318 Result := false
6319 else
6320 begin
6321 if not Class_IS(Self, TObject(var1^), var2type) then
6322 Result := false
6323 end;
6324 end;
6325 end;
6326 else begin
6327 CMD_Err(erTypeMismatch);
6328 exit;
6329 end;
6330 end;
6331 if not Result then begin
6332 CMD_Err(erTypeMismatch);
6333 exit;
6334 end;
6335 end;
6336 else begin
6337 Result := False;
6338 CMD_Err(erInvalidOpcodeParameter);
6339 exit;
6340 end;
6341 end;
6342 except
6343 {$IFDEF DELPHI6UP}
6344 Tmp := AcquireExceptionObject;
6345 {$ELSE}
6346 if RaiseList <> nil then
6347 begin
6348 Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
6349 PRaiseFrame(RaiseList)^.ExceptObject := nil;
6350 end else
6351 Tmp := nil;
6352 {$ENDIF}
6353 if Tmp <> nil then
6354 begin
6355 if Tmp is EPSException then
6356 begin
6357 Result := False;
6358 ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, tbtString(EPSException(tmp).Message), nil);
6359 exit;
6360 end else
6361 if Tmp is EDivByZero then
6362 begin
6363 Result := False;
6364 CMD_Err3(erDivideByZero, tbtString(Exception(Tmp).Message), Tmp);
6365 Exit;
6366 end;
6367 if Tmp is EZeroDivide then
6368 begin
6369 Result := False;
6370 CMD_Err3(erDivideByZero, tbtString(Exception(Tmp).Message), Tmp);
6371 Exit;
6372 end;
6373 if Tmp is EMathError then
6374 begin
6375 Result := False;
6376 CMD_Err3(erMathError,tbtString(Exception(Tmp).Message), Tmp);
6377 Exit;
6378 end;
6379 end;
6380 if (tmp <> nil) and (Tmp is Exception) then
6381 CMD_Err3(erException, tbtString(Exception(Tmp).Message), Tmp)
6382 else
6383 CMD_Err3(erException, '', Tmp);
6384 Result := False;
6385 end;
6386 end;
6387
TPSExec.ReadVariablenull6388 function TPSExec.ReadVariable(var Dest: TPSResultData; UsePointer: Boolean): Boolean;
6389 var
6390 VarType: Cardinal;
6391 Param: Cardinal;
6392 Tmp: PIfVariant;
6393 at: TPSTypeRec;
6394
6395 begin
6396 if FCurrentPosition + 4 >= FDataLength then
6397 begin
6398 CMD_Err(erOutOfRange); // Error
6399 Result := False;
6400 exit;
6401 end;
6402 VarType := FData^[FCurrentPosition];
6403 Inc(FCurrentPosition);
6404 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6405 Param := unaligned(Cardinal((@FData^[FCurrentPosition])^));
6406 {$else}
6407 Param := Cardinal((@FData^[FCurrentPosition])^);
6408 {$endif}
6409 Inc(FCurrentPosition, 4);
6410 case VarType of
6411 0:
6412 begin
6413 Dest.FreeType := vtNone;
6414 if Param < PSAddrNegativeStackStart then
6415 begin
6416 if Param >= Cardinal(FGlobalVars.Count) then
6417 begin
6418 CMD_Err(erOutOfGlobalVarsRange);
6419 Result := False;
6420 exit;
6421 end;
6422 Tmp := FGlobalVars.Data[param];
6423 end else
6424 begin
6425 Param := Cardinal(Longint(-PSAddrStackStart) +
6426 Longint(FCurrStackBase) + Longint(Param));
6427 if Param >= Cardinal(FStack.Count) then
6428 begin
6429 CMD_Err(erOutOfStackRange);
6430 Result := False;
6431 exit;
6432 end;
6433 Tmp := FStack.Data[param];
6434 end;
6435 if (UsePointer) and (Tmp.FType.BaseType = btPointer) then
6436 begin
6437 Dest.aType := PPSVariantPointer(Tmp).DestType;
6438 Dest.P := PPSVariantPointer(Tmp).DataDest;
6439 if Dest.P = nil then
6440 begin
6441 Cmd_Err(erNullPointerException);
6442 Result := False;
6443 exit;
6444 end;
6445 end else
6446 begin
6447 Dest.aType := PPSVariantData(Tmp).vi.FType;
6448 Dest.P := @PPSVariantData(Tmp).Data;
6449 end;
6450 end;
6451 1: begin
6452 if Param >= FTypes.Count then
6453 begin
6454 CMD_Err(erInvalidType);
6455 Result := False;
6456 exit;
6457 end;
6458 at := FTypes.Data^[Param];
6459 Param := FTempVars.FLength;
6460 FTempVars.FLength := Cardinal(Longint(Param) + Longint(at.RealSize) + Longint(RTTISize + 3)) and not 3;
6461 if FTempVars.FLength > FTempVars.FCapacity then FtempVars.AdjustLength;
6462 Tmp := Pointer(IPointer(FtempVars.FDataPtr) + IPointer(Param));
6463
6464 if Cardinal(FTempVars.FCount) >= Cardinal(FTempVars.FCapacity) then
6465 begin
6466 Inc(FTempVars.FCapacity, FCapacityInc);// := FCount + 1;
6467 ReAllocMem(FTempVars.FData, FTempVars.FCapacity shl 2);
6468 end;
6469 FTempVars.FData[FTempVars.FCount] := Tmp; // Instead of SetItem
6470 Inc(FTempVars.FCount);
6471 {$IFNDEF PS_NOSMARTLIST}
6472 Inc(FTempVars.FCheckCount);
6473 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
6474 {$ENDIF}
6475
6476
6477 Tmp.FType := at;
6478 Dest.P := @PPSVariantData(Tmp).Data;
6479 Dest.aType := tmp.FType;
6480 dest.FreeType := vtTempVar;
6481 case Dest.aType.BaseType of
6482 btSet:
6483 begin
6484 if not ReadData(Dest.P^, TPSTypeRec_Set(Dest.aType).aByteSize) then
6485 begin
6486 CMD_Err(erOutOfRange);
6487 FTempVars.Pop;
6488 Result := False;
6489 exit;
6490 end;
6491 end;
6492 bts8, btchar, btU8:
6493 begin
6494 if FCurrentPosition >= FDataLength then
6495 begin
6496 CMD_Err(erOutOfRange);
6497 FTempVars.Pop;
6498 Result := False;
6499 exit;
6500 end;
6501 tbtu8(dest.p^) := FData^[FCurrentPosition];
6502 Inc(FCurrentPosition);
6503 end;
6504 bts16, {$IFNDEF PS_NOWIDESTRING}btwidechar,{$ENDIF} btU16:
6505 begin
6506 if FCurrentPosition + 1>= FDataLength then
6507 begin
6508 CMD_Err(erOutOfRange);
6509 FTempVars.Pop;
6510 Result := False;
6511 exit;
6512 end;
6513 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6514 tbtu16(dest.p^) := unaligned(tbtu16((@FData^[FCurrentPosition])^));
6515 {$else}
6516 tbtu16(dest.p^) := tbtu16((@FData^[FCurrentPosition])^);
6517 {$endif}
6518 Inc(FCurrentPosition, 2);
6519 end;
6520 bts32, btU32:
6521 begin
6522 if FCurrentPosition + 3>= FDataLength then
6523 begin
6524 CMD_Err(erOutOfRange);
6525 FTempVars.Pop;
6526 Result := False;
6527 exit;
6528 end;
6529 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6530 tbtu32(dest.p^) := unaligned(tbtu32((@FData^[FCurrentPosition])^));
6531 {$else}
6532 tbtu32(dest.p^) := tbtu32((@FData^[FCurrentPosition])^);
6533 {$endif}
6534 Inc(FCurrentPosition, 4);
6535 end;
6536 btProcPtr:
6537 begin
6538 if FCurrentPosition + 3>= FDataLength then
6539 begin
6540 CMD_Err(erOutOfRange);
6541 FTempVars.Pop;
6542 Result := False;
6543 exit;
6544 end;
6545 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6546 tbtu32(dest.p^) := unaligned(tbtu32((@FData^[FCurrentPosition])^));
6547 {$else}
6548 tbtu32(dest.p^) := tbtu32((@FData^[FCurrentPosition])^);
6549 {$endif}
6550 tbtu32(Pointer(IPointer(dest.p)+PointerSize)^) := 0;
6551 tbtu32(Pointer(IPointer(dest.p)+PointerSize)^) := 0;
6552 Inc(FCurrentPosition, 4);
6553 end;
6554 {$IFNDEF PS_NOINT64}
6555 bts64:
6556 begin
6557 if FCurrentPosition + 7>= FDataLength then
6558 begin
6559 CMD_Err(erOutOfRange);
6560 FTempVars.Pop;
6561 Result := False;
6562 exit;
6563 end;
6564 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6565 tbts64(dest.p^) := unaligned(tbts64((@FData^[FCurrentPosition])^));
6566 {$else}
6567 tbts64(dest.p^) := tbts64((@FData^[FCurrentPosition])^);
6568 {$endif}
6569 Inc(FCurrentPosition, 8);
6570 end;
6571 {$ENDIF}
6572 btSingle:
6573 begin
6574 if FCurrentPosition + (Sizeof(Single)-1)>= FDataLength then
6575 begin
6576 CMD_Err(erOutOfRange);
6577 FTempVars.Pop;
6578 Result := False;
6579 exit;
6580 end;
6581 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6582 tbtsingle(dest.p^) := unaligned(tbtsingle((@FData^[FCurrentPosition])^));
6583 {$else}
6584 tbtsingle(dest.p^) := tbtsingle((@FData^[FCurrentPosition])^);
6585 {$endif}
6586 Inc(FCurrentPosition, Sizeof(Single));
6587 end;
6588 btDouble:
6589 begin
6590 if FCurrentPosition + (Sizeof(Double)-1)>= FDataLength then
6591 begin
6592 CMD_Err(erOutOfRange);
6593 FTempVars.Pop;
6594 Result := False;
6595 exit;
6596 end;
6597 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6598 tbtdouble(dest.p^) := unaligned(tbtdouble((@FData^[FCurrentPosition])^));
6599 {$else}
6600 tbtdouble(dest.p^) := tbtdouble((@FData^[FCurrentPosition])^);
6601 {$endif}
6602 Inc(FCurrentPosition, Sizeof(double));
6603 end;
6604
6605 btExtended:
6606 begin
6607 if FCurrentPosition + (sizeof(Extended)-1)>= FDataLength then
6608 begin
6609 CMD_Err(erOutOfRange);
6610 FTempVars.Pop;
6611 Result := False;
6612 exit;
6613 end;
6614 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6615 tbtextended(dest.p^) := unaligned(tbtextended((@FData^[FCurrentPosition])^));
6616 {$else}
6617 tbtextended(dest.p^) := tbtextended((@FData^[FCurrentPosition])^);
6618 {$endif}
6619 Inc(FCurrentPosition, sizeof(Extended));
6620 end;
6621 btPchar, btString:
6622 begin
6623 if FCurrentPosition + 3 >= FDataLength then
6624 begin
6625 Cmd_Err(erOutOfRange);
6626 FTempVars.Pop;
6627 Result := False;
6628 exit;
6629 end;
6630 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6631 Param := unaligned(Cardinal((@FData^[FCurrentPosition])^));
6632 {$else}
6633 Param := Cardinal((@FData^[FCurrentPosition])^);
6634 {$endif}
6635 Inc(FCurrentPosition, 4);
6636 Pointer(Dest.P^) := nil;
6637 SetLength(tbtstring(Dest.P^), Param);
6638 if Param <> 0 then begin
6639 if not ReadData(tbtstring(Dest.P^)[1], Param) then
6640 begin
6641 CMD_Err(erOutOfRange);
6642 FTempVars.Pop;
6643 Result := False;
6644 exit;
6645 end;
6646 pansichar(dest.p^)[Param] := #0;
6647 end;
6648 end;
6649 {$IFNDEF PS_NOWIDESTRING}
6650 btWidestring:
6651 begin
6652 if FCurrentPosition + 3 >= FDataLength then
6653 begin
6654 Cmd_Err(erOutOfRange);
6655 FTempVars.Pop;
6656 Result := False;
6657 exit;
6658 end;
6659 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6660 Param := unaligned(Cardinal((@FData^[FCurrentPosition])^));
6661 {$else}
6662 Param := Cardinal((@FData^[FCurrentPosition])^);
6663 {$endif}
6664 Inc(FCurrentPosition, 4);
6665 Pointer(Dest.P^) := nil;
6666 SetLength(tbtwidestring(Dest.P^), Param);
6667 if not ReadData(tbtwidestring(Dest.P^)[1], Param*2) then
6668 begin
6669 CMD_Err(erOutOfRange);
6670 FTempVars.Pop;
6671 Result := False;
6672 exit;
6673 end;
6674 end;
6675 btUnicodeString:
6676 begin
6677 if FCurrentPosition + 3 >= FDataLength then
6678 begin
6679 Cmd_Err(erOutOfRange);
6680 FTempVars.Pop;
6681 Result := False;
6682 exit;
6683 end;
6684 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6685 Param := unaligned(Cardinal((@FData^[FCurrentPosition])^));
6686 {$else}
6687 Param := Cardinal((@FData^[FCurrentPosition])^);
6688 {$endif}
6689 Inc(FCurrentPosition, 4);
6690 Pointer(Dest.P^) := nil;
6691 SetLength(tbtUnicodestring(Dest.P^), Param);
6692 if not ReadData(tbtUnicodestring(Dest.P^)[1], Param*2) then
6693 begin
6694 CMD_Err(erOutOfRange);
6695 FTempVars.Pop;
6696 Result := False;
6697 exit;
6698 end;
6699 end;
6700 {$ENDIF}
6701 else begin
6702 CMD_Err(erInvalidType);
6703 FTempVars.Pop;
6704 Result := False;
6705 exit;
6706 end;
6707 end;
6708 end;
6709 2:
6710 begin
6711 Dest.FreeType := vtNone;
6712 if Param < PSAddrNegativeStackStart then begin
6713 if Param >= Cardinal(FGlobalVars.Count) then
6714 begin
6715 CMD_Err(erOutOfGlobalVarsRange);
6716 Result := False;
6717 exit;
6718 end;
6719 Tmp := FGlobalVars.Data[param];
6720 end
6721 else begin
6722 Param := Cardinal(Longint(-PSAddrStackStart) + Longint(FCurrStackBase) + Longint(Param));
6723 if Param >= Cardinal(FStack.Count) then
6724 begin
6725 CMD_Err(erOutOfStackRange);
6726 Result := False;
6727 exit;
6728 end;
6729 Tmp := FStack.Data[param];
6730 end;
6731 if Tmp.FType.BaseType = btPointer then
6732 begin
6733 Dest.aType := PPSVariantPointer(Tmp).DestType;
6734 Dest.P := PPSVariantPointer(Tmp).DataDest;
6735 if Dest.P = nil then
6736 begin
6737 Cmd_Err(erNullPointerException);
6738 Result := False;
6739 exit;
6740 end;
6741 end else
6742 begin
6743 Dest.aType := PPSVariantData(Tmp).vi.FType;
6744 Dest.P := @PPSVariantData(Tmp).Data;
6745 end;
6746 if FCurrentPosition + 3 >= FDataLength then
6747 begin
6748 CMD_Err(erOutOfRange);
6749 Result := False;
6750 exit;
6751 end;
6752 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6753 Param := unaligned(Cardinal((@FData^[FCurrentPosition])^));
6754 {$else}
6755 Param := Cardinal((@FData^[FCurrentPosition])^);
6756 {$endif}
6757 Inc(FCurrentPosition, 4);
6758 case Dest.aType.BaseType of
6759 btRecord:
6760 begin
6761 if Param > Cardinal(TPSTypeRec_Record(Dest.aType).FFieldTypes.Count) then
6762 begin
6763 CMD_Err(erOutOfRange);
6764 Result := False;
6765 exit;
6766 end;
6767 Dest.P := Pointer(IPointer(Dest.P) + IPointer(TPSTypeRec_Record(Dest.aType).RealFieldOffsets[Param]));
6768 Dest.aType := TPSTypeRec_Record(Dest.aType).FieldTypes[Param];
6769 end;
6770 btArray:
6771 begin
6772 if Param >= Cardinal(PSDynArrayGetLength(Pointer(Dest.P^), dest.aType)) then
6773 begin
6774 CMD_Err(erOutOfRange);
6775 Result := False;
6776 exit;
6777 end;
6778 Dest.P := Pointer(IPointer(Dest.P^) + (Param * TPSTypeRec_Array(Dest.aType).FArrayType.RealSize));
6779 Dest.aType := TPSTypeRec_Array(dest.aType).ArrayType;
6780 end;
6781 btStaticArray:
6782 begin
6783 if Param >= Cardinal(TPSTypeRec_StaticArray(Dest.aType).Size) then
6784 begin
6785 CMD_Err(erOutOfRange);
6786 Result := False;
6787 exit;
6788 end;
6789 Dest.P := Pointer(IPointer(Dest.P) + (Param * TPSTypeRec_Array(Dest.aType).FArrayType.RealSize));
6790 Dest.aType := TPSTypeRec_Array(dest.aType).ArrayType;
6791 end;
6792 else
6793 CMD_Err(erInvalidType);
6794 Result := False;
6795 exit;
6796 end;
6797
6798 if UsePointer and (Dest.aType.BaseType = btPointer) then
6799 begin
6800 Dest.aType := TPSTypeRec(Pointer(IPointer(Dest.p)+PointerSize)^);
6801 Dest.P := Pointer(Dest.p^);
6802 if Dest.P = nil then
6803 begin
6804 Cmd_Err(erNullPointerException);
6805 Result := False;
6806 exit;
6807 end;
6808 end;
6809 end;
6810 3:
6811 begin
6812 Dest.FreeType := vtNone;
6813 if Param < PSAddrNegativeStackStart then begin
6814 if Param >= Cardinal(FGlobalVars.Count) then
6815 begin
6816 CMD_Err(erOutOfGlobalVarsRange);
6817 Result := False;
6818 exit;
6819 end;
6820 Tmp := FGlobalVars.Data[param];
6821 end
6822 else begin
6823 Param := Cardinal(Longint(-PSAddrStackStart) + Longint(FCurrStackBase) + Longint(Param));
6824 if Param >= Cardinal(FStack.Count) then
6825 begin
6826 CMD_Err(erOutOfStackRange);
6827 Result := False;
6828 exit;
6829 end;
6830 Tmp := FStack.Data[param];
6831 end;
6832 if (Tmp.FType.BaseType = btPointer) then
6833 begin
6834 Dest.aType := PPSVariantPointer(Tmp).DestType;
6835 Dest.P := PPSVariantPointer(Tmp).DataDest;
6836 if Dest.P = nil then
6837 begin
6838 Cmd_Err(erNullPointerException);
6839 Result := False;
6840 exit;
6841 end;
6842 end else
6843 begin
6844 Dest.aType := PPSVariantData(Tmp).vi.FType;
6845 Dest.P := @PPSVariantData(Tmp).Data;
6846 end;
6847 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
6848 Param := unaligned(Cardinal((@FData^[FCurrentPosition])^));
6849 {$else}
6850 Param := Cardinal((@FData^[FCurrentPosition])^);
6851 {$endif}
6852 Inc(FCurrentPosition, 4);
6853 if Param < PSAddrNegativeStackStart then
6854 begin
6855 if Param >= Cardinal(FGlobalVars.Count) then
6856 begin
6857 CMD_Err(erOutOfGlobalVarsRange);
6858 Result := false;
6859 exit;
6860 end;
6861 Tmp := FGlobalVars[Param];
6862 end
6863 else begin
6864 Param := Cardinal(Longint(-PSAddrStackStart) + Longint(FCurrStackBase) + Longint(Param));
6865 if Cardinal(Param) >= Cardinal(FStack.Count) then
6866 begin
6867 CMD_Err(erOutOfStackRange);
6868 Result := false;
6869 exit;
6870 end;
6871 Tmp := FStack[Param];
6872 end;
6873 case Tmp.FType.BaseType of
6874 btu8: Param := PPSVariantU8(Tmp).Data;
6875 bts8: Param := PPSVariants8(Tmp).Data;
6876 btu16: Param := PPSVariantU16(Tmp).Data;
6877 bts16: Param := PPSVariants16(Tmp).Data;
6878 btu32: Param := PPSVariantU32(Tmp).Data;
6879 bts32: Param := PPSVariants32(Tmp).Data;
6880 btPointer:
6881 begin
6882 if PPSVariantPointer(tmp).DestType <> nil then
6883 begin
6884 case PPSVariantPointer(tmp).DestType.BaseType of
6885 btu8: Param := tbtu8(PPSVariantPointer(tmp).DataDest^);
6886 bts8: Param := tbts8(PPSVariantPointer(tmp).DataDest^);
6887 btu16: Param := tbtu16(PPSVariantPointer(tmp).DataDest^);
6888 bts16: Param := tbts16(PPSVariantPointer(tmp).DataDest^);
6889 btu32, btProcPtr: Param := tbtu32(PPSVariantPointer(tmp).DataDest^);
6890 bts32: Param := tbts32(PPSVariantPointer(tmp).DataDest^);
6891 else
6892 begin
6893 CMD_Err(ErTypeMismatch);
6894 Result := false;
6895 exit;
6896 end;
6897 end;
6898 end else
6899 begin
6900 CMD_Err(ErTypeMismatch);
6901 Result := false;
6902 exit;
6903 end;
6904 end;
6905 else
6906 CMD_Err(ErTypeMismatch);
6907 Result := false;
6908 exit;
6909 end;
6910 case Dest.aType.BaseType of
6911 btRecord:
6912 begin
6913 if Param > Cardinal(TPSTypeRec_Record(Dest.aType).FFieldTypes.Count) then
6914 begin
6915 CMD_Err(erOutOfRange);
6916 Result := False;
6917 exit;
6918 end;
6919 Dest.P := Pointer(IPointer(Dest.P) + IPointer(TPSTypeRec_Record(Dest.aType).RealFieldOffsets[Param]));
6920 Dest.aType := TPSTypeRec_Record(Dest.aType).FieldTypes[Param];
6921 end;
6922 btArray:
6923 begin
6924 if Cardinal(Param) >= Cardinal(PSDynArrayGetLength(Pointer(Dest.P^), dest.aType)) then
6925 begin
6926 CMD_Err(erOutOfRange);
6927 Result := False;
6928 exit;
6929 end;
6930 Dest.P := Pointer(IPointer(Dest.P^) + (Param * TPSTypeRec_Array(Dest.aType).FArrayType.RealSize));
6931 Dest.aType := TPSTypeRec_Array(dest.aType).ArrayType;
6932 end;
6933 btStaticArray:
6934 begin
6935 if Param >= Cardinal(TPSTypeRec_StaticArray(Dest.aType).Size) then
6936 begin
6937 CMD_Err(erOutOfRange);
6938 Result := False;
6939 exit;
6940 end;
6941 Dest.P := Pointer(IPointer(Dest.P) + (Param * TPSTypeRec_Array(Dest.aType).FArrayType.RealSize));
6942 Dest.aType := TPSTypeRec_Array(dest.aType).ArrayType;
6943 end;
6944 else
6945 CMD_Err(erInvalidType);
6946 Result := False;
6947 exit;
6948 end;
6949 if UsePointer and (Dest.aType.BaseType = btPointer) then
6950 begin
6951 Dest.aType := TPSTypeRec(Pointer(IPointer(Dest.p)+PointerSize)^);
6952 Dest.P := Pointer(Dest.p^);
6953 if Dest.P = nil then
6954 begin
6955 Cmd_Err(erNullPointerException);
6956 Result := False;
6957 exit;
6958 end;
6959 end;
6960 end;
6961 else
6962 begin
6963 Result := False;
6964 exit;
6965 end;
6966 end;
6967 Result := true;
6968 end;
6969
DoMinusnull6970 function TPSExec.DoMinus(Dta: Pointer; aType: TPSTypeRec): Boolean;
6971 begin
6972 case atype.BaseType of
6973 btU8: tbtu8(dta^) := -tbtu8(dta^);
6974 btU16: tbtu16(dta^) := -tbtu16(dta^);
6975 btU32: tbtu32(dta^) := -tbtu32(dta^);
6976 btS8: tbts8(dta^) := -tbts8(dta^);
6977 btS16: tbts16(dta^) := -tbts16(dta^);
6978 btS32: tbts32(dta^) := -tbts32(dta^);
6979 {$IFNDEF PS_NOINT64}
6980 bts64: tbts64(dta^) := -tbts64(dta^);
6981 {$ENDIF}
6982 btSingle: tbtsingle(dta^) := -tbtsingle(dta^);
6983 btDouble: tbtdouble(dta^) := -tbtdouble(dta^);
6984 btExtended: tbtextended(dta^) := -tbtextended(dta^);
6985 btCurrency: tbtcurrency(dta^) := -tbtcurrency(dta^);
6986 btVariant:
6987 begin
6988 try
6989 Variant(dta^) := - Variant(dta^);
6990 except
6991 CMD_Err(erTypeMismatch);
6992 Result := False;
6993 exit;
6994 end;
6995 end;
6996 else
6997 begin
6998 CMD_Err(erTypeMismatch);
6999 Result := False;
7000 exit;
7001 end;
7002 end;
7003 Result := True;
7004 end;
7005
TPSExec.DoBooleanNotnull7006 function TPSExec.DoBooleanNot(Dta: Pointer; aType: TPSTypeRec): Boolean;
7007 begin
7008 case aType.BaseType of
7009 btU8: tbtu8(dta^) := tbtu8(tbtu8(dta^) = 0);
7010 btU16: tbtu16(dta^) := tbtu16(tbtu16(dta^) = 0);
7011 btU32: tbtu32(dta^) := tbtu32(tbtu32(dta^) = 0);
7012 btS8: tbts8(dta^) := tbts8(tbts8(dta^) = 0);
7013 btS16: tbts16(dta^) := tbts16(tbts16(dta^) = 0);
7014 btS32: tbts32(dta^) := tbts32(tbts32(dta^) = 0);
7015 {$IFNDEF PS_NOINT64}
7016 bts64: tbts64(dta^) := tbts64(tbts64(dta^) = 0);
7017 {$ENDIF}
7018 btVariant:
7019 begin
7020 try
7021 Variant(dta^) := Variant(dta^) = 0;
7022 except
7023 CMD_Err(erTypeMismatch);
7024 Result := False;
7025 exit;
7026 end;
7027 end;
7028 else
7029 begin
7030 CMD_Err(erTypeMismatch);
7031 Result := False;
7032 exit;
7033 end;
7034 end;
7035 Result := True;
7036 end;
7037
7038
7039 procedure TPSExec.Stop;
7040 begin
7041 if FStatus = isRunning then
7042 FStatus := isLoaded
7043 else if FStatus = isPaused then begin
7044 FStatus := isLoaded;
7045 FStack.Clear;
7046 FTempVars.Clear;
7047 end;
7048 end;
7049
7050
ReadLongnull7051 function TPSExec.ReadLong(var b: Cardinal): Boolean;
7052 begin
7053 if FCurrentPosition + 3 < FDataLength then begin
7054 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
7055 b := unaligned(Cardinal((@FData^[FCurrentPosition])^));
7056 {$else}
7057 b := Cardinal((@FData^[FCurrentPosition])^);
7058 {$endif}
7059 Inc(FCurrentPosition, 4);
7060 Result := True;
7061 end
7062 else
7063 Result := False;
7064 end;
7065
TPSExec.RunProcPnull7066 function TPSExec.RunProcP(const Params: array of Variant; const Procno: Cardinal): Variant;
7067 var
7068 ParamList: TPSList;
7069 ct: PIFTypeRec;
7070 pvar: PPSVariant;
7071 res, s: tbtString;
7072 Proc: TPSInternalProcRec;
7073 i: Longint;
7074 begin
7075 if ProcNo >= FProcs.Count then raise Exception.Create(RPS_UnknownProcedure);
7076 Proc := GetProcNo(ProcNo) as TPSInternalProcRec;
7077 ParamList := TPSList.Create;
7078 try
7079 s := Proc.ExportDecl;
7080 res := grfw(s);
7081 i := High(Params);
7082 while s <> '' do
7083 begin
7084 if i < 0 then raise Exception.Create(RPS_NotEnoughParameters);
7085 ct := FTypes[StrToInt(copy(GRLW(s), 2, MaxInt))];
7086 if ct = nil then raise Exception.Create(RPS_InvalidParameter);
7087 pvar := CreateHeapVariant(ct);
7088 ParamList.Add(pvar);
7089
7090 if not VariantToPIFVariant(Self, Params[i], pvar) then raise Exception.Create(RPS_InvalidParameter);
7091
7092 Dec(i);
7093 end;
7094 if I > -1 then raise Exception.Create(RPS_TooManyParameters);
7095 if res <> '-1' then
7096 begin
7097 pvar := CreateHeapVariant(FTypes[StrToInt(res)]);
7098 ParamList.Add(pvar);
7099 end else
7100 pvar := nil;
7101
7102 RunProc(ParamList, ProcNo);
7103
7104 RaiseCurrentException;
7105
7106 if pvar <> nil then
7107 begin
7108 PIFVariantToVariant(PVar, Result);
7109 end else
7110 Result := Null;
7111 finally
7112 FreePIFVariantList(ParamList);
7113 end;
7114 end;
TPSExec.RunProcPVarnull7115 function TPSExec.RunProcPVar(var Params: array of Variant; const Procno: Cardinal): Variant;
7116 var
7117 ParamList: TPSList;
7118 ct: PIFTypeRec;
7119 pvar: PPSVariant;
7120 res, s: tbtString;
7121 Proc: TPSInternalProcRec;
7122 i: Longint;
7123 begin
7124 if ProcNo >= FProcs.Count then raise Exception.Create(RPS_UnknownProcedure);
7125 Proc := GetProcNo(ProcNo) as TPSInternalProcRec;
7126 ParamList := TPSList.Create;
7127 try
7128 s := Proc.ExportDecl;
7129 res := grfw(s);
7130 i := High(Params);
7131 while s <> '' do
7132 begin
7133 if i < 0 then raise Exception.Create(RPS_NotEnoughParameters);
7134 ct := FTypes[StrToInt(copy(GRLW(s), 2, MaxInt))];
7135 if ct = nil then raise Exception.Create(RPS_InvalidParameter);
7136 pvar := CreateHeapVariant(ct);
7137 ParamList.Add(pvar);
7138
7139 if not VariantToPIFVariant(Self, Params[i], pvar) then raise Exception.Create(RPS_InvalidParameter);
7140
7141 Dec(i);
7142 end;
7143 if I > -1 then raise Exception.Create(RPS_TooManyParameters);
7144 if res <> '-1' then
7145 begin
7146 pvar := CreateHeapVariant(FTypes[StrToInt(res)]);
7147 ParamList.Add(pvar);
7148 end else
7149 pvar := nil;
7150
7151 RunProc(ParamList, ProcNo);
7152
7153 RaiseCurrentException;
7154
7155 for i := 0 to Length(Params) - 1 do
7156 PIFVariantToVariant(ParamList[i],
7157 Params[(Length(Params) - 1) - i]);
7158
7159 if pvar <> nil then
7160 begin
7161 PIFVariantToVariant(PVar, Result);
7162 end else
7163 Result := Null;
7164 finally
7165 FreePIFVariantList(ParamList);
7166 end;
7167 end;
7168
TPSExec.RunProcPNnull7169 function TPSExec.RunProcPN(const Params: array of Variant; const ProcName: tbtString): Variant;
7170 var
7171 ProcNo: Cardinal;
7172 begin
7173 ProcNo := GetProc(ProcName);
7174 if ProcNo = InvalidVal then
7175 raise Exception.Create(RPS_UnknownProcedure);
7176 Result := RunProcP(Params, ProcNo);
7177 end;
7178
7179
TPSExec.RunProcnull7180 function TPSExec.RunProc(Params: TPSList; ProcNo: Cardinal): Boolean;
7181 var
7182 I, I2: Integer;
7183 vnew, Vd: PIfVariant;
7184 Cp: TPSInternalProcRec;
7185 oldStatus: TPSStatus;
7186 tmp: TObject;
7187 begin
7188 if FStatus <> isNotLoaded then begin
7189 if ProcNo >= FProcs.Count then begin
7190 CMD_Err(erOutOfProcRange);
7191 Result := False;
7192 exit;
7193 end;
7194 if Params <> nil then
7195 begin
7196 for I := 0 to Params.Count - 1 do
7197 begin
7198 vd := Params[I];
7199 if vd = nil then
7200 begin
7201 Result := False;
7202 exit;
7203 end;
7204 vnew := FStack.PushType(FindType2(btPointer));
7205 if vd.FType.BaseType = btPointer then
7206 begin
7207 PPSVariantPointer(vnew).DestType := PPSVariantPointer(vd).DestType;
7208 PPSVariantPointer(vnew).DataDest := PPSVariantPointer(vd).DataDest;
7209 end else begin
7210 PPSVariantPointer(vnew).DestType := vd.FType;
7211 PPSVariantPointer(vnew).DataDest := @PPSVariantData(vd).Data;
7212 end;
7213 end;
7214 end;
7215 I := FStack.Count;
7216 Cp := FCurrProc;
7217 oldStatus := FStatus;
7218 if TPSProcRec(FProcs.Data^[ProcNo]).ClassType <> TPSExternalProcRec then
7219 begin
7220 vd := FStack.PushType(FReturnAddressType);
7221 PPSVariantReturnAddress(vd).Addr.ProcNo := nil;
7222 PPSVariantReturnAddress(vd).Addr.Position := FCurrentPosition;
7223 PPSVariantReturnAddress(vd).Addr.StackBase := FCurrStackBase;
7224 FCurrStackBase := FStack.Count - 1;
7225 FCurrProc := FProcs.Data^[ProcNo];
7226 FData := FCurrProc.Data;
7227 FDataLength := FCurrProc.Length;
7228 FCurrentPosition := 0;
7229 FStatus := isPaused;
7230 Result := RunScript;
7231 end else
7232 begin
7233 try
7234 Result := TPSExternalProcRec(FProcs.Data^[ProcNo]).ProcPtr(Self, TPSExternalProcRec(FProcs.Data^[ProcNo]), FGlobalVars, FStack);
7235 if not Result then
7236 begin
7237 if ExEx = erNoError then
7238 CMD_Err(erCouldNotCallProc);
7239 end;
7240 except
7241 {$IFDEF DELPHI6UP}
7242 Tmp := AcquireExceptionObject;
7243 {$ELSE}
7244 if RaiseList <> nil then
7245 begin
7246 Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
7247 PRaiseFrame(RaiseList)^.ExceptObject := nil;
7248 end else
7249 Tmp := nil;
7250 {$ENDIF}
7251 if Tmp <> nil then
7252 begin
7253 if Tmp is EPSException then
7254 begin
7255 Result := False;
7256 ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, tbtString(EPSException(tmp).Message), nil);
7257 exit;
7258 end else
7259 if Tmp is EDivByZero then
7260 begin
7261 Result := False;
7262 CMD_Err3(erDivideByZero, tbtString(Exception(Tmp).Message), Tmp);
7263 Exit;
7264 end;
7265 if Tmp is EZeroDivide then
7266 begin
7267 Result := False;
7268 CMD_Err3(erDivideByZero, tbtString(Exception(Tmp).Message), Tmp);
7269 Exit;
7270 end;
7271 if Tmp is EMathError then
7272 begin
7273 Result := False;
7274 CMD_Err3(erMathError, tbtString(Exception(Tmp).Message), Tmp);
7275 Exit;
7276 end;
7277 end;
7278 if (Tmp <> nil) and (Tmp is Exception) then
7279 CMD_Err3(erException, tbtString(Exception(Tmp).Message), Tmp) else
7280 CMD_Err3(erException, '', Tmp);
7281 Result := false;
7282 exit;
7283 end;
7284 end;
7285 if Cardinal(FStack.Count) > Cardinal(I) then
7286 begin
7287 vd := FStack[I];
7288 if (vd <> nil) and (vd.FType = FReturnAddressType) then
7289 begin
7290 for i2 := FStack.Count - 1 downto I + 1 do
7291 FStack.Pop;
7292 FCurrentPosition := PPSVariantReturnAddress(vd).Addr.Position;
7293 FCurrStackBase := PPSVariantReturnAddress(vd).Addr.StackBase;
7294 FStack.Pop;
7295 end;
7296 end;
7297 if Params <> nil then
7298 begin
7299 for I := Params.Count - 1 downto 0 do
7300 begin
7301 if FStack.Count = 0 then
7302 Break
7303 else
7304 FStack.Pop;
7305 end;
7306 end;
7307 FStatus := oldStatus;
7308 FCurrProc := Cp;
7309 if FCurrProc <> nil then
7310 begin
7311 FData := FCurrProc.Data;
7312 FDataLength := FCurrProc.Length;
7313 end;
7314 end else begin
7315 Result := False;
7316 end;
7317 end;
7318
7319
FindType2null7320 function TPSExec.FindType2(BaseType: TPSBaseType): PIFTypeRec;
7321 var
7322 l: Cardinal;
7323 begin
7324 FindType2 := FindType(0, BaseType, l);
7325
7326 end;
7327
TPSExec.FindTypenull7328 function TPSExec.FindType(StartAt: Cardinal; BaseType: TPSBaseType; var l: Cardinal): PIFTypeRec;
7329 var
7330 I: Integer;
7331 n: PIFTypeRec;
7332 begin
7333 for I := StartAt to FTypes.Count - 1 do begin
7334 n := FTypes[I];
7335 if n.BaseType = BaseType then begin
7336 l := I;
7337 Result := n;
7338 exit;
7339 end;
7340 end;
7341 Result := nil;
7342 end;
7343
TPSExec.GetTypeNonull7344 function TPSExec.GetTypeNo(l: Cardinal): PIFTypeRec;
7345 begin
7346 Result := FTypes[l];
7347 end;
7348
GetProcnull7349 function TPSExec.GetProc(const Name: tbtString): Cardinal;
7350 var
7351 MM,
7352 I: Longint;
7353 n: PIFProcRec;
7354 s: tbtString;
7355 begin
7356 s := FastUpperCase(name);
7357 MM := MakeHash(s);
7358 for I := FProcs.Count - 1 downto 0 do begin
7359 n := FProcs.Data^[I];
7360 if (n.ClassType = TPSInternalProcRec) and (TPSInternalProcRec(n).ExportNameHash = MM) and (TPSInternalProcRec(n).ExportName = s) then begin
7361 Result := I;
7362 exit;
7363 end else if (n.ClassType = TPSExternalProcRec) and (TPSExternalProcRec(n).Name = s) then
7364 begin
7365 Result := I;
7366 exit;
7367 end;
7368 end;
7369 Result := InvalidVal;
7370 end;
7371
TPSExec.GetTypenull7372 function TPSExec.GetType(const Name: tbtString): Cardinal;
7373 var
7374 MM,
7375 I: Longint;
7376 n: PIFTypeRec;
7377 s: tbtString;
7378 begin
7379 s := FastUpperCase(name);
7380 MM := MakeHash(s);
7381 for I := 0 to FTypes.Count - 1 do begin
7382 n := FTypes.Data^[I];
7383 if (Length(n.ExportName) <> 0) and (n.ExportNameHash = MM) and (n.ExportName = s) then begin
7384 Result := I;
7385 exit;
7386 end;
7387 end;
7388 Result := InvalidVal;
7389 end;
7390
7391
7392 procedure TPSExec.AddResource(Proc, P: Pointer);
7393 var
7394 Temp: PPSResource;
7395 begin
7396 New(Temp);
7397 Temp^.Proc := Proc;
7398 Temp^.P := p;
7399 FResources.Add(temp);
7400 end;
7401
7402 procedure TPSExec.DeleteResource(P: Pointer);
7403 var
7404 i: Longint;
7405 begin
7406 for i := Longint(FResources.Count) -1 downto 0 do
7407 begin
7408 if PPSResource(FResources[I])^.P = P then
7409 begin
7410 FResources.Delete(I);
7411 exit;
7412 end;
7413 end;
7414 end;
7415
FindProcResourcenull7416 function TPSExec.FindProcResource(Proc: Pointer): Pointer;
7417 var
7418 I: Longint;
7419 temp: PPSResource;
7420 begin
7421 for i := Longint(FResources.Count) -1 downto 0 do
7422 begin
7423 temp := FResources[I];
7424 if temp^.Proc = proc then
7425 begin
7426 Result := Temp^.P;
7427 exit;
7428 end;
7429 end;
7430 Result := nil;
7431 end;
7432
IsValidResourcenull7433 function TPSExec.IsValidResource(Proc, P: Pointer): Boolean;
7434 var
7435 i: Longint;
7436 temp: PPSResource;
7437 begin
7438 for i := 0 to Longint(FResources.Count) -1 do
7439 begin
7440 temp := FResources[i];
7441 if temp^.p = p then begin
7442 result := temp^.Proc = Proc;
7443 exit;
7444 end;
7445 end;
7446 result := false;
7447 end;
7448
TPSExec.FindProcResource2null7449 function TPSExec.FindProcResource2(Proc: Pointer;
7450 var StartAt: Longint): Pointer;
7451 var
7452 I: Longint;
7453 temp: PPSResource;
7454 begin
7455 if StartAt > longint(FResources.Count) -1 then
7456 StartAt := longint(FResources.Count) -1;
7457 for i := StartAt downto 0 do
7458 begin
7459 temp := FResources[I];
7460 if temp^.Proc = proc then
7461 begin
7462 Result := Temp^.P;
7463 StartAt := i -1;
7464 exit;
7465 end;
7466 end;
7467 StartAt := -1;
7468 Result := nil;
7469 end;
7470
7471 procedure TPSExec.RunLine;
7472 begin
7473 if @FOnRunLine <> nil then
7474 FOnRunLine(Self);
7475 end;
7476
7477 procedure TPSExec.CMD_Err3(EC: TPSError; const Param: tbtString; ExObject: TObject);
7478 var
7479 l: Longint;
7480 C: Cardinal;
7481 begin
7482 C := InvalidVal;
7483 for l := FProcs.Count - 1 downto 0 do begin
7484 if FProcs.Data^[l] = FCurrProc then begin
7485 C := l;
7486 break;
7487 end;
7488 end;
7489 if @FOnException <> nil then
7490 FOnException(Self, Ec, Param, ExObject, C, FCurrentPosition);
7491 ExceptionProc(C, FCurrentPosition, EC, Param, ExObject);
7492 end;
7493
7494 procedure TPSExec.AddSpecialProcImport(const FName: tbtString;
7495 P: TPSOnSpecialProcImport; Tag: Pointer);
7496 var
7497 N: PSpecialProc;
7498 begin
7499 New(n);
7500 n^.P := P;
7501 N^.Name := FName;
7502 n^.namehash := MakeHash(N^.Name);
7503 n^.Tag := Tag;
7504 FSpecialProcList.Add(n);
7505 end;
7506
TPSExec.GetVarnull7507 function TPSExec.GetVar(const Name: tbtString): Cardinal;
7508 var
7509 l: Longint;
7510 h: longint;
7511 s: tbtString;
7512 p: PPSExportedVar;
7513 begin
7514 s := FastUpperCase(name);
7515 h := MakeHash(s);
7516 for l := FExportedVars.Count - 1 downto 0 do
7517 begin
7518 p := FexportedVars.Data^[L];
7519 if (p^.FNameHash = h) and(p^.FName=s) then
7520 begin
7521 Result := L;
7522 exit;
7523 end;
7524 end;
7525 Result := InvalidVal;
7526 end;
7527
GetVarNonull7528 function TPSExec.GetVarNo(C: Cardinal): PIFVariant;
7529 begin
7530 Result := FGlobalVars[c];
7531 end;
7532
GetVar2null7533 function TPSExec.GetVar2(const Name: tbtString): PIFVariant;
7534 begin
7535 Result := GetVarNo(GetVar(Name));
7536 end;
7537
TPSExec.GetProcNonull7538 function TPSExec.GetProcNo(C: Cardinal): PIFProcRec;
7539 begin
7540 Result := FProcs[c];
7541 end;
7542
TPSExec.DoIntegerNotnull7543 function TPSExec.DoIntegerNot(Dta: Pointer; aType: TPSTypeRec): Boolean;
7544 begin
7545 case aType.BaseType of
7546 btU8: tbtu8(dta^) := not tbtu8(dta^);
7547 btU16: tbtu16(dta^) := not tbtu16(dta^);
7548 btU32: tbtu32(dta^) := not tbtu32(dta^);
7549 btS8: tbts8(dta^) := not tbts8(dta^);
7550 btS16: tbts16(dta^) := not tbts16(dta^);
7551 btS32: tbts32(dta^) := not tbts32(dta^);
7552 {$IFNDEF PS_NOINT64}
7553 bts64: tbts64(dta^) := not tbts64(dta^);
7554 {$ENDIF}
7555 btVariant:
7556 begin
7557 try
7558 Variant(dta^) := not Variant(dta^);
7559 except
7560 CMD_Err(erTypeMismatch);
7561 Result := False;
7562 exit;
7563 end;
7564 end;
7565 else
7566 begin
7567 CMD_Err(erTypeMismatch);
7568 Result := False;
7569 exit;
7570 end;
7571 end;
7572 Result := True;
7573 end;
7574
7575 type
7576 TMyRunLine = procedure(Self: TPSExec);
7577 TPSRunLine = procedure of object;
7578
GetRunLinenull7579 function GetRunLine(FOnRunLine: TPSOnLineEvent; meth: TPSRunLine): TMyRunLine;
7580 begin
7581 if (TMethod(Meth).Code = @TPSExec.RunLine) and (@FOnRunLine = nil) then
7582 Result := nil
7583 else
7584 Result := TMethod(Meth).Code;
7585 end;
7586
RunScriptnull7587 function TPSExec.RunScript: Boolean;
7588 var
7589 CalcType: Cardinal;
7590 vd, vs, v3: TPSResultData;
7591 vtemp: PIFVariant;
7592 p: Cardinal;
7593 P2: Longint;
7594 u: PIFProcRec;
7595 Cmd: Cardinal;
7596 I: Longint;
7597 pp: TPSExceptionHandler;
7598 FExitPoint: Cardinal;
7599 FOldStatus: TPSStatus;
7600 Tmp: TObject;
7601 btemp: Boolean;
7602 CallRunline: TMyRunLine;
7603 begin
7604 FExitPoint := InvalidVal;
7605 if FStatus = isLoaded then
7606 begin
7607 for i := FExceptionStack.Count -1 downto 0 do
7608 begin
7609 pp := FExceptionStack.Data[i];
7610 pp.Free;
7611 end;
7612 FExceptionStack.Clear;
7613 end;
7614 ExceptionProc(InvalidVal, InvalidVal, erNoError, '', nil);
7615 RunScript := True;
7616 FOldStatus := FStatus;
7617 case FStatus of
7618 isLoaded: begin
7619 if FMainProc = InvalidVal then
7620 begin
7621 RunScript := False;
7622 exit;
7623 end;
7624 FStatus := isRunning;
7625 FCurrProc := FProcs.Data^[FMainProc];
7626 if FCurrProc.ClassType = TPSExternalProcRec then begin
7627 CMD_Err(erNoMainProc);
7628 FStatus := isLoaded;
7629 exit;
7630 end;
7631 FData := FCurrProc.Data;
7632 FDataLength := FCurrProc.Length;
7633 FCurrStackBase := InvalidVal;
7634 FCurrentPosition := 0;
7635 end;
7636 isPaused: begin
7637 FStatus := isRunning;
7638 end;
7639 else begin
7640 RunScript := False;
7641 exit;
7642 end;
7643 end;
7644 CallRunLine := GetRunLine(FOnRunLine, Self.RunLine);
7645 repeat
7646 FStatus := isRunning;
7647 // Cmd := InvalidVal;
7648 while FStatus = isRunning do
7649 begin
7650 if @CallRunLine <> nil then CallRunLine(Self);
7651 if FCurrentPosition >= FDataLength then
7652 begin
7653 CMD_Err(erOutOfRange); // Error
7654 break;
7655 end;
7656 // if cmd <> invalidval then ProfilerExitProc(Cmd+1);
7657 cmd := FData^[FCurrentPosition];
7658 // ProfilerEnterProc(Cmd+1);
7659 Inc(FCurrentPosition);
7660 case Cmd of
7661 CM_A:
7662 begin
7663 if not ReadVariable(vd, True) then
7664 break;
7665 if vd.FreeType <> vtNone then
7666 begin
7667 if vd.aType.BaseType in NeedFinalization then
7668 FinalizeVariant(vd.P, vd.aType);
7669 p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
7670 Dec(FTempVars.FCount);
7671 {$IFNDEF PS_NOSMARTLIST}
7672 Inc(FTempVars.FCheckCount);
7673 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
7674 {$ENDIF}
7675 FTempVars.FLength := P;
7676 if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
7677
7678 CMD_Err(erInvalidOpcodeParameter);
7679 break;
7680 end;
7681 if not ReadVariable(vs, True) then
7682 Break;
7683 // nx change end
7684 { if (vd.aType.BaseType = btClass) and (vs.aType.BaseType in [btS32]) then
7685 DWord(vd.P^):=Dword(vs.P^)
7686 else
7687 if (vd.aType.BaseType in [btS32]) and (vs.aType.BaseType = btClass) then
7688 DWord(vd.P^):=Dword(vs.P^)
7689 else}
7690 // nx change start
7691 if not SetVariantValue(vd.P, vs.P, vd.aType, vs.aType) then
7692 begin
7693 if vs.FreeType <> vtNone then
7694 begin
7695 if vs.aType.BaseType in NeedFinalization then
7696 FinalizeVariant(vs.P, vs.aType);
7697 p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
7698 Dec(FTempVars.FCount);
7699 {$IFNDEF PS_NOSMARTLIST}
7700 Inc(FTempVars.FCheckCount);
7701 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
7702 {$ENDIF}
7703 FTempVars.FLength := P;
7704 if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
7705 end;
7706 Break;
7707 end;
7708 if vs.FreeType <> vtNone then
7709 begin
7710 if vs.aType.BaseType in NeedFinalization then
7711 FinalizeVariant(vs.P, vs.aType);
7712 p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
7713 Dec(FTempVars.FCount);
7714 {$IFNDEF PS_NOSMARTLIST}
7715 Inc(FTempVars.FCheckCount);
7716 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
7717 {$ENDIF}
7718 FTempVars.FLength := P;
7719 if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
7720 end;
7721 end;
7722 CM_CA:
7723 begin
7724 if FCurrentPosition >= FDataLength then
7725 begin
7726 CMD_Err(erOutOfRange); // Error
7727 break;
7728 end;
7729 calctype := FData^[FCurrentPosition];
7730 Inc(FCurrentPosition);
7731 if not ReadVariable(vd, True) then
7732 break;
7733 if vd.FreeType <> vtNone then
7734 begin
7735 if vd.aType.BaseType in NeedFinalization then
7736 FinalizeVariant(vd.P, vd.aType);
7737 p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
7738 Dec(FTempVars.FCount);
7739 {$IFNDEF PS_NOSMARTLIST}
7740 Inc(FTempVars.FCheckCount);
7741 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
7742 {$ENDIF}
7743 FTempVars.FLength := P;
7744 if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
7745 CMD_Err(erInvalidOpcodeParameter);
7746 break;
7747 end;
7748 if not ReadVariable(vs, True) then
7749 Break;
7750 if not DoCalc(vd.P, vs.p, vd.aType, vs.aType, CalcType) then
7751 begin
7752 if vs.FreeType <> vtNone then
7753 begin
7754 if vs.aType.BaseType in NeedFinalization then
7755 FinalizeVariant(vs.P, vs.aType);
7756 p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
7757 Dec(FTempVars.FCount);
7758 {$IFNDEF PS_NOSMARTLIST}
7759 Inc(FTempVars.FCheckCount);
7760 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
7761 {$ENDIF}
7762 FTempVars.FLength := P;
7763 if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
7764 end;
7765 Break;
7766 end;
7767 if vs.FreeType <> vtNone then
7768 begin
7769 if vs.aType.BaseType in NeedFinalization then
7770 FinalizeVariant(vs.P, vs.aType);
7771 p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
7772 Dec(FTempVars.FCount);
7773 {$IFNDEF PS_NOSMARTLIST}
7774 Inc(FTempVars.FCheckCount);
7775 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
7776 {$ENDIF}
7777 FTempVars.FLength := P;
7778 if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
7779 end;
7780 end;
7781 CM_P:
7782 begin
7783 if not ReadVariable(vs, True) then
7784 Break;
7785 vtemp := FStack.PushType(vs.aType);
7786 vd.P := Pointer(IPointer(vtemp)+PointerSize);
7787 vd.aType := Pointer(vtemp^);
7788 vd.FreeType := vtNone;
7789 if not SetVariantValue(Vd.P, vs.P, vd.aType, vs.aType) then
7790 begin
7791 if vs.FreeType <> vtnone then
7792 begin
7793 if vs.aType.BaseType in NeedFinalization then
7794 FinalizeVariant(vs.P, vs.aType);
7795 p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
7796 Dec(FTempVars.FCount);
7797 {$IFNDEF PS_NOSMARTLIST}
7798 Inc(FTempVars.FCheckCount);
7799 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
7800 {$ENDIF}
7801 FTempVars.FLength := P;
7802 if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
7803 end;
7804 break;
7805 end;
7806 if vs.FreeType <> vtnone then
7807 begin
7808 if vs.aType.BaseType in NeedFinalization then
7809 FinalizeVariant(vs.P, vs.aType);
7810 p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
7811 Dec(FTempVars.FCount);
7812 {$IFNDEF PS_NOSMARTLIST}
7813 Inc(FTempVars.FCheckCount);
7814 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
7815 {$ENDIF}
7816 FTempVars.FLength := P;
7817 if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
7818 end;
7819 end;
7820 CM_PV:
7821 begin
7822 if not ReadVariable(vs, True) then
7823 Break;
7824 if vs.FreeType <> vtnone then
7825 begin
7826 FTempVars.Pop;
7827 CMD_Err(erInvalidOpcodeParameter);
7828 break;
7829 end;
7830 vtemp := FStack.PushType(FindType2(btPointer));
7831 if vs.aType.BaseType = btPointer then
7832 begin
7833 PPSVariantPointer(vtemp).DataDest := Pointer(vs.p^);
7834 PPSVariantPointer(vtemp).DestType := Pointer(Pointer(IPointer(vs.P)+PointerSize)^);
7835 PPSVariantPointer(vtemp).FreeIt := False;
7836 end
7837 else
7838 begin
7839 PPSVariantPointer(vtemp).DataDest := vs.p;
7840 PPSVariantPointer(vtemp).DestType := vs.aType;
7841 PPSVariantPointer(vtemp).FreeIt := False;
7842 end;
7843 end;
7844 CM_PO: begin
7845 if FStack.Count = 0 then
7846 begin
7847 CMD_Err(erOutOfStackRange);
7848 break;
7849 end;
7850 vtemp := FStack.Data^[FStack.Count -1];
7851 if (vtemp = nil) or (vtemp.FType.BaseType = btReturnAddress) then
7852 begin
7853 CMD_Err(erOutOfStackRange);
7854 break;
7855 end;
7856 FStack.Pop;
7857 (* Dec(FStack.FCount);
7858 {$IFNDEF PS_NOSMARTLIST}
7859 Inc(FStack.FCheckCount);
7860 if FStack.FCheckCount > FMaxCheckCount then FStack.Recreate;
7861 {$ENDIF}
7862 FStack.FLength := Longint(IPointer(vtemp) - IPointer(FStack.DataPtr));
7863 if TPSTypeRec(vtemp^).BaseType in NeedFinalization then
7864 FinalizeVariant(Pointer(IPointer(vtemp)+PointerSize), Pointer(vtemp^));
7865 if ((FStack.FCapacity - FStack.FLength) shr 12) > 2 then FStack.AdjustLength;*)
7866 end;
7867 Cm_C: begin
7868 if FCurrentPosition + 3 >= FDataLength then
7869 begin
7870 Cmd_Err(erOutOfRange);
7871 Break;
7872 end;
7873 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
7874 p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
7875 {$else}
7876 p := Cardinal((@FData^[FCurrentPosition])^);
7877 {$endif}
7878 Inc(FCurrentPosition, 4);
7879 if p >= FProcs.Count then begin
7880 CMD_Err(erOutOfProcRange);
7881 break;
7882 end;
7883 u := FProcs.Data^[p];
7884 if u.ClassType = TPSExternalProcRec then begin
7885 try
7886 if not TPSExternalProcRec(u).ProcPtr(Self, TPSExternalProcRec(u), FGlobalVars, FStack) then begin
7887 if ExEx = erNoError then
7888 CMD_Err(erCouldNotCallProc);
7889 Break;
7890 end;
7891 except
7892 {$IFDEF DELPHI6UP}
7893 Tmp := AcquireExceptionObject;
7894 {$ELSE}
7895 if RaiseList <> nil then
7896 begin
7897 Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
7898 PRaiseFrame(RaiseList)^.ExceptObject := nil;
7899 end else
7900 Tmp := nil;
7901 {$ENDIF}
7902 if Tmp <> nil then
7903 begin
7904 if Tmp is EPSException then
7905 begin
7906 ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, tbtString(EPSException(tmp).Message), nil);
7907 Break;
7908 end else
7909 if Tmp is EDivByZero then
7910 begin
7911 CMD_Err3(erDivideByZero, tbtString(Exception(Tmp).Message), Tmp);
7912 Break;
7913 end;
7914 if Tmp is EZeroDivide then
7915 begin
7916 CMD_Err3(erDivideByZero, tbtString(Exception(Tmp).Message), Tmp);
7917 Break;
7918 end;
7919 if Tmp is EMathError then
7920 begin
7921 CMD_Err3(erMathError, tbtString(Exception(Tmp).Message), Tmp);
7922 Break;
7923 end;
7924 end;
7925 if (Tmp <> nil) and (Tmp is Exception) then
7926 CMD_Err3(erException, tbtString(Exception(Tmp).Message), Tmp) else
7927 CMD_Err3(erException, '', Tmp);
7928 Break;
7929 end;
7930 end
7931 else begin
7932 Vtemp := Fstack.PushType(FReturnAddressType);
7933 vd.P := Pointer(IPointer(VTemp)+PointerSize);
7934 vd.aType := pointer(vtemp^);
7935 vd.FreeType := vtNone;
7936 PPSVariantReturnAddress(vtemp).Addr.ProcNo := FCurrProc;
7937 PPSVariantReturnAddress(vtemp).Addr.Position := FCurrentPosition;
7938 PPSVariantReturnAddress(vtemp).Addr.StackBase := FCurrStackBase;
7939
7940 FCurrStackBase := FStack.Count - 1;
7941 FCurrProc := TPSInternalProcRec(u);
7942 FData := FCurrProc.Data;
7943 FDataLength := FCurrProc.Length;
7944 FCurrentPosition := 0;
7945 end;
7946 end;
7947 CM_PG:
7948 begin
7949 FStack.Pop;
7950 if FCurrentPosition + 3 >= FDataLength then
7951 begin
7952 Cmd_Err(erOutOfRange);
7953 Break;
7954 end;
7955 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
7956 p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
7957 {$else}
7958 p := Cardinal((@FData^[FCurrentPosition])^);
7959 {$endif}
7960 Inc(FCurrentPosition, 4);
7961 FCurrentPosition := FCurrentPosition + p;
7962 end;
7963 CM_P2G:
7964 begin
7965 FStack.Pop;
7966 FStack.Pop;
7967 if FCurrentPosition + 3 >= FDataLength then
7968 begin
7969 Cmd_Err(erOutOfRange);
7970 Break;
7971 end;
7972 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
7973 p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
7974 {$else}
7975 p := Cardinal((@FData^[FCurrentPosition])^);
7976 {$endif}
7977 Inc(FCurrentPosition, 4);
7978 FCurrentPosition := FCurrentPosition + p;
7979 end;
7980 Cm_G:
7981 begin
7982 if FCurrentPosition + 3 >= FDataLength then
7983 begin
7984 Cmd_Err(erOutOfRange);
7985 Break;
7986 end;
7987 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
7988 p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
7989 {$else}
7990 p := Cardinal((@FData^[FCurrentPosition])^);
7991 {$endif}
7992 Inc(FCurrentPosition, 4);
7993 FCurrentPosition := FCurrentPosition + p;
7994 end;
7995 Cm_CG:
7996 begin
7997 if FCurrentPosition + 3 >= FDataLength then
7998 begin
7999 Cmd_Err(erOutOfRange);
8000 Break;
8001 end;
8002 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
8003 p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
8004 {$else}
8005 p := Cardinal((@FData^[FCurrentPosition])^);
8006 {$endif}
8007 Inc(FCurrentPosition, 4);
8008 btemp := true;
8009 if not ReadVariable(vs, btemp) then
8010 Break;
8011 case Vs.aType.BaseType of
8012 btU8: btemp := tbtu8(vs.p^) <> 0;
8013 btS8: btemp := tbts8(vs.p^) <> 0;
8014 btU16: btemp := tbtu16(vs.p^) <> 0;
8015 btS16: btemp := tbts16(vs.p^) <> 0;
8016 btU32: btemp := tbtu32(vs.p^) <> 0;
8017 btS32: btemp := tbts32(vs.p^) <> 0;
8018 else begin
8019 CMD_Err(erInvalidType);
8020 if vs.FreeType <> vtNone then
8021 FTempVars.Pop;
8022 break;
8023 end;
8024 end;
8025 if vs.FreeType <> vtNone then
8026 FTempVars.Pop;
8027 if btemp then
8028 FCurrentPosition := FCurrentPosition + p;
8029 end;
8030 Cm_CNG:
8031 begin
8032 if FCurrentPosition + 3 >= FDataLength then
8033 begin
8034 Cmd_Err(erOutOfRange);
8035 Break;
8036 end;
8037 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
8038 p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
8039 {$else}
8040 p := Cardinal((@FData^[FCurrentPosition])^);
8041 {$endif}
8042 Inc(FCurrentPosition, 4);
8043 btemp := true;
8044 if not ReadVariable(vs, BTemp) then
8045 Break;
8046 case Vs.aType.BaseType of
8047 btU8: btemp := tbtu8(vs.p^) = 0;
8048 btS8: btemp := tbts8(vs.p^) = 0;
8049 btU16: btemp := tbtu16(vs.p^) = 0;
8050 btS16: btemp := tbts16(vs.p^) = 0;
8051 btU32: btemp := tbtu32(vs.p^) = 0;
8052 btS32: btemp := tbts32(vs.p^) = 0;
8053 else begin
8054 CMD_Err(erInvalidType);
8055 if vs.FreeType <> vtNone then
8056 FTempVars.Pop;
8057 break;
8058 end;
8059 end;
8060 if vs.FreeType <> vtNone then
8061 FTempVars.Pop;
8062 if btemp then
8063 FCurrentPosition := FCurrentPosition + p;
8064 end;
8065 Cm_R: begin
8066 FExitPoint := FCurrentPosition -1;
8067 P2 := 0;
8068 if FExceptionStack.Count > 0 then
8069 begin
8070 pp := FExceptionStack.Data[FExceptionStack.Count -1];
8071 while (pp.BasePtr = FCurrStackBase) or ((pp.BasePtr > FCurrStackBase) and (pp.BasePtr <> InvalidVal)) do
8072 begin
8073 if pp.StackSize < Cardinal(FStack.Count) then
8074 begin
8075 for p := Longint(FStack.count) -1 downto Longint(pp.StackSize) do
8076 FStack.Pop
8077 end;
8078 FCurrStackBase := pp.BasePtr;
8079 if pp.FinallyOffset <> InvalidVal then
8080 begin
8081 FCurrentPosition := pp.FinallyOffset;
8082 pp.FinallyOffset := InvalidVal;
8083 p2 := 1;
8084 break;
8085 end else if pp.Finally2Offset <> InvalidVal then
8086 begin
8087 FCurrentPosition := pp.Finally2Offset;
8088 pp.Finally2Offset := InvalidVal;
8089 p2 := 1;
8090 break;
8091 end else
8092 begin
8093 pp.Free;
8094 FExceptionStack.DeleteLast;
8095 if FExceptionStack.Count = 0 then break;
8096 pp := FExceptionStack.Data[FExceptionStack.Count -1];
8097 end;
8098 end;
8099 end;
8100 if p2 = 0 then
8101 begin
8102 FExitPoint := InvalidVal;
8103 if FCurrStackBase = InvalidVal then
8104 begin
8105 FStatus := FOldStatus;
8106 break;
8107 end;
8108 for P2 := FStack.Count - 1 downto FCurrStackBase + 1 do
8109 FStack.Pop;
8110 if FCurrStackBase >= FStack.Count then
8111 begin
8112 FStatus := FOldStatus;
8113 break;
8114 end;
8115 vtemp := FStack.Data[FCurrStackBase];
8116 FCurrProc := PPSVariantReturnAddress(vtemp).Addr.ProcNo;
8117 FCurrentPosition := PPSVariantReturnAddress(vtemp).Addr.Position;
8118 FCurrStackBase := PPSVariantReturnAddress(vtemp).Addr.StackBase;
8119 FStack.Pop;
8120 if FCurrProc = nil then begin
8121 FStatus := FOldStatus;
8122 break;
8123 end;
8124 FData := FCurrProc.Data;
8125 FDataLength := FCurrProc.Length;
8126 end;
8127 end;
8128 Cm_Pt: begin
8129 if FCurrentPosition + 3 >= FDataLength then
8130 begin
8131 Cmd_Err(erOutOfRange);
8132 Break;
8133 end;
8134 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
8135 p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
8136 {$else}
8137 p := Cardinal((@FData^[FCurrentPosition])^);
8138 {$endif}
8139 Inc(FCurrentPosition, 4);
8140 if p > FTypes.Count then
8141 begin
8142 CMD_Err(erInvalidType);
8143 break;
8144 end;
8145 FStack.PushType(FTypes.Data^[p]);
8146 end;
8147 cm_bn:
8148 begin
8149 if not ReadVariable(vd, True) then
8150 Break;
8151 if vd.FreeType <> vtNone then
8152 FTempVars.Pop;
8153 if not DoBooleanNot(Vd.P, vd.aType) then
8154 break;
8155 end;
8156 cm_in:
8157 begin
8158 if not ReadVariable(vd, True) then
8159 Break;
8160 if vd.FreeType <> vtNone then
8161 FTempVars.Pop;
8162 if not DoIntegerNot(Vd.P, vd.aType) then
8163 break;
8164 end;
8165 cm_vm:
8166 begin
8167 if not ReadVariable(vd, True) then
8168 Break;
8169 if vd.FreeType <> vtNone then
8170 FTempVars.Pop;
8171 if not DoMinus(Vd.P, vd.aType) then
8172 break;
8173 end;
8174 cm_sf:
8175 begin
8176 if not ReadVariable(vd, True) then
8177 Break;
8178 if FCurrentPosition >= FDataLength then
8179 begin
8180 CMD_Err(erOutOfRange); // Error
8181 if vd.FreeType <> vtNone then
8182 FTempVars.Pop;
8183 break;
8184 end;
8185 p := FData^[FCurrentPosition];
8186 Inc(FCurrentPosition);
8187 case Vd.aType.BaseType of
8188 btU8: FJumpFlag := tbtu8(Vd.p^) <> 0;
8189 btS8: FJumpFlag := tbts8(Vd.p^) <> 0;
8190 btU16: FJumpFlag := tbtu16(Vd.p^) <> 0;
8191 btS16: FJumpFlag := tbts16(Vd.p^) <> 0;
8192 btU32: FJumpFlag := tbtu32(Vd.p^) <> 0;
8193 btS32: FJumpFlag := tbts32(Vd.p^) <> 0;
8194 else begin
8195 CMD_Err(erInvalidType);
8196 if vd.FreeType <> vtNone then
8197 FTempVars.Pop;
8198 break;
8199 end;
8200 end;
8201 if p <> 0 then
8202 FJumpFlag := not FJumpFlag;
8203 if vd.FreeType <> vtNone then
8204 FTempVars.Pop;
8205 end;
8206 cm_fg:
8207 begin
8208 if FCurrentPosition + 3 >= FDataLength then
8209 begin
8210 Cmd_Err(erOutOfRange);
8211 Break;
8212 end;
8213 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
8214 p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
8215 {$else}
8216 p := Cardinal((@FData^[FCurrentPosition])^);
8217 {$endif}
8218 Inc(FCurrentPosition, 4);
8219 if FJumpFlag then
8220 FCurrentPosition := FCurrentPosition + p;
8221 end;
8222 cm_puexh:
8223 begin
8224 pp := TPSExceptionHandler.Create;
8225 pp.CurrProc := FCurrProc;
8226 pp.BasePtr :=FCurrStackBase;
8227 pp.StackSize := FStack.Count;
8228 if not ReadLong(pp.FinallyOffset) then begin
8229 CMD_Err(erOutOfRange);
8230 pp.Free;
8231 Break;
8232 end;
8233 if not ReadLong(pp.ExceptOffset) then begin
8234 CMD_Err(erOutOfRange);
8235 pp.Free;
8236 Break;
8237 end;
8238 if not ReadLong(pp.Finally2Offset) then begin
8239 CMD_Err(erOutOfRange);
8240 pp.Free;
8241 Break;
8242 end;
8243 if not ReadLong(pp.EndOfBlock) then begin
8244 CMD_Err(erOutOfRange);
8245 pp.Free;
8246 Break;
8247 end;
8248 if pp.FinallyOffset <> InvalidVal then
8249 pp.FinallyOffset := pp.FinallyOffset + FCurrentPosition;
8250 if pp.ExceptOffset <> InvalidVal then
8251 pp.ExceptOffset := pp.ExceptOffset + FCurrentPosition;
8252 if pp.Finally2Offset <> InvalidVal then
8253 pp.Finally2Offset := pp.Finally2Offset + FCurrentPosition;
8254 if pp.EndOfBlock <> InvalidVal then
8255 pp.EndOfBlock := pp.EndOfBlock + FCurrentPosition;
8256 if ((pp.FinallyOffset <> InvalidVal) and (pp.FinallyOffset >= FDataLength)) or
8257 ((pp.ExceptOffset <> InvalidVal) and (pp.ExceptOffset >= FDataLength)) or
8258 ((pp.Finally2Offset <> InvalidVal) and (pp.Finally2Offset >= FDataLength)) or
8259 ((pp.EndOfBlock <> InvalidVal) and (pp.EndOfBlock >= FDataLength)) then
8260 begin
8261 CMD_Err(ErOutOfRange);
8262 pp.Free;
8263 Break;
8264 end;
8265 FExceptionStack.Add(pp);
8266 end;
8267 cm_poexh:
8268 begin
8269 if FCurrentPosition >= FDataLength then
8270 begin
8271 CMD_Err(erOutOfRange); // Error
8272 break;
8273 end;
8274 p := FData^[FCurrentPosition];
8275 Inc(FCurrentPosition);
8276 case p of
8277 2:
8278 begin
8279 if (FExceptionStack.Count = 0) then
8280 begin
8281 cmd_err(ErOutOfRange);
8282 Break;
8283 end;
8284 pp := FExceptionStack.Data^[FExceptionStack.Count -1];
8285 if pp = nil then begin
8286 cmd_err(ErOutOfRange);
8287 Break;
8288 end;
8289 pp.ExceptOffset := InvalidVal;
8290 if pp.Finally2Offset <> InvalidVal then
8291 begin
8292 FCurrentPosition := pp.Finally2Offset;
8293 pp.Finally2Offset := InvalidVal;
8294 end else begin
8295 p := pp.EndOfBlock;
8296 pp.Free;
8297 FExceptionStack.DeleteLast;
8298 if FExitPoint <> InvalidVal then
8299 begin
8300 FCurrentPosition := FExitPoint;
8301 end else begin
8302 FCurrentPosition := p;
8303 end;
8304 end;
8305 end;
8306 0:
8307 begin
8308 pp := FExceptionStack.Data^[FExceptionStack.Count -1];
8309 if pp = nil then begin
8310 cmd_err(ErOutOfRange);
8311 Break;
8312 end;
8313 if pp.FinallyOffset <> InvalidVal then
8314 begin
8315 FCurrentPosition := pp.FinallyOffset;
8316 pp.FinallyOffset := InvalidVal;
8317 end else if pp.Finally2Offset <> InvalidVal then
8318 begin
8319 FCurrentPosition := pp.Finally2Offset;
8320 pp.ExceptOffset := InvalidVal;
8321 end else begin
8322 p := pp.EndOfBlock;
8323 pp.Free;
8324 FExceptionStack.DeleteLast;
8325 if ExEx <> eNoError then
8326 begin
8327 Tmp := ExObject;
8328 ExObject := nil;
8329 ExceptionProc(ExProc, ExPos, ExEx, ExParam, Tmp);
8330 end else
8331 if FExitPoint <> InvalidVal then
8332 begin
8333 FCurrentPosition := FExitPoint;
8334 end else begin
8335 FCurrentPosition := p;
8336 end;
8337 end;
8338 end;
8339 1:
8340 begin
8341 pp := FExceptionStack.Data^[FExceptionStack.Count -1];
8342 if pp = nil then begin
8343 cmd_err(ErOutOfRange);
8344 Break;
8345 end;
8346 if (ExEx <> ENoError) and (pp.ExceptOffset <> InvalidVal) and (pp.ExceptOffset <> InvalidVal -1) then
8347 begin
8348 FCurrentPosition := pp.ExceptOffset;
8349 pp.ExceptOffset := Cardinal(InvalidVal -1);
8350 pp.ExceptionData := ExEx;
8351 pp.ExceptionObject := ExObject;
8352 pp.ExceptionParam := ExParam;
8353 ExEx := ErNoError;
8354 ExObject := nil;
8355 end else if (pp.Finally2Offset <> InvalidVal) then
8356 begin
8357 FCurrentPosition := pp.Finally2Offset;
8358 pp.Finally2Offset := InvalidVal;
8359 end else begin
8360 p := pp.EndOfBlock;
8361 pp.Free;
8362 FExceptionStack.DeleteLast;
8363 if (ExEx <> eNoError) and (p <> InvalidVal) then
8364 begin
8365 Tmp := ExObject;
8366 ExObject := nil;
8367 ExceptionProc(ExProc, ExPos, ExEx, ExParam, Tmp);
8368 end else
8369 if FExitPoint <> InvalidVal then
8370 begin
8371 FCurrentPosition := FExitPoint;
8372 end else begin
8373 FCurrentPosition := p;
8374 end;
8375 end;
8376 end;
8377 3:
8378 begin
8379 pp := FExceptionStack.Data^[FExceptionStack.Count -1];
8380 if pp = nil then begin
8381 cmd_err(ErOutOfRange);
8382 Break;
8383 end;
8384 p := pp.EndOfBlock;
8385 pp.Free;
8386 FExceptionStack.DeleteLast;
8387 if ExEx <> eNoError then
8388 begin
8389 Tmp := ExObject;
8390 ExObject := nil;
8391 ExceptionProc(ExProc, ExPos, ExEx, ExParam, Tmp);
8392 end else
8393 if FExitPoint <> InvalidVal then
8394 begin
8395 FCurrentPosition := FExitPoint;
8396 end else begin
8397 FCurrentPosition := p;
8398 end;
8399 end;
8400 end;
8401 end;
8402 cm_spc:
8403 begin
8404 if not ReadVariable(vd, False) then
8405 Break;
8406 if vd.FreeType <> vtNone then
8407 begin
8408 FTempVars.Pop;
8409 CMD_Err(erInvalidOpcodeParameter);
8410 break;
8411 end;
8412 if (Vd.aType.BaseType <> btPointer) then
8413 begin
8414 CMD_Err(erInvalidOpcodeParameter);
8415 break;
8416 end;
8417 if not ReadVariable(vs, False) then
8418 Break;
8419 if Pointer(Pointer(IPointer(vD.P)+PointerSize2)^) <> nil then
8420 DestroyHeapVariant2(Pointer(vD.P^), Pointer(Pointer(IPointer(vd.P)+PointerSize)^));
8421 if vs.aType.BaseType = btPointer then
8422 begin
8423 if Pointer(vs.P^) <> nil then
8424 begin
8425 Pointer(vd.P^) := CreateHeapVariant2(Pointer(Pointer(IPointer(vs.P) + PointerSize)^));
8426 Pointer(Pointer(IPointer(vd.P) + PointerSize)^) := Pointer(Pointer(IPointer(vs.P) + PointerSize)^);
8427 Pointer(Pointer(IPointer(vd.P) + PointerSize2)^) := Pointer(1);
8428 if not CopyArrayContents(Pointer(vd.P^), Pointer(vs.P^), 1, Pointer(Pointer(IPointer(vd.P) + PointerSize)^)) then
8429 begin
8430 if vs.FreeType <> vtNone then
8431 FTempVars.Pop;
8432 CMD_Err(ErTypeMismatch);
8433 break;
8434 end;
8435 end else
8436 begin
8437 Pointer(vd.P^) := nil;
8438 Pointer(Pointer(IPointer(vd.P) + PointerSize)^) := nil;
8439 Pointer(Pointer(IPointer(vd.P) + PointerSize2)^) := nil;
8440 end;
8441 end else begin
8442 Pointer(vd.P^) := CreateHeapVariant2(vs.aType);
8443 Pointer(Pointer(IPointer(vd.P) + PointerSize)^) := vs.aType;
8444 LongBool(Pointer(IPointer(vd.P) + PointerSize2)^) := true;
8445 if not CopyArrayContents(Pointer(vd.P^), vs.P, 1, vs.aType) then
8446 begin
8447 if vs.FreeType <> vtNone then
8448 FTempVars.Pop;
8449 CMD_Err(ErTypeMismatch);
8450 break;
8451 end;
8452 end;
8453 if vs.FreeType <> vtNone then
8454 FTempVars.Pop;
8455
8456 end;
8457 cm_nop:;
8458 cm_dec:
8459 begin
8460 if not ReadVariable(vd, True) then
8461 Break;
8462 if vd.FreeType <> vtNone then
8463 begin
8464 FTempVars.Pop;
8465 CMD_Err(erInvalidOpcodeParameter);
8466 break;
8467 end;
8468 case vd.aType.BaseType of
8469 btu8: dec(tbtu8(vd.P^));
8470 bts8: dec(tbts8(vd.P^));
8471 btu16: dec(tbtu16(vd.P^));
8472 bts16: dec(tbts16(vd.P^));
8473 btu32: dec(tbtu32(vd.P^));
8474 bts32: dec(tbts32(vd.P^));
8475 {$IFNDEF PS_NOINT64}
8476 bts64: dec(tbts64(vd.P^));
8477 {$ENDIF}
8478 else
8479 begin
8480 CMD_Err(ErTypeMismatch);
8481 Break;
8482 end;
8483 end;
8484 end;
8485 cm_inc:
8486 begin
8487 if not ReadVariable(vd, True) then
8488 Break;
8489 if vd.FreeType <> vtNone then
8490 begin
8491 FTempVars.Pop;
8492 CMD_Err(erInvalidOpcodeParameter);
8493 break;
8494 end;
8495 case vd.aType.BaseType of
8496 btu8: Inc(tbtu8(vd.P^));
8497 bts8: Inc(tbts8(vd.P^));
8498 btu16: Inc(tbtu16(vd.P^));
8499 bts16: Inc(tbts16(vd.P^));
8500 btu32: Inc(tbtu32(vd.P^));
8501 bts32: Inc(tbts32(vd.P^));
8502 {$IFNDEF PS_NOINT64}
8503 bts64: Inc(tbts64(vd.P^));
8504 {$ENDIF}
8505 else
8506 begin
8507 CMD_Err(ErTypeMismatch);
8508 Break;
8509 end;
8510 end;
8511 end;
8512 cm_sp:
8513 begin
8514 if not ReadVariable(vd, False) then
8515 Break;
8516 if vd.FreeType <> vtNone then
8517 begin
8518 FTempVars.Pop;
8519 CMD_Err(erInvalidOpcodeParameter);
8520 break;
8521 end;
8522 if (Vd.aType.BaseType <> btPointer) then
8523 begin
8524 CMD_Err(erInvalidOpcodeParameter);
8525 break;
8526 end;
8527 if not ReadVariable(vs, False) then
8528 Break;
8529 if vs.FreeType <> vtNone then
8530 begin
8531 FTempVars.Pop;
8532 CMD_Err(erInvalidOpcodeParameter);
8533 break;
8534 end;
8535 if vs.aType.BaseType = btPointer then
8536 begin
8537 Pointer(vd.P^) := Pointer(vs.p^);
8538 Pointer(Pointer(IPointer(vd.P)+PointerSize)^) := Pointer(Pointer(IPointer(vs.P)+PointerSize)^);
8539 end
8540 else
8541 begin
8542 Pointer(vd.P^) := vs.P;
8543 Pointer(Pointer(IPointer(vd.P)+PointerSize)^) := vs.aType;
8544 end;
8545 end;
8546 Cm_cv:
8547 begin
8548 if not ReadVariable(vd, True) then
8549 Break;
8550 if vd.aType.BaseType <> btProcPtr then
8551 begin
8552 if vd.FreeType <> vtNone then
8553 FTempVars.Pop;
8554 CMD_Err(ErTypeMismatch);
8555 break;
8556 end;
8557 p := tbtu32(vd.P^);
8558 if vd.FreeType <> vtNone then
8559 FTempVars.Pop;
8560 if (p = 0) and (Pointer(Pointer(IPointer(vd.p)+PointerSize2)^) <> nil) then
8561 begin
8562 if not InvokeExternalMethod(TPSTypeRec_ProcPtr(vd.aType), Pointer(Pointer(IPointer(vd.p)+PointerSize)^), Pointer(Pointer(IPointer(vd.p)+PointerSize2)^)) then
8563 Break;
8564 end else begin
8565 if (p >= FProcs.Count) or (p = FMainProc) then begin
8566 CMD_Err(erOutOfProcRange);
8567 break;
8568 end;
8569 u := FProcs.Data^[p];
8570 if u.ClassType = TPSExternalProcRec then begin
8571 try
8572 if not TPSExternalProcRec(u).ProcPtr(Self, TPSExternalProcRec(u), FGlobalVars, FStack) then begin
8573 if ExEx = erNoError then
8574 CMD_Err(erCouldNotCallProc);
8575 Break;
8576 end;
8577 except
8578 {$IFDEF DELPHI6UP}
8579 Tmp := AcquireExceptionObject;
8580 {$ELSE}
8581 if RaiseList <> nil then
8582 begin
8583 Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
8584 PRaiseFrame(RaiseList)^.ExceptObject := nil;
8585 end else
8586 Tmp := nil;
8587 {$ENDIF}
8588 if Tmp <> nil then
8589 begin
8590 if Tmp is EPSException then
8591 begin
8592 ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, tbtString(EPSException(tmp).Message), nil);
8593 break;
8594 end else
8595 if Tmp is EDivByZero then
8596 begin
8597 CMD_Err3(erDivideByZero, tbtString(Exception(Tmp).Message), Tmp);
8598 break;
8599 end;
8600 if Tmp is EZeroDivide then
8601 begin
8602 CMD_Err3(erDivideByZero, tbtString(Exception(Tmp).Message), Tmp);
8603 break;
8604 end;
8605 if Tmp is EMathError then
8606 begin
8607 CMD_Err3(erMathError, tbtString(Exception(Tmp).Message), Tmp);
8608 break;
8609 end;
8610 end;
8611 if (Tmp <> nil) and (Tmp is Exception) then
8612 CMD_Err3(erException, tbtString(Exception(Tmp).Message), Tmp) else
8613 CMD_Err3(erException, '', Tmp);
8614 Break;
8615 end;
8616 end
8617 else begin
8618 vtemp := FStack.PushType(FReturnAddressType);
8619 PPSVariantReturnAddress(vtemp).Addr.ProcNo := FCurrProc;
8620 PPSVariantReturnAddress(vtemp).Addr.Position := FCurrentPosition;
8621 PPSVariantReturnAddress(vtemp).Addr.StackBase := FCurrStackBase;
8622 FCurrStackBase := FStack.Count - 1;
8623 FCurrProc := TPSInternalProcRec(u);
8624 FData := FCurrProc.Data;
8625 FDataLength := FCurrProc.Length;
8626 FCurrentPosition := 0;
8627 end;
8628 end;
8629 end;
8630 CM_CO:
8631 begin
8632 if FCurrentPosition >= FDataLength then
8633 begin
8634 CMD_Err(erOutOfRange); // Error
8635 break;
8636 end;
8637 calctype := FData^[FCurrentPosition];
8638 Inc(FCurrentPosition);
8639 if not ReadVariable(v3, True) then
8640 Break;
8641 if v3.FreeType <> vtNone then
8642 begin
8643 if v3.aType.BaseType in NeedFinalization then
8644 FinalizeVariant(v3.P, v3.aType);
8645 p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
8646 Dec(FTempVars.FCount);
8647 {$IFNDEF PS_NOSMARTLIST}
8648 Inc(FTempVars.FCheckCount);
8649 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
8650 {$ENDIF}
8651 FTempVars.FLength := P;
8652 if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
8653 CMD_Err(erInvalidOpcodeParameter);
8654 break;
8655 end;
8656 if not ReadVariable(vs, True) then
8657 Break;
8658 if not ReadVariable(vd, True) then
8659 begin
8660 if vs.FreeType <> vtNone then
8661 begin
8662 if vs.aType.BaseType in NeedFinalization then
8663 FinalizeVariant(vs.P, vs.aType);
8664 p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
8665 Dec(FTempVars.FCount);
8666 {$IFNDEF PS_NOSMARTLIST}
8667 Inc(FTempVars.FCheckCount);
8668 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
8669 {$ENDIF}
8670 FTempVars.FLength := P;
8671 if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
8672 end;
8673 Break;
8674 end;
8675 DoBooleanCalc(Vs.P, Vd.P, v3.P, vs.aType, vd.aType, v3.aType, CalcType);
8676 if vd.FreeType <> vtNone then
8677 begin
8678 if vd.aType.BaseType in NeedFinalization then
8679 FinalizeVariant(vd.P, vd.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 if vs.FreeType <> vtNone then
8690 begin
8691 if vs.aType.BaseType in NeedFinalization then
8692 FinalizeVariant(vs.P, vs.aType);
8693 p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
8694 Dec(FTempVars.FCount);
8695 {$IFNDEF PS_NOSMARTLIST}
8696 Inc(FTempVars.FCheckCount);
8697 if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
8698 {$ENDIF}
8699 FTempVars.FLength := P;
8700 if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
8701 end;
8702 end;
8703
8704 else
8705 CMD_Err(erInvalidOpcode); // Error
8706 end;
8707 end;
8708 // if cmd <> invalidval then ProfilerExitProc(Cmd+1);
8709 // if ExEx <> erNoError then FStatus := FOldStatus;
8710 until (FExceptionStack.Count = 0) or (Fstatus <> IsRunning);
8711 if FStatus = isLoaded then begin
8712 for I := Longint(FStack.Count) - 1 downto 0 do
8713 FStack.Pop;
8714 FStack.Clear;
8715 if FCallCleanup then Cleanup;
8716 end;
8717 Result := ExEx = erNoError;
8718 end;
8719
NVarProcnull8720 function NVarProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
8721 var
8722 tmp: TPSVariantIFC;
8723 begin
8724 case Longint(p.Ext1) of
8725 0:
8726 begin
8727 if @Caller.FOnSetNVariant = nil then begin Result := False; exit; end;
8728 tmp := NewTPSVariantIFC(Stack.Items[Stack.Count - 2], True);
8729 if (Tmp.Dta = nil) or (tmp.aType.BaseType <> btVariant) then begin Result := False; exit; end;
8730 Caller.FOnSetNVariant(Caller, Stack.GetAnsiString(-1), Variant(tmp.Dta^));
8731 Result := true;
8732 end;
8733 1:
8734 begin
8735 if @Caller.FOnGetNVariant = nil then begin Result := False; exit; end;
8736 tmp := NewTPSVariantIFC(Stack.Items[Stack.Count - 1], False);
8737 if (Tmp.Dta = nil) or (tmp.aType.BaseType <> btVariant) then begin Result := False; exit; end;
8738 Variant(tmp.Dta^) := Caller.FOnGetNVariant(Caller, Stack.GetAnsiString(-2));
8739 Result := true;
8740 end;
8741 else
8742 Result := False;
8743 end;
8744 end;
8745
DefProcnull8746 function DefProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
8747 var
8748 temp: TPSVariantIFC;
8749 I: Longint;
8750 b: Boolean;
8751 pex: TPSExceptionHandler;
8752 Tmp: TObject;
8753 begin
8754 { The following needs to be in synch in these 3 functions:
8755 -UPSCompiler.TPSPascalCompiler.DefineStandardProcedures
8756 -UPSRuntime.DefProc
8757 -UPSRuntime.TPSExec.RegisterStandardProcs
8758 }
8759 case Longint(p.Ext1) of
8760 0: Stack.SetAnsiString(-1, tbtstring(SysUtils.IntToStr(Stack.{$IFNDEF PS_NOINT64}GetInt64{$ELSE}GetInt{$ENDIF}(-2)))); // inttostr
8761 1: Stack.SetInt(-1, StrToInt(Stack.GetAnsiString(-2))); // strtoint
8762 2: Stack.SetInt(-1, StrToIntDef(Stack.GetAnsiString(-2), Stack.GetInt(-3))); // strtointdef
8763 3:
8764 {$IFNDEF PS_NOWIDESTRING}
8765 if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then
8766 Stack.SetInt(-1, Pos(Stack.GetUnicodeString(-2), Stack.GetUnicodeString(-3)))// pos
8767 else
8768 if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then
8769 Stack.SetInt(-1, Pos(Stack.GetWideString(-2), Stack.GetWideString(-3)))// pos
8770 else{$ENDIF}
8771 Stack.SetInt(-1, Pos(Stack.GetAnsiString(-2), Stack.GetAnsiString(-3)));// pos
8772 4:
8773 {$IFNDEF PS_NOWIDESTRING} if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then
8774 Stack.SetWideString(-1, Copy(Stack.GetWideString(-2), Stack.GetInt(-3), Stack.GetInt(-4))) // copy
8775 else
8776 if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then
8777 Stack.SetUnicodeString(-1, Copy(Stack.GetUnicodeString(-2), Stack.GetInt(-3), Stack.GetInt(-4))) // copy
8778 else{$ENDIF}
8779 Stack.SetAnsiString(-1, Copy(Stack.GetAnsiString(-2), Stack.GetInt(-3), Stack.GetInt(-4))); // copy
8780 5: //delete
8781 begin
8782 temp := NewTPSVariantIFC(Stack[Stack.Count -1], True);
8783 {$IFNDEF PS_NOWIDESTRING}
8784 if (temp.Dta <> nil) and (temp.aType.BaseType = btUnicodeString) then
8785 begin
8786 Delete(tbtUnicodeString(temp.Dta^), Stack.GetInt(-2), Stack.GetInt(-3));
8787 end else
8788 if (temp.Dta <> nil) and (temp.aType.BaseType = btWideString) then
8789 begin
8790 Delete(tbtwidestring(temp.Dta^), Stack.GetInt(-2), Stack.GetInt(-3));
8791 end else {$ENDIF} begin
8792 if (temp.Dta = nil) or (temp.aType.BaseType <> btString) then
8793 begin
8794 Result := False;
8795 exit;
8796 end;
8797 Delete(tbtstring(temp.Dta^), Stack.GetInt(-2), Stack.GetInt(-3));
8798 end;
8799 end;
8800 6: // insert
8801 begin
8802 temp := NewTPSVariantIFC(Stack[Stack.Count -2], True);
8803 {$IFNDEF PS_NOWIDESTRING}
8804 if (temp.Dta <> nil) and (temp.aType.BaseType = btUnicodeString) then begin
8805 Insert(Stack.GetUnicodeString(-1), tbtUnicodeString(temp.Dta^), Stack.GetInt(-3));
8806 end else if (temp.Dta <> nil) and (temp.aType.BaseType = btWideString) then begin
8807 Insert(Stack.GetWideString(-1), tbtwidestring(temp.Dta^), Stack.GetInt(-3));
8808 end else {$ENDIF} begin
8809 if (temp.Dta = nil) or (temp.aType.BaseType <> btString) then
8810 begin
8811 Result := False;
8812 exit;
8813 end;
8814 Insert(Stack.GetAnsiString(-1), tbtstring(temp.Dta^), Stack.GetInt(-3));
8815 end;
8816 end;
8817 7: // StrGet
8818 begin
8819 temp := NewTPSVariantIFC(Stack[Stack.Count -2], True);
8820 if (temp.Dta = nil) or not (temp.aType.BaseType in [btString, btUnicodeString]) then
8821 begin
8822 Result := False;
8823 exit;
8824 end;
8825 I := Stack.GetInt(-3);
8826 if (i<1) or (i>length(tbtstring(temp.Dta^))) then
8827 begin
8828 Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange));
8829 Result := False;
8830 exit;
8831 end;
8832 Stack.SetInt(-1,Ord(tbtstring(temp.Dta^)[i]));
8833 end;
8834 8: // StrSet
8835 begin
8836 temp := NewTPSVariantIFC(Stack[Stack.Count -3], True);
8837 if (temp.Dta = nil) or not (temp.aType.BaseType in [btString, btUnicodeString]) then
8838 begin
8839 Result := False;
8840 exit;
8841 end;
8842 I := Stack.GetInt(-2);
8843 if (i<1) or (i>length(tbtstring(temp.Dta^))) then
8844 begin
8845 Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange));
8846 Result := True;
8847 exit;
8848 end;
8849 tbtstring(temp.Dta^)[i] := tbtchar(Stack.GetInt(-1));
8850 end;
8851 10:
8852 {$IFNDEF PS_NOWIDESTRING}
8853 {$IFDEF DELPHI2009UP}
8854 if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then
8855 Stack.SetUnicodeString(-1, UpperCase(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, WideUpperCase(Stack.GetWideString(-2))) // Uppercase
8861 else
8862 {$ENDIF}
8863 Stack.SetAnsiString(-1, FastUppercase(Stack.GetAnsiString(-2))); // Uppercase
8864 11:
8865 {$IFNDEF PS_NOWIDESTRING}
8866 {$IFDEF DELPHI2009UP}
8867 if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then
8868 Stack.SetUnicodeString(-1, LowerCase(Stack.GetUnicodeString(-2))) // Uppercase
8869 else
8870 {$ENDIF}
8871 if (Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString) or
8872 (Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString) then
8873 Stack.SetWideString(-1, WideLowerCase(Stack.GetWideString(-2))) // Uppercase
8874 else
8875 {$ENDIF}
8876 Stack.SetAnsiString(-1, FastLowercase(Stack.GetAnsiString(-2)));// LowerCase
8877 12:
8878 {$IFNDEF PS_NOWIDESTRING}
8879 if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then
8880 Stack.SetUnicodeString(-1, SysUtils.Trim(Stack.GetUnicodestring(-2))) // Trim
8881 else if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then
8882 Stack.SetWideString(-1, SysUtils.Trim(Stack.GetWideString(-2))) // Trim
8883 else
8884 {$ENDIF}
8885 Stack.SetAnsiString(-1, AnsiString(SysUtils.Trim(String(Stack.GetAnsiString(-2)))));// Trim
8886 13: Stack.SetInt(-1, Length(Stack.GetAnsiString(-2))); // Length
8887 14: // SetLength
8888 begin
8889 temp := NewTPSVariantIFC(Stack[Stack.Count -1], True);
8890 if (temp.Dta = nil) or (temp.aType.BaseType <> btString) then
8891 begin
8892 Result := False;
8893 exit;
8894 end;
8895 SetLength(tbtstring(temp.Dta^), STack.GetInt(-2));
8896 end;
8897 15: Stack.SetReal(-1, Sin(Stack.GetReal(-2))); // Sin
8898 16: Stack.SetReal(-1, Cos(Stack.GetReal(-2))); // Cos
8899 17: Stack.SetReal(-1, SQRT(Stack.GetReal(-2))); // Sqrt
8900 18: Stack.SetInt(-1, Round(Stack.GetReal(-2))); // Round
8901 19: Stack.SetInt(-1, Trunc(Stack.GetReal(-2))); // Trunc
8902 20: Stack.SetReal(-1, Int(Stack.GetReal(-2))); // Int
8903 21: Stack.SetReal(-1, Pi); // Pi
8904 22: Stack.SetReal(-1, Abs(Stack.GetReal(-2))); // Abs
8905 23: Stack.SetReal(-1, StrToFloat(Stack.GetAnsiString(-2))); // StrToFloat
8906 24: Stack.SetAnsiString(-1, FloatToStr(Stack.GetReal(-2)));// FloatToStr
8907 25:
8908 {$IFNDEF PS_NOWIDESTRING}
8909 if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then
8910 Stack.SetUnicodeString(-1, upadL(Stack.GetUnicodeString(-2), Stack.GetInt(-3))) // PadL
8911 else
8912 if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then
8913 Stack.SetWideString(-1, wPadL(Stack.GetWideString(-2), Stack.GetInt(-3))) // PadL
8914 else{$ENDIF}
8915 Stack.SetAnsiString(-1, PadL(Stack.GetAnsiString(-2), Stack.GetInt(-3))); // PadL
8916 26:
8917 {$IFNDEF PS_NOWIDESTRING}
8918 if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then
8919 Stack.SetUnicodeString(-1, uPadR(Stack.GetUnicodeString(-2), Stack.GetInt(-3))) // PadR
8920 else
8921 if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then
8922 Stack.SetWideString(-1, wPadR(Stack.GetWideString(-2), Stack.GetInt(-3))) // PadR
8923 else{$ENDIF}
8924 Stack.SetAnsiString(-1, PadR(Stack.GetAnsiString(-2), Stack.GetInt(-3))); // PadR
8925 27:
8926 {$IFNDEF PS_NOWIDESTRING}
8927 if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then
8928 Stack.SetUnicodeString(-1, uPadZ(Stack.GetUnicodeString(-2), Stack.GetInt(-3)))// PadZ
8929 else
8930 if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then
8931 Stack.SetWideString(-1, wPadZ(Stack.GetWideString(-2), Stack.GetInt(-3)))// PadZ
8932 else{$ENDIF}
8933 Stack.SetAnsiString(-1, PadZ(Stack.GetAnsiString(-2), Stack.GetInt(-3)));// PadZ
8934 28: Stack.SetAnsiString(-1, StringOfChar(tbtChar(Stack.GetInt(-2)), Stack.GetInt(-3))); // Replicate/StrOfChar
8935 29: // Assigned
8936 begin
8937 temp := NewTPSVariantIFC(Stack[Stack.Count -2], True);
8938 if Temp.dta = nil then
8939 begin
8940 Result := False;
8941 exit;
8942 end;
8943 case temp.aType.BaseType of
8944 btU8, btS8: b := tbtu8(temp.dta^) <> 0;
8945 btU16, btS16: b := tbtu16(temp.dta^) <> 0;
8946 btU32, btS32: b := tbtu32(temp.dta^) <> 0;
8947 btString, btPChar: b := tbtstring(temp.dta^) <> '';
8948 {$IFNDEF PS_NOWIDESTRING}
8949 btWideString: b := tbtwidestring(temp.dta^)<> '';
8950 btUnicodeString: b := tbtUnicodeString(temp.dta^)<> '';
8951 {$ENDIF}
8952 btArray, btClass{$IFNDEF PS_NOINTERFACES}, btInterface{$ENDIF}: b := Pointer(temp.dta^) <> nil;
8953 else
8954 Result := False;
8955 Exit;
8956 end;
8957 if b then
8958 Stack.SetInt(-1, 1)
8959 else
8960 Stack.SetInt(-1, 0);
8961 end;
8962 30:
8963 begin {RaiseLastException}
8964 if (Caller.FExceptionStack.Count > 0) then begin
8965 pex := Caller.FExceptionStack.Data[Caller.fExceptionStack.Count -1];
8966 if pex.ExceptOffset = Cardinal(InvalidVal -1) then begin
8967 Tmp := pex.ExceptionObject;
8968 pex.ExceptionObject := nil;
8969 Caller.ExceptionProc(Caller.ExProc, pex.ExceptOffset, pex.ExceptionData, pex.ExceptionParam, tmp);
8970 end;
8971 end;
8972 end;
8973 31: Caller.CMD_Err2(TPSError(Stack.GetInt(-1)), Stack.GetAnsiString(-2)); {RaiseExeption}
8974 32: Stack.SetInt(-1, Ord(Caller.LastEx)); {ExceptionType}
8975 33: Stack.SetAnsiString(-1, Caller.LastExParam); {ExceptionParam}
8976 34: Stack.SetInt(-1, Caller.LastExProc); {ExceptionProc}
8977 35: Stack.SetInt(-1, Caller.LastExPos); {ExceptionPos}
8978 36: Stack.SetAnsiString(-1, PSErrorToString(TPSError(Stack.GetInt(-2)), Stack.GetAnsiString(-3))); {ExceptionToString}
8979 37: Stack.SetAnsiString(-1, tbtString(AnsiUpperCase(string(Stack.GetAnsiString(-2))))); // AnsiUppercase
8980 38: Stack.SetAnsiString(-1, tbtString(AnsiLowercase(string(Stack.GetAnsiString(-2))))); // AnsiLowerCase
8981 {$IFNDEF PS_NOINT64}
8982 39: Stack.SetInt64(-1, StrToInt64(string(Stack.GetAnsiString(-2)))); // StrToInt64
8983 40: Stack.SetAnsiString(-1, tbtstring(SysUtils.IntToStr(Stack.GetInt64(-2))));// Int64ToStr
8984 41: Stack.SetInt64(-1, StrToInt64Def(string(Stack.GetAnsiString(-2)), Stack.GetInt64(-3))); // StrToInt64Def
8985 {$ENDIF}
8986 42: // sizeof
8987 begin
8988 temp := NewTPSVariantIFC(Stack[Stack.Count -2], False);
8989 if Temp.aType = nil then
8990 Stack.SetInt(-1, 0)
8991 else
8992 Stack.SetInt(-1, Temp.aType.RealSize)
8993 end;
8994 {$IFNDEF PS_NOWIDESTRING}
8995 43: // WStrGet
8996 begin
8997 temp := NewTPSVariantIFC(Stack[Stack.Count -2], True);
8998 if temp.dta = nil then begin
8999 result := false;
9000 exit;
9001 end;
9002 case temp.aType.BaseType of
9003 btWideString:
9004 begin
9005 I := Stack.GetInt(-3);
9006 if (i<1) or (i>length(tbtwidestring(temp.Dta^))) then
9007 begin
9008 Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange));
9009 Result := False;
9010 exit;
9011 end;
9012 Stack.SetInt(-1,Ord(tbtwidestring(temp.Dta^)[i]));
9013 end;
9014 btUnicodeString:
9015 begin
9016 I := Stack.GetInt(-3);
9017 if (i<1) or (i>length(tbtUnicodeString(temp.Dta^))) then
9018 begin
9019 Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange));
9020 Result := False;
9021 exit;
9022 end;
9023 Stack.SetInt(-1,Ord(tbtUnicodeString(temp.Dta^)[i]));
9024 end;
9025
9026 else
9027 begin
9028 Result := False;
9029 exit;
9030 end;
9031 end;
9032 end;
9033 44: // WStrSet
9034 begin
9035 temp := NewTPSVariantIFC(Stack[Stack.Count -3], True);
9036 if (temp.Dta = nil) then
9037 begin
9038 Result := False;
9039 exit;
9040 end;
9041 case temp.aType.BaseType of
9042 btWideString:
9043 begin
9044 I := Stack.GetInt(-2);
9045 if (i<1) or (i>length(tbtWidestring(temp.Dta^))) then
9046 begin
9047 Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange));
9048 Result := True;
9049 exit;
9050 end;
9051 tbtWidestring(temp.Dta^)[i] := WideChar(Stack.GetInt(-1));
9052 end;
9053
9054 btUnicodeString:
9055 begin
9056 I := Stack.GetInt(-2);
9057 if (i<1) or (i>length(tbtunicodestring(temp.Dta^))) then
9058 begin
9059 Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange));
9060 Result := True;
9061 exit;
9062 end;
9063 tbtunicodestring(temp.Dta^)[i] := WideChar(Stack.GetInt(-1));
9064 end;
9065 else
9066 begin
9067 Result := False;
9068 exit;
9069 end;
9070 end;
9071 end;
9072 {$ENDIF}
9073 else
9074 begin
9075 Result := False;
9076 exit;
9077 end;
9078 end;
9079 Result := True;
9080 end;
GetArrayLengthnull9081 function GetArrayLength(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
9082 var
9083 arr: TPSVariantIFC;
9084 begin
9085 Arr := NewTPSVariantIFC(Stack[Stack.Count-2], True);
9086 if (arr.aType.BaseType <> btStaticArray) and ((arr.Dta = nil) or (arr.aType.BaseType <> btArray)) then
9087 begin
9088 Result := false;
9089 exit;
9090 end;
9091 if arr.aType.BaseType = btStaticArray then
9092 Stack.SetInt(-1, TPSTypeRec_StaticArray(arr.aType).Size)
9093 else
9094 Stack.SetInt(-1, PSDynArrayGetLength(Pointer(arr.Dta^), arr.aType));
9095 Result := True;
9096 end;
9097
SetArrayLengthnull9098 function SetArrayLength(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
9099 var
9100 arr: TPSVariantIFC;
9101 begin
9102 Arr := NewTPSVariantIFC(Stack[Stack.Count-1], True);
9103 if (arr.Dta = nil) or (arr.aType.BaseType <> btArray) then
9104 begin
9105 Result := false;
9106 exit;
9107 end;
9108 PSDynArraySetLength(Pointer(arr.Dta^), arr.aType, Stack.GetInt(-2));
9109 Result := True;
9110 end;
9111
9112
9113 function InterfaceProc(Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean; forward;
9114
9115 procedure RegisterInterfaceLibraryRuntime(Se: TPSExec);
9116 begin
9117 SE.AddSpecialProcImport('intf', InterfaceProc, nil);
9118 end;
9119
9120 {$IFNDEF DELPHI6UP}
Nullnull9121 function Null: Variant;
9122 begin
9123 Result := System.Null;
9124 end;
9125
Unassignednull9126 function Unassigned: Variant;
9127 begin
9128 Result := System.Unassigned;
9129 end;
9130 {$ENDIF}
Length_null9131 function Length_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
9132 var
9133 arr: TPSVariantIFC;
9134 begin
9135 arr:=NewTPSVariantIFC(Stack[Stack.Count-2],false);
9136 case arr.aType.BaseType of
9137 btArray:
9138 begin
9139 Stack.SetInt(-1,PSDynArrayGetLength(Pointer(arr.Dta^),arr.aType));
9140 Result:=true;
9141 end;
9142 btStaticArray:
9143 begin
9144 Stack.SetInt(-1,TPSTypeRec_StaticArray(arr.aType).Size);
9145 Result:=true;
9146 end;
9147 btString:
9148 begin
9149 Stack.SetInt(-1,length(tbtstring(arr.Dta^)));
9150 Result:=true;
9151 end;
9152 btChar:
9153 begin
9154 Stack.SetInt(-1, 1);
9155 Result:=true;
9156 end;
9157 {$IFNDEF PS_NOWIDESTRING}
9158 btWideString:
9159 begin
9160 Stack.SetInt(-1,length(tbtWidestring(arr.Dta^)));
9161 Result:=true;
9162 end;
9163 btUnicodeString:
9164 begin
9165 Stack.SetInt(-1,length(tbtUnicodeString(arr.Dta^)));
9166 Result:=true;
9167 end;
9168 {$ENDIF}
9169 btvariant:
9170 begin
9171 Stack.SetInt(-1,length(Variant(arr.Dta^)));
9172 Result:=true;
9173 end;
9174 else
9175 begin
9176 Caller.CMD_Err(ErTypeMismatch);
9177 result := true;
9178 end;
9179 end;
9180 end;
9181
9182
SetLength_null9183 function SetLength_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
9184 var
9185 arr: TPSVariantIFC;
9186 begin
9187 Result:=false;
9188 arr:=NewTPSVariantIFC(Stack[Stack.Count-1],true);
9189 if arr.aType.BaseType=btArray then
9190 begin
9191 PSDynArraySetLength(Pointer(arr.Dta^),arr.aType,Stack.GetInt(-2));
9192 Result:=true;
9193 end else
9194 if arr.aType.BaseType=btString then
9195 begin
9196 SetLength(tbtstring(arr.Dta^),STack.GetInt(-2));
9197 Result:=true;
9198 {$IFNDEF PS_NOWIDESTRING}
9199 end else
9200 if arr.aType.BaseType=btWideString then
9201 begin
9202 SetLength(tbtwidestring(arr.Dta^),STack.GetInt(-2));
9203 Result:=true;
9204 end else
9205 if arr.aType.BaseType=btUnicodeString then
9206 begin
9207 SetLength(tbtUnicodeString(arr.Dta^),STack.GetInt(-2));
9208 Result:=true;
9209 {$ENDIF}
9210 end;
9211 end;
9212
Low_null9213 function Low_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
9214 var
9215 arr: TPSVariantIFC;
9216 begin
9217 Result:=true;
9218 arr:=NewTPSVariantIFC(Stack[Stack.Count-2],false);
9219 case arr.aType.BaseType of
9220 btArray : Stack.SetInt(-1,0);
9221 btStaticArray: Stack.SetInt(-1,TPSTypeRec_StaticArray(arr.aType).StartOffset);
9222 btString : Stack.SetInt(-1,1);
9223 btU8 : Stack.SetInt(-1,Low(Byte)); //Byte: 0
9224 btS8 : Stack.SetInt(-1,Low(ShortInt)); //ShortInt: -128
9225 btU16 : Stack.SetInt(-1,Low(Word)); //Word: 0
9226 btS16 : Stack.SetInt(-1,Low(SmallInt)); //SmallInt: -32768
9227 btU32 : Stack.SetInt(-1,Low(Cardinal)); //Cardinal/LongWord: 0
9228 btS32 : Stack.SetInt(-1,Low(Integer)); //Integer/LongInt: -2147483648
9229 {$IFNDEF PS_NOINT64}
9230 btS64 : Stack.SetInt64(-1,Low(Int64)); //Int64: -9223372036854775808
9231 {$ENDIF}
9232 else Result:=false;
9233 end;
9234 end;
9235
High_null9236 function High_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
9237 var
9238 arr: TPSVariantIFC;
9239 begin
9240 Result:=true;
9241 arr:=NewTPSVariantIFC(Stack[Stack.Count-2],false);
9242 case arr.aType.BaseType of
9243 btArray : Stack.SetInt(-1,PSDynArrayGetLength(Pointer(arr.Dta^),arr.aType)-1);
9244 btStaticArray: Stack.SetInt(-1,TPSTypeRec_StaticArray(arr.aType).StartOffset+TPSTypeRec_StaticArray(arr.aType).Size-1);
9245 btString : Stack.SetInt(-1,Length(tbtstring(arr.Dta^)));
9246 btU8 : Stack.SetInt(-1,High(Byte)); //Byte: 255
9247 btS8 : Stack.SetInt(-1,High(ShortInt)); //ShortInt: 127
9248 btU16 : Stack.SetInt(-1,High(Word)); //Word: 65535
9249 btS16 : Stack.SetInt(-1,High(SmallInt)); //SmallInt: 32767
9250 btU32 : Stack.SetUInt(-1,High(Cardinal)); //Cardinal/LongWord: 4294967295
9251 btS32 : Stack.SetInt(-1,High(Integer)); //Integer/LongInt: 2147483647
9252 {$IFNDEF PS_NOINT64}
9253 btS64 : Stack.SetInt64(-1,High(Int64)); //Int64: 9223372036854775807
9254 {$ENDIF}
9255 else Result:=false;
9256 end;
9257 end;
9258
Dec_null9259 function Dec_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
9260 var
9261 arr: TPSVariantIFC;
9262 begin
9263 Result:=true;
9264 arr:=NewTPSVariantIFC(Stack[Stack.Count-1],true);
9265 case arr.aType.BaseType of
9266 btU8 : Stack.SetInt(-1,Tbtu8(arr.dta^)-1); //Byte
9267 btS8 : Stack.SetInt(-1,Tbts8(arr.dta^)-1); //ShortInt
9268 btU16 : Stack.SetInt(-1,Tbtu16(arr.dta^)-1); //Word
9269 btS16 : Stack.SetInt(-1,Tbts16(arr.dta^)-1); //SmallInt
9270 btU32 : Stack.SetInt(-1,Tbtu32(arr.dta^)-1); //Cardinal/LongWord
9271 btS32 : Stack.SetInt(-1,Tbts32(arr.dta^)-1); //Integer/LongInt
9272 {$IFNDEF PS_NOINT64}
9273 btS64 : Stack.SetInt64(-1,Tbts64(arr.dta^)-1);
9274 {$ENDIF}
9275 else Result:=false;
9276 end;
9277 end;
9278
Inc_null9279 function Inc_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
9280 var
9281 arr: TPSVariantIFC;
9282 begin
9283 Result:=true;
9284 arr:=NewTPSVariantIFC(Stack[Stack.Count-1],true);
9285 case arr.aType.BaseType of
9286 btU8 : Stack.SetInt(-1,Tbtu8(arr.dta^)+1); //Byte
9287 btS8 : Stack.SetInt(-1,Tbts8(arr.dta^)+1); //ShortInt
9288 btU16 : Stack.SetInt(-1,Tbtu16(arr.dta^)+1); //Word
9289 btS16 : Stack.SetInt(-1,Tbts16(arr.dta^)+1); //SmallInt
9290 btU32 : Stack.SetInt(-1,Tbtu32(arr.dta^)+1); //Cardinal/LongWord
9291 btS32 : Stack.SetInt(-1,Tbts32(arr.dta^)+1); //Integer/LongInt
9292 {$IFNDEF PS_NOINT64}
9293 btS64 : Stack.SetInt64(-1,Tbts64(arr.dta^)+1);
9294 {$ENDIF}
9295 else Result:=false;
9296 end;
9297 end;
9298
Include_null9299 function Include_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
9300 var
9301 TheSet, NewMember: TPSVariantIFC;
9302 SetData: PByteArray;
9303 Val: Tbtu8;
9304 begin
9305 TheSet:=NewTPSVariantIFC(Stack[Stack.Count-1],true);
9306 NewMember:=NewTPSVariantIFC(Stack[Stack.Count-2],false);
9307 Result := (TheSet.aType.BaseType = btSet) and (NewMember.aType.BaseType = btU8);
9308 if not Result then Exit;
9309 SetData := TheSet.Dta;
9310 Val := Tbtu8(NewMember.dta^);
9311 SetData^[Val shr 3] := SetData^[Val shr 3] or (1 shl (Val and 7));
9312 end;
9313
Exclude_null9314 function Exclude_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
9315 var
9316 TheSet, NewMember: TPSVariantIFC;
9317 SetData: PByteArray;
9318 Val: Tbtu8;
9319 begin
9320 TheSet:=NewTPSVariantIFC(Stack[Stack.Count-1],true);
9321 NewMember:=NewTPSVariantIFC(Stack[Stack.Count-2],false);
9322 Result := (TheSet.aType.BaseType = btSet) and (NewMember.aType.BaseType = btU8);
9323 if not Result then Exit;
9324 SetData := TheSet.Dta;
9325 Val := Tbtu8(NewMember.dta^);
9326 SetData^[Val shr 3] := SetData^[Val shr 3] and not (1 shl (Val and 7));
9327 end;
9328
9329
9330 {$IFDEF DELPHI6UP}
_VarArrayGetnull9331 function _VarArrayGet(var S : Variant; I : Integer) : Variant;
9332 begin
9333 result := VarArrayGet(S, [I]);
9334 end;
9335
9336 procedure _VarArraySet(const c : Variant; I : Integer; var s : Variant);
9337 begin
9338 VarArrayPut(s, c, [i]);
9339 end;
9340 {$ENDIF}
9341
9342 procedure TPSExec.RegisterStandardProcs;
9343 begin
9344 { The following needs to be in synch in these 3 functions:
9345 -UPSCompiler.TPSPascalCompiler.DefineStandardProcedures
9346 -UPSRuntime.DefProc
9347 -UPSRuntime.TPSExec.RegisterStandardProcs
9348 }
9349 RegisterFunctionName('!NOTIFICATIONVARIANTSET', NVarProc, Pointer(0), nil);
9350 RegisterFunctionName('!NOTIFICATIONVARIANTGET', NVarProc, Pointer(1), nil);
9351
9352 RegisterFunctionName('IntToStr', DefProc, Pointer(0), nil);
9353 RegisterFunctionName('StrToInt', DefProc, Pointer(1), nil);
9354 RegisterFunctionName('StrToIntDef', DefProc, Pointer(2), nil);
9355 RegisterFunctionName('Pos', DefProc, Pointer(3), nil);
9356 RegisterFunctionName('Copy', DefProc, Pointer(4), nil);
9357 RegisterFunctionName('Delete', DefProc, Pointer(5), nil);
9358 RegisterFunctionName('Insert', DefProc, Pointer(6), nil);
9359
9360 RegisterFunctionName('StrGet', DefProc, Pointer(7), nil);
9361 RegisterFunctionName('StrSet', DefProc, Pointer(8), nil);
9362 RegisterFunctionName('UpperCase', DefProc, Pointer(10), nil);
9363 RegisterFunctionName('LowerCase', DefProc, Pointer(11), nil);
9364 RegisterFunctionName('Trim', DefProc, Pointer(12), nil);
9365
9366 RegisterFunctionName('Length',Length_,nil,nil);
9367 RegisterFunctionName('SetLength',SetLength_,nil,nil);
9368 RegisterFunctionName('Low',Low_,nil,nil);
9369 RegisterFunctionName('High',High_,nil,nil);
9370 RegisterFunctionName('Dec',Dec_,nil,nil);
9371 RegisterFunctionName('Inc',Inc_,nil,nil);
9372 RegisterFunctionName('Include',Include_,nil,nil);
9373 RegisterFunctionName('Exclude',Exclude_,nil,nil);
9374
9375 RegisterFunctionName('Sin', DefProc, Pointer(15), nil);
9376 RegisterFunctionName('Cos', DefProc, Pointer(16), nil);
9377 RegisterFunctionName('Sqrt', DefProc, Pointer(17), nil);
9378 RegisterFunctionName('Round', DefProc, Pointer(18), nil);
9379 RegisterFunctionName('Trunc', DefProc, Pointer(19), nil);
9380 RegisterFunctionName('Int', DefProc, Pointer(20), nil);
9381 RegisterFunctionName('Pi', DefProc, Pointer(21), nil);
9382 RegisterFunctionName('Abs', DefProc, Pointer(22), nil);
9383 RegisterFunctionName('StrToFloat', DefProc, Pointer(23), nil);
9384 RegisterFunctionName('FloatToStr', DefProc, Pointer(24), nil);
9385 RegisterFunctionName('PadL', DefProc, Pointer(25), nil);
9386 RegisterFunctionName('PadR', DefProc, Pointer(26), nil);
9387 RegisterFunctionName('PadZ', DefProc, Pointer(27), nil);
9388 RegisterFunctionName('Replicate', DefProc, Pointer(28), nil);
9389 RegisterFunctionName('StringOfChar', DefProc, Pointer(28), nil);
9390 RegisterFunctionName('!ASSIGNED', DefProc, Pointer(29), nil);
9391
Unassignednull9392 RegisterDelphiFunction(@Unassigned, 'Unassigned', cdRegister);
VarIsEmptynull9393 RegisterDelphiFunction(@VarIsEmpty, 'VarIsEmpty', cdRegister);
9394 {$IFDEF DELPHI7UP}
VarIsClearnull9395 RegisterDelphiFunction(@VarIsClear, 'VarIsClear', cdRegister);
9396 {$ENDIF}
Nullnull9397 RegisterDelphiFunction(@Null, 'Null', cdRegister);
VarIsNullnull9398 RegisterDelphiFunction(@VarIsNull, 'VarIsNull', cdRegister);
9399 RegisterDelphiFunction(@{$IFDEF FPC}variants.{$ENDIF}VarType, 'VarType', cdRegister);
9400 {$IFNDEF PS_NOIDISPATCH}
IDispatchInvokenull9401 RegisterDelphiFunction(@IDispatchInvoke, 'IdispatchInvoke', cdregister);
9402 {$ENDIF}
9403
9404
9405 RegisterFunctionName('GetArrayLength', GetArrayLength, nil, nil);
9406 RegisterFunctionName('SetArrayLength', SetArrayLength, nil, nil);
9407
9408 RegisterFunctionName('RaiseLastException', DefPRoc, Pointer(30), nil);
9409 RegisterFunctionName('RaiseException', DefPRoc, Pointer(31), nil);
9410 RegisterFunctionName('ExceptionType', DefPRoc, Pointer(32), nil);
9411 RegisterFunctionName('ExceptionParam', DefPRoc, Pointer(33), nil);
9412 RegisterFunctionName('ExceptionProc', DefPRoc, Pointer(34), nil);
9413 RegisterFunctionName('ExceptionPos', DefPRoc, Pointer(35), nil);
9414 RegisterFunctionName('ExceptionToString', DefProc, Pointer(36), nil);
9415 RegisterFunctionName('AnsiUpperCase', DefProc, Pointer(37), nil);
9416 RegisterFunctionName('AnsiLowerCase', DefProc, Pointer(38), nil);
9417
9418 {$IFNDEF PS_NOINT64}
9419 RegisterFunctionName('StrToInt64', DefProc, Pointer(39), nil);
9420 RegisterFunctionName('Int64ToStr', DefProc, Pointer(40), nil);
9421 RegisterFunctionName('StrToInt64Def', DefProc, Pointer(41), nil);
9422 {$ENDIF}
9423 RegisterFunctionName('SizeOf', DefProc, Pointer(42), nil);
9424
9425 {$IFNDEF PS_NOWIDESTRING}
9426 RegisterFunctionName('WStrGet', DefProc, Pointer(43), nil);
9427 RegisterFunctionName('WStrSet', DefProc, Pointer(44), nil);
9428
9429 {$ENDIF}
9430 {$IFDEF DELPHI6UP}
_VarArrayGetnull9431 RegisterDelphiFunction(@_VarArrayGet, 'VarArrayGet', cdRegister);
_VarArraySetnull9432 RegisterDelphiFunction(@_VarArraySet, 'VarArraySet', cdRegister);
9433 {$ENDIF}
9434 RegisterInterfaceLibraryRuntime(Self);
9435 end;
9436
9437
ToStringnull9438 function ToString(p: PansiChar): tbtString;
9439 begin
9440 SetString(Result, p, {$IFDEF DELPHI_TOKYO_UP}AnsiStrings.{$ENDIF}StrLen(p));
9441 end;
9442
IntPIFVariantToVariantnull9443 function IntPIFVariantToVariant(Src: pointer; aType: TPSTypeRec; var Dest: Variant): Boolean;
BuildArraynull9444 function BuildArray(P: Pointer; aType: TPSTypeRec; Len: Longint): Boolean;
9445 var
9446 i, elsize: Longint;
9447 v: variant;
9448 begin
9449 elsize := aType.RealSize;
9450 Dest := VarArrayCreate([0, Len-1], varVariant);
9451 for i := 0 to Len -1 do
9452 begin
9453 if not IntPIFVariantToVariant(p, aType, v) then
9454 begin
9455 result := false;
9456 exit;
9457 end;
9458 Dest[i] := v;
9459 p := Pointer(IPointer(p) + Cardinal(elSize));
9460 end;
9461 result := true;
9462 end;
9463 begin
9464 if aType = nil then
9465 begin
9466 Dest := null;
9467 Result := True;
9468 exit;
9469 end;
9470 if aType.BaseType = btPointer then
9471 begin
9472 aType := TPSTypeRec(Pointer(IPointer(src)+PointerSize)^);
9473 Src := Pointer(Pointer(Src)^);
9474 end;
9475
9476 case aType.BaseType of
9477 btVariant: Dest := variant(src^);
9478 btArray: if not BuildArray(Pointer(Src^), TPSTypeRec_Array(aType).ArrayType, PSDynArrayGetLength(Pointer(src^), aType)) then begin result := false; exit; end;
9479 btStaticArray: if not BuildArray(Pointer(Src), TPSTypeRec_StaticArray(aType).ArrayType, PSDynArrayGetLength(Pointer(src^), aType)) then begin result := false; exit; end;
9480 btU8:
9481 if aType.ExportName = 'BOOLEAN' then
9482 Dest := boolean(tbtu8(Src^) <> 0)
9483 else
9484 Dest := tbtu8(Src^);
9485 btS8: Dest := tbts8(Src^);
9486 btU16: Dest := tbtu16(Src^);
9487 btS16: Dest := tbts16(Src^);
9488 btU32: Dest := {$IFDEF DELPHI6UP}tbtu32{$ELSE}tbts32{$ENDIF}(Src^);
9489 btS32: Dest := tbts32(Src^);
9490 btSingle: Dest := tbtsingle(Src^);
9491 btCurrency: Dest:=tbtCurrency(Src^);
9492 btDouble:
9493 begin
9494 if aType.ExportName = 'TDATETIME' then
9495 Dest := TDateTime(tbtDouble(Src^))
9496 else
9497 Dest := tbtDouble(Src^);
9498 end;
9499 btExtended: Dest := tbtExtended(Src^);
9500 btString: Dest := tbtString(Src^);
9501 btPChar: Dest := ToString(PansiChar(Src^));
9502 {$IFNDEF PS_NOINT64}
9503 {$IFDEF DELPHI6UP} btS64: Dest := tbts64(Src^); {$ELSE} bts64: begin Result := False; exit; end; {$ENDIF}
9504 {$ENDIF}
9505 btChar: Dest := tbtString(tbtchar(src^));
9506 {$IFNDEF PS_NOWIDESTRING}
9507 btWideString: Dest := tbtWideString(src^);
9508 btWideChar: Dest := tbtwidestring(tbtwidechar(src^));
9509 btUnicodeString: Dest := tbtUnicodeString(src^);
9510 {$ENDIF}
9511 else
9512 begin
9513 Result := False;
9514 exit;
9515 end;
9516 end;
9517 Result := True;
9518 end;
9519
PIFVariantToVariantnull9520 function PIFVariantToVariant(Src: PIFVariant; var Dest: Variant): Boolean;
9521 begin
9522 Result := IntPIFVariantToVariant(@PPSVariantData(src).Data, Src.FType, Dest);
9523 end;
9524
VariantToPIFVariantnull9525 function VariantToPIFVariant(Exec: TPSExec; const Src: Variant; Dest: PIFVariant): Boolean;
9526 var
9527 TT: PIFTypeRec;
9528 begin
9529 if Dest = nil then begin Result := false; exit; end;
9530 tt := Exec.FindType2(btVariant);
9531 if tt = nil then begin Result := false; exit; end;
9532 if Dest.FType.BaseType = btPointer then
9533 Result := Exec.SetVariantValue(PPSVariantPointer(Dest).DataDest, @Src, PPSVariantPointer(Dest).DestType, tt)
9534 else
9535 Result := Exec.SetVariantValue(@PPSVariantData(Dest).Data, @Src, Dest.FType, tt);
9536 end;
9537
9538 type
9539 POpenArray = ^TOpenArray;
9540 TOpenArray = record
9541 AType: Byte; {0}
9542 OrgVar: PPSVariantIFC;
9543 FreeIt: Boolean;
9544 ElementSize,
9545 ItemCount: Longint;
9546 Data: Pointer;
9547 VarParam: Boolean;
9548 end;
CreateOpenArraynull9549 function CreateOpenArray(VarParam: Boolean; Sender: TPSExec; val: PPSVariantIFC): POpenArray;
9550 var
9551 datap, p: Pointer;
9552 ctype: TPSTypeRec;
9553 cp: Pointer;
9554 i: Longint;
9555 begin
9556 if (Val.aType.BaseType <> btArray) and (val.aType.BaseType <> btStaticArray) then
9557 begin
9558 Result := nil;
9559 exit;
9560 end;
9561 New(Result);
9562 Result.AType := 0;
9563 Result.OrgVar := Val;
9564 Result.VarParam := VarParam;
9565
9566 if val.aType.BaseType = btStaticArray then
9567 begin
9568 Result^.ItemCount := TPSTypeRec_StaticArray(val.aType).Size;
9569 datap := Val.Dta;
9570 end else
9571 begin
9572 Result^.ItemCount := PSDynArrayGetLength(Pointer(Val.Dta^), val.aType);
9573 datap := Pointer(Val.Dta^);
9574 end;
9575 if TPSTypeRec_Array(Val.aType).ArrayType.BaseType <> btPointer then
9576 begin
9577 Result.FreeIt := False;
9578 result.ElementSize := 0;
9579 Result.Data := datap;
9580 exit;
9581 end;
9582 Result.FreeIt := True;
9583 Result.ElementSize := sizeof(TVarRec);
9584 GetMem(Result.Data, Result.ItemCount * Result.ElementSize);
9585 P := Result.Data;
9586 FillChar(p^, Result^.ItemCount * Result^.ElementSize, 0);
9587 for i := 0 to Result^.ItemCount -1 do
9588 begin
9589 ctype := Pointer(Pointer(IPointer(datap)+PointerSize)^);
9590 cp := Pointer(Datap^);
9591 if cp = nil then
9592 begin
9593 tvarrec(p^).VType := vtPointer;
9594 tvarrec(p^).VPointer := nil;
9595 end else begin
9596 case ctype.BaseType of
9597 btVariant: begin
9598 tvarrec(p^).VType := vtVariant;
9599 tvarrec(p^).VVariant := cp;
9600 end;
9601 btchar: begin
9602 tvarrec(p^).VType := vtChar;
9603 tvarrec(p^).VChar := tbtChar(tbtchar(cp^));
9604 end;
9605 btSingle:
9606 begin
9607 tvarrec(p^).VType := vtExtended;
9608 New(tvarrec(p^).VExtended);
9609 tvarrec(p^).VExtended^ := tbtsingle(cp^);
9610 end;
9611 btExtended:
9612 begin
9613 tvarrec(p^).VType := vtExtended;
9614 New(tvarrec(p^).VExtended);
9615 tvarrec(p^).VExtended^ := tbtextended(cp^);;
9616 end;
9617 btDouble:
9618 begin
9619 tvarrec(p^).VType := vtExtended;
9620 New(tvarrec(p^).VExtended);
9621 tvarrec(p^).VExtended^ := tbtdouble(cp^);
9622 end;
9623 {$IFNDEF PS_NOWIDESTRING}
9624 btwidechar: begin
9625 tvarrec(p^).VType := vtWideChar;
9626 tvarrec(p^).VWideChar := tbtwidechar(cp^);
9627 end;
9628 {$IFDEF DELPHI2009UP}
9629 btUnicodeString: begin
9630 tvarrec(p^).VType := vtUnicodeString;
9631 tbtunicodestring(TVarRec(p^).VUnicodeString) := tbtunicodestring(cp^);
9632 end;
9633 {$ELSE}
9634 btUnicodeString,
9635 {$ENDIF}
9636 btwideString: begin
9637 tvarrec(p^).VType := vtWideString;
9638 tbtwidestring(TVarRec(p^).VWideString) := tbtwidestring(cp^);
9639 end;
9640 {$ENDIF}
9641 btU8: begin
9642 tvarrec(p^).VType := vtInteger;
9643 tvarrec(p^).VInteger := tbtu8(cp^);
9644 end;
9645 btS8: begin
9646 tvarrec(p^).VType := vtInteger;
9647 tvarrec(p^).VInteger := tbts8(cp^);
9648 end;
9649 btU16: begin
9650 tvarrec(p^).VType := vtInteger;
9651 tvarrec(p^).VInteger := tbtu16(cp^);
9652 end;
9653 btS16: begin
9654 tvarrec(p^).VType := vtInteger;
9655 tvarrec(p^).VInteger := tbts16(cp^);
9656 end;
9657 btU32: begin
9658 tvarrec(p^).VType := vtInteger;
9659 tvarrec(p^).VInteger := tbtu32(cp^);
9660 end;
9661 btS32: begin
9662 tvarrec(p^).VType := vtInteger;
9663 tvarrec(p^).VInteger := tbts32(cp^);
9664 end;
9665 {$IFNDEF PS_NOINT64}
9666 btS64: begin
9667 tvarrec(p^).VType := vtInt64;
9668 New(tvarrec(p^).VInt64);
9669 tvarrec(p^).VInt64^ := tbts64(cp^);
9670 end;
9671 {$ENDIF}
9672 btString: begin
9673 tvarrec(p^).VType := vtAnsiString;
9674 tbtString(TVarRec(p^).VAnsiString) := tbtstring(cp^);
9675 end;
9676 btPChar:
9677 begin
9678 tvarrec(p^).VType := vtPchar;
9679 TVarRec(p^).VPChar := pointer(cp^);
9680 end;
9681 btClass:
9682 begin
9683 tvarrec(p^).VType := vtObject;
9684 tvarrec(p^).VObject := Pointer(cp^);
9685 end;
9686 {$IFNDEF PS_NOINTERFACES}
9687 {$IFDEF Delphi3UP}
9688 btInterface:
9689 begin
9690 tvarrec(p^).VType := vtInterface;
9691 IUnknown(tvarrec(p^).VInterface) := IUnknown(cp^);
9692 end;
9693
9694 {$ENDIF}
9695 {$ENDIF}
9696 end;
9697 end;
9698 datap := Pointer(IPointer(datap)+ (3*sizeof(Pointer)));
9699 p := PansiChar(p) + Result^.ElementSize;
9700 end;
9701 end;
9702
9703 procedure DestroyOpenArray(Sender: TPSExec; V: POpenArray);
9704 var
9705 cp, datap: pointer;
9706 ctype: TPSTypeRec;
9707 p: PVarRec;
9708 i: Longint;
9709 begin
9710 if v.FreeIt then // basetype = btPointer
9711 begin
9712 p := v^.Data;
9713 if v.OrgVar.aType.BaseType = btStaticArray then
9714 datap := v.OrgVar.Dta
9715 else
9716 datap := Pointer(v.OrgVar.Dta^);
9717 for i := 0 to v^.ItemCount -1 do
9718 begin
9719 ctype := Pointer(Pointer(IPointer(datap)+PointerSize)^);
9720 cp := Pointer(Datap^);
9721 case ctype.BaseType of
9722 btU8:
9723 begin
9724 if v^.varParam then
9725 tbtu8(cp^) := tvarrec(p^).VInteger
9726 end;
9727 btS8: begin
9728 if v^.varParam then
9729 tbts8(cp^) := tvarrec(p^).VInteger
9730 end;
9731 btU16: begin
9732 if v^.varParam then
9733 tbtu16(cp^) := tvarrec(p^).VInteger
9734 end;
9735 btS16: begin
9736 if v^.varParam then
9737 tbts16(cp^) := tvarrec(p^).VInteger
9738 end;
9739 btU32: begin
9740 if v^.varParam then
9741 tbtu32(cp^) := tvarrec(p^).VInteger
9742 end;
9743 btS32: begin
9744 if v^.varParam then
9745 tbts32(cp^) := tvarrec(p^).VInteger
9746 end;
9747 btChar: begin
9748 if v^.VarParam then
9749 tbtchar(cp^) := tbtChar(tvarrec(p^).VChar)
9750 end;
9751 btSingle: begin
9752 if v^.VarParam then
9753 tbtsingle(cp^) := tvarrec(p^).vextended^;
9754 dispose(tvarrec(p^).vextended);
9755 end;
9756 btDouble: begin
9757 if v^.VarParam then
9758 tbtdouble(cp^) := tvarrec(p^).vextended^;
9759 dispose(tvarrec(p^).vextended);
9760 end;
9761 btExtended: begin
9762 if v^.VarParam then
9763 tbtextended(cp^) := tvarrec(p^).vextended^;
9764 dispose(tvarrec(p^).vextended);
9765 end;
9766 {$IFNDEF PS_NOINT64}
9767 btS64: begin
9768 if v^.VarParam then
9769 tbts64(cp^) := tvarrec(p^).vInt64^;
9770 dispose(tvarrec(p^).VInt64);
9771 end;
9772 {$ENDIF}
9773 {$IFNDEF PS_NOWIDESTRING}
9774 btWideChar: begin
9775 if v^.varParam then
9776 tbtwidechar(cp^) := tvarrec(p^).VWideChar;
9777 end;
9778 {$IFDEF DELPHI2009UP}
9779 btUnicodeString:
9780 begin
9781 if v^.VarParam then
9782 tbtunicodestring(cp^) := tbtunicodestring(TVarRec(p^).VUnicodeString);
9783 finalize(tbtunicodestring(TVarRec(p^).VUnicodeString));
9784 end;
9785 {$ELSE}
9786 btUnicodeString,
9787 {$ENDIF}
9788 btWideString:
9789 begin
9790 if v^.VarParam then
9791 tbtwidestring(cp^) := tbtwidestring(TVarRec(p^).VWideString);
9792 finalize(widestring(TVarRec(p^).VWideString));
9793 end;
9794 {$ENDIF}
9795 btString: begin
9796 if v^.VarParam then
9797 tbtstring(cp^) := tbtstring(TVarRec(p^).VString);
9798 finalize(tbtString(TVarRec(p^).VAnsiString));
9799 end;
9800 btClass: begin
9801 if v^.VarParam then
9802 Pointer(cp^) := TVarRec(p^).VObject;
9803 end;
9804 {$IFNDEF PS_NOINTERFACES}
9805 {$IFDEF Delphi3UP}
9806 btInterface: begin
9807 if v^.VarParam then
9808 IUnknown(cp^) := IUnknown(TVarRec(p^).VInterface);
9809 finalize(tbtString(TVarRec(p^).VAnsiString));
9810 end;
9811 {$ENDIF}
9812 {$ENDIF}
9813 end;
9814 datap := Pointer(IPointer(datap)+ (3*sizeof(Pointer)));
9815 p := Pointer(IPointer(p) + Cardinal(v^.ElementSize));
9816 end;
9817 FreeMem(v.Data, v.ElementSize * v.ItemCount);
9818 end;
9819 Dispose(V);
9820 end;
9821
9822
9823 {$ifndef FPC}
9824 {$IFDEF Delphi6UP}
9825 {$IFDEF CPUX64}
9826 {$include x64.inc}
9827 {$ELSE}
9828 {$include x86.inc}
9829 {$ENDIF}
9830 {$ELSE}
9831 {$include x86.inc}
9832 {$ENDIF}
9833 {$else}
9834 {$IFDEF Delphi6UP}
9835 {$if defined(cpu86)}
9836 {$include x86.inc}
9837 {$elseif defined(cpupowerpc)}
9838 {$include powerpc.inc}
9839 {$elseif defined(cpuarm)}
9840 {$include arm.inc}
9841 {$elseif defined(CPUX86_64)}
9842 {$include x64.inc}
9843 {$else}
9844 {$WARNING Pascal Script is not supported for your architecture at the moment!}
TPSExec.InnerfuseCallnull9845 function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean;
9846 begin
9847 raise exception.create('This code is not supported on this CPU at the moment!');
9848 Result := True;
9849 end;
9850 {$ifend}
9851 {$ELSE}
9852 {$include x86.inc}
9853 {$ENDIF}
9854 {$endif}
9855
9856 type
9857 PScriptMethodInfo = ^TScriptMethodInfo;
9858 TScriptMethodInfo = record
9859 Se: TPSExec;
9860 ProcNo: Cardinal;
9861 end;
9862
9863
MkMethodnull9864 function MkMethod(FSE: TPSExec; No: Cardinal): TMethod;
9865 begin
9866 if (no = 0) or (no = InvalidVal) then
9867 begin
9868 Result.Code := nil;
9869 Result.Data := nil;
9870 end else begin
9871 Result.Code := @MyAllMethodsHandler;
9872 Result.Data := GetMethodInfoRec(FSE, No);
9873 end;
9874 end;
9875
9876
9877 procedure PFree(Sender: TPSExec; P: PScriptMethodInfo);
9878 begin
9879 Dispose(p);
9880 end;
9881
GetMethodInfoRecnull9882 function GetMethodInfoRec(SE: TPSExec; ProcNo: Cardinal): Pointer;
9883 var
9884 I: Longint;
9885 pp: PScriptMethodInfo;
9886 begin
9887 if (ProcNo = 0) or (ProcNo = InvalidVal) then
9888 begin
9889 Result := nil;
9890 exit;
9891 end;
9892 I := 2147483647;
9893 repeat
9894 pp := Se.FindProcResource2(@PFree, I);
9895 if (i <> -1) and (pp^.ProcNo = ProcNo) then
9896 begin
9897 Result := Pp;
9898 exit;
9899 end;
9900 until i = -1;
9901 New(pp);
9902 pp^.Se := TPSExec(Se);
9903 pp^.ProcNo := Procno;
9904 Se.AddResource(@PFree, pp);
9905 Result := pp;
9906 end;
9907
9908
9909
9910
9911
9912 type
9913 TPtrArr = array[0..1000] of Pointer;
9914 PPtrArr = ^TPtrArr;
9915 TByteArr = array[0..1000] of byte;
9916 PByteArr = ^TByteArr;
9917 PPointer = ^Pointer;
9918
9919
VirtualMethodPtrToPtrnull9920 function VirtualMethodPtrToPtr(Ptr, FSelf: Pointer): Pointer;
9921 {$IFDEF FPC}
9922 var
9923 x : PPtrArr;
9924 {$ENDIF}
9925 begin
9926 {$IFDEF FPC}
9927 x := Pointer(TObject(FSelf).ClassType) + vmtMethodStart;
9928 Result := x^[Longint(Ptr)];
9929 {$ELSE}
9930 Result := PPtrArr(PPointer(FSelf)^)^[Longint(Ptr)];
9931 {$ENDIF}
9932 end;
9933
VirtualClassMethodPtrToPtrnull9934 function VirtualClassMethodPtrToPtr(Ptr, FSelf: Pointer): Pointer;
9935 {$IFDEF FPC}
9936 var
9937 x : PPtrArr;
9938 {$ENDIF}
9939 begin
9940 {$IFDEF FPC}
9941 x := Pointer(FSelf) + vmtMethodStart;
9942 Result := x^[Longint(Ptr)];
9943 {$ELSE}
9944 Result := PPtrArr(FSelf)^[Longint(Ptr)];
9945 {$ENDIF}
9946 end;
9947
9948
9949 procedure CheckPackagePtr(var P: PByteArr);
9950 begin
9951 {$ifdef Win32}
9952 if (word((@p[0])^) = $25FF) and (word((@p[6])^)=$C08B)then
9953 begin
9954 p := PPointer((@p[2])^)^;
9955 end;
9956 {$endif}
9957 {$ifdef Win64}
9958 if (word((@p[0])^) = $25FF) {and (word((@p[6])^)=$C08B)}then
9959 begin
9960 p := PPointer(NativeUInt(@P[0]) + Cardinal((@p[2])^) + 6{Instruction Size})^
9961 end;
9962 {$endif}
9963 end;
9964
9965 {$IFDEF VER90}{$DEFINE NO_vmtSelfPtr}{$ENDIF}
9966 {$IFDEF FPC}{$DEFINE NO_vmtSelfPtr}{$ENDIF}
9967
9968 {$IFNDEF FPC}
9969
FindVirtualMethodPtrnull9970 function FindVirtualMethodPtr(Ret: TPSRuntimeClass; FClass: TClass; Ptr: Pointer): Pointer;
9971 // Idea of getting the number of VMT items from GExperts
9972 var
9973 p: PPtrArr;
9974 I: Longint;
9975 begin
9976 p := Pointer(FClass);
9977 CheckPackagePtr(PByteArr(Ptr));
9978 if Ret.FEndOfVMT = MaxInt then
9979 begin
9980 I := {$IFDEF NO_vmtSelfPtr}-48{$ELSE}vmtSelfPtr{$ENDIF} div SizeOf(Pointer) + 1;
9981 while I < 0 do
9982 begin
9983 if I < 0 then
9984 begin
9985 if I <> ({$IFDEF VER90}-44{$ELSE}vmtTypeInfo{$ENDIF} div SizeOf(Pointer)) then
9986 begin // from GExperts code
9987 if (IPointer(p^[I]) > IPointer(p)) and ((IPointer(p^[I]) - IPointer(p))
9988 div
9989 //PointerSize < Ret.FEndOfVMT) then
9990 PointerSize < Cardinal(Ret.FEndOfVMT)) then
9991 begin
9992 Ret.FEndOfVMT := (IPointer(p^[I]) - IPointer(p)) div SizeOf(Pointer);
9993 end;
9994 end;
9995 end;
9996 Inc(I);
9997 end;
9998 if Ret.FEndOfVMT = MaxInt then
9999 begin
10000 Ret.FEndOfVMT := 0; // cound not find EndOfVMT
10001 Result := nil;
10002 exit;
10003 end;
10004 end;
10005 I := 0;
10006 while I < Ret.FEndOfVMT do
10007 begin
10008 if p^[I] = Ptr then
10009 begin
10010 Result := Pointer(I);
10011 exit;
10012 end;
10013 I := I + 1;
10014 end;
10015 Result := nil;
10016 end;
10017
10018 {$ELSE}
10019
FindVirtualMethodPtrnull10020 function FindVirtualMethodPtr(Ret: TPSRuntimeClass; FClass: TClass; Ptr: Pointer): Pointer;
10021 var
10022 x,p: PPtrArr;
10023 I: Longint;
10024 t : Pointer;
10025 begin
10026 p := Pointer(FClass) + vmtMethodStart;
10027 I := 0;
10028 while (p^[I]<>nil) and (I < 10000) do
10029 begin
10030 if p^[I] = Ptr then
10031 begin
10032 Result := Pointer(I);
10033 x := Pointer(FClass) + vmtMethodStart;
10034 t := x^[I];
10035 Assert(t=Ptr,'Computation of virtual method pointer fail : t<>Ptr');
10036 exit;
10037 end;
10038 I := I + 1;
10039 end;
10040 Result := nil;
10041 end;
10042
10043 {$ENDIF}
10044
10045
NewTPSVariantIFCnull10046 function NewTPSVariantIFC(avar: PPSVariant; varparam: boolean): TPSVariantIFC;
10047 begin
10048 Result.VarParam := varparam;
10049 if avar = nil then
10050 begin
10051 Result.aType := nil;
10052 result.Dta := nil;
10053 end else
10054 begin
10055 Result.aType := avar.FType;
10056 result.Dta := @PPSVariantData(avar).Data;
10057 if Result.aType.BaseType = btPointer then
10058 begin
10059 Result.aType := Pointer(Pointer(IPointer(result.dta)+ PointerSize)^);
10060 Result.Dta := Pointer(Result.dta^);
10061 end;
10062 end;
10063 end;
10064
NewTPSVariantRecordIFCnull10065 function NewTPSVariantRecordIFC(avar: PPSVariant; Fieldno: Longint): TPSVariantIFC;
10066 var
10067 offs: Cardinal;
10068 begin
10069 Result := NewTPSVariantIFC(avar, false);
10070 if Result.aType.BaseType = btRecord then
10071 begin
10072 Offs := Cardinal(TPSTypeRec_Record(Result.aType).RealFieldOffsets[FieldNo]);
10073 Result.Dta := Pointer(IPointer(Result.dta) + Offs);
10074 Result.aType := TPSTypeRec_Record(Result.aType).FieldTypes[FieldNo];
10075 end else
10076 begin
10077 Result.Dta := nil;
10078 Result.aType := nil;
10079 end;
10080 end;
10081
PSGetArrayFieldnull10082 function PSGetArrayField(const avar: TPSVariantIFC; Fieldno: Longint): TPSVariantIFC;
10083 var
10084 offs: Cardinal;
10085 n: Longint;
10086 begin
10087 Result := aVar;
10088 case Result.aType.BaseType of
10089 btStaticArray, btArray:
10090 begin
10091 if Result.aType.BaseType = btStaticArray then
10092 n := TPSTypeRec_StaticArray(Result.aType).Size
10093 else
10094 n := PSDynArrayGetLength(Pointer(Result.Dta^), Result.aType);
10095 if (FieldNo <0) or (FieldNo >= n) then
10096 begin
10097 Result.Dta := nil;
10098 Result.aType := nil;
10099 exit;
10100 end;
10101 Offs := TPSTypeRec_Array(Result.aType).ArrayType.RealSize * Cardinal(FieldNo);
10102 if Result.aType.BaseType = btStaticArray then
10103 Result.Dta := Pointer(IPointer(Result.dta) + Offs)
10104 else
10105 Result.Dta := Pointer(IPointer(Result.dta^) + Offs);
10106 Result.aType := TPSTypeRec_Array(Result.aType).ArrayType;
10107 end
10108 else
10109 Result.Dta := nil;
10110 Result.aType := nil;
10111 end;
10112 end;
10113
PSGetRecFieldnull10114 function PSGetRecField(const avar: TPSVariantIFC; Fieldno: Longint): TPSVariantIFC;
10115 var
10116 offs: Cardinal;
10117 begin
10118 Result := aVar;
10119 if Result.aType.BaseType = btRecord then
10120 begin
10121 Offs := Cardinal(TPSTypeRec_Record(Result.aType).RealFieldOffsets[FieldNo]);
10122 Result.aType := TPSTypeRec_Record(Result.aType).FieldTypes[FieldNo];
10123 Result.Dta := Pointer(IPointer(Result.dta) + Offs);
10124 end else
10125 begin
10126 Result.Dta := nil;
10127 Result.aType := nil;
10128 end;
10129 end;
10130
NewPPSVariantIFCnull10131 function NewPPSVariantIFC(avar: PPSVariant; varparam: boolean): PPSVariantIFC;
10132 begin
10133 New(Result);
10134 Result^ := NewTPSVariantIFC(avar, varparam);
10135 end;
10136
10137
10138 procedure DisposePPSVariantIFC(aVar: PPSVariantIFC);
10139 begin
10140 if avar <> nil then
10141 Dispose(avar);
10142 end;
10143
10144 procedure DisposePPSVariantIFCList(list: TPSList);
10145 var
10146 i: Longint;
10147 begin
10148 for i := list.Count -1 downto 0 do
10149 DisposePPSVariantIFC(list[i]);
10150 list.free;
10151 end;
10152
ClassCallProcMethodnull10153 function ClassCallProcMethod(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
10154 var
10155 i: Integer;
10156 MyList: TPSList;
10157 n: PIFVariant;
10158 v: PPSVariantIFC;
10159 FSelf: Pointer;
10160 CurrStack: Cardinal;
10161 cc: TPSCallingConvention;
10162 s: tbtString;
10163 begin
10164 s := p.Decl;
10165 if length(S) < 2 then
10166 begin
10167 Result := False;
10168 exit;
10169 end;
10170 cc := TPSCallingConvention(s[1]);
10171 Delete(s, 1, 1);
10172 if s[1] = #0 then
10173 n := Stack[Stack.Count -1]
10174 else
10175 n := Stack[Stack.Count -2];
10176 if (n = nil) or (n^.FType.BaseType <> btClass)or (PPSVariantClass(n).Data = nil) then
10177 begin
10178 Caller.CMD_Err(erNullPointerException);
10179 result := false;
10180 exit;
10181 end;
10182 FSelf := PPSVariantClass(n).Data;
10183 CurrStack := Cardinal(Stack.Count) - Cardinal(length(s)) -1;
10184 if s[1] = #0 then inc(CurrStack);
10185 MyList := TPSList.Create;
10186 for i := 2 to length(s) do
10187 begin
10188 MyList.Add(nil);
10189 end;
10190 for i := length(s) downto 2 do
10191 begin
10192 n := Stack[CurrStack];
10193 MyList[i - 2] := NewPPSVariantIFC(n, s[i] <> #0);
10194 inc(CurrStack);
10195 end;
10196 if s[1] <> #0 then
10197 begin
10198 v := NewPPSVariantIFC(Stack[CurrStack + 1], True);
10199 end else v := nil;
10200 try
10201 if p.Ext2 = nil then
10202 Result := Caller.InnerfuseCall(FSelf, p.Ext1, cc, MyList, v)
10203 else
10204 Result := Caller.InnerfuseCall(FSelf, VirtualMethodPtrToPtr(p.Ext1, FSelf), cc, MyList, v);
10205 finally
10206 DisposePPSVariantIFC(v);
10207 DisposePPSVariantIFCList(mylist);
10208 end;
10209 end;
10210
ClassCallProcConstructornull10211 function ClassCallProcConstructor(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
10212 var
10213 i, h: Longint;
10214 v: PPSVariantIFC;
10215 MyList: TPSList;
10216 n: PIFVariant;
10217 FSelf: Pointer;
10218 CurrStack: Cardinal;
10219 cc: TPSCallingConvention;
10220 s: tbtString;
10221 FType: PIFTypeRec;
10222 x: TPSRuntimeClass;
10223 IntVal: PIFVariant;
10224 begin
10225 n := Stack[Stack.Count -2];
10226 if (n = nil) or (n^.FType.BaseType <> btU32) then
10227 begin
10228 result := false;
10229 exit;
10230 end;
10231 FType := Caller.GetTypeNo(PPSVariantU32(N).Data);
10232 if (FType = nil) then
10233 begin
10234 Result := False;
10235 exit;
10236 end;
10237 h := MakeHash(FType.ExportName);
10238 FSelf := nil;
10239 for i := 0 to TPSRuntimeClassImporter(p.Ext2).FClasses.Count -1 do
10240 begin
10241 x:= TPSRuntimeClassImporter(p.Ext2).FClasses[i];
10242 if (x.FClassNameHash = h) and (x.FClassName = FType.ExportName) then
10243 begin
10244 FSelf := x.FClass;
10245 end;
10246 end;
10247 if FSelf = nil then begin
10248 Result := False;
10249 exit;
10250 end;
10251 s := p.Decl;
10252 if length(S) < 2 then
10253 begin
10254 Result := False;
10255 exit;
10256 end;
10257 cc := TPSCallingConvention(s[1]);
10258 Delete(s, 1, 1);
10259 CurrStack := Cardinal(Stack.Count) - Cardinal(length(s)) -1;
10260 if s[1] = #0 then inc(CurrStack);
10261 {$IFDEF CPU64}
10262 IntVal := CreateHeapVariant(Caller.FindType2(btS64));
10263 {$ELSE}
10264 IntVal := CreateHeapVariant(Caller.FindType2(btU32));
10265 {$ENDIF}
10266 if IntVal = nil then
10267 begin
10268 Result := False;
10269 exit;
10270 end;
10271 {$IFDEF FPC}
10272 // under FPC a constructor it's called with self=0 (EAX) and
10273 // the VMT class pointer in EDX so they are effectively swaped
10274 // using register calling convention
10275 {$IFDEF CPU64}
10276 PPSVariantS64(IntVal).Data := Int64(FSelf);
10277 {$ELSE}
10278 PPSVariantU32(IntVal).Data := Cardinal(FSelf);
10279 {$ENDIF}
10280 FSelf := pointer(1);
10281 {$ELSE}
10282 PPSVariantU32(IntVal).Data := 1;
10283 {$ENDIF}
10284 MyList := TPSList.Create;
10285 MyList.Add(NewPPSVariantIFC(intval, false));
10286 for i := 2 to length(s) do
10287 begin
10288 MyList.Add(nil);
10289 end;
10290 for i := length(s) downto 2 do
10291 begin
10292 n :=Stack[CurrStack];
10293 // if s[i] <> #0 then
10294 // begin
10295 // MyList[i - 2] := NewPPSVariantIFC(n, s[i] <> #0);
10296 // end;
10297 MyList[i - 1] := NewPPSVariantIFC(n, s[i] <> #0);
10298 inc(CurrStack);
10299 end;
10300 if s[1] <> #0 then
10301 begin
10302 v := NewPPSVariantIFC(Stack[CurrStack + 1], True);
10303 end else v := nil;
10304 try
10305 Result := Caller.InnerfuseCall(FSelf, p.Ext1, {$IFDEF FPC}TPSCallingConvention(Integer(cc) or 64){$ELSE}cc{$ENDIF}, MyList, v);
10306 finally
10307 DisposePPSVariantIFC(v);
10308 DisposePPSVariantIFCList(mylist);
10309 DestroyHeapVariant(intval);
10310 end;
10311 end;
10312
10313
10314 function ClassCallProcVirtualConstructor(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
10315 var
10316 i, h: Longint;
10317 v: PPSVariantIFC;
10318 MyList: TPSList;
10319 n: PIFVariant;
10320 FSelf: Pointer;
10321 CurrStack: Cardinal;
10322 cc: TPSCallingConvention;
10323 s: tbtString;
10324 FType: PIFTypeRec;
10325 x: TPSRuntimeClass;
10326 IntVal: PIFVariant;
10327 begin
10328 n := Stack[Stack.Count -2];
10329 if (n = nil) or (n^.FType.BaseType <> btU32) then
10330 begin
10331 Caller.CMD_Err(erNullPointerException);
10332 result := false;
10333 exit;
10334 end;
10335 FType := Caller.GetTypeNo(PPSVariantU32(N).Data);
10336 if (FType = nil) then
10337 begin
10338 Caller.CMD_Err(erNullPointerException);
10339 Result := False;
10340 exit;
10341 end;
10342 h := MakeHash(FType.ExportName);
10343 FSelf := nil;
10344 for i := 0 to TPSRuntimeClassImporter(p.Ext2).FClasses.Count -1 do
10345 begin
10346 x:= TPSRuntimeClassImporter(p.Ext2).FClasses[i];
10347 if (x.FClassNameHash = h) and (x.FClassName = FType.ExportName) then
10348 begin
10349 FSelf := x.FClass;
10350 end;
10351 end;
10352 if FSelf = nil then begin
10353 Result := False;
10354 exit;
10355 end;
10356 s := p.Decl;
10357 if length(S) < 2 then
10358 begin
10359 Result := False;
10360 exit;
10361 end;
10362 cc := TPSCallingConvention(s[1]);
10363 delete(s, 1, 1);
10364 CurrStack := Cardinal(Stack.Count) - Cardinal(length(s)) -1;
10365 if s[1] = #0 then inc(CurrStack);
10366 IntVal := CreateHeapVariant(Caller.FindType2(btU32));
10367 if IntVal = nil then
10368 begin
10369 Result := False;
10370 exit;
10371 end;
10372 PPSVariantU32(IntVal).Data := 1;
10373 MyList := TPSList.Create;
10374 MyList.Add(NewPPSVariantIFC(intval, false));
10375 for i := 2 to length(s) do
10376 begin
10377 MyList.Add(nil);
10378 end;
10379 for i := length(s) downto 2 do
10380 begin
10381 n :=Stack[CurrStack];
10382 MyList[i - 1] := NewPPSVariantIFC(n, s[i] <> #0);
10383 inc(CurrStack);
10384 end;
10385 if s[1] <> #0 then
10386 begin
10387 v := NewPPSVariantIFC(Stack[CurrStack + 1], True);
10388 end else v := nil;
10389 try
10390 Result := Caller.InnerfuseCall(FSelf, VirtualClassMethodPtrToPtr(p.Ext1, FSelf), {$IFDEF FPC}TPSCallingConvention(Integer(cc) or 128){$ELSE}cc{$ENDIF}, MyList, v);
10391 finally
10392 DisposePPSVariantIFC(v);
10393 DisposePPSVariantIFCList(mylist);
10394 DestroyHeapVariant(intval);
10395 end;
10396 end;
10397
10398 function CastProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
10399 var
10400 TypeNo, InVar, ResVar: TPSVariantIFC;
10401 FSelf: TClass;
10402 FType: PIFTypeRec;
10403 H, I: Longint;
10404 x: TPSRuntimeClass;
10405 begin
10406 TypeNo := NewTPSVariantIFC(Stack[Stack.Count-3], false);
10407 InVar := NewTPSVariantIFC(Stack[Stack.Count-2], false);
10408 ResVar := NewTPSVariantIFC(Stack[Stack.Count-1], true);
10409 if (TypeNo.Dta = nil) or (InVar.Dta = nil) or (ResVar.Dta = nil) or
10410 (TypeNo.aType.BaseType <> btu32) or (resvar.aType <> Caller.FTypes[tbtu32(Typeno.dta^)])
10411 then
10412 begin
10413 Result := False;
10414 Exit;
10415 end;
10416 {$IFNDEF PS_NOINTERFACES}
10417 if (invar.atype.BaseType = btInterface) and (resvar.aType.BaseType = btInterface) then
10418 begin
10419 {$IFNDEF Delphi3UP}
10420 if IUnknown(resvar.Dta^) <> nil then
10421 IUnknown(resvar.Dta^).Release;
10422 {$ENDIF}
10423 IUnknown(resvar.Dta^) := nil;
10424 if (IUnknown(invar.Dta^) = nil) or (IUnknown(invar.Dta^).QueryInterface(TPSTypeRec_Interface(ResVar.aType).Guid, IUnknown(resvar.Dta^)) <> 0) then
10425 begin
10426 Caller.CMD_Err2(erCustomError, tbtString(RPS_CannotCastInterface));
10427 Result := False;
10428 exit;
10429 end;
10430 {$IFDEF Delphi3UP}
10431 end else if (Invar.aType.BaseType = btclass) and (resvar.aType.BaseType = btInterface) then
10432 begin
10433 {$IFNDEF Delphi3UP}
10434 if IUnknown(resvar.Dta^) <> nil then
10435 IUnknown(resvar.Dta^).Release;
10436 {$ENDIF}
10437 IUnknown(resvar.Dta^) := nil;
10438 if (TObject(invar.Dta^)= nil) or (not TObject(invar.dta^).GetInterface(TPSTypeRec_Interface(ResVar.aType).Guid, IUnknown(resvar.Dta^))) then
10439 begin
10440 Caller.CMD_Err2(erCustomError, tbtString(RPS_CannotCastInterface));
10441 Result := False;
10442 exit;
10443 end;
10444 {$ENDIF}
10445 end else {$ENDIF}if (invar.aType.BaseType = btclass) and (resvar.aType.BaseType = btclass ) then
10446 begin
10447 FType := Caller.GetTypeNo(tbtu32(TypeNo.Dta^));
10448 if (FType = nil) then
10449 begin
10450 Result := False;
10451 exit;
10452 end;
10453 h := MakeHash(FType.ExportName);
10454 FSelf := nil;
10455 for i := 0 to TPSRuntimeClassImporter(p.Ext2).FClasses.Count -1 do
10456 begin
10457 x:= TPSRuntimeClassImporter(p.Ext2).FClasses[i];
10458 if (x.FClassNameHash = h) and (x.FClassName = FType.ExportName) then
10459 begin
10460 FSelf := x.FClass;
10461 end;
10462 end;
10463 if FSelf = nil then begin
10464 Result := False;
10465 exit;
10466 end;
10467
10468 try
10469 TObject(ResVar.Dta^) := TObject(InVar.Dta^) as FSelf;
10470 except
10471 Result := False;
10472 Caller.CMD_Err2(erCustomError, tbtString(RPS_CannotCastObject));
10473 exit;
10474 end;
10475 end else
10476 begin
10477 Result := False;
10478 exit;
10479 end;
10480 result := True;
10481 end;
10482
10483
10484 function NilProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
10485 var
10486 n: TPSVariantIFC;
10487 begin
10488 n := NewTPSVariantIFC(Stack[Stack.Count-1], True);
10489 if (n.Dta = nil) or ((n.aType.BaseType <> btClass) and (n.aType.BaseType <> btInterface)) then
10490 begin
10491 Result := False;
10492 Caller.CMD_Err(erNullPointerException);
10493 Exit;
10494 end;
10495 {$IFNDEF PS_NOINTERFACES}
10496 if n.aType.BaseType = btInterface then
10497 begin
10498 {$IFNDEF Delphi3UP}
10499 if IUnknown(n.Dta^) <> nil then
10500 IUnknown(n.Dta^).Release;
10501 {$ENDIF}
10502 IUnknown(n.Dta^) := nil;
10503 end else
10504 {$ENDIF}
10505 Pointer(n.Dta^) := nil;
10506 result := True;
10507 end;
10508 function IntfCallProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
10509 var
10510 i: Integer;
10511 MyList: TPSList;
10512 n: TPSVariantIFC;
10513 n2: PPSVariantIFC;
10514 FSelf: Pointer;
10515 CurrStack: Cardinal;
10516 cc: TPSCallingConvention;
10517 s: tbtString;
10518 begin
10519 s := p.Decl;
10520 if length(S) < 2 then
10521 begin
10522 Result := False;
10523 exit;
10524 end;
10525 cc := TPSCallingConvention(s[1]);
10526 Delete(s, 1, 1);
10527 if s[1] = #0 then
10528 n := NewTPSVariantIFC(Stack[Stack.Count -1], false)
10529 else
10530 n := NewTPSVariantIFC(Stack[Stack.Count -2], false);
10531 if (n.dta = nil) or (n.atype.BaseType <> btInterface) or (Pointer(n.Dta^) = nil) then
10532 begin
10533 Caller.CMD_Err(erNullPointerException);
10534 result := false;
10535 exit;
10536 end;
10537 FSelf := Pointer(n.dta^);
10538 CurrStack := Cardinal(Stack.Count) - Cardinal(length(s)) -1;
10539 if s[1] = #0 then inc(CurrStack);
10540 MyList := TPSList.Create;
10541 for i := 2 to length(s) do
10542 begin
10543 MyList.Add(nil);
10544 end;
10545 for i := length(s) downto 2 do
10546 begin
10547 MyList[i - 2] := NewPPSVariantIFC(Stack[CurrStack], s[i] <> #0);
10548 inc(CurrStack);
10549 end;
10550 if s[1] <> #0 then
10551 begin
10552 n2 := NewPPSVariantIFC(Stack[CurrStack + 1], True);
10553 end else n2 := nil;
10554 try
10555 Caller.InnerfuseCall(FSelf, Pointer(Pointer(IPointer(FSelf^) + (Cardinal(p.Ext1) * Sizeof(Pointer)))^), cc, MyList, n2);
10556 result := true;
10557 finally
10558 DisposePPSVariantIFC(n2);
10559 DisposePPSVariantIFCList(MyList);
10560 end;
10561 end;
10562
10563
10564 function InterfaceProc(Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean;
10565 var
10566 s: tbtString;
10567 begin
10568 s := p.Decl;
10569 delete(s,1,5); // delete 'intf:'
10570 if s = '' then
10571 begin
10572 Result := False;
10573 exit;
10574 end;
10575 if s[1] = '.'then
10576 begin
10577 Delete(s,1,1);
10578 if length(S) < 6 then
10579 begin
10580 Result := False;
10581 exit;
10582 end;
10583 p.ProcPtr := IntfCallProc;
10584 p.Ext1 := Pointer((@s[1])^); // Proc Offset
10585 Delete(s,1,4);
10586 P.Decl := s;
10587 Result := True;
10588 end else Result := False;
10589 end;
10590
10591
10592 function getMethodNo(P: TMethod; SE: TPSExec): Cardinal;
10593 begin
10594 if (p.Code <> @MyAllMethodsHandler) or (p.Data = nil)or (PScriptMethodInfo(p.Data)^.Se <> se) then
10595 Result := 0
10596 else
10597 begin
10598 Result := PScriptMethodInfo(p.Data)^.ProcNo;
10599 end;
10600 end;
10601
10602 function ClassCallProcProperty(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
10603 var
10604 n: TPSVariantIFC;
10605 ltemp: Longint;
10606 FSelf: Pointer;
10607 m: TMethod;
10608 begin
10609 try
10610 if p.Ext2 = Pointer(0) then
10611 begin
10612 n := NewTPSVariantIFC(Stack[Stack.Count -1], False);
10613 if (n.Dta = nil) or (n.aType.BaseType <> btclass) then
10614 begin
10615 result := false;
10616 Caller.CMD_Err(erNullPointerException);
10617 exit;
10618 end;
10619 FSelf := Pointer(n.dta^);
10620 if FSelf = nil then
10621 begin
10622 Caller.CMD_Err(erCouldNotCallProc);
10623 Result := False;
10624 exit;
10625 end;
10626 n := NewTPSVariantIFC(Stack[Stack.Count -2], false);
10627 if (PPropInfo(p.Ext1)^.PropType^.Kind = tkMethod) and ((n.aType.BaseType = btu32) or (n.aType.BaseType = btProcPtr))then
10628 begin
10629 SetMethodProp(TObject(FSelf), PPropInfo(p.Ext1), MkMethod(Caller, tbtu32(n.dta^)));
10630 end else
10631 case n.aType.BaseType of
10632 btSet:
10633 begin
10634 ltemp := 0;
10635 move(Byte(n.Dta^), ltemp, TPSTypeRec_Set(n.aType).aByteSize);
10636 SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), ltemp);
10637 end;
10638 btChar, btU8: SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), tbtu8(n.Dta^));
10639 btS8: SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), tbts8(n.Dta^));
10640 {$IFNDEF PS_NOWIDESTRING}btwidechar, {$ENDIF}btU16: SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), tbtu16(n.Dta^));
10641 btS16: SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), tbts16(n.Dta^));
10642 btU32: SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), tbtu32(n.Dta^));
10643 btS32: SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), tbts32(n.Dta^));
10644 btSingle: SetFloatProp(TObject(FSelf), p.Ext1, tbtsingle(n.Dta^));
10645 btDouble: SetFloatProp(TObject(FSelf), p.Ext1, tbtdouble(n.Dta^));
10646 btExtended: SetFloatProp(TObject(FSelf), p.Ext1, tbtextended(n.Dta^));
10647 btString: SetStrProp(TObject(FSelf), p.Ext1, string(tbtString(n.Dta^)));
10648 btPChar: SetStrProp(TObject(FSelf), p.Ext1, string(pansichar(n.Dta^)));
10649 btClass: SetOrdProp(TObject(FSelf), P.Ext1, Longint(n.Dta^));
10650 {$IFDEF DELPHI6UP}
10651 {$IFNDEF PS_NOWIDESTRING}
10652 {$IFNDEF DELPHI2009UP}btUnicodeString,{$ENDIF}
10653 btWideString: SetWideStrProp(TObject(FSelf), P.Ext1, tbtWidestring(n.dta^));
10654 {$IFDEF DELPHI2009UP}
10655 btUnicodeString: {$IFDEF DELPHI_TOKYO_UP}SetStrProp{$ELSE}SetUnicodeStrProp{$ENDIF}(TObject(FSelf), P.Ext1, tbtUnicodestring(n.dta^));
10656 {$ENDIF}
10657 {$ENDIF}
10658 {$ENDIF}
10659 else
10660 begin
10661 Result := False;
10662 exit;
10663 end;
10664 end;
10665 Result := true;
10666 end else begin
10667 n := NewTPSVariantIFC(Stack[Stack.Count -2], False);
10668 if (n.dta = nil) or (n.aType.BaseType <> btClass)then
10669 begin
10670 result := false;
10671 Caller.CMD_Err(erNullPointerException);
10672 exit;
10673 end;
10674 FSelf := Pointer(n.dta^);
10675 if FSelf = nil then
10676 begin
10677 Caller.CMD_Err(erCouldNotCallProc);
10678 Result := False;
10679 exit;
10680 end;
10681 n := NewTPSVariantIFC(Stack[Stack.Count -1], false);
10682 if (PPropInfo(p.Ext1)^.PropType^.Kind = tkMethod) and ((n.aType.BaseType = btu32) or (n.aType.BaseType = btprocptr)) then
10683 begin
10684 m := GetMethodProp(TObject(FSelf), PPropInfo(p.Ext1));
10685 Cardinal(n.Dta^) := GetMethodNo(m, Caller);
10686 if Cardinal(n.dta^) = 0 then
10687 begin
10688 Pointer(Pointer((IPointer(n.dta)+PointerSize))^) := m.Data;
10689 Pointer(Pointer((IPointer(n.dta)+PointerSize2))^) := m.Code;
10690 end;
10691 end else
10692 case n.aType.BaseType of
10693 btSet:
10694 begin
10695 ltemp := GetOrdProp(TObject(FSelf), PPropInfo(p.Ext1));
10696 move(ltemp, Byte(n.Dta^), TPSTypeRec_Set(n.aType).aByteSize);
10697 end;
10698 btU8: tbtu8(n.Dta^) := GetOrdProp(TObject(FSelf), p.Ext1);
10699 btS8: tbts8(n.Dta^) := GetOrdProp(TObject(FSelf), p.Ext1);
10700 btU16: tbtu16(n.Dta^) := GetOrdProp(TObject(FSelf), p.Ext1);
10701 btS16: tbts16(n.Dta^) := GetOrdProp(TObject(FSelf), p.Ext1);
10702 btU32: tbtu32(n.Dta^) := GetOrdProp(TObject(FSelf), p.Ext1);
10703 btS32: tbts32(n.Dta^) := GetOrdProp(TObject(FSelf), p.Ext1);
10704 btSingle: tbtsingle(n.Dta^) := GetFloatProp(TObject(FSelf), p.Ext1);
10705 btDouble: tbtdouble(n.Dta^) := GetFloatProp(TObject(FSelf), p.Ext1);
10706 btExtended: tbtextended(n.Dta^) := GetFloatProp(TObject(FSelf), p.Ext1);
10707 btString: tbtString(n.Dta^) := tbtString(GetStrProp(TObject(FSelf), p.Ext1));
10708 btClass: Longint(n.dta^) := GetOrdProp(TObject(FSelf), p.Ext1);
10709 {$IFDEF DELPHI6UP}
10710 {$IFNDEF PS_NOWIDESTRING}
10711 {$IFDEF DELPHI2009UP}
10712 btUnicodeString: tbtUnicodeString(n.dta^) := {$IFDEF DELPHI_TOKYO_UP}GetStrProp{$ELSE}GetUnicodeStrProp{$ENDIF}(TObject(FSelf), P.Ext1);
10713 {$ELSE}
10714 btUnicodeString,
10715 {$ENDIF}
10716 btWideString: tbtWidestring(n.dta^) := GetWideStrProp(TObject(FSelf), P.Ext1);
10717 {$ENDIF}
10718 {$ENDIF}
10719 else
10720 begin
10721 Result := False;
10722 exit;
10723 end;
10724 end;
10725 Result := True;
10726 end;
10727 finally
10728 end;
10729 end;
10730
10731 function ClassCallProcPropertyHelper(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
10732 var
10733 I, ParamCount: Longint;
10734 Params: TPSList;
10735 n: TPSVariantIFC;
10736 FSelf: Pointer;
10737 begin
10738 if Length(P.Decl) < 4 then begin
10739 Result := False;
10740 exit;
10741 end;
10742 ParamCount := Longint((@P.Decl[1])^);
10743 if Longint(Stack.Count) < ParamCount +1 then begin
10744 Result := False;
10745 exit;
10746 end;
10747 Dec(ParamCount);
10748 if p.Ext1 <> nil then // read
10749 begin
10750 n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 2], False);
10751 if (n.Dta = nil) or (n.aType.BaseType <> btClass) then
10752 begin
10753 result := false;
10754 Caller.CMD_Err(erNullPointerException);
10755 exit;
10756 end;
10757 FSelf := pointer(n.Dta^);
10758 if FSelf = nil then
10759 begin
10760 Caller.CMD_Err(erCouldNotCallProc);
10761 Result := False;
10762 exit;
10763 end;
10764 Params := TPSList.Create;
10765 Params.Add(NewPPSVariantIFC(Stack[Longint(Stack.Count) - 1], True));
10766 for i := Stack.Count -3 downto Longint(Stack.Count) - ParamCount -2 do
10767 begin
10768 Params.Add(NewPPSVariantIFC(Stack[I], False));
10769 end;
10770 try
10771 Result := Caller.InnerfuseCall(FSelf, p.Ext1, cdRegister, Params, nil);
10772 finally
10773 DisposePPSVariantIFCList(Params);
10774 end;
10775 end else begin
10776 n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 1], False);
10777 if (n.Dta = nil) or (n.aType.BaseType <> btClass) then
10778 begin
10779 result := false;
10780 Caller.CMD_Err(erNullPointerException);
10781 exit;
10782 end;
10783 FSelf := pointer(n.Dta^);
10784 if FSelf = nil then
10785 begin
10786 Caller.CMD_Err(erCouldNotCallProc);
10787 Result := False;
10788 exit;
10789 end;
10790 Params := TPSList.Create;
10791 Params.Add(NewPPSVariantIFC(Stack[Longint(Stack.Count) - ParamCount - 2], False));
10792
10793 for i := Stack.Count -2 downto Longint(Stack.Count) - ParamCount -1 do
10794 begin
10795 Params.Add(NewPPSVariantIFC(Stack[I], False));
10796 end;
10797 try
10798 Result := Caller.InnerfuseCall(FSelf, p.Ext2, cdregister, Params, nil);
10799 finally
10800 DisposePPSVariantIFCList(Params);
10801 end;
10802 end;
10803 end;
10804
10805 function ClassCallProcPropertyHelperName(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
10806 var
10807 I, ParamCount: Longint;
10808 Params: TPSList;
10809 tt: PIFVariant;
10810 n: TPSVariantIFC;
10811 FSelf: Pointer;
10812 begin
10813 if Length(P.Decl) < 4 then begin
10814 Result := False;
10815 exit;
10816 end;
10817 ParamCount := Longint((@P.Decl[1])^);
10818 if Longint(Stack.Count) < ParamCount +1 then begin
10819 Result := False;
10820 exit;
10821 end;
10822 Dec(ParamCount);
10823 if p.Ext1 <> nil then // read
10824 begin
10825 n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 2], false);
10826 if (n.Dta = nil) or (n.aType.BaseType <> btClass) then
10827 begin
10828 result := false;
10829 Caller.CMD_Err(erNullPointerException);
10830 exit;
10831 end;
10832 FSelf := Tobject(n.dta^);
10833 Params := TPSList.Create;
10834 Params.Add(NewPPSVariantIFC(Stack[Longint(Stack.Count) - 1], True));
10835 for i := Stack.Count -3 downto Longint(Stack.Count) - ParamCount -2 do
10836 Params.Add(NewPPSVariantIFC(Stack[I], False));
10837 tt := CreateHeapVariant(Caller.FindType2(btString));
10838 if tt <> nil then
10839 begin
10840 PPSVariantAString(tt).Data := p.Name;
10841 Params.Add(NewPPSVariantIFC(tt, false));
10842 end;
10843 try
10844 Result := Caller.InnerfuseCall(FSelf, p.Ext1, cdRegister, Params, nil);
10845 finally
10846 DestroyHeapVariant(tt);
10847 DisposePPSVariantIFCList(Params);
10848 end;
10849 end else begin
10850 n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 1], false);
10851 if (n.Dta = nil) or (n.aType.BaseType <> btClass) then
10852 begin
10853 result := false;
10854 Caller.CMD_Err(erNullPointerException);
10855 exit;
10856 end;
10857 FSelf := Tobject(n.dta^);
10858 Params := TPSList.Create;
10859 Params.Add(NewPPSVariantIFC(Stack[Longint(Stack.Count) - 2], True));
10860
10861 for i := Stack.Count -2 downto Longint(Stack.Count) - ParamCount -1 do
10862 begin
10863 Params.Add(NewPPSVariantIFC(Stack[I], false));
10864 end;
10865 tt := CreateHeapVariant(Caller.FindType2(btString));
10866 if tt <> nil then
10867 begin
10868 PPSVariantAString(tt).Data := p.Name;
10869 Params.Add(NewPPSVariantIFC(tt, false));
10870 end;
10871 try
10872 Result := Caller.InnerfuseCall(FSelf, p.Ext2, cdregister, Params, nil);
10873 finally
10874 DestroyHeapVariant(tt);
10875 DisposePPSVariantIFCList(Params);
10876 end;
10877 end;
10878 end;
10879
10880
10881
10882 function ClassCallProcEventPropertyHelper(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
10883 {Event property helper}
10884 var
10885 I, ParamCount: Longint;
10886 Params: TPSList;
10887 n: TPSVariantIFC;
10888 data: TMethod;
10889 n2: PIFVariant;
10890 FSelf: Pointer;
10891 begin
10892 if Length(P.Decl) < 4 then begin
10893 Result := False;
10894 exit;
10895 end;
10896 ParamCount := Longint((@P.Decl[1])^);
10897 if Longint(Stack.Count) < ParamCount +1 then begin
10898 Result := False;
10899 exit;
10900 end;
10901 Dec(ParamCount);
10902 if p.Ext1 <> nil then // read
10903 begin
10904 n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 2], false);
10905 if (n.Dta = nil) or (n.aType.BaseType <> btClass) then
10906 begin
10907 result := false;
10908 Caller.CMD_Err(erNullPointerException);
10909 exit;
10910 end;
10911 FSelf := Tobject(n.dta^);
10912 n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 1], True); // Result
10913 if (n.aType.BaseType <> btU32) and (n.aType.BaseType <> btProcPtr) then
10914 begin
10915 Result := False;
10916 Caller.CMD_Err(erNullPointerException);
10917 exit;
10918 end;
10919 n2 := CreateHeapVariant(Caller.FindType2(btPChar));
10920 if n2 = nil then
10921 begin
10922 Result := False;
10923 exit;
10924 end;
10925 Params := TPSList.Create;
10926 //{$IFDEF CPU64}
10927 //{$ELSE}
10928 data.Code := nil;
10929 data.Data := nil;
10930 //{$ENDIF}
10931 PPSVariantDynamicArray(n2)^.Data:= @data;
10932 Params.Add(NewPPSVariantIFC(n2, false));
10933 for i := Stack.Count -3 downto Longint(Stack.Count) - ParamCount -2 do
10934 Params.Add(NewPPSVariantIFC(Stack[i], False));
10935 try
10936 Result := Caller.InnerfuseCall(FSelf, p.Ext1, cdRegister, Params, nil);
10937 finally
10938 Cardinal(n.Dta^) := getMethodNo(data, Caller);
10939 if Cardinal(n.Dta^) = 0 then
10940 begin
10941 Pointer(Pointer((IPointer(n.dta)+PointerSize))^) := data.Data;
10942 Pointer(Pointer((IPointer(n.dta)+PointerSize2))^) := data.Code;
10943 end;
10944 DestroyHeapVariant(n2);
10945 DisposePPSVariantIFCList(Params);
10946 end;
10947 end else begin
10948 n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 1], false);
10949 if (n.Dta = nil) or (n.aType.BaseType <> btClass) then
10950 begin
10951 result := false;
10952 Caller.CMD_Err(erNullPointerException);
10953 exit;
10954 end;
10955 FSelf := Tobject(n.dta^);
10956 n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 2], false);
10957 if (n.Dta = nil) or ((n.aType.BaseType <> btu32) and (n.aType.BaseType <> btProcPtr)) then
10958 begin
10959 result := false;
10960 Caller.CMD_Err(erNullPointerException);
10961 exit;
10962 end;
10963 (*n2 := CreateHeapVariant(Caller.FindType2(btPchar));
10964 if n2 = nil then
10965 begin
10966 Result := False;
10967 exit;
10968 end; *)
10969
10970 //if (n.aType.BaseType = btProcPtr) and (cardinal(n.dta^) = 0) then
10971 // data := TMethod(Pointer(IPointer(n.dta^)+4)^)
10972 //else
10973 // data := MkMethod(Caller, cardinal(n.dta^));
10974
10975 Params := TPSList.Create;
10976 Params.Add(@n);
10977
10978 // for i := Stack.Count -2 downto Longint(Stack.Count) - ParamCount -1 do
10979 // begin
10980 // Params.Add(NewPPSVariantIFC(Stack[I], False));
10981 // end;
10982 try
10983 Result := Caller.InnerfuseCall(FSelf, p.Ext2, cdregister, Params, nil);
10984 finally
10985 Params.Clear;
10986 //DestroyHeapVariant(n2);
10987 DisposePPSVariantIFCList(Params);
10988 end;
10989 end;
10990 end;
10991
10992
10993 {'class:'+CLASSNAME+'|'+FUNCNAME+'|'+chr(CallingConv)+chr(hasresult)+params
10994
10995 For property write functions there is an '@' after the funcname.
10996 }
10997 function SpecImport(Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean;
10998 var
10999 H, I: Longint;
11000 S, s2: tbtString;
11001 CL: TPSRuntimeClass;
11002 Px: PClassItem;
11003 pp: PPropInfo;
11004 IsRead: Boolean;
11005 begin
11006 s := p.Decl;
11007 delete(s, 1, 6);
11008 if s = '-' then {nil function}
11009 begin
11010 p.ProcPtr := NilProc;
11011 Result := True;
11012 exit;
11013 end;
11014 if s = '+' then {cast function}
11015 begin
11016 p.ProcPtr := CastProc;
11017 p.Ext2 := Tag;
11018 Result := True;
11019 exit;
11020 end;
11021 s2 := copy(S, 1, pos(tbtchar('|'), s)-1);
11022 delete(s, 1, length(s2) + 1);
11023 H := MakeHash(s2);
11024 ISRead := False;
11025 cl := nil;
11026 for I := TPSRuntimeClassImporter(Tag).FClasses.Count -1 downto 0 do
11027 begin
11028 Cl := TPSRuntimeClassImporter(Tag).FClasses[I];
11029 if (Cl.FClassNameHash = h) and (cl.FClassName = s2) then
11030 begin
11031 IsRead := True;
11032 break;
11033 end;
11034 end;
11035 if not isRead then begin
11036 Result := False;
11037 exit;
11038 end;
11039 s2 := copy(S, 1, pos(tbtchar('|'), s)-1);
11040 delete(s, 1, length(s2) + 1);
11041 if (s2 <> '') and (s2[length(s2)] = '@') then
11042 begin
11043 IsRead := False;
11044 Delete(S2, length(s2), 1);
11045 end else
11046 isRead := True;
11047 p.Name := s2;
11048 H := MakeHash(s2);
11049 for i := cl.FClassItems.Count -1 downto 0 do
11050 begin
11051 px := cl.FClassItems[I];
11052 if (px^.FNameHash = h) and (px^.FName = s2) then
11053 begin
11054 p.Decl := s;
11055 case px^.b of
11056 {0: ext1=ptr}
11057 {1: ext1=pointerinlist}
11058 {2: ext1=propertyinfo}
11059 {3: ext1=readfunc; ext2=writefunc}
11060 4:
11061 begin
11062 p.ProcPtr := ClassCallProcConstructor;
11063 p.Ext1 := px^.Ptr;
11064 if p.Ext1 = nil then begin result := false; exit; end;
11065 p.Ext2 := Tag;
11066 end;
11067 5:
11068 begin
11069 p.ProcPtr := ClassCallProcVirtualConstructor;
11070 p.Ext1 := px^.Ptr;
11071 if p.Ext1 = nil then begin result := false; exit; end;
11072 p.Ext2 := Tag;
11073 end;
11074 6:
11075 begin
11076 p.ProcPtr := ClassCallProcEventPropertyHelper;
11077 if IsRead then
11078 begin
11079 p.Ext1 := px^.FReadFunc;
11080 if p.Ext1 = nil then begin result := false; exit; end;
11081 p.Ext2 := nil;
11082 end else
11083 begin
11084 p.Ext1 := nil;
11085 p.Ext2 := px^.FWriteFunc;
11086 if p.Ext2 = nil then begin result := false; exit; end;
11087 end;
11088 end;
11089 0:
11090 begin
11091 p.ProcPtr := ClassCallProcMethod;
11092 p.Ext1 := px^.Ptr;
11093 if p.Ext1 = nil then begin result := false; exit; end;
11094 p.Ext2 := nil;
11095 end;
11096 1:
11097 begin
11098 p.ProcPtr := ClassCallProcMethod;
11099 p.Ext1 := px^.PointerInList;
11100 //if p.Ext1 = nil then begin result := false; exit; end;
11101 p.ext2 := pointer(1);
11102 end;
11103 3:
11104 begin
11105 p.ProcPtr := ClassCallProcPropertyHelper;
11106 if IsRead then
11107 begin
11108 p.Ext1 := px^.FReadFunc;
11109 if p.Ext1 = nil then begin result := false; exit; end;
11110 p.Ext2 := nil;
11111 end else
11112 begin
11113 p.Ext1 := nil;
11114 p.Ext2 := px^.FWriteFunc;
11115 if p.Ext2 = nil then begin result := false; exit; end;
11116 end;
11117 end;
11118 7:
11119 begin
11120 p.ProcPtr := ClassCallProcPropertyHelperName;
11121 if IsRead then
11122 begin
11123 p.Ext1 := px^.FReadFunc;
11124 if p.Ext1 = nil then begin result := false; exit; end;
11125 p.Ext2 := nil;
11126 end else
11127 begin
11128 p.Ext1 := nil;
11129 p.Ext2 := px^.FWriteFunc;
11130 if p.Ext2 = nil then begin result := false; exit; end;
11131 end;
11132 end;
11133 8:
11134 begin
11135 p.ProcPtr := px^.ProcPtr;
11136 p.Ext1 := px^.Ext1;
11137 p.Ext2 := px^.Ext2;
11138 end;
11139 9:
11140 begin
11141 if IsRead then
11142 begin
11143 p.ProcPtr := px^.ReadProcPtr;
11144 p.Ext1 := px^.ExtRead1;
11145 p.Ext2 := px^.ExtRead2;
11146 end else
11147 begin
11148 p.ProcPtr := px^.WriteProcPtr;
11149 p.Ext1 := px^.ExtWrite1;
11150 p.Ext2 := px^.ExtWrite2;
11151 end;
11152 end;
11153 else
11154 begin
11155 result := false;
11156 exit;
11157 end;
11158 end;
11159 Result := true;
11160 exit;
11161 end;
11162 end;
11163 if cl.FClass.ClassInfo <> nil then
11164 begin
11165 pp := GetPropInfo(cl.FClass.ClassInfo, string(s2));
11166 if pp <> nil then
11167 begin
11168 p.ProcPtr := ClassCallProcProperty;
11169 p.Ext1 := pp;
11170 if IsRead then
11171 p.Ext2 := Pointer(1)
11172 else
11173 p.Ext2 := Pointer(0);
11174 Result := True;
11175 end else
11176 result := false;
11177 end else
11178 Result := False;
11179 end;
11180
11181 procedure RegisterClassLibraryRuntime(SE: TPSExec; Importer: TPSRuntimeClassImporter);
11182 begin
11183 SE.AddSpecialProcImport('class', SpecImport, Importer);
11184 end;
11185
11186
11187 procedure TPSExec.ClearspecialProcImports;
11188 var
11189 I: Longint;
11190 P: PSpecialProc;
11191 begin
11192 for I := FSpecialProcList.Count -1 downto 0 do
11193 begin
11194 P := FSpecialProcList[I];
11195 Dispose(p);
11196 end;
11197 FSpecialProcList.Clear;
11198 end;
11199
11200 procedure TPSExec.RaiseCurrentException;
11201 var
11202 ExObj: TObject;
11203 begin
11204 if ExEx = erNoError then exit; // do nothing
11205 ExObj := Self.ExObject;
11206 if ExObj <> nil then
11207 begin
11208 Self.ExObject := nil;
11209 raise ExObj;
11210 end;
11211 raise EPSException.Create(PSErrorToString(ExceptionCode, ExceptionString), Self, ExProc, ExPos);
11212 end;
11213
11214 procedure TPSExec.CMD_Err2(EC: TPSError; const Param: tbtString);
11215 begin
11216 CMD_Err3(EC, Param, Nil);
11217 end;
11218
GetProcAsMethodnull11219 function TPSExec.GetProcAsMethod(const ProcNo: Cardinal): TMethod;
11220 begin
11221 Result := MkMethod(Self, ProcNo);
11222 end;
11223
GetProcAsMethodNnull11224 function TPSExec.GetProcAsMethodN(const ProcName: tbtString): TMethod;
11225 var
11226 procno: Cardinal;
11227 begin
11228 Procno := GetProc(ProcName);
11229 if Procno = InvalidVal then
11230 begin
11231 Result.Code := nil;
11232 Result.Data := nil;
11233 end
11234 else
11235 Result := MkMethod(Self, procno)
11236 end;
11237
11238
11239 procedure TPSExec.RegisterAttributeType(useproc: TPSAttributeUseProc;
11240 const TypeName: tbtString);
11241 var
11242 att: TPSAttributeType;
11243 begin
11244 att := TPSAttributeType.Create;
11245 att.TypeName := TypeName;
11246 att.TypeNameHash := MakeHash(TypeName);
11247 att.UseProc := UseProc;
11248 FAttributeTypes.Add(att);
11249 end;
11250
GetProcCountnull11251 function TPSExec.GetProcCount: Cardinal;
11252 begin
11253 Result := FProcs.Count;
11254 end;
11255
GetTypeCountnull11256 function TPSExec.GetTypeCount: Longint;
11257 begin
11258 Result := FTypes.Count;
11259 end;
11260
GetVarCountnull11261 function TPSExec.GetVarCount: Longint;
11262 begin
11263 Result := FGlobalVars.Count;
11264 end;
11265
FindSpecialProcImportnull11266 function TPSExec.FindSpecialProcImport(
11267 P: TPSOnSpecialProcImport): pointer;
11268 var
11269 i: Longint;
11270 pr: PSpecialProc;
11271 begin
11272 for i := FSpecialProcList.Count -1 downto 0 do
11273 begin
11274 pr := FSpecialProcList[i];
11275 if @pr.P = @p then
11276 begin
11277 Result := pr.tag;
11278 exit;
11279 end;
11280 end;
11281 result := nil;
11282 end;
11283
InvokeExternalMethodnull11284 function TPSExec.InvokeExternalMethod(At: TPSTypeRec_ProcPtr; Slf,
11285 Ptr: Pointer): Boolean;
11286 var
11287 res: PPSVariantIFC;
11288 s: tbtString;
11289 CurrStack, i: Longint;
11290 n: PPSVariant;
11291 MyList: TPSList;
11292 begin
11293 s := TPSTypeRec_ProcPtr(at).ParamInfo;
11294 CurrStack := Cardinal(FStack.Count) - Cardinal(length(s));
11295 if s[1] = #0 then inc(CurrStack);
11296 MyList := TPSList.Create;
11297 for i := 2 to length(s) do
11298 begin
11299 MyList.Add(nil);
11300 end;
11301 for i := length(s) downto 2 do
11302 begin
11303 n := FStack[CurrStack];
11304 MyList[i - 2] := NewPPSVariantIFC(n, s[i] <> #0);
11305 inc(CurrStack);
11306 end;
11307 if s[1] <> #0 then
11308 begin
11309 res := NewPPSVariantIFC(FStack[CurrStack + 1], True);
11310 end else res := nil;
11311 Result := InnerfuseCall(Slf, Ptr, cdRegister, MyList, Res);
11312
11313 DisposePPSVariantIFC(res);
11314 DisposePPSVariantIFCList(mylist);
11315 end;
11316
LastExnull11317 function TPSExec.LastEx: TPSError;
11318 var
11319 pp: TPSExceptionHandler;
11320 begin
11321 if FExceptionStack.Count = 0 then begin
11322 result := ExEx;
11323 exit;
11324 end;
11325 pp := fExceptionStack[fExceptionStack.Count-1];
11326 result := pp.ExceptionData;
11327 end;
11328
LastExParamnull11329 function TPSExec.LastExParam: tbtString;
11330 var
11331 pp: TPSExceptionHandler;
11332 begin
11333 if FExceptionStack.Count = 0 then begin
11334 result := ExParam;
11335 exit;
11336 end;
11337 pp := fExceptionStack[fExceptionStack.Count-1];
11338 result := pp.ExceptionParam;
11339 end;
11340
LastExPosnull11341 function TPSExec.LastExPos: Integer;
11342 var
11343 pp: TPSExceptionHandler;
11344 begin
11345 if FExceptionStack.Count = 0 then begin
11346 result := ExPos;
11347 exit;
11348 end;
11349 pp := fExceptionStack[fExceptionStack.Count-1];
11350 result := pp.ExceptOffset;
11351
11352 end;
11353
LastExProcnull11354 function TPSExec.LastExProc: Integer;
11355 var
11356 pp: TPSExceptionHandler;
11357 begin
11358 if FExceptionStack.Count = 0 then begin
11359 result := ExProc;
11360 exit;
11361 end;
11362 pp := fExceptionStack[fExceptionStack.Count-1];
11363 result := FProcs.IndexOf(pp.CurrProc);
11364 end;
11365
LastExObjectnull11366 function TPSExec.LastExObject: TObject;
11367 var
11368 pp: TPSExceptionHandler;
11369 begin
11370 if FExceptionStack.Count = 0 then begin
11371 result := ExObject;
11372 exit;
11373 end;
11374 pp := fExceptionStack[fExceptionStack.Count-1];
11375 result := pp.ExceptionObject;
11376 end;
11377
11378 { TPSRuntimeClass }
11379
11380 constructor TPSRuntimeClass.Create(aClass: TClass; const AName: tbtString);
11381 begin
11382 inherited Create;
11383 FClass := AClass;
11384 if AName = '' then
11385 begin
11386 FClassName := FastUpperCase(tbtString(aClass.ClassName));
11387 FClassNameHash := MakeHash(FClassName);
11388 end else begin
11389 FClassName := FastUppercase(AName);
11390 FClassNameHash := MakeHash(FClassName);
11391 end;
11392 FClassItems:= TPSList.Create;
11393 FEndOfVmt := MaxInt;
11394 end;
11395
11396 destructor TPSRuntimeClass.Destroy;
11397 var
11398 I: Longint;
11399 P: PClassItem;
11400 begin
11401 for i:= FClassItems.Count -1 downto 0 do
11402 begin
11403 P := FClassItems[I];
11404 Dispose(p);
11405 end;
11406 FClassItems.Free;
11407 inherited Destroy;
11408 end;
11409
11410 procedure TPSRuntimeClass.RegisterVirtualAbstractMethod(ClassDef: TClass;
11411 ProcPtr: Pointer; const Name: tbtString);
11412 var
11413 P: PClassItem;
11414 begin
11415 New(P);
11416 p^.FName := FastUppercase(Name);
11417 p^.FNameHash := MakeHash(p^.FName);
11418 p^.b := 1;
11419 p^.PointerInList := FindVirtualMethodPtr(Self, ClassDef, ProcPtr);
11420 FClassItems.Add(p);
11421 end;
11422
11423 procedure TPSRuntimeClass.RegisterConstructor(ProcPtr: Pointer;
11424 const Name: tbtString);
11425 var
11426 P: PClassItem;
11427 begin
11428 New(P);
11429 p^.FName := FastUppercase(Name);
11430 p^.FNameHash := MakeHash(p^.FName);
11431 p^.b := 4;
11432 p^.Ptr := ProcPtr;
11433 FClassItems.Add(p);
11434 end;
11435
11436 procedure TPSRuntimeClass.RegisterMethod(ProcPtr: Pointer; const Name: tbtString);
11437 var
11438 P: PClassItem;
11439 begin
11440 New(P);
11441 p^.FName := FastUppercase(Name);
11442 p^.FNameHash := MakeHash(p^.FName);
11443 p^.b := 0;
11444 p^.Ptr := ProcPtr;
11445 FClassItems.Add(p);
11446 end;
11447
11448 procedure TPSRuntimeClass.RegisterMethodName(const Name: tbtstring;
11449 ProcPtr: TPSProcPtr; Ext1, Ext2: Pointer);
11450 var
11451 P: PClassItem;
11452 begin
11453 New(P);
11454 p^.FName := FastUppercase(Name);
11455 p^.FNameHash := MakeHash(p^.FName);
11456 p^.b := 8;
11457 p^.ProcPtr := ProcPtr;
11458 p^.Ext1 := Ext1;
11459 p^.Ext2 := Ext2;
11460 FClassItems.Add(p);
11461 end;
11462
11463 procedure TPSRuntimeClass.RegisterPropertyHelper(ReadFunc,
11464 WriteFunc: Pointer; const Name: tbtString);
11465 var
11466 P: PClassItem;
11467 begin
11468 New(P);
11469 p^.FName := FastUppercase(Name);
11470 p^.FNameHash := MakeHash(p^.FName);
11471 p^.b := 3;
11472 p^.FReadFunc := ReadFunc;
11473 p^.FWriteFunc := WriteFunc;
11474 FClassItems.Add(p);
11475 end;
11476
11477 procedure TPSRuntimeClass.RegisterVirtualConstructor(ProcPtr: Pointer;
11478 const Name: tbtString);
11479 var
11480 P: PClassItem;
11481 begin
11482 New(P);
11483 p^.FName := FastUppercase(Name);
11484 p^.FNameHash := MakeHash(p^.FName);
11485 p^.b := 5;
11486 p^.PointerInList := FindVirtualMethodPtr(Self, FClass, ProcPtr);
11487 FClassItems.Add(p);
11488 end;
11489
11490 procedure TPSRuntimeClass.RegisterVirtualMethod(ProcPtr: Pointer; const Name: tbtString);
11491 var
11492 P: PClassItem;
11493 begin
11494 New(P);
11495 p^.FName := FastUppercase(Name);
11496 p^.FNameHash := MakeHash(p^.FName);
11497 p^.b := 1;
11498 p^.PointerInList := FindVirtualMethodPtr(Self, FClass, ProcPtr);
11499 FClassItems.Add(p);
11500 end;
11501
11502 procedure TPSRuntimeClass.RegisterEventPropertyHelper(ReadFunc,
11503 WriteFunc: Pointer; const Name: tbtString);
11504 var
11505 P: PClassItem;
11506 begin
11507 New(P);
11508 p^.FName := FastUppercase(Name);
11509 p^.FNameHash := MakeHash(p^.FName);
11510 p^.b := 6;
11511 p^.FReadFunc := ReadFunc;
11512 p^.FWriteFunc := WriteFunc;
11513 FClassItems.Add(p);
11514 end;
11515
11516
11517 procedure TPSRuntimeClass.RegisterPropertyHelperName(ReadFunc,
11518 WriteFunc: Pointer; const Name: tbtString);
11519 var
11520 P: PClassItem;
11521 begin
11522 New(P);
11523 p^.FName := FastUppercase(Name);
11524 p^.FNameHash := MakeHash(p^.FName);
11525 p^.b := 7;
11526 p^.FReadFunc := ReadFunc;
11527 p^.FWriteFunc := WriteFunc;
11528 FClassItems.Add(p);
11529 end;
11530
11531 procedure TPSRuntimeClass.RegisterPropertyNameHelper(const Name: tbtstring;
11532 ProcPtr: TPSProcPtr; ExtRead1, ExtRead2, ExtWrite1, ExtWrite2: Pointer);
11533 var
11534 P: PClassItem;
11535 begin
11536 New(P);
11537 p^.FName := FastUppercase(Name);
11538 p^.FNameHash := MakeHash(p^.FName);
11539 p^.b := 9;
11540 p^.ReadProcPtr := ProcPtr;
11541 p^.WriteProcPtr := ProcPtr;
11542 p^.ExtRead1 := ExtRead1;
11543 p^.ExtRead2 := ExtRead2;
11544 p^.ExtWrite1 := ExtWrite1;
11545 p^.ExtWrite2 := ExtWrite2;
11546 FClassItems.Add(p);
11547 end;
11548
11549 procedure TPSRuntimeClass.RegisterPropertyNameHelper(const Name: tbtstring;
11550 ProcReadPtr, ProcWritePtr: TPSProcPtr; ExtRead1, ExtRead2, ExtWrite1,
11551 ExtWrite2: Pointer);
11552 var
11553 P: PClassItem;
11554 begin
11555 New(P);
11556 p^.FName := FastUppercase(Name);
11557 p^.FNameHash := MakeHash(p^.FName);
11558 p^.b := 9;
11559 p^.ReadProcPtr := ProcReadPtr;
11560 p^.WriteProcPtr := ProcWritePtr;
11561 p^.ExtRead1 := ExtRead1;
11562 p^.ExtRead2 := ExtRead2;
11563 p^.ExtWrite1 := ExtWrite1;
11564 p^.ExtWrite2 := ExtWrite2;
11565 FClassItems.Add(p);
11566 end;
11567
11568 { TPSRuntimeClassImporter }
11569
Addnull11570 function TPSRuntimeClassImporter.Add(aClass: TClass): TPSRuntimeClass;
11571 begin
11572 Result := FindClass(tbtstring(aClass.ClassName));
11573 if Result <> nil then exit;
11574 Result := TPSRuntimeClass.Create(aClass, '');
11575 FClasses.Add(Result);
11576 end;
11577
Add2null11578 function TPSRuntimeClassImporter.Add2(aClass: TClass;
11579 const Name: tbtString): TPSRuntimeClass;
11580 begin
11581 Result := FindClass(Name);
11582 if Result <> nil then exit;
11583 Result := TPSRuntimeClass.Create(aClass, Name);
11584 FClasses.Add(Result);
11585 end;
11586
11587 procedure TPSRuntimeClassImporter.Clear;
11588 var
11589 I: Longint;
11590 begin
11591 for i := 0 to FClasses.Count -1 do
11592 begin
11593 TPSRuntimeClass(FClasses[I]).Free;
11594 end;
11595 FClasses.Clear;
11596 end;
11597
11598 constructor TPSRuntimeClassImporter.Create;
11599 begin
11600 inherited Create;
11601 FClasses := TPSList.Create;
11602
11603 end;
11604
11605 constructor TPSRuntimeClassImporter.CreateAndRegister(Exec: TPSExec;
11606 AutoFree: Boolean);
11607 begin
11608 inherited Create;
11609 FClasses := TPSList.Create;
11610 RegisterClassLibraryRuntime(Exec, Self);
11611 if AutoFree then
11612 Exec.AddResource(@RCIFreeProc, Self);
11613 end;
11614
11615 destructor TPSRuntimeClassImporter.Destroy;
11616 begin
11617 Clear;
11618 FClasses.Free;
11619 inherited Destroy;
11620 end;
11621
11622 {$IFNDEF PS_NOINTERFACES}
11623 procedure SetVariantToInterface(V: PIFVariant; Cl: IUnknown);
11624 begin
11625 if (v <> nil) and (v.FType.BaseType = btInterface) then
11626 begin
11627 PPSVariantinterface(v).Data := cl;
11628 {$IFNDEF Delphi3UP}
11629 if PPSVariantinterface(v).Data <> nil then
11630 PPSVariantinterface(v).Data.AddRef;
11631 {$ENDIF}
11632 end;
11633 end;
11634 {$ENDIF}
11635
11636 procedure SetVariantToClass(V: PIFVariant; Cl: TObject);
11637 begin
11638 if (v <> nil) and (v.FType.BaseType = btClass) then
11639 begin
11640 PPSVariantclass(v).Data := cl;
11641 end;
11642 end;
11643
11644 function BGRFW(var s: tbtString): tbtString;
11645 var
11646 l: Longint;
11647 begin
11648 l := Length(s);
11649 while l >0 do
11650 begin
11651 if s[l] = ' ' then
11652 begin
11653 Result := copy(s, l + 1, Length(s) - l);
11654 Delete(s, l, Length(s) - l + 1);
11655 exit;
11656 end;
11657 Dec(l);
11658 end;
11659 Result := s;
11660 s := '';
11661 end;
11662
11663 {$ifdef CPUX64}
11664
11665 {.$DEFINE empty_methods_handler}
11666 {$ENDIF}
11667
11668 {$ifdef fpc}
11669 {$if defined(cpu86)} // Has MyAllMethodsHandler
11670 {$else}
11671 // {$if defined(cpupowerpc) or defined(cpuarm) or defined(cpu64)}
11672 {$define empty_methods_handler}
11673 {$ifend}
11674 {$endif}
11675
11676 {$ifdef empty_methods_handler}
11677 procedure MyAllMethodsHandler;
11678 begin
11679 end;
11680 {$else}
11681
11682
11683 function MyAllMethodsHandler2(Self: PScriptMethodInfo; const Stack: PPointer; _EDX, _ECX: Pointer): Integer; forward;
11684
11685 procedure MyAllMethodsHandler;
11686 {$ifdef CPUX64}
11687 // On entry:
11688 // RCX = Self pointer
11689 // RDX, R8, R9 = param1 .. param3
11690 // STACK = param4... paramcount
11691 asm
11692 PUSH R9
11693 MOV R9,R8 // R9:=_ECX
11694 MOV R8,RDX // R8:=_EDX
11695 MOV RDX, RSP // RDX:=Stack
11696 SUB RSP, 20h
11697 CALL MyAllMethodsHandler2
11698 ADD RSP, 20h //Restore stack
11699 POP R9
11700 end;
11701 {$else}
11702 // On entry:
11703 // EAX = Self pointer
11704 // EDX, ECX = param1 and param2
11705 // STACK = param3... paramcount
11706 asm
11707 push 0
11708 push ecx
11709 push edx
11710 mov edx, esp
11711 add edx, 16 // was 12
11712 pop ecx
11713 call MyAllMethodsHandler2
11714 pop ecx
11715 mov edx, [esp]
11716 add esp, eax
11717 mov [esp], edx
11718 mov eax, ecx
11719 end;
11720 {$endif}
11721
11722 function ResultAsRegister(b: TPSTypeRec): Boolean;
11723 begin
11724 case b.BaseType of
11725 btSingle,
11726 btDouble,
11727 btExtended,
11728 btU8,
11729 bts8,
11730 bts16,
11731 btu16,
11732 bts32,
11733 btu32,
11734 {$IFDEF PS_FPCSTRINGWORKAROUND}
11735 btString,
11736 {$ENDIF}
11737 {$IFNDEF PS_NOINT64}
11738 bts64,
11739 {$ENDIF}
11740 btPChar,
11741 {$IFNDEF PS_NOWIDESTRING}
11742 btWideChar,
11743 {$ENDIF}
11744 btChar,
11745 btclass,
11746 btEnum: Result := true;
11747 btSet: Result := b.RealSize <= PointerSize;
11748 btStaticArray: Result := b.RealSize <= PointerSize;
11749 else
11750 Result := false;
11751 end;
11752 end;
11753
11754 function SupportsRegister(b: TPSTypeRec): Boolean;
11755 begin
11756 case b.BaseType of
11757 btU8,
11758 bts8,
11759 bts16,
11760 btu16,
11761 bts32,
11762 btu32,
11763 btstring,
11764 btclass,
11765 {$IFNDEF PS_NOINTERFACES}
11766 btinterface,
11767 {$ENDIF}
11768 btPChar,
11769 {$IFNDEF PS_NOWIDESTRING}
11770 btwidestring,
11771 btUnicodeString,
11772 btWideChar,
11773 {$ENDIF}
11774 btChar,
11775 btArray,
11776 btEnum: Result := true;
11777 btSet: Result := b.RealSize <= PointerSize;
11778 btStaticArray: Result := b.RealSize <= PointerSize;
11779 else
11780 Result := false;
11781 end;
11782 end;
11783
11784 function AlwaysAsVariable(aType: TPSTypeRec): Boolean;
11785 begin
11786 case atype.BaseType of
11787 btVariant: Result := true;
11788 btSet: Result := atype.RealSize > PointerSize;
11789 btRecord: Result := atype.RealSize > PointerSize;
11790 btStaticArray: Result := atype.RealSize > PointerSize;
11791 else
11792 Result := false;
11793 end;
11794 end;
11795
11796
11797 procedure PutOnFPUStackExtended(ft: extended);
11798 asm
11799 // fstp tbyte ptr [ft]
11800 fld tbyte ptr [ft]
11801
11802 end;
11803
11804
11805 function MyAllMethodsHandler2(Self: PScriptMethodInfo; const Stack: PPointer; _EDX, _ECX: Pointer): Integer;
11806 var
11807 Decl: tbtString;
11808 I, C, regno: Integer;
11809 Params: TPSList;
11810 Res, Tmp: PIFVariant;
11811 cpt: PIFTypeRec;
11812 fmod: tbtchar;
11813 s,e: tbtString;
11814 FStack: pointer;
11815 ex: TPSExceptionHandler;
11816
11817
11818 begin
11819 Decl := TPSInternalProcRec(Self^.Se.FProcs[Self^.ProcNo]).ExportDecl;
11820
11821 FStack := Stack;
11822 Params := TPSList.Create;
11823 s := decl;
11824 grfw(s);
11825 while s <> '' do
11826 begin
11827 Params.Add(nil);
11828 grfw(s);
11829 end;
11830 c := Params.Count;
11831 regno := 0;
11832 Result := 0;
11833 s := decl;
11834 grfw(s);
11835 for i := c-1 downto 0 do
11836 begin
11837 e := grfw(s);
11838 fmod := e[1];
11839 delete(e, 1, 1);
11840 cpt := Self.Se.GetTypeNo(StrToInt(e));
11841 if ((fmod = '%') or (fmod = '!') or (AlwaysAsVariable(cpt))) and (RegNo < 2) then
11842 begin
11843 tmp := CreateHeapVariant(self.Se.FindType2(btPointer));
11844 PPSVariantPointer(tmp).DestType := cpt;
11845 Params[i] := tmp;
11846 case regno of
11847 0: begin
11848 PPSVariantPointer(tmp).DataDest := Pointer(_EDX);
11849 inc(regno);
11850 end;
11851 1: begin
11852 PPSVariantPointer(tmp).DataDest := Pointer(_ECX);
11853 inc(regno);
11854 end;
11855 (* else begin
11856 PPSVariantPointer(tmp).DataDest := Pointer(FStack^);
11857 FStack := Pointer(IPointer(FStack) + 4);
11858 end;*)
11859 end;
11860 end
11861 else if SupportsRegister(cpt) and (RegNo < 2) then
11862 begin
11863 tmp := CreateHeapVariant(cpt);
11864 Params[i] := tmp;
11865 case regno of
11866 0: begin
11867 CopyArrayContents(@PPSVariantData(tmp)^.Data, @_EDX, 1, cpt);
11868 inc(regno);
11869 end;
11870 1: begin
11871 CopyArrayContents(@PPSVariantData(tmp)^.Data, @_ECX, 1, cpt);
11872 inc(regno);
11873 end;
11874 (* else begin
11875 CopyArrayContents(@PPSVariantData(tmp)^.Data, Pointer(FStack), 1, cpt);
11876 FStack := Pointer(IPointer(FStack) + 4);
11877 end;*)
11878 end;
11879 (* end else
11880 begin
11881 tmp := CreateHeapVariant(cpt);
11882 Params[i] := tmp;
11883 CopyArrayContents(@PPSVariantData(tmp)^.Data, Pointer(FStack), 1, cpt);
11884 FStack := Pointer(IPointer(FStack) + cpt.RealSize + 3 and not 3);*)
11885 end;
11886 end;
11887 s := decl;
11888 e := grfw(s);
11889
11890 if e <> '-1' then
11891 begin
11892 cpt := Self.Se.GetTypeNo(StrToInt(e));
11893 if not ResultAsRegister(cpt) then
11894 begin
11895 Res := CreateHeapVariant(Self.Se.FindType2(btPointer));
11896 PPSVariantPointer(Res).DestType := cpt;
11897 Params.Add(Res);
11898 case regno of
11899 0: begin
11900 PPSVariantPointer(Res).DataDest := Pointer(_EDX);
11901 end;
11902 1: begin
11903 PPSVariantPointer(Res).DataDest := Pointer(_ECX);
11904 end;
11905 else begin
11906 PPSVariantPointer(Res).DataDest := Pointer(FStack^);
11907 Inc(Result, PointerSize);
11908 end;
11909 end;
11910 end else
11911 begin
11912 Res := CreateHeapVariant(cpt);
11913 Params.Add(Res);
11914 end;
11915 end else Res := nil;
11916 s := decl;
11917 grfw(s);
11918 for i := 0 to c -1 do
11919 begin
11920 e := grlw(s);
11921 fmod := e[1];
11922 delete(e, 1, 1);
11923 if Params[i] <> nil then Continue;
11924 cpt := Self.Se.GetTypeNo(StrToInt(e));
11925 if (fmod = '%') or (fmod = '!') or (AlwaysAsVariable(cpt)) then
11926 begin
11927 tmp := CreateHeapVariant(self.Se.FindType2(btPointer));
11928 PPSVariantPointer(tmp).DestType := cpt;
11929 Params[i] := tmp;
11930 PPSVariantPointer(tmp).DataDest := Pointer(FStack^);
11931 FStack := Pointer(IPointer(FStack) + PointerSize);
11932 Inc(Result, PointerSize);
11933 end
11934 (* else if SupportsRegister(cpt) then
11935 begin
11936 tmp := CreateHeapVariant(cpt);
11937 Params[i] := tmp;
11938 CopyArrayContents(@PPSVariantData(tmp)^.Data, Pointer(FStack), 1, cpt);
11939 FStack := Pointer(IPointer(FStack) + 4);
11940 end;
11941 end *)else
11942 begin
11943 tmp := CreateHeapVariant(cpt);
11944 Params[i] := tmp;
11945 CopyArrayContents(@PPSVariantData(tmp)^.Data, Pointer(FStack), 1, cpt);
11946 FStack := Pointer((IPointer(FStack) + cpt.RealSize + 3) and not 3);
11947 Inc(Result, (cpt.RealSize + 3) and not 3);
11948 end;
11949 end;
11950 ex := TPSExceptionHandler.Create;
11951 ex.FinallyOffset := InvalidVal;
11952 ex.ExceptOffset := InvalidVal;
11953 ex.Finally2Offset := InvalidVal;
11954 ex.EndOfBlock := InvalidVal;
11955 ex.CurrProc := nil;
11956 ex.BasePtr := Self.Se.FCurrStackBase;
11957 Ex.StackSize := Self.Se.FStack.Count;
11958 i := Self.Se.FExceptionStack.Add(ex);
11959 Self.Se.RunProc(Params, Self.ProcNo);
11960 if Self.Se.FExceptionStack[i] = ex then
11961 begin
11962 Self.Se.FExceptionStack.Remove(ex);
11963 ex.Free;
11964 end;
11965
11966 if (Res <> nil) then
11967 begin
11968 Params.DeleteLast;
11969 if (ResultAsRegister(Res.FType)) then
11970 begin
11971 if (res^.FType.BaseType = btSingle) or (res^.FType.BaseType = btDouble) or
11972 (res^.FType.BaseType = btCurrency) or (res^.Ftype.BaseType = btExtended) then
11973 begin
11974 case Res^.FType.BaseType of
11975 btSingle: PutOnFPUStackExtended(PPSVariantSingle(res).Data);
11976 btDouble: PutOnFPUStackExtended(PPSVariantDouble(res).Data);
11977 btExtended: PutOnFPUStackExtended(PPSVariantExtended(res).Data);
11978 btCurrency: PutOnFPUStackExtended(PPSVariantCurrency(res).Data);
11979 end;
11980 DestroyHeapVariant(Res);
11981 Res := nil;
11982 end else
11983 begin
11984 {$IFNDEF PS_NOINT64}
11985 if res^.FType.BaseType <> btS64 then
11986 {$ENDIF}
11987 //CopyArrayContents(Pointer(Longint(Stack)-PointerSize2), @PPSVariantData(res)^.Data, 1, Res^.FType);
11988 CopyArrayContents(Pointer(Longint(Stack)-Longint(PointerSize2)), @PPSVariantData(res)^.Data, 1, Res^.FType);
11989 end;
11990 end;
11991 DestroyHeapVariant(res);
11992 end;
11993 for i := 0 to Params.Count -1 do
11994 DestroyHeapVariant(Params[i]);
11995 Params.Free;
11996 if Self.Se.ExEx <> erNoError then
11997 begin
11998 if Self.Se.ExObject <> nil then
11999 begin
12000 FStack := Self.Se.ExObject;
12001 Self.Se.ExObject := nil;
12002 raise TObject(FStack);
12003 end else
12004 raise EPSException.Create(PSErrorToString(Self.SE.ExceptionCode, Self.Se.ExceptionString), Self.Se, Self.Se.ExProc, Self.Se.ExPos);
12005 end;
12006 end;
12007 {$endif}
FindClassnull12008 function TPSRuntimeClassImporter.FindClass(const Name: tbtString): TPSRuntimeClass;
12009 var
12010 h, i: Longint;
12011 lName: tbtstring;
12012 p: TPSRuntimeClass;
12013 begin
12014 lName := FastUpperCase(Name);
12015 h := MakeHash(lName);
12016 for i := FClasses.Count -1 downto 0 do
12017 begin
12018 p := FClasses[i];
12019 if (p.FClassNameHash = h) and (p.FClassName = lName) then
12020 begin
12021 Result := P;
12022 exit;
12023 end;
12024 end;
12025 Result := nil;
12026 end;
12027
12028 function DelphiFunctionProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack; CC: TPSCallingConvention): Boolean;
12029 var
12030 i: Integer;
12031 MyList: TPSList;
12032 n: PPSVariantIFC;
12033 CurrStack: Cardinal;
12034 s: tbtString;
12035 begin
12036 s := P.Decl;
12037 if length(s) = 0 then begin Result := False; exit; end;
12038 CurrStack := Cardinal(Stack.Count) - Cardinal(length(s));
12039 if s[1] = #0 then inc(CurrStack);
12040 MyList := TPSList.Create;
12041
12042 for i := 2 to length(s) do
12043 begin
12044 MyList.Add(nil);
12045 end;
12046 for i := length(s) downto 2 do
12047 begin
12048 MyList[i - 2] := NewPPSVariantIFC(Stack[CurrStack], s[i] <> #0);
12049 inc(CurrStack);
12050 end;
12051 if s[1] <> #0 then
12052 begin
12053 n := NewPPSVariantIFC(Stack[CurrStack], True);
12054 end else n := nil;
12055 try
12056 result := Caller.InnerfuseCall(p.Ext2, p.Ext1, cc, MyList, n);
12057 finally
12058 DisposePPSVariantIFC(n);
12059 DisposePPSVariantIFCList(mylist);
12060 end;
12061 end;
12062
12063 function DelphiFunctionProc_CDECL(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
12064 begin
12065 Result := DelphiFunctionProc(Caller, p, Global, Stack, cdCdecl);
12066 end;
12067 function DelphiFunctionProc_Register(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
12068 begin
12069 Result := DelphiFunctionProc(Caller, p, Global, Stack, cdRegister);
12070 end;
12071 function DelphiFunctionProc_Pascal(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
12072 begin
12073 Result := DelphiFunctionProc(Caller, p, Global, Stack, cdPascal);
12074 end;
12075 function DelphiFunctionProc_Stdcall(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
12076 begin
12077 Result := DelphiFunctionProc(Caller, p, Global, Stack, cdStdCall);
12078 end;
12079 function DelphiFunctionProc_Safecall(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
12080 begin
12081 Result := DelphiFunctionProc(Caller, p, Global, Stack, cdSafeCall);
12082 end;
12083
12084 procedure TPSExec.RegisterDelphiFunction(ProcPtr: Pointer;
12085 const Name: tbtString; CC: TPSCallingConvention);
12086 begin
12087 RegisterDelphiMethod(nil, ProcPtr, FastUppercase(Name), CC);
12088 end;
12089
12090 procedure TPSExec.RegisterDelphiMethod(Slf, ProcPtr: Pointer;
12091 const Name: tbtString; CC: TPSCallingConvention);
12092 begin
12093 case cc of
12094 cdRegister: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_Register, ProcPtr, Slf);
12095 cdPascal: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_Pascal, ProcPtr, Slf);
12096 cdStdCall: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_Stdcall, ProcPtr, Slf);
12097 cdSafeCall: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_Safecall, ProcPtr, Slf);
12098 cdCdecl: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_CDECL, ProcPtr, Slf);
12099 end;
12100 end;
12101
12102 { EPSException }
12103
12104 constructor EPSException.Create(const Error: tbtString; Exec: TPSExec;
12105 Procno, ProcPos: Cardinal);
12106 begin
12107 inherited Create(string(Error));
12108 FExec := Exec;
12109 FProcNo := Procno;
12110 FProcPos := ProcPos;
12111 end;
12112
12113 { TPSRuntimeAttribute }
12114
AddValuenull12115 function TPSRuntimeAttribute.AddValue(aType: TPSTypeRec): PPSVariant;
12116 begin
12117 Result := FValues.PushType(aType);
12118 end;
12119
12120 procedure TPSRuntimeAttribute.AdjustSize;
12121 begin
12122 FValues.Capacity := FValues.Length;
12123 end;
12124
12125 constructor TPSRuntimeAttribute.Create(Owner: TPSRuntimeAttributes);
12126 begin
12127 inherited Create;
12128 FOwner := Owner;
12129 FValues := TPSStack.Create;
12130 end;
12131
12132 procedure TPSRuntimeAttribute.DeleteValue(i: Longint);
12133 begin
12134 if Cardinal(i) <> Cardinal(FValues.Count -1) then
12135 raise Exception.Create(RPS_CanOnlySendLastItem);
12136 FValues.Pop;
12137 end;
12138
12139 destructor TPSRuntimeAttribute.Destroy;
12140 begin
12141 FValues.Free;
12142 inherited Destroy;
12143 end;
12144
GetValuenull12145 function TPSRuntimeAttribute.GetValue(I: Longint): PIFVariant;
12146 begin
12147 Result := FValues[i];
12148 end;
12149
GetValueCountnull12150 function TPSRuntimeAttribute.GetValueCount: Longint;
12151 begin
12152 Result := FValues.Count;
12153 end;
12154
12155 { TPSRuntimeAttributes }
12156
Addnull12157 function TPSRuntimeAttributes.Add: TPSRuntimeAttribute;
12158 begin
12159 Result := TPSRuntimeAttribute.Create(Self);
12160 FAttributes.Add(Result);
12161 end;
12162
12163 constructor TPSRuntimeAttributes.Create(AOwner: TPSExec);
12164 begin
12165 inherited Create;
12166 FAttributes := TPSList.Create;
12167 FOwner := AOwner;
12168 end;
12169
12170 procedure TPSRuntimeAttributes.Delete(I: Longint);
12171 begin
12172 TPSRuntimeAttribute(FAttributes[i]).Free;
12173 FAttributes.Delete(i);
12174 end;
12175
12176 destructor TPSRuntimeAttributes.Destroy;
12177 var
12178 i: Longint;
12179 begin
12180 for i := FAttributes.Count -1 downto 0 do
12181 TPSRuntimeAttribute(FAttributes[i]).Free;
12182 FAttributes.Free;
12183 inherited Destroy;
12184 end;
12185
FindAttributenull12186 function TPSRuntimeAttributes.FindAttribute(
12187 const Name: tbtString): TPSRuntimeAttribute;
12188 var
12189 n: tbtString;
12190 i, h: Longint;
12191 begin
12192 n := FastUpperCase(Name);
12193 h := MakeHash(n);
12194 for i := 0 to FAttributes.Count -1 do
12195 begin
12196 Result := FAttributes[i];
12197 if (Result.AttribTypeHash = h) and (Result.AttribType = n) then
12198 exit;
12199 end;
12200 Result := nil;
12201 end;
12202
GetCountnull12203 function TPSRuntimeAttributes.GetCount: Longint;
12204 begin
12205 Result := FAttributes.Count;
12206 end;
12207
GetItemnull12208 function TPSRuntimeAttributes.GetItem(I: Longint): TPSRuntimeAttribute;
12209 begin
12210 Result := FAttributes[i];
12211 end;
12212
12213 { TPSInternalProcRec }
12214
12215 destructor TPSInternalProcRec.Destroy;
12216 begin
12217 if FData <> nil then
12218 Freemem(Fdata, FLength);
12219 inherited Destroy;
12220 end;
12221
12222 { TPsProcRec }
12223
12224 constructor TPSProcRec.Create(Owner: TPSExec);
12225 begin
12226 inherited Create;
12227 FAttributes := TPSRuntimeAttributes.Create(Owner);
12228 end;
12229
12230 destructor TPSProcRec.Destroy;
12231 begin
12232 FAttributes.Free;
12233 inherited Destroy;
12234 end;
12235
12236 { TPSTypeRec_Array }
12237
12238 procedure TPSTypeRec_Array.CalcSize;
12239 begin
12240 FrealSize := PointerSize;
12241 end;
12242
12243 { TPSTypeRec_StaticArray }
12244
12245 procedure TPSTypeRec_StaticArray.CalcSize;
12246 begin
12247 FrealSize := Cardinal(FArrayType.RealSize) * Cardinal(Size);
12248 end;
12249
12250 { TPSTypeRec_Set }
12251
12252 procedure TPSTypeRec_Set.CalcSize;
12253 begin
12254 FrealSize := FByteSize;
12255 end;
12256
12257 const
12258 MemDelta = 4096;
12259
12260 { TPSStack }
12261
12262 procedure TPSStack.AdjustLength;
12263 var
12264 MyLen: Longint;
12265 begin
12266 MyLen := ((FLength shr 12) + 1) shl 12;
12267 if fCapacity < MyLen then
12268 SetCapacity(((MyLen + MemDelta) div MemDelta) * MemDelta);
12269 end;
12270
12271 procedure TPSStack.Clear;
12272 var
12273 v: Pointer;
12274 i: Longint;
12275 begin
12276 for i := Count -1 downto 0 do
12277 begin
12278 v := Data[i];
12279 if TPSTypeRec(v^).BaseType in NeedFinalization then
12280 FinalizeVariant(Pointer(IPointer(v)+PointerSize), TPSTypeRec(v^));
12281 end;
12282 inherited Clear;
12283 FLength := 0;
12284 SetCapacity(0);
12285 end;
12286
12287 constructor TPSStack.Create;
12288 begin
12289 inherited Create;
12290 GetMem(FDataPtr, MemDelta);
12291 FCapacity := MemDelta;
12292 FLength := 0;
12293 end;
12294
12295 destructor TPSStack.Destroy;
12296 var
12297 v: Pointer;
12298 i: Longint;
12299 begin
12300 for i := Count -1 downto 0 do
12301 begin
12302 v := Data[i];
12303 if TPSTypeRec(v^).BaseType in NeedFinalization then
12304 FinalizeVariant(Pointer(IPointer(v)+PointerSize), Pointer(v^));
12305 end;
12306 FreeMem(FDataPtr, FCapacity);
12307 inherited Destroy;
12308 end;
12309
GetBoolnull12310 function TPSStack.GetBool(ItemNo: Longint): Boolean;
12311 var
12312 val: PPSVariant;
12313 begin
12314 if ItemNo < 0 then
12315 val := Items[Longint(ItemNo) + Longint(Count)]
12316 else
12317 val := Items[ItemNo];
12318 Result := PSGetUInt(@PPSVariantData(val).Data, val.FType) <> 0;
12319 end;
12320
GetClassnull12321 function TPSStack.GetClass(ItemNo: Longint): TObject;
12322 var
12323 val: PPSVariant;
12324 begin
12325 if ItemNo < 0 then
12326 val := Items[Longint(ItemNo) + Longint(Count)]
12327 else
12328 val := Items[ItemNo];
12329 Result := PSGetObject(@PPSVariantData(val).Data, val.FType);
12330 end;
12331
GetCurrencynull12332 function TPSStack.GetCurrency(ItemNo: Longint): Currency;
12333 var
12334 val: PPSVariant;
12335 begin
12336 if ItemNo < 0 then
12337 val := Items[Longint(ItemNo) + Longint(Count)]
12338 else
12339 val := Items[ItemNo];
12340 Result := PSGetCurrency(@PPSVariantData(val).Data, val.FType);
12341 end;
12342
GetIntnull12343 function TPSStack.GetInt(ItemNo: Longint): Longint;
12344 var
12345 val: PPSVariant;
12346 begin
12347 if ItemNo < 0 then
12348 val := items[Longint(ItemNo) + Longint(Count)]
12349 else
12350 val := items[ItemNo];
12351 Result := PSGetInt(@PPSVariantData(val).Data, val.FType);
12352 end;
12353
12354 {$IFNDEF PS_NOINT64}
GetInt64null12355 function TPSStack.GetInt64(ItemNo: Longint): Int64;
12356 var
12357 val: PPSVariant;
12358 begin
12359 if ItemNo < 0 then
12360 val := items[Longint(ItemNo) + Longint(Count)]
12361 else
12362 val := items[ItemNo];
12363 Result := PSGetInt64(@PPSVariantData(val).Data, val.FType);
12364 end;
12365 {$ENDIF}
12366
GetItemnull12367 function TPSStack.GetItem(I: Longint): PPSVariant;
12368 begin
12369 if Cardinal(I) >= Cardinal(Count) then
12370 Result := nil
12371 else
12372 Result := Data[i];
12373 end;
12374
GetRealnull12375 function TPSStack.GetReal(ItemNo: Longint): Extended;
12376 var
12377 val: PPSVariant;
12378 begin
12379 if ItemNo < 0 then
12380 val := items[Longint(ItemNo) + Longint(Count)]
12381 else
12382 val := items[ItemNo];
12383 Result := PSGetreal(@PPSVariantData(val).Data, val.FType);
12384 end;
12385
GetAnsiStringnull12386 function TPSStack.GetAnsiString(ItemNo: Longint): tbtString;
12387 var
12388 val: PPSVariant;
12389 begin
12390 if ItemNo < 0 then
12391 val := items[Longint(ItemNo) + Longint(Count)]
12392 else
12393 val := items[ItemNo];
12394 Result := PSGetAnsiString(@PPSVariantData(val).Data, val.FType);
12395 end;
12396
GetStringnull12397 function TPSStack.GetString(ItemNo: Longint): string; // calls the native method
12398 begin
12399 result := {$IFNDEF PS_NOWIDESTRING}{$IFDEF DELPHI2009UP}GetUnicodeString(ItemNo){$ELSE}GetAnsiString(ItemNo){$ENDIF}{$ELSE}GetAnsiString(ItemNo){$ENDIF};
12400 end;
12401
GetUIntnull12402 function TPSStack.GetUInt(ItemNo: Longint): Cardinal;
12403 var
12404 val: PPSVariant;
12405 begin
12406 if ItemNo < 0 then
12407 val := items[Longint(ItemNo) + Longint(Count)]
12408 else
12409 val := items[ItemNo];
12410 Result := PSGetUInt(@PPSVariantData(val).Data, val.FType);
12411 end;
12412
12413 {$IFNDEF PS_NOWIDESTRING}
GetUnicodeStringnull12414 function TPSStack.GetUnicodeString(ItemNo: Integer): tbtunicodestring;
12415 var
12416 val: PPSVariant;
12417 begin
12418 if ItemNo < 0 then
12419 val := items[Longint(ItemNo) + Longint(Count)]
12420 else
12421 val := items[ItemNo];
12422 Result := PSGetUnicodeString(@PPSVariantData(val).Data, val.FType);
12423 end;
12424
GetWideStringnull12425 function TPSStack.GetWideString(ItemNo: Longint): tbtWideString;
12426 var
12427 val: PPSVariant;
12428 begin
12429 if ItemNo < 0 then
12430 val := items[Longint(ItemNo) + Longint(Count)]
12431 else
12432 val := items[ItemNo];
12433 Result := PSGetWideString(@PPSVariantData(val).Data, val.FType);
12434 end;
12435 {$ENDIF}
12436
12437 procedure TPSStack.Pop;
12438 var
12439 p1: Pointer;
12440 c: Longint;
12441 begin
12442 c := count -1;
12443 p1 := Data[c];
12444 DeleteLast;
12445 FLength := IPointer(p1) - IPointer(FDataPtr);
12446 if TPSTypeRec(p1^).BaseType in NeedFinalization then
12447 FinalizeVariant(Pointer(IPointer(p1)+PointerSize), Pointer(p1^));
12448 if ((FCapacity - FLength) shr 12) > 2 then AdjustLength;
12449 end;
12450
Pushnull12451 function TPSStack.Push(TotalSize: Longint): PPSVariant;
12452 var
12453 o: Cardinal;
12454 p: Pointer;
12455 begin
12456 o := FLength;
12457 FLength := (FLength + TotalSize);
12458 //if FLength mod PointerSize <> 0 then
12459 if FLength mod Longint(PointerSize) <> 0 then
12460 //FLength := FLength + (PointerSize - (FLength mod PointerSize));
12461 FLength := FLength + (Longint(PointerSize) - Longint((FLength mod Longint(PointerSize))));
12462 if FLength > FCapacity then AdjustLength;
12463 p := Pointer(IPointer(FDataPtr) + IPointer(o));
12464 Add(p);
12465 Result := P;
12466 end;
12467
PushTypenull12468 function TPSStack.PushType(aType: TPSTypeRec): PPSVariant;
12469 begin
12470 Result := Push(aType.RealSize + Sizeof(Pointer));
12471 Result.FType := aType;
12472 InitializeVariant(Pointer(IPointer(Result)+PointerSize), aType);
12473 end;
12474
12475 procedure TPSStack.SetBool(ItemNo: Longint; const Data: Boolean);
12476 var
12477 val: PPSVariant;
12478 ok: Boolean;
12479 begin
12480 if ItemNo < 0 then
12481 val := items[Longint(ItemNo) + Longint(Count)]
12482 else
12483 val := items[ItemNo];
12484 ok := true;
12485 if Data then
12486 PSSetUInt(@PPSVariantData(val).Data, val.FType, ok, 1)
12487 else
12488 PSSetUInt(@PPSVariantData(val).Data, val.FType, ok, 0);
12489 if not ok then raise Exception.Create(RPS_TypeMismatch);
12490 end;
12491
12492 procedure TPSStack.SetCapacity(const Value: Longint);
12493 var
12494 p: Pointer;
12495 OOFS: IPointer;
12496 I: Longint;
12497 begin
12498 if Value < FLength then raise Exception.Create(RPS_CapacityLength);
12499 if Value = 0 then
12500 begin
12501 if FDataPtr <> nil then
12502 begin
12503 FreeMem(FDataPtr, FCapacity);
12504 FDataPtr := nil;
12505 end;
12506 FCapacity := 0;
12507 end;
12508 GetMem(p, Value);
12509 if FDataPtr <> nil then
12510 begin
12511 if FLength > FCapacity then
12512 OOFS := FCapacity
12513 else
12514 OOFS := FLength;
12515 Move(FDataPtr^, p^, OOFS);
12516 OOFS := IPointer(P) - IPointer(FDataPtr);
12517
12518 for i := Count -1 downto 0 do begin
12519 Data[i] := Pointer(IPointer(Data[i]) + OOFS);
12520 if Items[i].FType.FBaseType = btPointer then begin // check if pointer points to moved stack data
12521 if (IPointer(PPSVariantPointer(Data[i]).DataDest) >= IPointer(FDataPtr)) and
12522 (IPointer(PPSVariantPointer(Data[i]).DataDest) < IPointer(FDataPtr)+IPointer(FLength)) then
12523 PPSVariantPointer(Data[i]).DataDest := Pointer(IPointer(PPSVariantPointer(Data[i]).DataDest) + OOFS);
12524 end;
12525 end;
12526
12527 FreeMem(FDataPtr, FCapacity);
12528 end;
12529 FDataPtr := p;
12530 FCapacity := Value;
12531 end;
12532
12533 procedure TPSStack.SetClass(ItemNo: Longint; const Data: TObject);
12534 var
12535 val: PPSVariant;
12536 ok: Boolean;
12537 begin
12538 if ItemNo < 0 then
12539 val := items[Longint(ItemNo) + Longint(Count)]
12540 else
12541 val := items[ItemNo];
12542 ok := true;
12543 PSSetObject(@PPSVariantData(val).Data, val.FType, ok, Data);
12544 if not ok then raise Exception.Create(RPS_TypeMismatch);
12545 end;
12546
12547 procedure TPSStack.SetCurrency(ItemNo: Longint; const Data: Currency);
12548 var
12549 val: PPSVariant;
12550 ok: Boolean;
12551 begin
12552 if ItemNo < 0 then
12553 val := items[Longint(ItemNo) + Longint(Count)]
12554 else
12555 val := items[ItemNo];
12556 ok := true;
12557 PSSetCurrency(@PPSVariantData(val).Data, val.FType, ok, Data);
12558 if not ok then raise Exception.Create(RPS_TypeMismatch);
12559 end;
12560
12561 procedure TPSStack.SetInt(ItemNo: Longint; const Data: Longint);
12562 var
12563 val: PPSVariant;
12564 ok: Boolean;
12565 begin
12566 if ItemNo < 0 then
12567 val := items[Longint(ItemNo) + Longint(Count)]
12568 else
12569 val := items[ItemNo];
12570 ok := true;
12571 PSSetInt(@PPSVariantData(val).Data, val.FType, ok, Data);
12572 if not ok then raise Exception.Create(RPS_TypeMismatch);
12573 end;
12574
12575 {$IFNDEF PS_NOINT64}
12576 procedure TPSStack.SetInt64(ItemNo: Longint; const Data: Int64);
12577 var
12578 val: PPSVariant;
12579 ok: Boolean;
12580 begin
12581 if ItemNo < 0 then
12582 val := items[Longint(ItemNo) + Longint(Count)]
12583 else
12584 val := items[ItemNo];
12585 ok := true;
12586 PSSetInt64(@PPSVariantData(val).Data, val.FType, ok, Data);
12587 if not ok then raise Exception.Create(RPS_TypeMismatch);
12588 end;
12589 {$ENDIF}
12590
12591 procedure TPSStack.SetReal(ItemNo: Longint; const Data: Extended);
12592 var
12593 val: PPSVariant;
12594 ok: Boolean;
12595 begin
12596 if ItemNo < 0 then
12597 val := items[Longint(ItemNo) + Longint(Count)]
12598 else
12599 val := items[ItemNo];
12600 ok := true;
12601 PSSetReal(@PPSVariantData(val).Data, val.FType, ok, Data);
12602 if not ok then raise Exception.Create(RPS_TypeMismatch);
12603 end;
12604
12605 procedure TPSStack.SetAnsiString(ItemNo: Longint; const Data: tbtString);
12606 var
12607 val: PPSVariant;
12608 ok: Boolean;
12609 begin
12610 if ItemNo < 0 then
12611 val := items[Longint(ItemNo) + Longint(Count)]
12612 else
12613 val := items[ItemNo];
12614 ok := true;
12615 PSSetAnsiString(@PPSVariantData(val).Data, val.FType, ok, Data);
12616 if not ok then raise Exception.Create(RPS_TypeMismatch);
12617 end;
12618
12619 procedure TPSStack.SetString(ItemNo: Longint; const Data: string);
12620 begin
12621 {$IFNDEF PS_NOWIDESTRING}
12622 {$IFDEF DELPHI2009UP}
12623 SetUnicodeString(ItemNo, Data);
12624 {$ELSE}
12625 SetAnsiString(ItemNo, Data);
12626 {$ENDIF}
12627 {$ELSE}
12628 SetAnsiString(ItemNo, Data);
12629 {$ENDIF}
12630 end;
12631
12632
12633 procedure TPSStack.SetUInt(ItemNo: Longint; const Data: Cardinal);
12634 var
12635 val: PPSVariant;
12636 ok: Boolean;
12637 begin
12638 if ItemNo < 0 then
12639 val := items[Longint(ItemNo) + Longint(Count)]
12640 else
12641 val := items[ItemNo];
12642 ok := true;
12643 PSSetUInt(@PPSVariantData(val).Data, val.FType, ok, Data);
12644 if not ok then raise Exception.Create(RPS_TypeMismatch);
12645 end;
12646
12647
12648 {$IFNDEF PS_NOWIDESTRING}
12649 procedure TPSStack.SetUnicodeString(ItemNo: Integer;
12650 const Data: tbtunicodestring);
12651 var
12652 val: PPSVariant;
12653 ok: Boolean;
12654 begin
12655 if ItemNo < 0 then
12656 val := items[Longint(ItemNo) + Longint(Count)]
12657 else
12658 val := items[ItemNo];
12659 ok := true;
12660 PSSetUnicodeString(@PPSVariantData(val).Data, val.FType, ok, Data);
12661 end;
12662
12663 procedure TPSStack.SetWideString(ItemNo: Longint;
12664 const Data: tbtWideString);
12665 var
12666 val: PPSVariant;
12667 ok: Boolean;
12668 begin
12669 if ItemNo < 0 then
12670 val := items[Longint(ItemNo) + Longint(Count)]
12671 else
12672 val := items[ItemNo];
12673 ok := true;
12674 PSSetWideString(@PPSVariantData(val).Data, val.FType, ok, Data);
12675 if not ok then raise Exception.Create(RPS_TypeMismatch);
12676 end;
12677 {$ENDIF}
12678
12679
12680 {$IFNDEF PS_NOIDISPATCH}
12681 var
12682 DispPropertyPut: Integer = DISPID_PROPERTYPUT;
12683 const
12684 LOCALE_SYSTEM_DEFAULT = 2 shl 10; // Delphi 2 doesn't define this
12685
12686 function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: tbtString; const Par: array of Variant): Variant;
12687 var
12688 Param: Word;
12689 i, ArgErr: Longint;
12690 DispatchId: Longint;
12691 DispParam: TDispParams;
12692 ExceptInfo: TExcepInfo;
12693 aName: PWideChar;
12694 WSFreeList: TPSList;
12695 begin
12696 if Self = nil then begin
12697 raise EPSException.Create('Variant is null, cannot invoke', nil, 0, 0);
12698 end;
12699 FillChar(ExceptInfo, SizeOf(ExceptInfo), 0);
12700 if Name='' then begin
12701 DispatchId:=0;
12702 end else begin
12703 aName := StringToOleStr(Name);
12704 try
12705 if Self = nil then
12706 raise Exception.Create(RPS_NILInterfaceException);
12707 if Self.GetIDsOfNames(GUID_NULL, @aName, 1, LOCALE_SYSTEM_DEFAULT, @DispatchId) <> S_OK then
12708 raise Exception.Create(RPS_UnknownMethod);
12709 finally
12710 SysFreeString(aName);
12711 end;
12712 end;
12713 DispParam.cNamedArgs := 0;
12714 DispParam.rgdispidNamedArgs := nil;
12715 DispParam.cArgs := (High(Par) + 1);
12716
12717 if PropertySet then
12718 begin
12719 Param := DISPATCH_PROPERTYPUT;
12720 DispParam.cNamedArgs := 1;
12721 DispParam.rgdispidNamedArgs := @DispPropertyPut;
12722 end else
12723 Param := DISPATCH_METHOD or DISPATCH_PROPERTYGET;
12724
12725 WSFreeList := TPSList.Create;
12726 try
12727 GetMem(DispParam.rgvarg, sizeof(TVariantArg) * (High(Par) + 1));
12728 FillCHar(DispParam.rgvarg^, sizeof(TVariantArg) * (High(Par) + 1), 0);
12729 try
12730 for i := 0 to High(Par) do
12731 begin
12732 if PVarData(@Par[High(Par)-i]).VType = varString then
12733 begin
12734 DispParam.rgvarg[i].vt := VT_BSTR;
12735 DispParam.rgvarg[i].bstrVal := StringToOleStr(AnsiString(Par[High(Par)-i]));
12736 WSFreeList.Add(DispParam.rgvarg[i].bstrVal);
12737 {$IFDEF UNICODE}
12738 end else if (PVarData(@Par[High(Par)-i]).VType = varOleStr) or (PVarData(@Par[High(Par)-i]).VType = varUString) then
12739 begin
12740 DispParam.rgvarg[i].vt := VT_BSTR;
12741 DispParam.rgvarg[i].bstrVal := StringToOleStr(UnicodeString(Par[High(Par)-i]));
12742 WSFreeList.Add(DispParam.rgvarg[i].bstrVal);
12743 {$ENDIF}
12744 end else
12745 begin
12746 DispParam.rgvarg[i].vt := VT_VARIANT or VT_BYREF;
12747 New(
12748 {$IFDEF DELPHI4UP}
12749 POleVariant
12750 {$ELSE}
12751 PVariant{$ENDIF}
12752 (DispParam.rgvarg[i].pvarVal));
12753
12754 (*
12755 {$IFDEF DELPHI4UP}
12756 POleVariant
12757 {$ELSE}
12758 PVariant
12759 {$ENDIF}
12760 (DispParam.rgvarg[i].pvarVal)^ := Par[High(Par)-i];
12761 *)
12762 Move(Par[High(Par)-i],Pointer(DispParam.rgvarg[i].pvarVal)^,
12763 Sizeof({$IFDEF DELPHI4UP}OleVariant{$ELSE}Variant{$ENDIF}));
12764
12765 end;
12766 end;
12767 i :=Self.Invoke(DispatchId, GUID_NULL, LOCALE_SYSTEM_DEFAULT, Param, DispParam, @Result, @ExceptInfo, @ArgErr);
12768 {$IFNDEF Delphi3UP}
12769 try
12770 if not Succeeded(i) then
12771 begin
12772 if i = DISP_E_EXCEPTION then
12773 raise Exception.Create(OleStrToString(ExceptInfo.bstrSource)+': '+OleStrToString(ExceptInfo.bstrDescription))
12774 else
12775 raise Exception.Create(SysErrorMessage(i));
12776 end;
12777 finally
12778 SysFreeString(ExceptInfo.bstrSource);
12779 SysFreeString(ExceptInfo.bstrDescription);
12780 SysFreeString(ExceptInfo.bstrHelpFile);
12781 end;
12782 {$ELSE}
12783 if not Succeeded(i) then
12784 begin
12785 if i = DISP_E_EXCEPTION then
12786 {$IFDEF FPC}
12787 raise Exception.Create(ExceptInfo.Source+': '+ExceptInfo.Description)
12788 {$ELSE}
12789 raise Exception.Create(ExceptInfo.bstrSource+': '+ExceptInfo.bstrDescription)
12790 {$ENDIF}
12791 else
12792 raise Exception.Create(SysErrorMessage(i));
12793 end;
12794 {$ENDIF}
12795 finally
12796 for i := 0 to High(Par) do
12797 begin
12798 if DispParam.rgvarg[i].vt = (VT_VARIANT or VT_BYREF) then
12799 begin
12800 if{$IFDEF DELPHI4UP}POleVariant{$ELSE}PVariant{$ENDIF}
12801 (DispParam.rgvarg[i].pvarVal) <> nil then
12802 Dispose(
12803 {$IFDEF DELPHI4UP}
12804 POleVariant
12805 {$ELSE}
12806 PVariant
12807 {$ENDIF}
12808 (DispParam.rgvarg[i].pvarVal));
12809 end;
12810 end;
12811 FreeMem(DispParam.rgvarg, sizeof(TVariantArg) * (High(Par) + 1));
12812 end;
12813 finally
12814 for i := WSFreeList.Count -1 downto 0 do
12815 SysFreeString(WSFreeList[i]);
12816 WSFreeList.Free;
12817 end;
12818 end;
12819 {$ENDIF}
12820
12821
12822 { TPSTypeRec_ProcPtr }
12823
12824 procedure TPSTypeRec_ProcPtr.CalcSize;
12825 begin
12826 FRealSize := 3 * sizeof(Pointer);
12827 end;
12828
12829 end.
12830
12831