1 unit uPSCompiler;
2 {$I PascalScript.inc}
3 interface
4 uses
5   {$IFNDEF DELPHI3UP}{$IFNDEF PS_NOINTERFACES}{$IFNDEF LINUX}Windows, Ole2,{$ENDIF}
6   {$ENDIF}{$ENDIF}SysUtils, uPSUtils;
7 
8 
9 type
10 {$IFNDEF PS_NOINTERFACES}
11   TPSInterface = class;
12 {$ENDIF}
13 
14   TPSParameterMode = (pmIn, pmOut, pmInOut);
15   TPSPascalCompiler = class;
16   TPSType = class;
17   TPSValue = class;
18   TPSParameters = class;
19 
20   TPSSubOptType = (tMainBegin, tProcBegin, tSubBegin, tOneLiner, tifOneliner, tRepeat, tTry, tTryEnd
21     {$IFDEF PS_USESSUPPORT},tUnitInit, tUnitFinish {$ENDIF}); //nvds
22 
23 
24   {TPSExternalClass is used when external classes need to be called}
25   TPSCompileTimeClass = class;
26   TPSAttributes = class;
27   TPSAttribute = class;
28 
29   EPSCompilerException = class(Exception) end;
30 
31   TPSParameterDecl = class(TObject)
32   private
33     FName: tbtString;
34     FOrgName: tbtString;
35     FMode: TPSParameterMode;
36     FType: TPSType;
37     {$IFDEF PS_USESSUPPORT}
38     FDeclareUnit: tbtString;
39     {$ENDIF}
40     FDeclarePos: Cardinal;
41     FDeclareRow: Cardinal;
42     FDeclareCol: Cardinal;
43     procedure SetName(const s: tbtString);
44   public
45 
46     property Name: tbtString read FName;
47 
48     property OrgName: tbtString read FOrgName write SetName;
49 
50     property aType: TPSType read FType write FType;
51 
52     property Mode: TPSParameterMode read FMode write FMode;
53 
54     {$IFDEF PS_USESSUPPORT}
55     property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit;
56     {$ENDIF}
57 
58     property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
59 
60     property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
61 
62     property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
63 
64   end;
65 
66 
67   TPSParametersDecl = class(TObject)
68   private
69     FParams: TPSList;
70     FResult: TPSType;
GetParamnull71     function GetParam(I: Longint): TPSParameterDecl;
GetParamCountnull72     function GetParamCount: Longint;
73   public
74 
75     property Params[I: Longint]: TPSParameterDecl read GetParam;
76 
77     property ParamCount: Longint read GetParamCount;
78 
79 
AddParamnull80     function AddParam: TPSParameterDecl;
81 
82     procedure DeleteParam(I: Longint);
83 
84 
85     property Result : TPSType read FResult write FResult;
86 
87 
88     procedure Assign(Params: TPSParametersDecl);
89 
90 
Samenull91     function Same(d: TPSParametersDecl): boolean;
92 
93 
94     constructor Create;
95 
96     destructor Destroy; override;
97   end;
98 
99 
100   TPSRegProc = class(TObject)
101   private
102     FNameHash: Longint;
103     FName: tbtString;
104     FDecl: TPSParametersDecl;
105     FExportName: Boolean;
106     FImportDecl: tbtString;
107     FOrgName: tbtString;
108     procedure SetName(const Value: tbtString);
109   public
110 
111     property OrgName: tbtString read FOrgName write FOrgName;
112 
113     property Name: tbtString read FName write SetName;
114 
115     property NameHash: Longint read FNameHash;
116 
117     property Decl: TPSParametersDecl read FDecl;
118 
119     property ExportName: Boolean read FExportName write FExportName;
120 
121     property ImportDecl: tbtString read FImportDecl write FImportDecl;
122 
123 
124     constructor Create;
125 
126     destructor Destroy; override;
127   end;
128 
129   PIFPSRegProc = TPSRegProc;
130 
131   PIfRVariant = ^TIfRVariant;
132 
133   TIfRVariant = record
134 
135     FType: TPSType;
136     case Byte of
137       1: (tu8: TbtU8);
138       2: (tS8: TbtS8);
139       3: (tu16: TbtU16);
140       4: (ts16: TbtS16);
141       5: (tu32: TbtU32);
142       6: (ts32: TbtS32);
143       7: (tsingle: TbtSingle);
144       8: (tdouble: TbtDouble);
145       9: (textended: TbtExtended);
146       11: (tcurrency: tbtCurrency);
147       10: (tstring: Pointer);
148       {$IFNDEF PS_NOINT64}
149       17: (ts64: Tbts64);
150       {$ENDIF}
151       19: (tchar: tbtChar);
152       {$IFNDEF PS_NOWIDESTRING}
153       18: (twidestring: Pointer);
154       20: (twidechar: tbtwidechar);
155       {$ENDIF}
156       21: (ttype: TPSType);
157       22: (tunistring: Pointer);
158   end;
159 
160   TPSRecordFieldTypeDef = class(TObject)
161   private
162     FFieldOrgName: tbtString;
163     FFieldName: tbtString;
164     FFieldNameHash: Longint;
165     FType: TPSType;
166     procedure SetFieldOrgName(const Value: tbtString);
167   public
168 
169     property FieldOrgName: tbtString read FFieldOrgName write SetFieldOrgName;
170 
171     property FieldName: tbtString read FFieldName;
172 
173     property FieldNameHash: Longint read FFieldNameHash;
174 
175     property aType: TPSType read FType write FType;
176   end;
177 
178   PIFPSRecordFieldTypeDef = TPSRecordFieldTypeDef;
179 
180   TPSType = class(TObject)
181   private
182     FNameHash: Longint;
183     FName: tbtString;
184     FBaseType: TPSBaseType;
185     {$IFDEF PS_USESSUPPORT}
186     FDeclareUnit: tbtString;
187     {$ENDIF}
188     FDeclarePos: Cardinal;
189     FDeclareRow: Cardinal;
190     FDeclareCol: Cardinal;
191     FUsed: Boolean;
192     FExportName: Boolean;
193     FOriginalName: tbtString;
194     FAttributes: TPSAttributes;
195     FFinalTypeNo: cardinal;
196     procedure SetName(const Value: tbtString);
197   public
198 
199     constructor Create;
200 
201     destructor Destroy; override;
202 
203     property Attributes: TPSAttributes read FAttributes;
204 
205 
206     property FinalTypeNo: cardinal read FFinalTypeNo;
207 
208 
209     property OriginalName: tbtString read FOriginalName write FOriginalName;
210 
211     property Name: tbtString read FName write SetName;
212 
213     property NameHash: Longint read FNameHash;
214 
215     property BaseType: TPSBaseType read FBaseType write FBaseType;
216 
217     {$IFDEF PS_USESSUPPORT}
218     property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit;
219     {$ENDIF}
220 
221     property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
222 
223     property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
224 
225     property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
226 
227     property Used: Boolean read FUsed;
228 
229     property ExportName: Boolean read FExportName write FExportName;
230 
231     procedure Use;
232   end;
233 
234 
235   PIFPSType = TPSType;
236 
237   TPSVariantType = class(TPSType)
238   private
239   public
GetDynInvokeProcNonull240     function GetDynInvokeProcNo(Owner: TPSPascalCompiler; const Name: tbtString; Params: TPSParameters): Cardinal; virtual;
GetDynIvokeSelfTypenull241     function GetDynIvokeSelfType(Owner: TPSPascalCompiler): TPSType; virtual;
GetDynInvokeParamTypenull242     function GetDynInvokeParamType(Owner: TPSPascalCompiler): TPSType; virtual;
GetDynIvokeResulTypenull243     function GetDynIvokeResulType(Owner: TPSPascalCompiler): TPSType; virtual;
244   end;
245 
246 
247   TPSRecordType = class(TPSType)
248   private
249     FRecordSubVals: TPSList;
250   public
251 
252     constructor Create;
253 
254     destructor Destroy; override;
255 
RecValCountnull256     function RecValCount: Longint;
257 
RecValnull258     function RecVal(I: Longint): PIFPSRecordFieldTypeDef;
259 
AddRecValnull260     function AddRecVal: PIFPSRecordFieldTypeDef;
261   end;
262 
263   TPSClassType = class(TPSType)
264   private
265     FCL: TPSCompiletimeClass;
266   public
267 
268     property Cl: TPSCompileTimeClass read FCL write FCL;
269   end;
270   TPSExternalClass = class;
271   TPSUndefinedClassType = class(TPSType)
272   private
273     FExtClass: TPSExternalClass;
274   public
275     property ExtClass: TPSExternalClass read FExtClass write FExtClass;
276   end;
277 {$IFNDEF PS_NOINTERFACES}
278 
279   TPSInterfaceType = class(TPSType)
280   private
281     FIntf: TPSInterface;
282   public
283 
284     property Intf: TPSInterface read FIntf write FIntf;
285   end;
286 {$ENDIF}
287 
288 
289   TPSProceduralType = class(TPSType)
290   private
291     FProcDef: TPSParametersDecl;
292   public
293 
294     property ProcDef: TPSParametersDecl read FProcDef;
295 
296     constructor Create;
297 
298     destructor Destroy; override;
299   end;
300 
301   TPSArrayType = class(TPSType)
302   private
303     FArrayTypeNo: TPSType;
304   public
305 
306     property ArrayTypeNo: TPSType read FArrayTypeNo write FArrayTypeNo;
307   end;
308 
309   TPSStaticArrayType = class(TPSArrayType)
310   private
311     FStartOffset: Longint;
312     FLength: Cardinal;
313   public
314 
315     property StartOffset: Longint read FStartOffset write FStartOffset;
316 
317     property Length: Cardinal read FLength write FLength;
318   end;
319 
320   TPSSetType = class(TPSType)
321   private
322     FSetType: TPSType;
GetByteSizenull323     function GetByteSize: Longint;
GetBitSizenull324     function GetBitSize: Longint;
325   public
326 
327     property SetType: TPSType read FSetType write FSetType;
328 
329     property ByteSize: Longint read GetByteSize;
330 
331     property BitSize: Longint read GetBitSize;
332   end;
333 
334   TPSTypeLink = class(TPSType)
335   private
336     FLinkTypeNo: TPSType;
337   public
338 
339     property LinkTypeNo: TPSType read FLinkTypeNo write FLinkTypeNo;
340   end;
341 
342   TPSEnumType = class(TPSType)
343   private
344     FHighValue: Cardinal;
345   public
346 
347     property HighValue: Cardinal read FHighValue write FHighValue;
348   end;
349 
350 
351   TPSProcedure = class(TObject)
352   private
353     FAttributes: TPSAttributes;
354   public
355 
356     property Attributes: TPSAttributes read FAttributes;
357 
358 
359     constructor Create;
360 
361     destructor Destroy; override;
362   end;
363 
364   TPSAttributeType = class;
365 
366   TPSAttributeTypeField = class(TObject)
367   private
368     FOwner: TPSAttributeType;
369     FFieldOrgName: tbtString;
370     FFieldName: tbtString;
371     FFieldNameHash: Longint;
372     FFieldType: TPSType;
373     FHidden: Boolean;
374     procedure SetFieldOrgName(const Value: tbtString);
375   public
376 
377     constructor Create(AOwner: TPSAttributeType);
378 
379     property Owner: TPSAttributeType read FOwner;
380 
381     property FieldOrgName: tbtString read FFieldOrgName write SetFieldOrgName;
382 
383     property FieldName: tbtString read FFieldName;
384 
385     property FieldNameHash: Longint read FFieldNameHash;
386 
387     property FieldType: TPSType read FFieldType write FFieldType;
388 
389     property Hidden: Boolean read FHidden write FHidden;
390   end;
391 
392   TPSApplyAttributeToType = function (Sender: TPSPascalCompiler; aType: TPSType; Attr: TPSAttribute): Boolean;
393 
394   TPSApplyAttributeToProc = function (Sender: TPSPascalCompiler; aProc: TPSProcedure; Attr: TPSAttribute): Boolean;
395   { An attribute type }
396   TPSAttributeType = class(TPSType)
397   private
398     FFields: TPSList;
399     FName: tbtString;
400     FOrgname: tbtString;
401     FNameHash: Longint;
402     FAAProc: TPSApplyAttributeToProc;
403     FAAType: TPSApplyAttributeToType;
GetFieldnull404     function GetField(I: Longint): TPSAttributeTypeField;
GetFieldCountnull405     function GetFieldCount: Longint;
406     procedure SetName(const s: tbtString);
407   public
408 
409     property OnApplyAttributeToType: TPSApplyAttributeToType read FAAType write FAAType;
410 
411     property OnApplyAttributeToProc: TPSApplyAttributeToProc read FAAProc write FAAProc;
412 
413     property Fields[i: Longint]: TPSAttributeTypeField read GetField;
414 
415     property FieldCount: Longint read GetFieldCount;
416 
417     procedure DeleteField(I: Longint);
418 
AddFieldnull419     function AddField: TPSAttributeTypeField;
420 
421     property Name: tbtString read FName;
422 
423     property OrgName: tbtString read FOrgName write SetName;
424 
425     property NameHash: Longint read FNameHash;
426 
427     constructor Create;
428 
429     destructor Destroy; override;
430   end;
431 
432   TPSAttribute = class(TObject)
433   private
434     FAttribType: TPSAttributeType;
435     FValues: TPSList;
GetValueCountnull436     function GetValueCount: Longint;
GetValuenull437     function GetValue(I: Longint): PIfRVariant;
438   public
439 
440     constructor Create(AttribType: TPSAttributeType);
441 
442     procedure Assign(Item: TPSAttribute);
443 
444     property AType: TPSAttributeType read FAttribType;
445 
446     property Count: Longint read GetValueCount;
447 
448     property Values[i: Longint]: PIfRVariant read GetValue; default;
449 
450     procedure DeleteValue(i: Longint);
451 
AddValuenull452     function AddValue(v: PIFRVariant): Longint;
453 
454     destructor Destroy; override;
455   end;
456 
457 
458   TPSAttributes = class(TObject)
459   private
460     FItems: TPSList;
GetCountnull461     function GetCount: Longint;
GetItemnull462     function GetItem(I: Longint): TPSAttribute;
463   public
464 
465     procedure Assign(attr: TPSAttributes; Move: Boolean);
466 
467     property Count: Longint read GetCount;
468 
469     property Items[i: Longint]: TPSAttribute read GetItem; default;
470 
471     procedure Delete(i: Longint);
472 
Addnull473     function Add(AttribType: TPSAttributeType): TPSAttribute;
474 
FindAttributenull475     function FindAttribute(const Name: tbtString): TPSAttribute;
476 
477     constructor Create;
478 
479     destructor Destroy; override;
480   end;
481 
482 
483   TPSProcVar = class(TObject)
484   private
485     FNameHash: Longint;
486     FName: tbtString;
487     FOrgName: tbtString;
488     FType: TPSType;
489     FUsed: Boolean;
490     {$IFDEF PS_USESSUPPORT}
491     FDeclareUnit: tbtString;
492     {$ENDIF}
493     FDeclarePos, FDeclareRow, FDeclareCol: Cardinal;
494     procedure SetName(const Value: tbtString);
495   public
496 
497     property OrgName: tbtString read FOrgName write FOrgname;
498 
499     property NameHash: Longint read FNameHash;
500 
501     property Name: tbtString read FName write SetName;
502 
503     property AType: TPSType read FType write FType;
504 
505     property Used: Boolean read FUsed;
506 
507     {$IFDEF PS_USESSUPPORT}
508     property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit;
509     {$ENDIF}
510 
511     property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
512 
513     property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
514 
515     property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
516 
517     procedure Use;
518   end;
519 
520   PIFPSProcVar = TPSProcVar;
521 
522   TPSExternalProcedure = class(TPSProcedure)
523   private
524     FRegProc: TPSRegProc;
525   public
526 
527     property RegProc: TPSRegProc read FRegProc write FRegProc;
528   end;
529 
530 
531   TPSInternalProcedure = class(TPSProcedure)
532   private
533     FForwarded: Boolean;
534     FData: tbtString;
535     FNameHash: Longint;
536     FName: tbtString;
537     FDecl: TPSParametersDecl;
538     FProcVars: TPSList;
539     FUsed: Boolean;
540     FOutputDeclPosition: Cardinal;
541     FResultUsed: Boolean;
542     FLabels: TIfStringList;
543     FGotos: TIfStringList;
544     FDeclareRow: Cardinal;
545     {$IFDEF PS_USESSUPPORT}
546     FDeclareUnit: tbtString;
547     {$ENDIF}
548     FDeclarePos: Cardinal;
549     FDeclareCol: Cardinal;
550     FOriginalName: tbtString;
551     procedure SetName(const Value: tbtString);
552   public
553 
554     constructor Create;
555 
556     destructor Destroy; override;
557     {Attributes}
558 
559 
560     property Forwarded: Boolean read FForwarded write FForwarded;
561 
562     property Data: tbtString read FData write FData;
563 
564     property Decl: TPSParametersDecl read FDecl;
565 
566     property OriginalName: tbtString read FOriginalName write FOriginalName;
567 
568     property Name: tbtString read FName write SetName;
569 
570     property NameHash: Longint read FNameHash;
571 
572     property ProcVars: TPSList read FProcVars;
573 
574     property Used: Boolean read FUsed;
575 
576     {$IFDEF PS_USESSUPPORT}
577     property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit;
578     {$ENDIF}
579 
580     property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
581 
582     property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
583 
584     property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
585 
586     property OutputDeclPosition: Cardinal read FOutputDeclPosition write FOutputDeclPosition;
587 
588     property ResultUsed: Boolean read FResultUsed;
589 
590 
591     property Labels: TIfStringList read FLabels;
592 
593     property Gotos: TIfStringList read FGotos;
594 
595     procedure Use;
596 
597     procedure ResultUse;
598   end;
599 
600   TPSVar = class(TObject)
601   private
602     FNameHash: Longint;
603     FOrgName: tbtString;
604     FName: tbtString;
605     FType: TPSType;
606     FUsed: Boolean;
607     FExportName: tbtString;
608     FDeclareRow: Cardinal;
609     {$IFDEF PS_USESSUPPORT}
610     FDeclareUnit: tbtString;
611     {$ENDIF}
612     FDeclarePos: Cardinal;
613     FDeclareCol: Cardinal;
614     FSaveAsPointer: Boolean;
615     procedure SetName(const Value: tbtString);
616   public
617 
618     property SaveAsPointer: Boolean read FSaveAsPointer write FSaveAsPointer;
619 
620     property ExportName: tbtString read FExportName write FExportName;
621 
622     property Used: Boolean read FUsed;
623 
624     property aType: TPSType read FType write FType;
625 
626     property OrgName: tbtString read FOrgName write FOrgName;
627 
628     property Name: tbtString read FName write SetName;
629 
630     property NameHash: Longint read FNameHash;
631 
632     {$IFDEF PS_USESSUPPORT}
633     property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit;
634     {$ENDIF}
635 
636     property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
637 
638     property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
639 
640     property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
641 
642     procedure Use;
643   end;
644 
645   PIFPSVar = TPSVar;
646 
647   TPSConstant = class(TObject)
648   private
649 
650     FOrgName: tbtString;
651 
652     FNameHash: Longint;
653 
654     FName: tbtString;
655 
656     FDeclareRow: Cardinal;
657     {$IFDEF PS_USESSUPPORT}
658     FDeclareUnit: tbtString;
659     {$ENDIF}
660     FDeclarePos: Cardinal;
661     FDeclareCol: Cardinal;
662 
663     FValue: PIfRVariant;
664     procedure SetName(const Value: tbtString);
665   public
666 
667     property OrgName: tbtString read FOrgName write FOrgName;
668 
669     property Name: tbtString read FName write SetName;
670 
671     property NameHash: Longint read FNameHash;
672 
673     property Value: PIfRVariant read FValue write FValue;
674 
675     {$IFDEF PS_USESSUPPORT}
676     property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit;
677     {$ENDIF}
678 
679     property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
680 
681     property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
682 
683     property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
684 
685 
686     procedure SetSet(const val);
687 
688 
689     procedure SetInt(const Val: Longint);
690 
691     procedure SetUInt(const Val: Cardinal);
692     {$IFNDEF PS_NOINT64}
693 
694     procedure SetInt64(const Val: Int64);
695     {$ENDIF}
696 
697     procedure SetString(const Val: tbtString);
698 
699     procedure SetChar(c: tbtChar);
700     {$IFNDEF PS_NOWIDESTRING}
701 
702     procedure SetWideChar(const val: WideChar);
703 
704     procedure SetWideString(const val: tbtwidestring);
705     procedure SetUnicodeString(const val: tbtunicodestring);
706     {$ENDIF}
707 
708     procedure SetExtended(const Val: Extended);
709 
710 
711     destructor Destroy; override;
712   end;
713 
714   PIFPSConstant = TPSConstant;
715 
716   TPSPascalCompilerErrorType = (
717     ecUnknownIdentifier,
718     ecIdentifierExpected,
719     ecCommentError,
720     ecStringError,
721     ecCharError,
722     ecSyntaxError,
723     ecUnexpectedEndOfFile,
724     ecSemicolonExpected,
725     ecBeginExpected,
726     ecPeriodExpected,
727     ecDuplicateIdentifier,
728     ecColonExpected,
729     ecUnknownType,
730     ecCloseRoundExpected,
731     ecTypeMismatch,
732     ecInternalError,
733     ecAssignmentExpected,
734     ecThenExpected,
735     ecDoExpected,
736     ecNoResult,
737     ecOpenRoundExpected,
738     ecCommaExpected,
739     ecToExpected,
740     ecIsExpected,
741     ecOfExpected,
742     ecCloseBlockExpected,
743     ecVariableExpected,
744     ecStringExpected,
745     ecEndExpected,
746     ecUnSetLabel,
747     ecNotInLoop,
748     ecInvalidJump,
749     ecOpenBlockExpected,
750     ecWriteOnlyProperty,
751     ecReadOnlyProperty,
752     ecClassTypeExpected,
753     ecCustomError,
754     ecDivideByZero,
755     ecMathError,
756     ecUnsatisfiedForward,
757     ecForwardParameterMismatch,
758     ecInvalidnumberOfParameters
759     {$IFDEF PS_USESSUPPORT}
760     , ecNotAllowed,
761     ecUnitNotFoundOrContainsErrors,
762     ecCrossReference
763     {$ENDIF}
764     );
765 
766   TPSPascalCompilerHintType = (
767     ehVariableNotUsed,
768     ehFunctionNotUsed,
769     ehCustomHint
770     );
771 
772   TPSPascalCompilerWarningType = (
773     ewCalculationAlwaysEvaluatesTo,
774     ewIsNotNeeded,
775     ewAbstractClass,
776     ewCustomWarning
777   );
778 
779   TPSPascalCompilerMessage = class(TObject)
780   protected
781 
782     FRow: Cardinal;
783 
784     FCol: Cardinal;
785 
786     FModuleName: tbtString;
787 
788     FParam: tbtString;
789 
790     FPosition: Cardinal;
791 
792     procedure SetParserPos(Parser: TPSPascalParser);
793   public
794 
795     property ModuleName: tbtString read FModuleName write FModuleName;
796 
797     property Param: tbtString read FParam write FParam;
798 
799     property Pos: Cardinal read FPosition write FPosition;
800 
801     property Row: Cardinal read FRow write FRow;
802 
803     property Col: Cardinal read FCol write FCol;
804 
ErrorTypenull805     function ErrorType: tbtString; virtual; abstract;
806 
807     procedure SetCustomPos(Pos, Row, Col: Cardinal);
808 
MessageToStringnull809     function MessageToString: tbtString; virtual;
810 
ShortMessageToStringnull811     function ShortMessageToString: tbtString; virtual; abstract;
812   end;
813 
814   TPSPascalCompilerError = class(TPSPascalCompilerMessage)
815   protected
816 
817     FError: TPSPascalCompilerErrorType;
818   public
819 
820     property Error: TPSPascalCompilerErrorType read FError;
821 
ErrorTypenull822     function ErrorType: tbtString; override;
ShortMessageToStringnull823     function ShortMessageToString: tbtString; override;
824   end;
825 
826   TPSPascalCompilerHint = class(TPSPascalCompilerMessage)
827   protected
828 
829     FHint: TPSPascalCompilerHintType;
830   public
831 
832     property Hint: TPSPascalCompilerHintType read FHint;
833 
ErrorTypenull834     function ErrorType: tbtString; override;
ShortMessageToStringnull835     function ShortMessageToString: tbtString; override;
836   end;
837 
838   TPSPascalCompilerWarning = class(TPSPascalCompilerMessage)
839   protected
840 
841     FWarning: TPSPascalCompilerWarningType;
842   public
843 
844     property Warning: TPSPascalCompilerWarningType read FWarning;
845 
ErrorTypenull846     function ErrorType: tbtString; override;
ShortMessageToStringnull847     function ShortMessageToString: tbtString; override;
848   end;
849   TPSDuplicCheck = set of (dcTypes, dcProcs, dcVars, dcConsts);
850 
851   TPSBlockInfo = class(TObject)
852   private
853     FOwner: TPSBlockInfo;
854     FWithList: TPSList;
855     FProcNo: Cardinal;
856     FProc: TPSInternalProcedure;
857     FSubType: TPSSubOptType;
858   public
859 
860     property WithList: TPSList read FWithList;
861 
862     property ProcNo: Cardinal read FProcNo write FProcNo;
863 
864     property Proc: TPSInternalProcedure read FProc write FProc;
865 
866     property SubType: TPSSubOptType read FSubType write FSubType;
867 
868     procedure Clear;
869 
870     constructor Create(Owner: TPSBlockInfo);
871 
872     destructor Destroy; override;
873   end;
874 
875 
876 
877   TPSBinOperatorType = (otAdd, otSub, otMul, otDiv, otMod, otShl, otShr, otAnd, otOr, otXor, otAs, otIntDiv,
878                           otGreaterEqual, otLessEqual, otGreater, otLess, otEqual,
879                           otNotEqual, otIs, otIn);
880 
881   TPSUnOperatorType = (otNot, otMinus, otCast);
882 
883   TPSOnUseVariable = procedure (Sender: TPSPascalCompiler; VarType: TPSVariableType; VarNo: Longint; ProcNo, Position: Cardinal; const PropData: tbtString);
884 
endernull885   TPSOnUses = function(Sender: TPSPascalCompiler; const Name: tbtString): Boolean;
886 
endernull887   TPSOnExportCheck = function(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; const ProcDecl: tbtString): Boolean;
888 
889   {$IFNDEF PS_USESSUPPORT}
890   TPSOnWriteLineEvent = function (Sender: TPSPascalCompiler; Position: Cardinal): Boolean;
891   {$ELSE}
892   TPSOnWriteLineEvent = function (Sender: TPSPascalCompiler; FileName: tbtString; Position: Cardinal): Boolean;
893   {$ENDIF}
894 
895   TPSOnExternalProc = function (Sender: TPSPascalCompiler; Decl: TPSParametersDecl; const Name, FExternal: tbtString): TPSRegProc;
896 
897   TPSOnTranslateLineInfoProc = procedure (Sender: TPSPascalCompiler; var Pos, Row, Col: Cardinal; var Name: tbtString);
898   TPSOnNotify = function (Sender: TPSPascalCompiler): Boolean;
899 
900   TPSOnFunction = procedure(name: tbtString; Pos, Row, Col: Integer) of object;
901 
902 
903   TPSPascalCompiler = class
904   protected
905     FAnyString: TPSType;
906     FUnitName: tbtString;
907     FID: Pointer;
908     FOnExportCheck: TPSOnExportCheck;
909     FDefaultBoolType: TPSType;
910     FRegProcs: TPSList;
911     FConstants: TPSList;
912     FProcs: TPSList;
913     FTypes: TPSList;
914     FAttributeTypes: TPSList;
915     FVars: TPSList;
916     FOutput: tbtString;
917     FParser: TPSPascalParser;
918     FParserHadError: Boolean;
919     FMessages: TPSList;
920     FOnUses: TPSOnUses;
921     FUtf8Decode: Boolean;
922     FIsUnit: Boolean;
923     FAllowNoBegin: Boolean;
924     FAllowNoEnd: Boolean;
925     FAllowUnit: Boolean;
926     FAllowDuplicateRegister : Boolean;
927     FBooleanShortCircuit: Boolean;
928     FDebugOutput: tbtString;
929     FOnExternalProc: TPSOnExternalProc;
930     FOnUseVariable: TPSOnUseVariable;
931     FOnBeforeOutput: TPSOnNotify;
932     FOnBeforeCleanup: TPSOnNotify;
933     FOnWriteLine: TPSOnWriteLineEvent;
934     FContinueOffsets, FBreakOffsets: TPSList;
935     FOnTranslateLineInfo: TPSOnTranslateLineInfoProc;
936     FAutoFreeList: TPSList;
937     FClasses: TPSList;
938     FOnFunctionStart: TPSOnFunction;
FOnFunctionEndnull939     FOnFunctionEnd: TPSOnFunction;
940 
941 
942 		FWithCount: Integer;
943 		FTryCount: Integer;
944     FExceptFinallyCount: Integer;
945 
946 
947     {$IFDEF PS_USESSUPPORT}
948     FUnitInits : TPSList; //nvds
949     FUnitFinits: TPSList; //nvds
950     FUses      : TPSStringList;
951     fUnits     : TPSUnitList;
952     fUnit      : TPSUnit;
953     fModule    : tbtString;
954     {$ENDIF}
955     fInCompile : Integer;
956 {$IFNDEF PS_NOINTERFACES}
957     FInterfaces: TPSList;
958 {$ENDIF}
959 
960     FCurrUsedTypeNo: Cardinal;
961     FGlobalBlock: TPSBlockInfo;
962 
IsBooleannull963     function IsBoolean(aType: TPSType): Boolean;
964     {$IFNDEF PS_NOWIDESTRING}
965 
GetWideStringnull966     function GetWideString(Src: PIfRVariant; var s: Boolean): tbtwidestring;
GetUnicodeStringnull967     function GetUnicodeString(Src: PIfRVariant; var s: Boolean): tbtunicodestring;
968     {$ENDIF}
PreCalcnull969     function PreCalc(FUseUsedTypes: Boolean; Var1Mod: Byte; var1: PIFRVariant; Var2Mod: Byte;
970       Var2: PIfRVariant; Cmd: TPSBinOperatorType; Pos, Row, Col: Cardinal): Boolean;
971 
FindBaseTypenull972     function FindBaseType(BaseType: TPSBaseType): TPSType;
973 
IsIntBoolTypenull974     function IsIntBoolType(aType: TPSType): Boolean;
GetTypeCopyLinknull975     function GetTypeCopyLink(p: TPSType): TPSType;
976 
at2utnull977     function at2ut(p: TPSType): TPSType;
978     procedure UseProc(procdecl: TPSParametersDecl);
979 
980 
GetMsgCountnull981     function GetMsgCount: Longint;
982 
GetMsgnull983     function GetMsg(l: Longint): TPSPascalCompilerMessage;
984 
985 
MakeExportDeclnull986     function MakeExportDecl(decl: TPSParametersDecl): tbtString;
987 
988 
989     procedure DefineStandardTypes;
990 
991     procedure DefineStandardProcedures;
992 
ReadRealnull993     function ReadReal(const s: tbtString): PIfRVariant;
ReadStringnull994     function ReadString: PIfRVariant;
ReadIntegernull995     function ReadInteger(const s: tbtString): PIfRVariant;
ReadAttributesnull996     function ReadAttributes(Dest: TPSAttributes): Boolean;
ReadConstantnull997     function ReadConstant(FParser: TPSPascalParser; StopOn: TPSPasToken): PIfRVariant;
998 
ApplyAttribsToFunctionnull999     function ApplyAttribsToFunction(func: TPSProcedure): boolean;
ProcessFunctionnull1000     function ProcessFunction(AlwaysForward: Boolean; Att: TPSAttributes): Boolean;
ValidateParametersnull1001     function ValidateParameters(BlockInfo: TPSBlockInfo; Params: TPSParameters; ParamTypes: TPSParametersDecl): boolean;
1002 
IsVarInCompatiblenull1003     function IsVarInCompatible(ft1, ft2: TPSType): Boolean;
GetTypeNonull1004     function GetTypeNo(BlockInfo: TPSBlockInfo; p: TPSValue): TPSType;
DoVarBlocknull1005     function DoVarBlock(proc: TPSInternalProcedure): Boolean;
DoTypeBlocknull1006     function DoTypeBlock(FParser: TPSPascalParser): Boolean;
ReadTypenull1007     function ReadType(const Name: tbtString; FParser: TPSPascalParser): TPSType;
ProcessLabelnull1008     function ProcessLabel(Proc: TPSInternalProcedure): Boolean;
ProcessSubnull1009     function ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
ProcessLabelForwardsnull1010     function ProcessLabelForwards(Proc: TPSInternalProcedure): Boolean;
1011 
1012     procedure WriteDebugData(const s: tbtString);
1013 
1014     procedure Debug_SavePosition(ProcNo: Cardinal; Proc: TPSInternalProcedure);
1015 
1016     procedure Debug_WriteParams(ProcNo: Cardinal; Proc: TPSInternalProcedure);
1017 
1018     procedure Debug_WriteLine(BlockInfo: TPSBlockInfo);
1019 
1020 
IsCompatibleTypenull1021     function IsCompatibleType(p1, p2: TPSType; Cast: Boolean): Boolean;
1022 
IsDuplicatenull1023     function IsDuplicate(const s: tbtString; const check: TPSDuplicCheck): Boolean;
1024     {$IFDEF PS_USESSUPPORT}
IsInLocalUnitListnull1025     function IsInLocalUnitList(s: tbtString): Boolean;
1026 	{$ENDIF}
1027 
NewProcnull1028     function NewProc(const OriginalName, Name: tbtString): TPSInternalProcedure;
1029 
AddUsedFunctionnull1030     function AddUsedFunction(var Proc: TPSInternalProcedure): Cardinal;
1031 
AddUsedFunction2null1032     function AddUsedFunction2(var Proc: TPSExternalProcedure): Cardinal;
1033 
1034 
CheckCompatProcnull1035     function CheckCompatProc(P: TPSType; ProcNo: Cardinal): Boolean;
1036 
1037 
1038     procedure ParserError(Parser: TObject; Kind: TPSParserErrorKind);
1039 
ReadTypeAddProcedurenull1040     function ReadTypeAddProcedure(const Name: tbtString; FParser: TPSPascalParser): TPSType;
1041 
VarIsDuplicatenull1042     function VarIsDuplicate(Proc: TPSInternalProcedure; const VarNames, s: tbtString): Boolean;
1043 
IsProcDuplicLabelnull1044     function IsProcDuplicLabel(Proc: TPSInternalProcedure; const s: tbtString): Boolean;
1045 
1046     procedure CheckForUnusedVars(Func: TPSInternalProcedure);
ProcIsDuplicnull1047     function ProcIsDuplic(Decl: TPSParametersDecl; const FunctionName, FunctionParamNames: tbtString; const s: tbtString; Func: TPSInternalProcedure): Boolean;
1048    public
GetConstantnull1049      function GetConstant(const Name: tbtString): TPSConstant;
1050 
UseExternalProcnull1051      function UseExternalProc(const Name: tbtString): TPSParametersDecl;
1052 
FindProcnull1053     function FindProc(const aName: tbtString): Cardinal;
1054 
GetTypeCountnull1055     function GetTypeCount: Longint;
1056 
GetTypenull1057     function GetType(I: Longint): TPSType;
1058 
GetVarCountnull1059     function GetVarCount: Longint;
1060 
GetVarnull1061     function GetVar(I: Longint): TPSVar;
1062 
GetProcCountnull1063     function GetProcCount: Longint;
1064 
GetProcnull1065     function GetProc(I: Longint): TPSProcedure;
1066 
GetConstCountnull1067     function GetConstCount: Longint;
1068 
GetConstnull1069     function GetConst(I: Longint): TPSConstant;
1070 
GetRegProcCountnull1071     function GetRegProcCount: Longint;
1072 
GetRegProcnull1073     function GetRegProc(I: Longint): TPSRegProc;
1074 
AddAttributeTypenull1075     function AddAttributeType: TPSAttributeType;
FindAttributeTypenull1076     function FindAttributeType(const Name: tbtString): TPSAttributeType;
1077 
1078     procedure AddToFreeList(Obj: TObject);
1079 
1080     property ID: Pointer read FID write FID;
1081 
MakeErrornull1082     function MakeError(const Module: tbtString; E: TPSPascalCompilerErrorType; const
1083       Param: tbtString): TPSPascalCompilerMessage;
1084 
MakeWarningnull1085     function MakeWarning(const Module: tbtString; E: TPSPascalCompilerWarningType;
1086       const Param: tbtString): TPSPascalCompilerMessage;
1087 
MakeHintnull1088     function MakeHint(const Module: tbtString; E: TPSPascalCompilerHintType;
1089       const Param: tbtString): TPSPascalCompilerMessage;
1090 
1091 {$IFNDEF PS_NOINTERFACES}
1092 
AddInterfacenull1093     function AddInterface(InheritedFrom: TPSInterface; Guid: TGuid; const Name: tbtString): TPSInterface;
1094 
FindInterfacenull1095     function FindInterface(const Name: tbtString): TPSInterface;
1096 
1097 {$ENDIF}
AddClassnull1098     function AddClass(InheritsFrom: TPSCompileTimeClass; aClass: TClass): TPSCompileTimeClass;
1099 
AddClassNnull1100     function AddClassN(InheritsFrom: TPSCompileTimeClass; const aClass: tbtString): TPSCompileTimeClass;
1101 
1102 
FindClassnull1103     function FindClass(const aClass: tbtString): TPSCompileTimeClass;
1104 
AddFunctionnull1105     function AddFunction(const Header: tbtString): TPSRegProc;
1106 
AddDelphiFunctionnull1107     function AddDelphiFunction(const Decl: tbtString): TPSRegProc;
1108 
AddTypenull1109     function AddType(const Name: tbtString; const BaseType: TPSBaseType): TPSType;
1110 
AddTypeSnull1111     function AddTypeS(const Name, Decl: tbtString): TPSType;
1112 
AddTypeCopynull1113     function AddTypeCopy(const Name: tbtString; TypeNo: TPSType): TPSType;
1114 
AddTypeCopyNnull1115     function AddTypeCopyN(const Name, FType: tbtString): TPSType;
1116 
AddConstantnull1117     function AddConstant(const Name: tbtString; FType: TPSType): TPSConstant;
1118 
AddConstantNnull1119     function AddConstantN(const Name, FType: tbtString): TPSConstant;
1120 
AddVariablenull1121     function AddVariable(const Name: tbtString; FType: TPSType): TPSVar;
1122 
AddVariableNnull1123     function AddVariableN(const Name, FType: tbtString): TPSVar;
1124 
AddUsedVariablenull1125     function AddUsedVariable(const Name: tbtString; FType: TPSType): TPSVar;
1126 
AddUsedVariableNnull1127     function AddUsedVariableN(const Name, FType: tbtString): TPSVar;
1128 
AddUsedPtrVariablenull1129     function AddUsedPtrVariable(const Name: tbtString; FType: TPSType): TPSVar;
1130 
AddUsedPtrVariableNnull1131     function AddUsedPtrVariableN(const Name, FType: tbtString): TPSVar;
1132 
FindTypenull1133     function FindType(const Name: tbtString): TPSType;
1134 
MakeDeclnull1135     function MakeDecl(decl: TPSParametersDecl): tbtString;
1136 
Compilenull1137     function Compile(const s: tbtString): Boolean;
1138 
GetOutputnull1139     function GetOutput(var s: tbtString): Boolean;
1140 
GetDebugOutputnull1141     function GetDebugOutput(var s: tbtString): Boolean;
1142 
1143     procedure Clear;
1144 
1145     constructor Create;
1146 
1147     destructor Destroy; override;
1148 
1149     property MsgCount: Longint read GetMsgCount;
1150 
1151     property Msg[l: Longint]: TPSPascalCompilerMessage read GetMsg;
1152 
1153     property OnTranslateLineInfo: TPSOnTranslateLineInfoProc read FOnTranslateLineInfo write FOnTranslateLineInfo;
1154 
1155     property OnUses: TPSOnUses read FOnUses write FOnUses;
1156 
1157     property OnExportCheck: TPSOnExportCheck read FOnExportCheck write FOnExportCheck;
1158 
1159     property OnWriteLine: TPSOnWriteLineEvent read FOnWriteLine write FOnWriteLine;
1160 
1161     property OnExternalProc: TPSOnExternalProc read FOnExternalProc write FOnExternalProc;
1162 
1163     property OnUseVariable: TPSOnUseVariable read FOnUseVariable write FOnUseVariable;
1164 
1165     property OnBeforeOutput: TPSOnNotify read FOnBeforeOutput write FOnBeforeOutput;
1166 
1167     property OnBeforeCleanup: TPSOnNotify read FOnBeforeCleanup write FOnBeforeCleanup;
1168 
readnull1169     property OnFunctionStart: TPSOnFunction read FOnFunctionStart write FOnFunctionStart;
1170 
readnull1171     property OnFunctionEnd: TPSOnFunction read FOnFunctionEnd write FOnFunctionEnd;
1172 
1173     property IsUnit: Boolean read FIsUnit;
1174 
1175     property AllowNoBegin: Boolean read FAllowNoBegin write FAllowNoBegin;
1176 
1177     property AllowUnit: Boolean read FAllowUnit write FAllowUnit;
1178 
1179     property AllowNoEnd: Boolean read FAllowNoEnd write FAllowNoEnd;
1180 
1181     property AllowDuplicateRegister : Boolean read FAllowDuplicateRegister write FAllowDuplicateRegister;
1182 
1183     property BooleanShortCircuit: Boolean read FBooleanShortCircuit write FBooleanShortCircuit;
1184 
1185     property UTF8Decode: Boolean read FUtf8Decode write FUtf8Decode;
1186 
1187     {$WARNINGS OFF}
1188     property UnitName: tbtString read FUnitName;
1189     {$WARNINGS ON}
1190   end;
1191   TIFPSPascalCompiler = TPSPascalCompiler;
1192 
1193   TPSValue = class(TObject)
1194   private
1195     FPos, FRow, FCol: Cardinal;
1196   public
1197 
1198     property Pos: Cardinal read FPos write FPos;
1199 
1200     property Row: Cardinal read FRow write FRow;
1201 
1202     property Col: Cardinal read FCol write FCol;
1203 
1204     procedure SetParserPos(P: TPSPascalParser);
1205 
1206   end;
1207 
1208   TPSParameter = class(TObject)
1209   private
1210     FValue: TPSValue;
1211     FTempVar: TPSValue;
1212     FParamMode: TPSParameterMode;
1213     FExpectedType: TPSType;
1214   public
1215 
1216     property Val: TPSValue read FValue write FValue;
1217 
1218     property ExpectedType: TPSType read FExpectedType write FExpectedType;
1219 
1220     property TempVar: TPSValue read FTempVar write FTempVar;
1221 
1222     property ParamMode: TPSParameterMode read FParamMode write FParamMode;
1223 
1224     destructor Destroy; override;
1225   end;
1226 
1227   TPSParameters = class(TObject)
1228   private
1229     FItems: TPSList;
GetCountnull1230     function GetCount: Cardinal;
GetItemnull1231     function GetItem(I: Longint): TPSParameter;
1232   public
1233 
1234     constructor Create;
1235 
1236     destructor Destroy; override;
1237 
1238     property Count: Cardinal read GetCount;
1239 
1240     property Item[I: Longint]: TPSParameter read GetItem; default;
1241 
1242     procedure Delete(I: Cardinal);
1243 
Addnull1244     function Add: TPSParameter;
1245   end;
1246 
1247   TPSSubItem = class(TObject)
1248   private
1249     FType: TPSType;
1250   public
1251 
1252     property aType: TPSType read FType write FType;
1253   end;
1254 
1255   TPSSubNumber = class(TPSSubItem)
1256   private
1257     FSubNo: Cardinal;
1258   public
1259 
1260     property SubNo: Cardinal read FSubNo write FSubNo;
1261   end;
1262 
1263   TPSSubValue = class(TPSSubItem)
1264   private
1265     FSubNo: TPSValue;
1266   public
1267 
1268     property SubNo: TPSValue read FSubNo write FSubNo;
1269 
1270     destructor Destroy; override;
1271   end;
1272 
1273   TPSValueVar = class(TPSValue)
1274   private
1275     FRecItems: TPSList;
GetRecCountnull1276     function GetRecCount: Cardinal;
GetRecItemnull1277     function GetRecItem(I: Cardinal): TPSSubItem;
1278   public
1279     constructor Create;
1280     destructor Destroy; override;
1281 
RecAddnull1282     function RecAdd(Val: TPSSubItem): Cardinal;
1283 
1284     procedure RecDelete(I: Cardinal);
1285 
1286     property RecItem[I: Cardinal]: TPSSubItem read GetRecItem;
1287 
1288     property RecCount: Cardinal read GetRecCount;
1289   end;
1290 
1291   TPSValueGlobalVar = class(TPSValueVar)
1292   private
1293     FAddress: Cardinal;
1294   public
1295 
1296     property GlobalVarNo: Cardinal read FAddress write FAddress;
1297   end;
1298 
1299 
1300   TPSValueLocalVar = class(TPSValueVar)
1301   private
1302     FLocalVarNo: Longint;
1303   public
1304 
1305     property LocalVarNo: Longint read FLocalVarNo write FLocalVarNo;
1306   end;
1307 
1308   TPSValueParamVar = class(TPSValueVar)
1309   private
1310     FParamNo: Longint;
1311   public
1312 
1313     property ParamNo: Longint read FParamNo write FParamNo;
1314   end;
1315 
1316   TPSValueAllocatedStackVar = class(TPSValueLocalVar)
1317   private
1318     FProc: TPSInternalProcedure;
1319   public
1320 
1321     property Proc: TPSInternalProcedure read FProc write FProc;
1322     destructor Destroy; override;
1323   end;
1324 
1325   TPSValueData = class(TPSValue)
1326   private
1327     FData: PIfRVariant;
1328   public
1329 
1330     property Data: PIfRVariant read FData write FData;
1331     destructor Destroy; override;
1332   end;
1333 
1334   TPSValueReplace = class(TPSValue)
1335   private
1336     FPreWriteAllocated: Boolean;
1337     FFreeOldValue: Boolean;
1338     FFreeNewValue: Boolean;
1339     FOldValue: TPSValue;
1340     FNewValue: TPSValue;
1341     FReplaceTimes: Longint;
1342   public
1343 
1344     property OldValue: TPSValue read FOldValue write FOldValue;
1345 
1346     property NewValue: TPSValue read FNewValue write FNewValue;
1347     {Should it free the old value when destroyed?}
1348     property FreeOldValue: Boolean read FFreeOldValue write FFreeOldValue;
1349     property FreeNewValue: Boolean read FFreeNewValue write FFreeNewValue;
1350     property PreWriteAllocated: Boolean read FPreWriteAllocated write FPreWriteAllocated;
1351 
1352     property ReplaceTimes: Longint read FReplaceTimes write FReplaceTimes;
1353 
1354     constructor Create;
1355     destructor Destroy; override;
1356   end;
1357 
1358 
1359   TPSUnValueOp = class(TPSValue)
1360   private
1361     FVal1: TPSValue;
1362     FOperator: TPSUnOperatorType;
1363     FType: TPSType;
1364   public
1365 
1366     property Val1: TPSValue read FVal1 write FVal1;
1367     {The operator}
1368     property Operator: TPSUnOperatorType read FOperator write FOperator;
1369 
1370     property aType: TPSType read FType write FType;
1371     destructor Destroy; override;
1372   end;
1373 
1374   TPSBinValueOp = class(TPSValue)
1375   private
1376     FVal1,
1377     FVal2: TPSValue;
1378     FOperator: TPSBinOperatorType;
1379     FType: TPSType;
1380   public
1381 
1382     property Val1: TPSValue read FVal1 write FVal1;
1383 
1384     property Val2: TPSValue read FVal2 write FVal2;
1385     {The operator for this value}
1386     property Operator: TPSBinOperatorType read FOperator write FOperator;
1387 
1388     property aType: TPSType read FType write FType;
1389 
1390     destructor Destroy; override;
1391   end;
1392 
1393   TPSValueNil = class(TPSValue)
1394   end;
1395 
1396   TPSValueProcPtr = class(TPSValue)
1397   private
1398     FProcNo: Cardinal;
1399   public
1400 
1401     property ProcPtr: Cardinal read FProcNo write FProcNo;
1402   end;
1403 
1404   TPSValueProc = class(TPSValue)
1405   private
1406     FSelfPtr: TPSValue;
1407     FParameters: TPSParameters;
1408     FResultType: TPSType;
1409   public
1410     property ResultType: TPSType read FResultType write FResultType;
1411 
1412     property SelfPtr: TPSValue read FSelfPtr write FSelfPtr;
1413 
1414     property Parameters: TPSParameters read FParameters write FParameters;
1415     destructor Destroy; override;
1416   end;
1417 
1418   TPSValueProcNo = class(TPSValueProc)
1419   private
1420     FProcNo: Cardinal;
1421   public
1422 
1423     property ProcNo: Cardinal read FProcNo write FProcNo;
1424   end;
1425 
1426   TPSValueProcVal = class(TPSValueProc)
1427   private
1428     FProcNo: TPSValue;
1429   public
1430 
1431     property ProcNo: TPSValue read FProcNo write FProcNo;
1432 
1433     destructor Destroy; override;
1434   end;
1435 
1436   TPSValueArray = class(TPSValue)
1437   private
1438     FItems: TPSList;
GetCountnull1439     function GetCount: Cardinal;
GetItemnull1440     function GetItem(I: Cardinal): TPSValue;
1441   public
Addnull1442     function Add(Item: TPSValue): Cardinal;
1443     procedure Delete(I: Cardinal);
1444     property Item[I: Cardinal]: TPSValue read GetItem;
1445     property Count: Cardinal read GetCount;
1446 
1447     constructor Create;
1448     destructor Destroy; override;
1449   end;
1450 
1451   TPSDelphiClassItem = class;
1452 
1453   TPSPropType = (iptRW, iptR, iptW);
1454 
1455   TPSCompileTimeClass = class
1456   private
1457     FInheritsFrom: TPSCompileTimeClass;
1458     FClass: TClass;
1459     FClassName: tbtString;
1460     FClassNameHash: Longint;
1461     FClassItems: TPSList;
1462     FDefaultProperty: Cardinal;
1463     FIsAbstract: Boolean;
1464     FCastProc,
1465     FNilProc: Cardinal;
1466     FType: TPSType;
1467 
1468     FOwner: TPSPascalCompiler;
GetCountnull1469     function GetCount: Longint;
GetItemnull1470     function GetItem(i: Longint): TPSDelphiClassItem;
1471   public
1472 
1473     property aType: TPSType read FType;
1474 
1475     property Items[i: Longint]: TPSDelphiClassItem read GetItem;
1476 
1477     property Count: Longint read GetCount;
1478 
1479     property IsAbstract: Boolean read FIsAbstract write FIsAbstract;
1480 
1481 
1482     property ClassInheritsFrom: TPSCompileTimeClass read FInheritsFrom write FInheritsFrom;
1483 
RegisterMethodnull1484     function RegisterMethod(const Decl: tbtString): Boolean;
1485 
1486     procedure RegisterProperty(const PropertyName, PropertyType: tbtString; PropAC: TPSPropType);
1487 
1488     procedure RegisterPublishedProperties;
1489 
RegisterPublishedPropertynull1490     function RegisterPublishedProperty(const Name: tbtString): Boolean;
1491 
1492     procedure SetDefaultPropery(const Name: tbtString);
1493 
1494     constructor Create(ClassName: tbtString; aOwner: TPSPascalCompiler; aType: TPSType);
1495 
CreateCnull1496     class function CreateC(FClass: TClass; aOwner: TPSPascalCompiler; aType: TPSType): TPSCompileTimeClass;
1497 
1498 
1499     destructor Destroy; override;
1500 
1501 
IsCompatibleWithnull1502     function IsCompatibleWith(aType: TPSType): Boolean;
1503 
SetNilnull1504     function SetNil(var ProcNo: Cardinal): Boolean;
1505 
CastToTypenull1506     function CastToType(IntoType: TPSType; var ProcNo: Cardinal): Boolean;
1507 
1508 
Property_Findnull1509     function Property_Find(const Name: tbtString; var Index: TPSDelphiClassItem): Boolean;
1510 
Property_Getnull1511     function Property_Get(Index: TPSDelphiClassItem; var ProcNo: Cardinal): Boolean;
1512 
Property_Setnull1513     function Property_Set(Index: TPSDelphiClassItem; var ProcNo: Cardinal): Boolean;
1514 
Property_GetHeadernull1515     function Property_GetHeader(Index: TPSDelphiClassItem; Dest: TPSParametersDecl): Boolean;
1516 
1517 
Func_Findnull1518     function Func_Find(const Name: tbtString; var Index: TPSDelphiClassItem): Boolean;
1519 
Func_Callnull1520     function Func_Call(Index: TPSDelphiClassItem; var ProcNo: Cardinal): Boolean;
1521 
1522 
ClassFunc_Findnull1523     function ClassFunc_Find(const Name: tbtString; var Index: IPointer): Boolean;
1524 
ClassFunc_Callnull1525     function ClassFunc_Call(Index: IPointer; var ProcNo: Cardinal): Boolean;
1526   end;
1527 
1528   TPSDelphiClassItem = class(TObject)
1529   private
1530     FOwner: TPSCompileTimeClass;
1531     FOrgName: tbtString;
1532     FName: tbtString;
1533     FNameHash: Longint;
1534     FDecl: TPSParametersDecl;
1535     procedure SetName(const s: tbtString);
1536   public
1537 
1538     constructor Create(Owner: TPSCompileTimeClass);
1539 
1540     destructor Destroy; override;
1541 
1542     property Decl: TPSParametersDecl read FDecl;
1543 
1544     property Name: tbtString read FName;
1545 
1546     property OrgName: tbtString read FOrgName write SetName;
1547 
1548     property NameHash: Longint read FNameHash;
1549 
1550     property Owner: TPSCompileTimeClass read FOwner;
1551   end;
1552 
1553   TPSDelphiClassItemMethod = class(TPSDelphiClassItem)
1554   private
1555     FMethodNo: Cardinal;
1556   public
1557 
1558     property MethodNo: Cardinal read FMethodNo write FMethodNo;
1559   end;
1560 
1561   TPSDelphiClassItemProperty = class(TPSDelphiClassItem)
1562   private
1563     FReadProcNo: Cardinal;
1564     FWriteProcNo: Cardinal;
1565     FAccessType: TPSPropType;
1566   public
1567 
1568     property AccessType: TPSPropType read FAccessType write FAccessType;
1569 
1570     property ReadProcNo: Cardinal read FReadProcNo write FReadProcNo;
1571 
1572     property WriteProcNo: Cardinal read FWriteProcNo write FWriteProcNo;
1573   end;
1574 
1575 
1576   TPSDelphiClassItemConstructor = class(TPSDelphiClassItemMethod)
1577   end;
1578 
1579 {$IFNDEF PS_NOINTERFACES}
1580 
1581   TPSInterfaceMethod = class;
1582 
1583   TPSInterface = class(TObject)
1584   private
1585     FOwner: TPSPascalCompiler;
1586     FType: TPSType;
1587     FInheritedFrom: TPSInterface;
1588     FGuid: TGuid;
1589     FCastProc,
1590     FNilProc: Cardinal;
1591     FItems: TPSList;
1592     FName: tbtString;
1593     FNameHash: Longint;
1594     procedure SetInheritedFrom(p: TPSInterface);
1595   public
1596 
1597     constructor Create(Owner: TPSPascalCompiler; InheritedFrom: TPSInterface; Guid: TGuid; const Name: tbtString; aType: TPSType);
1598 
1599     destructor Destroy; override;
1600 
1601     property aType: TPSType read FType;
1602 
1603     property InheritedFrom: TPSInterface read FInheritedFrom write SetInheritedFrom;
1604 
1605     property Guid: TGuid read FGuid write FGuid;
1606 
1607     property Name: tbtString read FName write FName;
1608 
1609     property NameHash: Longint read FNameHash;
1610 
1611 
RegisterMethodnull1612     function RegisterMethod(const Declaration: tbtString; const cc: TPSCallingConvention): Boolean;
1613 
RegisterMethodExnull1614     function RegisterMethodEx(const Declaration: tbtString; const cc: TPSCallingConvention; const CustomParser: TPSPascalParser): Boolean;
1615 
1616     procedure RegisterDummyMethod;
1617 
IsCompatibleWithnull1618     function IsCompatibleWith(aType: TPSType): Boolean;
1619 
SetNilnull1620     function SetNil(var ProcNo: Cardinal): Boolean;
1621 
CastToTypenull1622     function CastToType(IntoType: TPSType; var ProcNo: Cardinal): Boolean;
1623 
Func_Findnull1624     function Func_Find(const Name: tbtString; var Index: TPSInterfaceMethod): Boolean;
1625 
Func_Callnull1626     function Func_Call(Index: TPSInterfaceMethod; var ProcNo: Cardinal): Boolean;
1627   end;
1628 
1629 
1630   TPSInterfaceMethod = class(TObject)
1631   private
1632     FName: tbtString;
1633     FDecl: TPSParametersDecl;
1634     FNameHash: Longint;
1635     FCC: TPSCallingConvention;
1636     FScriptProcNo: Cardinal;
1637     FOrgName: tbtString;
1638     FOwner: TPSInterface;
1639     FOffsetCache: Cardinal;
GetAbsoluteProcOffsetnull1640     function GetAbsoluteProcOffset: Cardinal;
1641   public
1642 
1643     property AbsoluteProcOffset: Cardinal read GetAbsoluteProcOffset;
1644 
1645     property ScriptProcNo: Cardinal read FScriptProcNo;
1646 
1647     property OrgName: tbtString read FOrgName;
1648 
1649     property Name: tbtString read FName;
1650 
1651     property NameHash: Longint read FNameHash;
1652 
1653     property Decl: TPSParametersDecl read FDecl;
1654 
1655     property CC: TPSCallingConvention read FCC;
1656 
1657 
1658     constructor Create(Owner: TPSInterface);
1659 
1660     destructor Destroy; override;
1661   end;
1662 {$ENDIF}
1663 
1664 
1665   TPSExternalClass = class(TObject)
1666   protected
1667 
1668     SE: TPSPascalCompiler;
1669 
1670     FTypeNo: TPSType;
1671   public
1672 
SelfTypenull1673     function SelfType: TPSType; virtual;
1674 
1675     constructor Create(Se: TPSPascalCompiler; TypeNo: TPSType);
1676 
ClassFunc_Findnull1677     function ClassFunc_Find(const Name: tbtString; var Index: Cardinal): Boolean; virtual;
1678 
ClassFunc_Callnull1679     function ClassFunc_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
1680 
Func_Findnull1681     function Func_Find(const Name: tbtString; var Index: Cardinal): Boolean; virtual;
1682 
Func_Callnull1683     function Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
1684 
IsCompatibleWithnull1685     function IsCompatibleWith(Cl: TPSExternalClass): Boolean; virtual;
1686 
SetNilnull1687     function SetNil(var ProcNo: Cardinal): Boolean; virtual;
1688 
CastToTypenull1689     function CastToType(IntoType: TPSType; var ProcNo: Cardinal): Boolean; virtual;
1690 
CompareClassnull1691     function CompareClass(OtherTypeNo: TPSType; var ProcNo: Cardinal): Boolean; virtual;
1692   end;
1693 
1694 
ExportChecknull1695 function ExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure;
1696   Types: array of TPSBaseType; Modes: array of TPSParameterMode): Boolean;
1697 
1698 
1699 procedure SetVarExportName(P: TPSVar; const ExpName: tbtString);
1700 
AddImportedClassVariablenull1701 function AddImportedClassVariable(Sender: TPSPascalCompiler; const VarName, VarType: tbtString): Boolean;
1702 
1703 const
1704   {Invalid value, this is returned by most functions of pascal script that return a cardinal, when they fail}
1705   InvalidVal = Cardinal(-1);
1706 
1707 type
1708   TIFPSCompileTimeClass = TPSCompileTimeClass;
1709   TIFPSInternalProcedure = TPSInternalProcedure;
1710   TIFPSPascalCompilerError = TPSPascalCompilerError;
1711 
1712   TPMFuncType = (mftProc
1713   , mftConstructor
1714   );
1715 
1716 
PS_mi2snull1717 function PS_mi2s(i: Cardinal): tbtString;
1718 
ParseMethodnull1719 function ParseMethod(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType): Boolean;
ParseMethodExnull1720 function ParseMethodEx(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType; CustomParser: TPSPascalParser): Boolean;
1721 
DeclToBitsnull1722 function DeclToBits(const Decl: TPSParametersDecl): tbtString;
1723 
NewVariantnull1724 function NewVariant(FType: TPSType): PIfRVariant;
1725 procedure DisposeVariant(p: PIfRVariant);
1726 
1727 implementation
1728 
1729 uses {$IFDEF DELPHI5}ComObj, {$ENDIF}{$IFDEF PS_FPC_HAS_COM}ComObj, {$ENDIF}Classes, typInfo;
1730 
1731 {$IFDEF DELPHI3UP}
1732 resourceString
1733 {$ELSE}
1734 const
1735 {$ENDIF}
1736 
1737   RPS_OnUseEventOnly = 'This function can only be called from within the OnUses event';
1738   RPS_UnableToRegisterFunction = 'Unable to register function %s';
1739   RPS_UnableToRegisterConst = 'Unable to register constant %s';
1740   RPS_InvalidTypeForVar = 'Invalid type for variable %s';
1741   RPS_InvalidType = 'Invalid Type';
1742   RPS_UnableToRegisterType = 'Unable to register type %s';
1743   RPS_UnknownInterface = 'Unknown interface: %s';
1744   RPS_ConstantValueMismatch = 'Constant Value Type Mismatch';
1745   RPS_ConstantValueNotAssigned = 'Constant Value is not assigned';
1746 
1747   RPS_Error = 'Error';
1748   RPS_UnknownIdentifier = 'Unknown identifier ''%s''';
1749   RPS_IdentifierExpected = 'Identifier expected';
1750   RPS_CommentError = 'Comment error';
1751   RPS_StringError = 'String error';
1752   RPS_CharError = 'Char error';
1753   RPS_SyntaxError = 'Syntax error';
1754   RPS_EOF = 'Unexpected end of file';
1755   RPS_SemiColonExpected = 'Semicolon ('';'') expected';
1756   RPS_BeginExpected = '''BEGIN'' expected';
1757   RPS_PeriodExpected = 'period (''.'') expected';
1758   RPS_DuplicateIdent = 'Duplicate identifier ''%s''';
1759   RPS_ColonExpected = 'colon ('':'') expected';
1760   RPS_UnknownType = 'Unknown type ''%s''';
1761   RPS_CloseRoundExpected = 'Closing parenthesis expected';
1762   RPS_TypeMismatch = 'Type mismatch';
1763   RPS_InternalError = 'Internal error (%s)';
1764   RPS_AssignmentExpected = 'Assignment expected';
1765   RPS_ThenExpected = '''THEN'' expected';
1766   RPS_DoExpected = '''DO'' expected';
1767   RPS_NoResult = 'No result';
1768   RPS_OpenRoundExpected = 'opening parenthesis (''('')expected';
1769   RPS_CommaExpected = 'comma ('','') expected';
1770   RPS_ToExpected = '''TO'' expected';
1771   RPS_IsExpected = 'is (''='') expected';
1772   RPS_OfExpected = '''OF'' expected';
1773   RPS_CloseBlockExpected = 'Closing square bracket ('']'') expected';
1774   RPS_VariableExpected = 'Variable Expected';
1775   RPS_StringExpected = 'String Expected';
1776   RPS_EndExpected = '''END'' expected';
1777   RPS_UnSetLabel = 'Label ''%s'' not set';
1778   RPS_NotInLoop = 'Not in a loop';
1779   RPS_InvalidJump = 'Invalid jump';
1780   RPS_OpenBlockExpected = 'Opening square brackets (''['') expected';
1781   RPS_WriteOnlyProperty = 'Write-only property';
1782   RPS_ReadOnlyProperty = 'Read-only property';
1783   RPS_ClassTypeExpected = 'Class type expected';
1784   RPS_DivideByZero = 'Divide by Zero';
1785   RPS_MathError = 'Math Error';
1786   RPS_UnsatisfiedForward = 'Unsatisfied Forward %s';
1787   RPS_ForwardParameterMismatch = 'Forward Parameter Mismatch';
1788   RPS_InvalidNumberOfParameter = 'Invalid number of parameters';
1789   RPS_UnknownError = 'Unknown error';
1790   {$IFDEF PS_USESSUPPORT}
1791   RPS_NotAllowed = '%s is not allowed at this position';
1792   RPS_UnitNotFound = 'Unit ''%s'' not found or contains errors';
1793   RPS_CrossReference = 'Cross-Reference error of ''%s''';
1794   {$ENDIF}
1795 
1796 
1797   RPS_Hint = 'Hint';
1798   RPS_VariableNotUsed = 'Variable ''%s'' never used';
1799   RPS_FunctionNotUsed = 'Function ''%s'' never used';
1800   RPS_UnknownHint = 'Unknown hint';
1801 
1802 
1803   RPS_Warning = 'Warning';
1804   RPS_CalculationAlwaysEvaluatesTo = 'Calculation always evaluates to %s';
1805   RPS_IsNotNeeded =  '%s is not needed';
1806   RPS_AbstractClass = 'Abstract Class Construction';
1807   RPS_UnknownWarning = 'Unknown warning';
1808 
1809   {$IFDEF DEBUG }
1810   RPS_UnableToRegister = 'Unable to register %s';
1811   {$ENDIF}
1812 
1813   RPS_NotArrayProperty = 'Not an array property : ''%s''';
1814   RPS_NotProperty = 'Not a property : ''%s''';
1815   RPS_UnknownProperty = 'Unknown Property : ''%s''';
1816 
DeclToBitsnull1817 function DeclToBits(const Decl: TPSParametersDecl): tbtString;
1818 var
1819   i: longint;
1820 begin
1821   Result := '';
1822   if Decl.Result = nil then
1823   begin
1824     Result := Result + #0;
1825   end else
1826     Result := Result + #1;
1827   for i := 0 to Decl.ParamCount -1 do
1828   begin
1829     if Decl.Params[i].Mode <> pmIn then
1830       Result := Result + #1
1831     else
1832       Result := Result + #0;
1833   end;
1834 end;
1835 
1836 
1837 procedure BlockWriteByte(BlockInfo: TPSBlockInfo; b: Byte);
1838 begin
1839   BlockInfo.Proc.Data := BlockInfo.Proc.Data + tbtChar(b);
1840 end;
1841 
1842 procedure BlockWriteData(BlockInfo: TPSBlockInfo; const Data; Len: Longint);
1843 begin
1844   SetLength(BlockInfo.Proc.FData, Length(BlockInfo.Proc.FData) + Len);
1845   Move(Data, BlockInfo.Proc.FData[Length(BlockInfo.Proc.FData) - Len + 1], Len);
1846 end;
1847 
1848 procedure BlockWriteLong(BlockInfo: TPSBlockInfo; l: Cardinal);
1849 begin
1850   BlockWriteData(BlockInfo, l, 4);
1851 end;
1852 
1853 procedure BlockWriteVariant(BlockInfo: TPSBlockInfo; p: PIfRVariant);
1854 var
1855   du8: tbtu8;
1856   du16: tbtu16;
1857 begin
1858   BlockWriteLong(BlockInfo, p^.FType.FinalTypeNo);
1859   case p.FType.BaseType of
1860   btType: BlockWriteData(BlockInfo, p^.ttype.FinalTypeno, 4);
1861   {$IFNDEF PS_NOWIDESTRING}
1862   btWideString:
1863     begin
1864       BlockWriteLong(BlockInfo, Length(tbtWideString(p^.twidestring)));
1865       BlockWriteData(BlockInfo, tbtwidestring(p^.twidestring)[1], 2*Length(tbtWideString(p^.twidestring)));
1866     end;
1867   btUnicodeString:
1868     begin
1869       BlockWriteLong(BlockInfo, Length(tbtUnicodeString(p^.twidestring)));
1870       BlockWriteData(BlockInfo, tbtUnicodeString(p^.twidestring)[1], 2*Length(tbtUnicodeString(p^.twidestring)));
1871     end;
1872   btWideChar: BlockWriteData(BlockInfo, p^.twidechar, 2);
1873   {$ENDIF}
1874   btSingle: BlockWriteData(BlockInfo, p^.tsingle, sizeof(tbtSingle));
1875   btDouble: BlockWriteData(BlockInfo, p^.tdouble, sizeof(tbtDouble));
1876   btExtended: BlockWriteData(BlockInfo, p^.textended, sizeof(tbtExtended));
1877   btCurrency: BlockWriteData(BlockInfo, p^.tcurrency, sizeof(tbtCurrency));
1878   btChar: BlockWriteData(BlockInfo, p^.tchar, 1);
1879   btSet:
1880     begin
1881       BlockWriteData(BlockInfo, tbtString(p^.tstring)[1], Length(tbtString(p^.tstring)));
1882     end;
1883   btString:
1884     begin
1885       BlockWriteLong(BlockInfo, Length(tbtString(p^.tstring)));
1886       BlockWriteData(BlockInfo, tbtString(p^.tstring)[1], Length(tbtString(p^.tstring)));
1887     end;
1888      btenum:
1889      begin
1890        if TPSEnumType(p^.FType).HighValue <=256 then
1891       begin
1892         du8 := tbtu8(p^.tu32);
1893         BlockWriteData(BlockInfo, du8, 1)
1894       end
1895        else if TPSEnumType(p^.FType).HighValue <=65536 then
1896       begin
1897         du16 := tbtu16(p^.tu32);
1898         BlockWriteData(BlockInfo, du16, 2)
1899       end;
1900 	end;
1901 
1902   bts8,btu8: BlockWriteData(BlockInfo, p^.tu8, 1);
1903   bts16,btu16: BlockWriteData(BlockInfo, p^.tu16, 2);
1904   bts32,btu32: BlockWriteData(BlockInfo, p^.tu32, 4);
1905   {$IFNDEF PS_NOINT64}
1906   bts64: BlockWriteData(BlockInfo, p^.ts64, 8);
1907   {$ENDIF}
1908   btProcPtr: BlockWriteData(BlockInfo, p^.tu32, 4);
1909   {$IFDEF DEBUG}
1910   {$IFNDEF FPC}
1911   else
1912       asm int 3; end;
1913   {$ENDIF}
1914   {$ENDIF}
1915   end;
1916 end;
1917 
1918 
1919 
ExportChecknull1920 function ExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; Types: array of TPSBaseType; Modes: array of TPSParameterMode): Boolean;
1921 var
1922   i: Longint;
1923   ttype: TPSType;
1924 begin
1925   if High(Types) <> High(Modes)+1 then
1926   begin
1927     Result := False;
1928     exit;
1929   end;
1930   if High(Types) <> Proc.Decl.ParamCount then
1931   begin
1932     Result := False;
1933     exit;
1934   end;
1935   TType := Proc.Decl.Result;
1936   if TType = nil then
1937   begin
1938     if Types[0] <> btReturnAddress then
1939     begin
1940       Result := False;
1941       exit;
1942     end;
1943   end else
1944   begin
1945     if TType.BaseType <> Types[0] then
1946     begin
1947       Result := False;
1948       exit;
1949     end;
1950   end;
1951   for i := 0 to High(Modes) do
1952   begin
1953     TType := Proc.Decl.Params[i].aType;
1954     if Modes[i] <> Proc.Decl.Params[i].Mode then
1955     begin
1956       Result := False;
1957       exit;
1958     end;
1959     if TType.BaseType <> Types[i+1] then
1960     begin
1961       Result := False;
1962       exit;
1963     end;
1964   end;
1965   Result := True;
1966 end;
1967 
1968 procedure SetVarExportName(P: TPSVar; const ExpName: tbtString);
1969 begin
1970   if p <> nil then
1971     p.exportname := ExpName;
1972 end;
1973 
FindAndAddTypenull1974 function FindAndAddType(Owner: TPSPascalCompiler; const Name, Decl: tbtString): TPSType;
1975 var
1976   tt: TPSType;
1977 begin
1978   Result := Owner.FindType(Name);
1979   if Result = nil then
1980   begin
1981     tt := Owner.AddTypeS(Name, Decl);
1982     Result := tt;
1983   end;
1984 end;
1985 
ParseMethodnull1986 function ParseMethod(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType): Boolean;
1987 begin
1988   Result := ParseMethodEx(Owner, FClassName, Decl, OrgName, DestDecl, Func, nil);
1989 end;
1990 
ParseMethodExnull1991 function ParseMethodEx(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType; CustomParser: TPSPascalParser): Boolean;
1992 var
1993   Parser: TPSPascalParser;
1994   FuncType: Byte;
1995   VNames: tbtString;
1996   modifier: TPSParameterMode;
1997   VCType: TPSType;
1998   ERow, EPos, ECol: Integer;
1999 
2000 begin
2001   if CustomParser = nil then begin
2002     Parser := TPSPascalParser.Create;
2003     Parser.SetText(Decl);
2004   end else
2005     Parser := CustomParser;
thennull2006   if Parser.CurrTokenId = CSTII_Function then
2007     FuncType:= 0
2008   else if Parser.CurrTokenId = CSTII_Procedure then
2009     FuncType := 1
2010   else if (Parser.CurrTokenId = CSTII_Constructor) and (FClassName <> '') then
2011     FuncType := 2
2012   else
2013   begin
2014     if Parser <> CustomParser then
2015       Parser.Free;
2016     Result := False;
2017     exit;
2018   end;
2019   Parser.Next;
2020   if Parser.CurrTokenId <> CSTI_Identifier then
2021   begin
2022     if Parser <> CustomParser then
2023       Parser.Free
2024     else
2025       Owner.MakeError('', ecIdentifierExpected, '');
2026     Result := False;
2027     exit;
2028   end; {if}
2029   OrgName := Parser.OriginalToken;
2030   Parser.Next;
2031   if Parser.CurrTokenId = CSTI_OpenRound then
2032   begin
2033     Parser.Next;
2034     if Parser.CurrTokenId <> CSTI_CloseRound then
2035     begin
2036       while True do
2037       begin
2038         if Parser.CurrTokenId = CSTII_Const then
2039         begin
2040           modifier := pmIn;
2041           Parser.Next;
2042         end
2043         else
2044         if Parser.CurrTokenId = CSTII_Var then
2045         begin
2046           modifier := pmInOut;
2047           Parser.Next;
2048         end
2049         else
2050         if Parser.CurrTokenId = CSTII_Out then
2051         begin
2052           modifier := pmOut;
2053           Parser.Next;
2054         end
2055         else
2056           modifier := pmIn;
2057         if Parser.CurrTokenId <> CSTI_Identifier then
2058         begin
2059           if Parser <> CustomParser then
2060             Parser.Free
2061           else
2062             Owner.MakeError('', ecIdentifierExpected, '');
2063           Result := False;
2064           exit;
2065         end;
2066         EPos:=Parser.CurrTokenPos;
2067         ERow:=Parser.Row;
2068         ECol:=Parser.Col;
2069 
2070         VNames := Parser.OriginalToken + '|';
2071         Parser.Next;
2072         while Parser.CurrTokenId = CSTI_Comma do
2073         begin
2074           Parser.Next;
2075           if Parser.CurrTokenId <> CSTI_Identifier then
2076           begin
2077             if Parser <> CustomParser then
2078               Parser.Free
2079             else
2080               Owner.MakeError('', ecIdentifierExpected, '');
2081             Result := False;
2082             exit;
2083           end;
2084           VNames := VNames + Parser.OriginalToken + '|';
2085           Parser.Next;
2086         end;
2087         if Parser.CurrTokenId <> CSTI_Colon then
2088         begin
2089           if Parser <> CustomParser then
2090             Parser.Free
2091           else
2092             Owner.MakeError('', ecColonExpected, '');
2093           Result := False;
2094           exit;
2095         end;
2096         Parser.Next;
2097         if Parser.CurrTokenID = CSTII_Array then
2098         begin
2099           Parser.nExt;
2100           if Parser.CurrTokenId <> CSTII_Of then
2101           begin
2102             if Parser <> CustomParser then
2103               Parser.Free
2104             else
2105               Owner.MakeError('', ecOfExpected, '');
2106             Result := False;
2107             exit;
2108           end;
2109           Parser.Next;
2110           if Parser.CurrTokenId = CSTII_Const then
2111           begin
2112             VCType := FindAndAddType(Owner, '!OPENARRAYOFCONST', 'array of ___Pointer')
2113           end
2114           else begin
2115             VCType := Owner.GetTypeCopyLink(Owner.FindType(Parser.GetToken));
2116             if VCType = nil then
2117             begin
2118               if Parser <> CustomParser then
2119                 Parser.Free
2120               else
2121                 Owner.MakeError('', ecUnknownType, Parser.GetToken);
2122               Result := False;
2123               exit;
2124             end;
2125             case VCType.BaseType of
2126               btU8: VCType := FindAndAddType(Owner, '!OPENARRAYOFU8', 'array of Byte');
2127               btS8: VCType := FindAndAddType(Owner, '!OPENARRAYOFS8', 'array of ShortInt');
2128               btU16: VCType := FindAndAddType(Owner, '!OPENARRAYOFU16', 'array of SmallInt');
2129               btS16: VCType := FindAndAddType(Owner, '!OPENARRAYOFS16', 'array of Word');
2130               btU32: VCType := FindAndAddType(Owner, '!OPENARRAYOFU32', 'array of Cardinal');
2131               btS32: VCType := FindAndAddType(Owner, '!OPENARRAYOFS32', 'array of LongInt');
2132               btSingle: VCType := FindAndAddType(Owner, '!OPENARRAYOFSINGLE', 'array of Single');
2133               btDouble: VCType := FindAndAddType(Owner, '!OPENARRAYOFDOUBLE', 'array of Double');
2134               btExtended: VCType := FindAndAddType(Owner, '!OPENARRAYOFEXTENDED', 'array of Extended');
2135               btString: VCType := FindAndAddType(Owner, '!OPENARRAYOFSTRING', 'array of string');
2136               btPChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFPCHAR', {$IFDEF PS_PANSICHAR}'array of PAnsiChar'{$ELSE}'array of PChar'{$ENDIF});
2137               btNotificationVariant, btVariant: VCType := FindAndAddType(Owner, '!OPENARRAYOFVARIANT', 'array of Variant');
2138             {$IFNDEF PS_NOINT64}btS64:  VCType := FindAndAddType(Owner, '!OPENARRAYOFS64', 'array of Int64');{$ENDIF}
2139               btChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFCHAR', 'array of Char');
2140             {$IFNDEF PS_NOWIDESTRING}
2141               btWideString: VCType := FindAndAddType(Owner, '!OPENARRAYOFWIDESTRING', 'array of WideString');
2142               btUnicodeString: VCType := FindAndAddType(Owner, '!OPENARRAYOFUNICODESTRING', 'array of UnicodeString');
2143               btWideChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFWIDECHAR', 'array of WideChar');
2144             {$ENDIF}
2145               btClass: VCType := FindAndAddType(Owner, '!OPENARRAYOFTOBJECT', 'array of TObject');
2146               btRecord: VCType := FindAndAddType(Owner, '!OPENARRAYOFRECORD_'+FastUpperCase(Parser.OriginalToken), 'array of ' +FastUpperCase(Parser.OriginalToken));
2147               btEnum: VCType := FindAndAddType(Owner, '!OPENARRAYOFENUM_' + FastUpperCase(Parser.OriginalToken), 'array of ' + FastUpperCase(Parser.OriginalToken));
2148             else
2149               begin
2150                 if Parser <> CustomParser then
2151                   Parser.Free;
2152                 Result := False;
2153                 exit;
2154               end;
2155             end;
2156           end;
2157         end else if Parser.CurrTokenID = CSTII_Const then
2158           VCType := nil // any type
2159         else begin
2160           VCType := Owner.FindType(Parser.GetToken);
2161           if VCType = nil then
2162           begin
2163             if Parser <> CustomParser then
2164               Parser.Free
2165             else
2166               Owner.MakeError('', ecUnknownType, Parser.GetToken);
2167             Result := False;
2168             exit;
2169           end;
2170         end;
2171         while Pos(tbtchar('|'), VNames) > 0 do
2172         begin
2173           with DestDecl.AddParam do
2174           begin
2175             {$IFDEF PS_USESSUPPORT}
2176             DeclareUnit:=Owner.fModule;
2177             {$ENDIF}
2178             DeclarePos := EPos;
2179             DeclareRow := ERow;
2180             DeclareCol := ECol;
2181             Mode := modifier;
2182             OrgName := copy(VNames, 1, Pos(tbtchar('|'), VNames) - 1);
2183             aType := VCType;
2184           end;
2185           Delete(VNames, 1, Pos(tbtchar('|'), VNames));
2186         end;
2187         Parser.Next;
2188         if Parser.CurrTokenId = CSTI_CloseRound then
2189           break;
2190         if Parser.CurrTokenId <> CSTI_Semicolon then
2191         begin
2192           if Parser <> CustomParser then
2193             Parser.Free
2194           else
2195             Owner.MakeError('', ecSemiColonExpected, '');
2196           Result := False;
2197           exit;
2198         end;
2199         Parser.Next;
2200       end; {while}
2201     end; {if}
2202     Parser.Next;
2203   end; {if}
2204   if FuncType = 0 then
2205   begin
2206     if Parser.CurrTokenId <> CSTI_Colon then
2207     begin
2208       if Parser <> CustomParser then
2209         Parser.Free
2210       else
2211         Owner.MakeError('', ecColonExpected, '');
2212       Result := False;
2213       exit;
2214     end;
2215 
2216     Parser.Next;
2217     VCType := Owner.FindType(Parser.GetToken);
2218     if VCType = nil then
2219     begin
2220       if Parser <> CustomParser then
2221         Parser.Free
2222       else
2223         Owner.MakeError('', ecUnknownType, Parser.GetToken);
2224       Result := False;
2225       exit;
2226     end;
2227     Parser.Next;
2228   end
2229   else if FuncType = 2 then {constructor}
2230   begin
2231     VCType := Owner.FindType(FClassName)
2232   end else
2233     VCType := nil;
2234   DestDecl.Result := VCType;
2235   if Parser <> CustomParser then
2236     Parser.Free;
2237   if FuncType = 2 then
2238     Func := mftConstructor
2239   else
2240     Func := mftProc;
2241   Result := True;
2242 end;
2243 
2244 
2245 
TPSPascalCompiler.FindProcnull2246 function TPSPascalCompiler.FindProc(const aName: tbtString): Cardinal;
2247 var
2248   l, h: Longint;
2249   x: TPSProcedure;
2250   xr: TPSRegProc;
2251   name: tbtString;
2252 
2253 begin
2254   name := FastUpperCase(aName);
2255   h := MakeHash(Name);
2256   if FProcs = nil then
2257   begin
2258     result := InvalidVal;
2259     Exit;
2260   end;
2261 
2262   for l := FProcs.Count - 1 downto 0 do
2263   begin
2264     x := FProcs.Data^[l];
2265     if x.ClassType = TPSInternalProcedure then
2266     begin
2267       if (TPSInternalProcedure(x).NameHash = h) and
2268         (TPSInternalProcedure(x).Name = Name) then
2269       begin
2270         Result := l;
2271         exit;
2272       end;
2273     end
2274     else
2275     begin
2276       if (TPSExternalProcedure(x).RegProc.NameHash = h) and
2277         (TPSExternalProcedure(x).RegProc.Name = Name)then
2278       begin
2279         Result := l;
2280         exit;
2281       end;
2282     end;
2283   end;
2284   for l := FRegProcs.Count - 1 downto 0 do
2285   begin
2286     xr := FRegProcs[l];
2287     if (xr.NameHash = h) and (xr.Name = Name) then
2288     begin
2289       x := TPSExternalProcedure.Create;
2290       TPSExternalProcedure(x).RegProc := xr;
2291       FProcs.Add(x);
2292       Result := FProcs.Count - 1;
2293       exit;
2294     end;
2295   end;
2296   Result := InvalidVal;
2297 end; {findfunc}
2298 
UseExternalProcnull2299 function TPSPascalCompiler.UseExternalProc(const Name: tbtString): TPSParametersDecl;
2300 var
2301   ProcNo: cardinal;
2302   proc: TPSProcedure;
2303 begin
2304   ProcNo := FindProc(FastUppercase(Name));
2305   if ProcNo = InvalidVal then Result := nil
2306   else
2307   begin
2308     proc := TPSProcedure(FProcs[ProcNo]);
2309     if Proc is TPSExternalProcedure then
2310     begin
2311       Result := TPSExternalProcedure(Proc).RegProc.Decl;
2312     end else result := nil;
2313   end;
2314 end;
2315 
2316 
2317 
TPSPascalCompiler.FindBaseTypenull2318 function TPSPascalCompiler.FindBaseType(BaseType: TPSBaseType): TPSType;
2319 var
2320   l: Longint;
2321   x: TPSType;
2322 begin
2323   for l := 0 to FTypes.Count -1 do
2324   begin
2325     X := FTypes[l];
2326     if (x.BaseType = BaseType) and (x.ClassType = TPSType)  then
2327     begin
2328       Result := at2ut(x);
2329       exit;
2330     end;
2331   end;
2332   X := TPSType.Create;
2333   x.Name := '';
2334   x.BaseType := BaseType;
2335   {$IFDEF PS_USESSUPPORT}
2336   x.DeclareUnit:=fModule;
2337   {$ENDIF}
2338   x.DeclarePos := InvalidVal;
2339   x.DeclareCol := 0;
2340   x.DeclareRow := 0;
2341   FTypes.Add(x);
2342   Result := at2ut(x);
2343 end;
2344 
MakeDeclnull2345 function TPSPascalCompiler.MakeDecl(decl: TPSParametersDecl): tbtString;
2346 var
2347   i: Longint;
2348 begin
2349   if Decl.Result = nil then result := '0' else
2350   result := Decl.Result.Name;
2351 
2352   for i := 0 to decl.ParamCount -1 do
2353   begin
2354     if decl.GetParam(i).Mode = pmIn then
2355       Result := Result + ' @'
2356     else
2357       Result := Result + ' !';
2358     Result := Result + decl.GetParam(i).aType.Name;
2359   end;
2360 end;
2361 
2362 
2363 { TPSPascalCompiler }
2364 
2365 const
2366   BtTypeCopy = 255;
2367 
2368 
2369 type
2370   TFuncType = (ftProc, ftFunc);
2371 
PS_mi2snull2372 function PS_mi2s(i: Cardinal): tbtString;
2373 begin
2374   SetLength(Result, 4);
2375   Cardinal((@Result[1])^) := i;
2376 end;
2377 
2378 
2379 
2380 
TPSPascalCompiler.AddTypenull2381 function TPSPascalCompiler.AddType(const Name: tbtString; const BaseType: TPSBaseType): TPSType;
2382 begin
2383   if FProcs = nil then
2384   begin
2385     raise EPSCompilerException.Create(RPS_OnUseEventOnly);
2386   end;
2387 
2388   if not(AllowDuplicateRegister) and IsDuplicate(FastUpperCase(Name),[dcTypes, dcProcs, dcVars]) then
2389       Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Name]);
2390 
2391   case BaseType of
2392     btProcPtr: Result := TPSProceduralType.Create;
2393     BtTypeCopy: Result := TPSTypeLink.Create;
2394     btRecord: Result := TPSRecordType.Create;
2395     btArray: Result := TPSArrayType.Create;
2396     btStaticArray: Result := TPSStaticArrayType.Create;
2397     btEnum: Result := TPSEnumType.Create;
2398     btClass: Result := TPSClassType.Create;
2399     btExtClass: REsult := TPSUndefinedClassType.Create;
2400     btNotificationVariant, btVariant: Result := TPSVariantType.Create;
2401 {$IFNDEF PS_NOINTERFACES}
2402     btInterface: Result := TPSInterfaceType.Create;
2403 {$ENDIF}
2404   else
2405     Result := TPSType.Create;
2406   end;
2407   Result.Name := FastUppercase(Name);
2408   Result.OriginalName := Name;
2409   Result.BaseType := BaseType;
2410   {$IFDEF PS_USESSUPPORT}
2411   Result.DeclareUnit:=fModule;
2412   {$ENDIF}
2413   Result.DeclarePos := InvalidVal;
2414   Result.DeclareCol := 0;
2415   Result.DeclareRow := 0;
2416   FTypes.Add(Result);
2417 end;
2418 
2419 
TPSPascalCompiler.AddFunctionnull2420 function TPSPascalCompiler.AddFunction(const Header: tbtString): TPSRegProc;
2421 var
2422   Parser: TPSPascalParser;
2423   i: Integer;
Booleannull2424   IsFunction: Boolean;
2425   VNames, Name: tbtString;
2426   Decl: TPSParametersDecl;
2427   modifier: TPSParameterMode;
2428   VCType: TPSType;
2429   x: TPSRegProc;
2430 begin
2431   if FProcs = nil then
2432     raise EPSCompilerException.Create(RPS_OnUseEventOnly);
2433 
2434   Parser := TPSPascalParser.Create;
2435   Parser.SetText(Header);
2436   Decl := TPSParametersDecl.Create;
2437   x := nil;
2438   try
thennull2439     if Parser.CurrTokenId = CSTII_Function then
2440       IsFunction := True
2441     else if Parser.CurrTokenId = CSTII_Procedure then
2442       IsFunction := False
2443     else
2444       Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, ['']);
2445     Parser.Next;
2446     if Parser.CurrTokenId <> CSTI_Identifier then
2447       Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, ['']);
2448     Name := Parser.OriginalToken;
2449     Parser.Next;
2450     if Parser.CurrTokenId = CSTI_OpenRound then
2451     begin
2452       Parser.Next;
2453       if Parser.CurrTokenId <> CSTI_CloseRound then
2454       begin
2455         while True do
2456         begin
2457           if Parser.CurrTokenId = CSTII_Out then
2458           begin
2459             Modifier := pmOut;
2460             Parser.Next;
2461           end else
2462           if Parser.CurrTokenId = CSTII_Const then
2463           begin
2464             Modifier := pmIn;
2465             Parser.Next;
2466           end else
2467           if Parser.CurrTokenId = CSTII_Var then
2468           begin
2469             modifier := pmInOut;
2470             Parser.Next;
2471           end
2472           else
2473             modifier := pmIn;
2474           if Parser.CurrTokenId <> CSTI_Identifier then
2475             raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
2476           VNames := Parser.OriginalToken + '|';
2477           Parser.Next;
2478           while Parser.CurrTokenId = CSTI_Comma do
2479           begin
2480             Parser.Next;
2481             if Parser.CurrTokenId <> CSTI_Identifier then
2482               Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
2483             VNames := VNames + Parser.OriginalToken + '|';
2484             Parser.Next;
2485           end;
2486           if Parser.CurrTokenId <> CSTI_Colon then
2487           begin
2488             Parser.Free;
2489             Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
2490           end;
2491           Parser.Next;
2492           VCType := FindType(Parser.GetToken);
2493           if VCType = nil then
2494             Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
2495           while Pos(tbtchar('|'), VNames) > 0 do
2496           begin
2497             with Decl.AddParam do
2498             begin
2499               Mode := modifier;
2500               OrgName := copy(VNames, 1, Pos(tbtchar('|'), VNames) - 1);
2501               aType := VCType;
2502             end;
2503             Delete(VNames, 1, Pos(tbtchar('|'), VNames));
2504           end;
2505           Parser.Next;
2506           if Parser.CurrTokenId = CSTI_CloseRound then
2507             break;
2508           if Parser.CurrTokenId <> CSTI_Semicolon then
2509             Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
2510           Parser.Next;
2511         end; {while}
2512       end; {if}
2513       Parser.Next;
2514     end; {if}
thennull2515     if IsFunction then
2516     begin
2517       if Parser.CurrTokenId <> CSTI_Colon then
2518         Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
2519 
2520       Parser.Next;
2521       VCType := FindType(Parser.GetToken);
2522       if VCType = nil then
2523         Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
2524     end
2525     else
2526       VCType := nil;
2527     Decl.Result := VCType;
2528     X := TPSRegProc.Create;
2529     x.OrgName := Name;
2530     x.Name := FastUpperCase(Name);
2531     x.ExportName := True;
2532     x.Decl.Assign(decl);
2533     if Decl.Result = nil then
2534     begin
2535       x.ImportDecl := x.ImportDecl + #0;
2536     end else
2537       x.ImportDecl := x.ImportDecl + #1;
2538     for i := 0 to Decl.ParamCount -1 do
2539     begin
2540       if Decl.Params[i].Mode <> pmIn then
2541         x.ImportDecl := x.ImportDecl + #1
2542       else
2543         x.ImportDecl := x.ImportDecl + #0;
2544     end;
2545 
2546     FRegProcs.Add(x);
2547   finally
2548     Decl.Free;
2549     Parser.Free;
2550   end;
2551   Result := x;
2552 end;
2553 
MakeHintnull2554 function TPSPascalCompiler.MakeHint(const Module: tbtString; E: TPSPascalCompilerHintType; const Param: tbtString): TPSPascalCompilerMessage;
2555 var
2556   n: TPSPascalCompilerHint;
2557 begin
2558   N := TPSPascalCompilerHint.Create;
2559   n.FHint := e;
2560   n.SetParserPos(FParser);
2561   n.FModuleName := Module;
2562   n.FParam := Param;
2563   FMessages.Add(n);
2564   Result := n;
2565 end;
2566 
TPSPascalCompiler.MakeErrornull2567 function TPSPascalCompiler.MakeError(const Module: tbtString; E:
2568   TPSPascalCompilerErrorType; const Param: tbtString): TPSPascalCompilerMessage;
2569 var
2570   n: TPSPascalCompilerError;
2571 begin
2572   N := TPSPascalCompilerError.Create;
2573   n.FError := e;
2574   n.SetParserPos(FParser);
2575   {$IFNDEF PS_USESSUPPORT}
2576   n.FModuleName := Module;
2577   {$ELSE}
2578   if Module <> '' then
2579     n.FModuleName := Module
2580   else
2581     n.FModuleName := fModule;
2582   {$ENDIF}
2583   n.FParam := Param;
2584   FMessages.Add(n);
2585   Result := n;
2586 end;
2587 
MakeWarningnull2588 function TPSPascalCompiler.MakeWarning(const Module: tbtString; E:
2589   TPSPascalCompilerWarningType; const Param: tbtString): TPSPascalCompilerMessage;
2590 var
2591   n: TPSPascalCompilerWarning;
2592 begin
2593   N := TPSPascalCompilerWarning.Create;
2594   n.FWarning := e;
2595   n.SetParserPos(FParser);
2596   n.FModuleName := Module;
2597   n.FParam := Param;
2598   FMessages.Add(n);
2599   Result := n;
2600 end;
2601 
2602 procedure TPSPascalCompiler.Clear;
2603 var
2604   l: Longint;
2605 begin
2606   FDebugOutput := '';
2607   FOutput := '';
2608   for l := 0 to FMessages.Count - 1 do
2609     TPSPascalCompilerMessage(FMessages[l]).Free;
2610   FMessages.Clear;
2611   for L := FAutoFreeList.Count -1 downto 0 do
2612   begin
2613     TObject(FAutoFreeList[l]).Free;
2614   end;
2615   FAutoFreeList.Clear;
2616 end;
2617 
2618 procedure CopyVariantContents(Src, Dest: PIfRVariant);
2619 begin
2620   case src.FType.BaseType of
2621     btu8, bts8: dest^.tu8 := src^.tu8;
2622     btu16, bts16: dest^.tu16 := src^.tu16;
2623     btenum, btu32, bts32: dest^.tu32 := src^.tu32;
2624     btsingle: Dest^.tsingle := src^.tsingle;
2625     btdouble: Dest^.tdouble := src^.tdouble;
2626     btextended: Dest^.textended := src^.textended;
2627     btCurrency: Dest^.tcurrency := Src^.tcurrency;
2628     btchar: Dest^.tchar := src^.tchar;
2629     {$IFNDEF PS_NOINT64}bts64: dest^.ts64 := src^.ts64;{$ENDIF}
2630     btset, btstring: tbtstring(dest^.tstring) := tbtstring(src^.tstring);
2631     {$IFNDEF PS_NOWIDESTRING}
2632     btunicodestring: tbtunicodestring(dest^.tunistring) := tbtunicodestring(src^.tunistring);
2633     btwidestring: tbtwidestring(dest^.twidestring) := tbtwidestring(src^.twidestring);
2634     btwidechar: Dest^.twidechar := src^.twidechar;
2635     {$ENDIF}
2636   end;
2637 end;
2638 
DuplicateVariantnull2639 function DuplicateVariant(Src: PIfRVariant): PIfRVariant;
2640 begin
2641   New(Result);
2642   FillChar(Result^, SizeOf(TIfRVariant), 0);
2643   CopyVariantContents(Src, Result);
2644 end;
2645 
2646 
2647 procedure InitializeVariant(Vari: PIfRVariant; FType: TPSType);
2648 begin
2649   FillChar(vari^, SizeOf(TIfRVariant), 0);
2650   if FType.BaseType = btSet then
2651   begin
2652     SetLength(tbtstring(vari^.tstring), TPSSetType(FType).ByteSize);
2653     fillchar(tbtstring(vari^.tstring)[1], length(tbtstring(vari^.tstring)), 0);
2654   end;
2655   vari^.FType := FType;
2656 end;
2657 
NewVariantnull2658 function NewVariant(FType: TPSType): PIfRVariant;
2659 begin
2660   New(Result);
2661   InitializeVariant(Result, FType);
2662 end;
2663 
2664 procedure FinalizeA(var s: tbtString); overload; begin s := ''; end;
2665 {$IFNDEF PS_NOWIDESTRING}
2666 procedure FinalizeW(var s: tbtwidestring); overload; begin s := ''; end;
2667 procedure FinalizeU(var s: tbtunicodestring); overload; begin s := ''; end;
2668 {$ENDIF}
2669 procedure FinalizeVariant(var p: TIfRVariant);
2670 begin
2671   if (p.FType.BaseType = btString) or (p.FType.basetype = btSet) then
2672     finalizeA(tbtstring(p.tstring))
2673   {$IFNDEF PS_NOWIDESTRING}
2674   else if p.FType.BaseType = btWideString then
2675     finalizeW(tbtWideString(p.twidestring)) // tbtwidestring
2676   else if p.FType.BaseType = btUnicodeString then
2677     finalizeU(tbtUnicodeString(p.tunistring)); // tbtwidestring
2678   {$ENDIF}
2679 end;
2680 
2681 procedure DisposeVariant(p: PIfRVariant);
2682 begin
2683   if p <> nil then
2684   begin
2685     FinalizeVariant(p^);
2686     Dispose(p);
2687   end;
2688 end;
2689 
2690 
2691 
GetTypeCopyLinknull2692 function TPSPascalCompiler.GetTypeCopyLink(p: TPSType): TPSType;
2693 begin
2694   if p = nil then
2695     Result := nil
2696   else
2697   if p.BaseType = BtTypeCopy then
2698   begin
2699     Result := TPSTypeLink(p).LinkTypeNo;
2700   end else Result := p;
2701 end;
2702 
IsIntTypenull2703 function IsIntType(b: TPSBaseType): Boolean;
2704 begin
2705   case b of
2706     btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF PS_NOINT64}, btS64{$ENDIF}: Result := True;
2707   else
2708     Result := False;
2709   end;
2710 end;
2711 
IsRealTypenull2712 function IsRealType(b: TPSBaseType): Boolean;
2713 begin
2714   case b of
2715     btSingle, btDouble, btCurrency, btExtended: Result := True;
2716   else
2717     Result := False;
2718   end;
2719 end;
2720 
IsIntRealTypenull2721 function IsIntRealType(b: TPSBaseType): Boolean;
2722 begin
2723   case b of
2724     btSingle, btDouble, btCurrency, btExtended, btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF PS_NOINT64}, btS64{$ENDIF}:
2725       Result := True;
2726   else
2727     Result := False;
2728   end;
2729 
2730 end;
2731 
DiffRecnull2732 function DiffRec(p1, p2: TPSSubItem): Boolean;
2733 begin
2734   if p1.ClassType = p2.ClassType then
2735   begin
2736     if P1.ClassType = TPSSubNumber then
2737       Result := TPSSubNumber(p1).SubNo <> TPSSubNumber(p2).SubNo
2738     else if P1.ClassType = TPSSubValue then
2739       Result := TPSSubValue(p1).SubNo <> TPSSubValue(p2).SubNo
2740     else
2741       Result := False;
2742   end else Result := True;
2743 end;
2744 
SameRegnull2745 function SameReg(x1, x2: TPSValue): Boolean;
2746 var
2747   I: Longint;
2748 begin
2749   if (x1.ClassType = x2.ClassType) and (X1 is TPSValueVar) then
2750   begin
2751     if
2752     ((x1.ClassType = TPSValueGlobalVar) and (TPSValueGlobalVar(x1).GlobalVarNo = TPSValueGlobalVar(x2).GlobalVarNo)) or
2753     ((x1.ClassType = TPSValueLocalVar) and (TPSValueLocalVar(x1).LocalVarNo = TPSValueLocalVar(x2).LocalVarNo)) or
2754     ((x1.ClassType = TPSValueParamVar) and (TPSValueParamVar(x1).ParamNo = TPSValueParamVar(x2).ParamNo)) or
2755     ((x1.ClassType = TPSValueAllocatedStackVar) and (TPSValueAllocatedStackVar(x1).LocalVarNo = TPSValueAllocatedStackVar(x2).LocalVarNo)) then
2756     begin
2757       if TPSValueVar(x1).GetRecCount <> TPSValueVar(x2).GetRecCount then
2758       begin
2759         Result := False;
2760         exit;
2761       end;
2762       for i := 0 to TPSValueVar(x1).GetRecCount -1 do
2763       begin
2764         if DiffRec(TPSValueVar(x1).RecItem[i], TPSValueVar(x2).RecItem[i]) then
2765         begin
2766           Result := False;
2767           exit;
2768         end;
2769       end;
2770       Result := True;
2771     end else Result := False;
2772   end
2773   else
2774     Result := False;
2775 end;
2776 
GetUIntnull2777 function GetUInt(Src: PIfRVariant; var s: Boolean): Cardinal;
2778 begin
2779   case Src.FType.BaseType of
2780     btU8: Result := Src^.tu8;
2781     btS8: Result := Src^.ts8;
2782     btU16: Result := Src^.tu16;
2783     btS16: Result := Src^.ts16;
2784     btU32: Result := Src^.tu32;
2785     btS32: Result := Src^.ts32;
2786     {$IFNDEF PS_NOINT64}
2787     bts64: Result := src^.ts64;
2788     {$ENDIF}
2789     btChar: Result := ord(Src^.tchar);
2790     {$IFNDEF PS_NOWIDESTRING}
2791     btWideChar: Result := ord(tbtwidechar(src^.twidechar));
2792     {$ENDIF}
2793     btEnum: Result := src^.tu32;
2794   else
2795     begin
2796       s := False;
2797       Result := 0;
2798     end;
2799   end;
2800 end;
2801 
GetIntnull2802 function GetInt(Src: PIfRVariant; var s: Boolean): Longint;
2803 begin
2804   case Src.FType.BaseType of
2805     btU8: Result := Src^.tu8;
2806     btS8: Result := Src^.ts8;
2807     btU16: Result := Src^.tu16;
2808     btS16: Result := Src^.ts16;
2809     btU32: Result := Src^.tu32;
2810     btS32: Result := Src^.ts32;
2811     {$IFNDEF PS_NOINT64}
2812     bts64: Result := src^.ts64;
2813     {$ENDIF}
2814     btChar: Result := ord(Src^.tchar);
2815     {$IFNDEF PS_NOWIDESTRING}
2816     btWideChar: Result := ord(tbtwidechar(src^.twidechar));
2817     {$ENDIF}
2818     btEnum: Result := src^.tu32;
2819   else
2820     begin
2821       s := False;
2822       Result := 0;
2823     end;
2824   end;
2825 end;
2826 {$IFNDEF PS_NOINT64}
GetInt64null2827 function GetInt64(Src: PIfRVariant; var s: Boolean): Int64;
2828 begin
2829   case Src.FType.BaseType of
2830     btU8: Result := Src^.tu8;
2831     btS8: Result := Src^.ts8;
2832     btU16: Result := Src^.tu16;
2833     btS16: Result := Src^.ts16;
2834     btU32: Result := Src^.tu32;
2835     btS32: Result := Src^.ts32;
2836     bts64: Result := src^.ts64;
2837     btChar: Result := ord(Src^.tchar);
2838     {$IFNDEF PS_NOWIDESTRING}
2839     btWideChar: Result := ord(tbtwidechar(src^.twidechar));
2840     {$ENDIF}
2841     btEnum: Result := src^.tu32;
2842   else
2843     begin
2844       s := False;
2845       Result := 0;
2846     end;
2847   end;
2848 end;
2849 {$ENDIF}
2850 
GetRealnull2851 function GetReal(Src: PIfRVariant; var s: Boolean): Extended;
2852 begin
2853   case Src.FType.BaseType of
2854     btU8: Result := Src^.tu8;
2855     btS8: Result := Src^.ts8;
2856     btU16: Result := Src^.tu16;
2857     btS16: Result := Src^.ts16;
2858     btU32: Result := Src^.tu32;
2859     btS32: Result := Src^.ts32;
2860     {$IFNDEF PS_NOINT64}
2861     bts64: Result := src^.ts64;
2862     {$ENDIF}
2863     btChar: Result := ord(Src^.tchar);
2864     {$IFNDEF PS_NOWIDESTRING}
2865     btWideChar: Result := ord(tbtwidechar(src^.twidechar));
2866     {$ENDIF}
2867     btSingle: Result := Src^.tsingle;
2868     btDouble: Result := Src^.tdouble;
2869     btCurrency: Result := SRc^.tcurrency;
2870     btExtended: Result := Src^.textended;
2871   else
2872     begin
2873       s := False;
2874       Result := 0;
2875     end;
2876   end;
2877 end;
2878 
GetStringnull2879 function GetString(Src: PIfRVariant; var s: Boolean): tbtString;
2880 begin
2881   case Src.FType.BaseType of
2882     btChar: Result := Src^.tchar;
2883     btString: Result := tbtstring(src^.tstring);
2884     {$IFNDEF PS_NOWIDESTRING}
2885     btWideChar: Result := tbtstring(src^.twidechar);
2886     btWideString: Result := tbtstring(tbtWideString(src^.twidestring));
2887     btUnicodeString: Result := tbtstring(tbtUnicodeString(src^.tunistring));
2888     {$ENDIF}
2889   else
2890     begin
2891       s := False;
2892       Result := '';
2893     end;
2894   end;
2895 end;
2896 
2897 {$IFNDEF PS_NOWIDESTRING}
GetWideStringnull2898 function TPSPascalCompiler.GetWideString(Src: PIfRVariant; var s: Boolean): tbtwidestring;
2899 begin
2900   case Src.FType.BaseType of
2901     btChar: Result := tbtWidestring(Src^.tchar);
2902     btString: Result := tbtWidestring(tbtstring(src^.tstring));
2903     btWideChar: Result := src^.twidechar;
2904     btWideString: Result := tbtWideString(src^.twidestring);
2905     btUnicodeString: result := tbtUnicodeString(src^.tunistring);
2906   else
2907     begin
2908       s := False;
2909       Result := '';
2910     end;
2911   end;
2912 end;
TPSPascalCompiler.GetUnicodeStringnull2913 function TPSPascalCompiler.GetUnicodeString(Src: PIfRVariant; var s: Boolean): tbtunicodestring;
2914 begin
2915   case Src.FType.BaseType of
2916     btChar: Result := tbtunicodestring(Src^.tchar);
2917     btString: Result := tbtunicodestring(tbtstring(src^.tstring));
2918     btWideChar: Result := src^.twidechar;
2919     btWideString: Result := tbtWideString(src^.twidestring);
2920     btUnicodeString: result := tbtUnicodeString(src^.tunistring);
2921   else
2922     begin
2923       s := False;
2924       Result := '';
2925     end;
2926   end;
2927 end;
2928 {$ENDIF}
2929 
abnull2930 function ab(b: Longint): Longint;
2931 begin
2932   ab := Longint(b = 0);
2933 end;
2934 
2935 procedure Set_Union(Dest, Src: PByteArray; ByteSize: Integer);
2936 var
2937   i: Longint;
2938 begin
2939   for i := ByteSize -1 downto 0 do
2940     Dest^[i] := Dest^[i] or Src^[i];
2941 end;
2942 
2943 procedure Set_Diff(Dest, Src: PByteArray; ByteSize: Integer);
2944 var
2945   i: Longint;
2946 begin
2947   for i := ByteSize -1 downto 0 do
2948     Dest^[i] := Dest^[i] and not Src^[i];
2949 end;
2950 
2951 procedure Set_Intersect(Dest, Src: PByteArray; ByteSize: Integer);
2952 var
2953   i: Longint;
2954 begin
2955   for i := ByteSize -1 downto 0 do
2956     Dest^[i] := Dest^[i] and Src^[i];
2957 end;
2958 
2959 procedure Set_Subset(Dest, Src: PByteArray; ByteSize: Integer; var Val: Boolean);
2960 var
2961   i: Integer;
2962 begin
2963   for i := ByteSize -1 downto 0 do
2964   begin
2965     if not (Src^[i] and Dest^[i] = Dest^[i]) then
2966     begin
2967       Val := False;
2968       exit;
2969     end;
2970   end;
2971   Val := True;
2972 end;
2973 
2974 procedure Set_Equal(Dest, Src: PByteArray; ByteSize: Integer; var Val: Boolean);
2975 var
2976   i: Longint;
2977 begin
2978   for i := ByteSize -1 downto 0 do
2979   begin
2980     if Dest^[i] <> Src^[i] then
2981     begin
2982       Val := False;
2983       exit;
2984     end;
2985   end;
2986   val := True;
2987 end;
2988 
2989 procedure Set_membership(Item: Longint; Src: PByteArray; var Val: Boolean);
2990 begin
2991   Val := (Src^[Item shr 3] and (1 shl (Item and 7))) <> 0;
2992 end;
2993 
2994 procedure Set_MakeMember(Item: Longint; Src: PByteArray);
2995 begin
2996   Src^[Item shr 3] := Src^[Item shr 3] or (1 shl (Item and 7));
2997 end;
2998 
2999 procedure ConvertToBoolean(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIFRVariant; b: Boolean);
3000 begin
3001   FinalizeVariant(var1^);
3002   if FUseUsedTypes then
3003     Var1^.FType := se.at2ut(se.FDefaultBoolType)
3004   else
3005     Var1^.FType := Se.FDefaultBoolType;
3006   var1^.tu32 := Ord(b);
3007 end;
3008 
3009 procedure ConvertToString(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIFRVariant; const s: tbtString);
3010 var
3011   atype: TPSType;
3012 begin
3013   FinalizeVariant(var1^);
3014   atype := se.FindBaseType(btString);
3015   if FUseUsedTypes then
3016     InitializeVariant(var1, se.at2ut(atype))
3017   else
3018     InitializeVariant(var1, atype);
3019   tbtstring(var1^.tstring) := s;
3020 end;
3021 {$IFNDEF PS_NOWIDESTRING}
3022 procedure ConvertToUnicodeString(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIFRVariant; const s: tbtunicodestring);
3023 var
3024   atype: TPSType;
3025 begin
3026   FinalizeVariant(var1^);
3027   atype := se.FindBaseType(btUnicodeString);
3028   if FUseUsedTypes then
3029     InitializeVariant(var1, se.at2ut(atype))
3030   else
3031     InitializeVariant(var1, atype);
3032   tbtunicodestring(var1^.tunistring) := s;
3033 end;
3034 {$ENDIF}
3035 procedure ConvertToFloat(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIfRVariant; NewType: TPSType);
3036 var
3037   vartemp: PIfRVariant;
3038   b: Boolean;
3039 begin
3040   New(vartemp);
3041   b := false;
3042   if FUseUsedTypes then
3043     NewType := se.at2ut(NewType);
3044   InitializeVariant(vartemp, var1.FType);
3045   CopyVariantContents(var1, vartemp);
3046   FinalizeVariant(var1^);
3047   InitializeVariant(var1, newtype);
3048   case var1.ftype.basetype of
3049     btSingle:
3050       begin
3051         if (vartemp.ftype.BaseType = btu8) or (vartemp.ftype.BaseType = btu16) or (vartemp.ftype.BaseType = btu32) then
3052           var1^.tsingle := GetUInt(vartemp, b)
3053         else
3054           var1^.tsingle := GetInt(vartemp, b)
3055       end;
3056     btDouble:
3057       begin
3058         if (vartemp.ftype.BaseType = btu8) or (vartemp.ftype.BaseType = btu16) or (vartemp.ftype.BaseType = btu32) then
3059           var1^.tdouble := GetUInt(vartemp, b)
3060         else
3061           var1^.tdouble := GetInt(vartemp, b)
3062       end;
3063     btExtended:
3064       begin
3065         if (vartemp.ftype.BaseType = btu8) or (vartemp.ftype.BaseType = btu16) or (vartemp.ftype.BaseType = btu32) then
3066           var1^.textended:= GetUInt(vartemp, b)
3067         else
3068           var1^.textended:= GetInt(vartemp, b)
3069       end;
3070     btCurrency:
3071       begin
3072         if (vartemp.ftype.BaseType = btu8) or (vartemp.ftype.BaseType = btu16) or (vartemp.ftype.BaseType = btu32) then
3073           var1^.tcurrency:= GetUInt(vartemp, b)
3074         else
3075           var1^.tcurrency:= GetInt(vartemp, b)
3076       end;
3077   end;
3078   DisposeVariant(vartemp);
3079 end;
3080 
3081 
IsCompatibleTypenull3082 function TPSPascalCompiler.IsCompatibleType(p1, p2: TPSType; Cast: Boolean): Boolean;
3083 begin
3084   if
3085     ((p1.BaseType = btProcPtr) and (p2 = p1)) or
3086     (p1.BaseType = btPointer) or
3087     (p2.BaseType = btPointer) or
3088     ((p1.BaseType = btNotificationVariant) or (p1.BaseType = btVariant)) or
3089     ((p2.BaseType = btNotificationVariant) or (p2.BaseType = btVariant))  or
3090     (IsIntType(p1.BaseType) and IsIntType(p2.BaseType)) or
3091     (IsRealType(p1.BaseType) and IsIntRealType(p2.BaseType)) or
3092     (((p1.basetype = btPchar) or (p1.BaseType = btString)) and ((p2.BaseType = btString) or (p2.BaseType = btPchar))) or
3093     (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btChar)) or
3094     (((p1.BaseType = btArray) or (p1.BaseType = btStaticArray)) and (
3095     (p2.BaseType = btArray) or (p2.BaseType = btStaticArray)) and IsCompatibleType(TPSArrayType(p1).ArrayTypeNo, TPSArrayType(p2).ArrayTypeNo, False)) or
3096     ((p1.BaseType = btChar) and (p2.BaseType = btChar)) or
3097     ((p1.BaseType = btSet) and (p2.BaseType = btSet)) or
3098     {$IFNDEF PS_NOWIDESTRING}
3099     ((p1.BaseType = btChar) and (p2.BaseType = btWideChar)) or
3100     ((p1.BaseType = btWideChar) and (p2.BaseType = btChar)) or
3101     ((p1.BaseType = btWideChar) and (p2.BaseType = btWideChar)) or
3102     ((p1.BaseType = btWidestring) and (p2.BaseType = btChar)) or
3103     ((p1.BaseType = btWidestring) and (p2.BaseType = btWideChar)) or
3104     ((p1.BaseType = btWidestring) and ((p2.BaseType = btString) or (p2.BaseType = btPchar) or (p2.BaseType = btUnicodeString))) or
3105     ((p1.BaseType = btWidestring) and ((p2.BaseType = btWidestring))) or
3106     ((p1.BaseType = btUnicodeString) and (p2.BaseType = btChar)) or
3107     ((p1.BaseType = btUnicodeString) and (p2.BaseType = btWideChar)) or
3108     ((p1.BaseType = btUnicodeString) and ((p2.BaseType = btString) or (p2.BaseType = btPchar) or (p2.BaseType = btUnicodeString))) or
3109     ((p1.BaseType = btUnicodeString) and (p2.BaseType = btWidestring)) or
3110     (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btWideString)or (p2.BaseType = btUnicodeString)) or
3111     (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btWidechar)) or
3112     (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btchar)) or
3113     {$ENDIF}
3114     ((p1.BaseType = btRecord) and (p2.BaseType = btrecord) and (not IsVarInCompatible(p1, p2))) or
3115     ((p1.BaseType = btEnum) and (p2.BaseType = btEnum)) or
3116     (Cast and IsIntType(P1.BaseType) and (p2.baseType = btEnum)) or
3117     (Cast and (p1.baseType = btEnum) and IsIntType(P2.BaseType))
3118     then
3119     Result := True
3120   // nx change start - allow casting class -> integer and vice versa
3121   else if p1.BaseType = btclass then
3122     Result := TPSClassType(p1).cl.IsCompatibleWith(p2) or (p2.BaseType in [btU32, btS32])
3123   else if (p1.BaseType in [btU32, btS32]) then
3124     Result := (p2.BaseType = btClass)
3125   // nx change end
3126 {$IFNDEF PS_NOINTERFACES}
3127   else if p1.BaseType = btInterface then
3128     Result := TPSInterfaceType(p1).Intf.IsCompatibleWith(p2)
3129 {$ENDIF}
3130   else if ((p1.BaseType = btExtClass) and (p2.BaseType = btExtClass)) then
3131   begin
3132     Result := TPSUndefinedClassType(p1).ExtClass.IsCompatibleWith(TPSUndefinedClassType(p2).ExtClass);
3133   end
3134   else
3135     Result := False;
3136 end;
3137 
3138 
PreCalcnull3139 function TPSPascalCompiler.PreCalc(FUseUsedTypes: Boolean; Var1Mod: Byte; var1: PIFRVariant; Var2Mod: Byte; Var2: PIfRVariant; Cmd: TPSBinOperatorType; Pos, Row, Col: Cardinal): Boolean;
3140   { var1=dest, var2=src }
3141 var
3142   b: Boolean;
3143 
3144 begin
3145   Result := True;
3146   try
3147     if (IsRealType(var2.FType.BaseType) and IsIntType(var1.FType.BaseType)) then
3148       ConvertToFloat(Self, FUseUsedTypes, var1, var2^.FType);
3149     case Cmd of
3150       otAdd:
3151         begin { + }
3152           case var1.FType.BaseType of
3153             btU8: var1^.tu8 := var1^.tu8 + GetUint(Var2, Result);
3154             btS8: var1^.ts8 := var1^.ts8 + GetInt(Var2, Result);
3155             btU16: var1^.tu16 := var1^.tu16 + GetUint(Var2, Result);
3156             btS16: var1^.ts16 := var1^.ts16 + Getint(Var2, Result);
3157             btEnum, btU32: var1^.tu32 := var1^.tu32 + GetUint(Var2, Result);
3158             btS32: var1^.ts32 := var1^.ts32 + Getint(Var2, Result);
3159             {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 + GetInt64(Var2, Result); {$ENDIF}
3160             btSingle: var1^.tsingle := var1^.tsingle + GetReal( Var2, Result);
3161             btDouble: var1^.tdouble := var1^.tdouble + GetReal( Var2, Result);
3162             btExtended: var1^.textended := var1^.textended + GetReal( Var2, Result);
3163             btCurrency: var1^.tcurrency := var1^.tcurrency + GetReal( Var2, Result);
3164             btSet:
3165               begin
3166                 if (var1.FType = var2.FType) then
3167                 begin
3168                   Set_Union(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize);
3169                 end else Result := False;
3170               end;
3171             btChar:
3172               begin
3173                 ConvertToString(Self, FUseUsedTypes, var1, getstring(Var1, b)+getstring(Var2, b));
3174               end;
3175             btString: tbtstring(var1^.tstring) := tbtstring(var1^.tstring) + GetString(Var2, Result);
3176             {$IFNDEF PS_NOWIDESTRING}
3177             btwideString: tbtwidestring(var1^.twidestring) := tbtwidestring(var1^.twidestring) + GetWideString(Var2, Result);
3178             btUnicodeString: tbtunicodestring(var1^.tunistring) := tbtunicodestring(var1^.tunistring) + GetUnicodeString(Var2, Result);
3179             btWidechar:
3180               begin
3181                 ConvertToUnicodeString(Self, FUseUsedTypes, var1, GetUnicodeString(Var1, b)+GetUnicodeString(Var2, b));
3182               end;
3183             {$ENDIF}
3184             else Result := False;
3185           end;
3186         end;
3187       otSub:
3188         begin { - }
3189           case Var1.FType.BaseType of
3190             btU8: var1^.tu8 := var1^.tu8 - GetUint(Var2, Result);
3191             btS8: var1^.ts8 := var1^.ts8 - Getint(Var2, Result);
3192             btU16: var1^.tu16 := var1^.tu16 - GetUint(Var2, Result);
3193             btS16: var1^.ts16 := var1^.ts16 - Getint(Var2, Result);
3194             btEnum, btU32: var1^.tu32 := var1^.tu32 - GetUint(Var2, Result);
3195             btS32: var1^.ts32 := var1^.ts32 - Getint(Var2, Result);
3196             {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 - GetInt64(Var2, Result); {$ENDIF}
3197             btSingle: var1^.tsingle := var1^.tsingle - GetReal( Var2, Result);
3198             btDouble: var1^.tdouble := var1^.tdouble - GetReal(Var2, Result);
3199             btExtended: var1^.textended := var1^.textended - GetReal(Var2, Result);
3200             btCurrency: var1^.tcurrency := var1^.tcurrency - GetReal( Var2, Result);
3201             btSet:
3202               begin
3203                 if (var1.FType = var2.FType) then
3204                 begin
3205                   Set_Diff(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize);
3206                 end else Result := False;
3207               end;
3208             else Result := False;
3209           end;
3210         end;
3211       otMul:
3212         begin { * }
3213           case Var1.FType.BaseType of
3214             btU8: var1^.tu8 := var1^.tu8 * GetUint(Var2, Result);
3215             btS8: var1^.ts8 := var1^.ts8 * Getint(Var2, Result);
3216             btU16: var1^.tu16 := var1^.tu16 * GetUint(Var2, Result);
3217             btS16: var1^.ts16 := var1^.ts16 * Getint(Var2, Result);
3218             btU32: var1^.tu32 := var1^.tu32 * GetUint(Var2, Result);
3219             btS32: var1^.ts32 := var1^.ts32 * Getint(Var2, Result);
3220             {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 * GetInt64(Var2, Result); {$ENDIF}
3221             btSingle: var1^.tsingle := var1^.tsingle * GetReal(Var2, Result);
3222             btDouble: var1^.tdouble := var1^.tdouble * GetReal(Var2, Result);
3223             btExtended: var1^.textended := var1^.textended * GetReal( Var2, Result);
3224             btCurrency: var1^.tcurrency := var1^.tcurrency * GetReal( Var2, Result);
3225             btSet:
3226               begin
3227                 if (var1.FType = var2.FType) then
3228                 begin
3229                   Set_Intersect(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize);
3230                 end else Result := False;
3231               end;
3232             else Result := False;
3233           end;
3234         end;
3235 {$IFDEF PS_DELPHIDIV}
3236       otDiv:
3237         begin { / }
3238           if IsIntType(var1.FType.BaseType) then
3239             ConvertToFloat(self, FUseUsedTypes, var1, Self.FindType('EXTENDED'));
3240           case Var1.FType.BaseType of
3241             btSingle: var1^.tsingle := var1^.tsingle / GetReal( Var2, Result);
3242             btDouble: var1^.tdouble := var1^.tdouble / GetReal( Var2, Result);
3243             btExtended: var1^.textended := var1^.textended / GetReal( Var2, Result);
3244             btCurrency: var1^.tcurrency := var1^.tcurrency / GetReal( Var2, Result);
3245             else Result := False;
3246           end;
3247         end;
3248       otIntDiv:
3249         begin { / }
3250           case Var1.FType.BaseType of
3251             btU8: var1^.tu8 := var1^.tu8 div GetUint(Var2, Result);
3252             btS8: var1^.ts8 := var1^.ts8 div Getint(Var2, Result);
3253             btU16: var1^.tu16 := var1^.tu16 div GetUint(Var2, Result);
3254             btS16: var1^.ts16 := var1^.ts16 div Getint(Var2, Result);
3255             btU32: var1^.tu32 := var1^.tu32 div GetUint(Var2, Result);
3256             btS32: var1^.ts32 := var1^.ts32 div Getint(Var2, Result);
3257             {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 div GetInt64(Var2, Result); {$ENDIF}
3258             else Result := False;
3259           end;
3260         end;
3261 {$ELSE}
3262       otDiv, otIntDiv:
3263         begin { / }
3264           case Var1.FType.BaseType of
3265             btU8: var1^.tu8 := var1^.tu8 div GetUint(Var2, Result);
3266             btS8: var1^.ts8 := var1^.ts8 div Getint(Var2, Result);
3267             btU16: var1^.tu16 := var1^.tu16 div GetUint(Var2, Result);
3268             btS16: var1^.ts16 := var1^.ts16 div Getint(Var2, Result);
3269             btU32: var1^.tu32 := var1^.tu32 div GetUint(Var2, Result);
3270             btS32: var1^.ts32 := var1^.ts32 div Getint(Var2, Result);
3271             {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 div GetInt64(Var2, Result); {$ENDIF}
3272             btSingle: var1^.tsingle := var1^.tsingle / GetReal( Var2, Result);
3273             btDouble: var1^.tdouble := var1^.tdouble / GetReal( Var2, Result);
3274             btExtended: var1^.textended := var1^.textended / GetReal( Var2, Result);
3275             btCurrency: var1^.tcurrency := var1^.tcurrency / GetReal( Var2, Result);
3276             else Result := False;
3277           end;
3278         end;
3279 {$ENDIF}
3280       otMod:
3281         begin { MOD }
3282           case Var1.FType.BaseType of
3283             btU8: var1^.tu8 := var1^.tu8 mod GetUint(Var2, Result);
3284             btS8: var1^.ts8 := var1^.ts8 mod Getint(Var2, Result);
3285             btU16: var1^.tu16 := var1^.tu16 mod GetUint(Var2, Result);
3286             btS16: var1^.ts16 := var1^.ts16 mod Getint(Var2, Result);
3287             btU32: var1^.tu32 := var1^.tu32 mod GetUint(Var2, Result);
3288             btS32: var1^.ts32 := var1^.ts32 mod Getint(Var2, Result);
3289             {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 mod GetInt64(Var2, Result); {$ENDIF}
3290             else Result := False;
3291           end;
3292         end;
3293       otshl:
3294         begin { SHL }
3295           case Var1.FType.BaseType of
3296             btU8: var1^.tu8 := var1^.tu8 shl GetUint(Var2, Result);
3297             btS8: var1^.ts8 := var1^.ts8 shl Getint(Var2, Result);
3298             btU16: var1^.tu16 := var1^.tu16 shl GetUint(Var2, Result);
3299             btS16: var1^.ts16 := var1^.ts16 shl Getint(Var2, Result);
3300             btU32: var1^.tu32 := var1^.tu32 shl GetUint(Var2, Result);
3301             btS32: var1^.ts32 := var1^.ts32 shl Getint(Var2, Result);
3302             {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 shl GetInt64(Var2, Result); {$ENDIF}
3303             else Result := False;
3304           end;
3305         end;
3306       otshr:
3307         begin { SHR }
3308           case Var1.FType.BaseType of
3309             btU8: var1^.tu8 := var1^.tu8 shr GetUint(Var2, Result);
3310             btS8: var1^.ts8 := var1^.ts8 shr Getint(Var2, Result);
3311             btU16: var1^.tu16 := var1^.tu16 shr GetUint(Var2, Result);
3312             btS16: var1^.ts16 := var1^.ts16 shr Getint(Var2, Result);
3313             btU32: var1^.tu32 := var1^.tu32 shr GetUint(Var2, Result);
3314             btS32: var1^.ts32 := var1^.ts32 shr Getint(Var2, Result);
3315             {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 shr GetInt64( Var2, Result); {$ENDIF}
3316             else Result := False;
3317           end;
3318         end;
3319       otAnd:
3320         begin { AND }
3321           case Var1.FType.BaseType of
3322             btU8: var1^.tu8 := var1^.tu8 and GetUint(Var2, Result);
3323             btS8: var1^.ts8 := var1^.ts8 and Getint(Var2, Result);
3324             btU16: var1^.tu16 := var1^.tu16 and GetUint(Var2, Result);
3325             btS16: var1^.ts16 := var1^.ts16 and Getint(Var2, Result);
3326             btU32: var1^.tu32 := var1^.tu32 and GetUint(Var2, Result);
3327             btS32: var1^.ts32 := var1^.ts32 and Getint(Var2, Result);
3328             btEnum: var1^.ts32 := var1^.ts32 and Getint(Var2, Result);
3329             {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 and GetInt64(Var2, Result); {$ENDIF}
3330             else Result := False;
3331           end;
3332         end;
3333       otor:
3334         begin { OR }
3335           case Var1.FType.BaseType of
3336             btU8: var1^.tu8 := var1^.tu8 or GetUint(Var2, Result);
3337             btS8: var1^.ts8 := var1^.ts8 or Getint(Var2, Result);
3338             btU16: var1^.tu16 := var1^.tu16 or GetUint(Var2, Result);
3339             btS16: var1^.ts16 := var1^.ts16 or Getint(Var2, Result);
3340             btU32: var1^.tu32 := var1^.tu32 or GetUint(Var2, Result);
3341             btS32: var1^.ts32 := var1^.ts32 or Getint(Var2, Result);
3342             {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 or GetInt64(Var2, Result); {$ENDIF}
3343             btEnum: var1^.ts32 := var1^.ts32 or Getint(Var2, Result);
3344             else Result := False;
3345           end;
3346         end;
3347       otxor:
3348         begin { XOR }
3349           case Var1.FType.BaseType of
3350             btU8: var1^.tu8 := var1^.tu8 xor GetUint(Var2, Result);
3351             btS8: var1^.ts8 := var1^.ts8 xor Getint(Var2, Result);
3352             btU16: var1^.tu16 := var1^.tu16 xor GetUint(Var2, Result);
3353             btS16: var1^.ts16 := var1^.ts16 xor Getint(Var2, Result);
3354             btU32: var1^.tu32 := var1^.tu32 xor GetUint(Var2, Result);
3355             btS32: var1^.ts32 := var1^.ts32 xor Getint(Var2, Result);
3356             {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 xor GetInt64(Var2, Result); {$ENDIF}
3357             btEnum: var1^.ts32 := var1^.ts32 xor Getint(Var2, Result);
3358             else Result := False;
3359           end;
3360         end;
3361       otGreaterEqual:
3362         begin { >= }
3363           case Var1.FType.BaseType of
3364             btU8: b := var1^.tu8 >= GetUint(Var2, Result);
3365             btS8: b := var1^.ts8 >= Getint(Var2, Result);
3366             btU16: b := var1^.tu16 >= GetUint(Var2, Result);
3367             btS16: b := var1^.ts16 >= Getint(Var2, Result);
3368             btU32: b := var1^.tu32 >= GetUint(Var2, Result);
3369             btS32: b := var1^.ts32 >= Getint(Var2, Result);
3370             {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 >= GetInt64(Var2, Result); {$ENDIF}
3371             btSingle: b := var1^.tsingle >= GetReal( Var2, Result);
3372             btDouble: b := var1^.tdouble >= GetReal( Var2, Result);
3373             btExtended: b := var1^.textended >= GetReal( Var2, Result);
3374             btCurrency: b := var1^.tcurrency >= GetReal( Var2, Result);
3375             btSet:
3376               begin
3377                 if (var1.FType = var2.FType) then
3378                 begin
3379                   Set_Subset(var2.tstring, var1.tstring, TPSSetType(var1.FType).ByteSize, b);
3380                 end else Result := False;
3381               end;
3382           else
3383             Result := False;
3384           end;
3385           ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
3386         end;
3387       otLessEqual:
3388         begin { <= }
3389           case Var1.FType.BaseType of
3390             btU8: b := var1^.tu8 <= GetUint(Var2, Result);
3391             btS8: b := var1^.ts8 <= Getint(Var2, Result);
3392             btU16: b := var1^.tu16 <= GetUint(Var2, Result);
3393             btS16: b := var1^.ts16 <= Getint(Var2, Result);
3394             btU32: b := var1^.tu32 <= GetUint(Var2, Result);
3395             btS32: b := var1^.ts32 <= Getint(Var2, Result);
3396             {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 <= GetInt64(Var2, Result); {$ENDIF}
3397             btSingle: b := var1^.tsingle <= GetReal( Var2, Result);
3398             btDouble: b := var1^.tdouble <= GetReal( Var2, Result);
3399             btExtended: b := var1^.textended <= GetReal( Var2, Result);
3400             btCurrency: b := var1^.tcurrency <= GetReal( Var2, Result);
3401             btSet:
3402               begin
3403                 if (var1.FType = var2.FType) then
3404                 begin
3405                   Set_Subset(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize, b);
3406                 end else Result := False;
3407               end;
3408           else
3409             Result := False;
3410           end;
3411           ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
3412         end;
3413       otGreater:
3414         begin { > }
3415           case Var1.FType.BaseType of
3416             btU8: b := var1^.tu8 > GetUint(Var2, Result);
3417             btS8: b := var1^.ts8 > Getint(Var2, Result);
3418             btU16: b := var1^.tu16 > GetUint(Var2, Result);
3419             btS16: b := var1^.ts16 > Getint(Var2, Result);
3420             btU32: b := var1^.tu32 > GetUint(Var2, Result);
3421             btS32: b := var1^.ts32 > Getint(Var2, Result);
3422             {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 > GetInt64(Var2, Result); {$ENDIF}
3423             btSingle: b := var1^.tsingle > GetReal( Var2, Result);
3424             btDouble: b := var1^.tdouble > GetReal( Var2, Result);
3425             btExtended: b := var1^.textended > GetReal( Var2, Result);
3426             btCurrency: b := var1^.tcurrency > GetReal( Var2, Result);
3427           else
3428             Result := False;
3429           end;
3430           ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
3431         end;
3432       otLess:
3433         begin { < }
3434           case Var1.FType.BaseType of
3435             btU8: b := var1^.tu8 < GetUint(Var2, Result);
3436             btS8: b := var1^.ts8 < Getint(Var2, Result);
3437             btU16: b := var1^.tu16 < GetUint(Var2, Result);
3438             btS16: b := var1^.ts16 < Getint(Var2, Result);
3439             btU32: b := var1^.tu32 < GetUint(Var2, Result);
3440             btS32: b := var1^.ts32 < Getint(Var2, Result);
3441             {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 < GetInt64(Var2, Result); {$ENDIF}
3442             btSingle: b := var1^.tsingle < GetReal( Var2, Result);
3443             btDouble: b := var1^.tdouble < GetReal( Var2, Result);
3444             btExtended: b := var1^.textended < GetReal( Var2, Result);
3445             btCurrency: b := var1^.tcurrency < GetReal( Var2, Result);
3446           else
3447             Result := False;
3448           end;
3449           ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
3450         end;
3451       otNotEqual:
3452         begin { <> }
3453           case Var1.FType.BaseType of
3454             btU8: b := var1^.tu8 <> GetUint(Var2, Result);
3455             btS8: b := var1^.ts8 <> Getint(Var2, Result);
3456             btU16: b := var1^.tu16 <> GetUint(Var2, Result);
3457             btS16: b := var1^.ts16 <> Getint(Var2, Result);
3458             btU32: b := var1^.tu32 <> GetUint(Var2, Result);
3459             {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 <> GetInt64(Var2, Result); {$ENDIF}
3460             btS32: b := var1^.ts32 <> Getint(Var2, Result);
3461             btSingle: b := var1^.tsingle <> GetReal( Var2, Result);
3462             btDouble: b := var1^.tdouble <> GetReal( Var2, Result);
3463             btExtended: b := var1^.textended <> GetReal( Var2, Result);
3464             btCurrency: b := var1^.tcurrency <> GetReal( Var2, Result);
3465             btEnum: b := var1^.ts32 <> Getint(Var2, Result);
3466             btString: b := tbtstring(var1^.tstring) <> GetString(var2, Result);
3467             btChar: b := var1^.tchar <> GetString(var2, Result);
3468             {$IFNDEF PS_NOWIDESTRING}
3469             btWideString: b := tbtWideString(var1^.twidestring) <> GetWideString(var2, Result);
3470             btUnicodeString: b := tbtUnicodeString(var1^.tunistring) <> GetUnicodeString(var2, Result);
3471             btWideChar: b := var1^.twidechar <> GetUnicodeString(var2, Result);
3472             {$ENDIF}
3473             btSet:
3474               begin
3475                 if (var1.FType = var2.FType) then
3476                 begin
3477                   Set_Equal(var1.tstring, var2.tstring, TPSSetType(var1.FType).GetByteSize, b);
3478                   b := not b;
3479                 end else Result := False;
3480               end;
3481           else
3482             Result := False;
3483           end;
3484           ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
3485         end;
3486       otEqual:
3487         begin { = }
3488           case Var1.FType.BaseType of
3489             btU8: b := var1^.tu8 = GetUint(Var2, Result);
3490             btS8: b := var1^.ts8 = Getint(Var2, Result);
3491             btU16: b := var1^.tu16 = GetUint(Var2, Result);
3492             btS16: b := var1^.ts16 = Getint(Var2, Result);
3493             btU32: b := var1^.tu32 = GetUint(Var2, Result);
3494             btS32: b := var1^.ts32 = Getint(Var2, Result);
3495             {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 = GetInt64(Var2, Result); {$ENDIF}
3496             btSingle: b := var1^.tsingle = GetReal( Var2, Result);
3497             btDouble: b := var1^.tdouble = GetReal( Var2, Result);
3498             btExtended: b := var1^.textended = GetReal( Var2, Result);
3499             btCurrency: b := var1^.tcurrency = GetReal( Var2, Result);
3500             btEnum: b := var1^.ts32 = Getint(Var2, Result);
3501             btString: b := tbtstring(var1^.tstring) = GetString(var2, Result);
3502             btChar: b := var1^.tchar = GetString(var2, Result);
3503             {$IFNDEF PS_NOWIDESTRING}
3504             btWideString: b := tbtWideString(var1^.twidestring) = GetWideString(var2, Result);
3505             btUnicodeString: b := tbtUnicodeString(var1^.twidestring) = GetUnicodeString(var2, Result);
3506             btWideChar: b := var1^.twidechar = GetUnicodeString(var2, Result);
3507             {$ENDIF}
3508             btSet:
3509               begin
3510                 if (var1.FType = var2.FType) then
3511                 begin
3512                   Set_Equal(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize, b);
3513                 end else Result := False;
3514               end;
3515           else
3516             Result := False;
3517           end;
3518           ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
3519         end;
3520       otIn:
3521         begin
3522           if (var2.Ftype.BaseType = btset) and (TPSSetType(var2).SetType = Var1.FType) then
3523           begin
3524             Set_membership(GetUint(var1, result), var2.tstring, b);
3525           end else Result := False;
3526         end;
3527       else
3528         Result := False;
3529     end;
3530   except
3531     on E: EDivByZero do
3532     begin
3533       Result := False;
3534       MakeError('', ecDivideByZero, '');
3535       Exit;
3536     end;
3537     on E: EZeroDivide do
3538     begin
3539       Result := False;
3540       MakeError('', ecDivideByZero, '');
3541       Exit;
3542     end;
3543     on E: EMathError do
3544     begin
3545       Result := False;
3546       MakeError('', ecMathError, tbtstring(e.Message));
3547       Exit;
3548     end;
3549     on E: Exception do
3550     begin
3551       Result := False;
3552       MakeError('', ecInternalError, tbtstring(E.Message));
3553       Exit;
3554     end;
3555   end;
3556   if not Result then
3557   begin
3558     with MakeError('', ecTypeMismatch, '') do
3559     begin
3560       FPosition := Pos;
3561       FRow := Row;
3562       FCol := Col;
3563     end;
3564   end;
3565 end;
3566 
IsDuplicatenull3567 function TPSPascalCompiler.IsDuplicate(const s: tbtString; const check: TPSDuplicCheck): Boolean;
3568 var
3569   h, l: Longint;
3570   x: TPSProcedure;
3571 begin
3572   if (s = 'RESULT') then
3573   begin
3574     Result := True;
3575     exit;
3576   end;
3577   h := MakeHash(s);
3578   if dcTypes in Check then
3579   for l := FTypes.Count - 1 downto 0 do
3580   begin
3581     if (TPSType(FTypes.Data[l]).NameHash = h) and
3582       (TPSType(FTypes.Data[l]).Name = s) then
3583     begin
3584       Result := True;
3585       exit;
3586     end;
3587   end;
3588 
3589   if dcProcs in Check then
3590   for l := FProcs.Count - 1 downto 0 do
3591   begin
3592     x := FProcs.Data[l];
3593     if x.ClassType = TPSInternalProcedure then
3594     begin
3595       if (h = TPSInternalProcedure(x).NameHash) and (s = TPSInternalProcedure(x).Name) then
3596       begin
3597         Result := True;
3598         exit;
3599       end;
3600     end
3601     else
3602     begin
3603       if (TPSExternalProcedure(x).RegProc.NameHash = h) and
3604         (TPSExternalProcedure(x).RegProc.Name = s) then
3605       begin
3606         Result := True;
3607         exit;
3608       end;
3609     end;
3610   end;
3611   if dcVars in Check then
3612   for l := FVars.Count - 1 downto 0 do
3613   begin
3614     if (TPSVar(FVars.Data[l]).NameHash = h) and
3615       (TPSVar(FVars.Data[l]).Name = s) then
3616     begin
3617       Result := True;
3618       exit;
3619     end;
3620   end;
3621   if dcConsts in Check then
3622   for l := FConstants.Count -1 downto 0 do
3623   begin
3624     if (TPSConstant(FConstants.Data[l]).NameHash = h) and
3625       (TPSConstant(FConstants.Data[l]).Name = s) then
3626     begin
3627       Result := TRue;
3628       exit;
3629     end;
3630   end;
3631   Result := False;
3632 end;
3633 
3634 procedure ClearRecSubVals(RecSubVals: TPSList);
3635 var
3636   I: Longint;
3637 begin
3638   for I := 0 to RecSubVals.Count - 1 do
3639     TPSRecordFieldTypeDef(RecSubVals[I]).Free;
3640   RecSubVals.Free;
3641 end;
3642 
TPSPascalCompiler.ReadTypeAddProcedurenull3643 function TPSPascalCompiler.ReadTypeAddProcedure(const Name: tbtString; FParser: TPSPascalParser): TPSType;
3644 var
Booleannull3645   IsFunction: Boolean;
3646   VNames: tbtString;
3647   modifier: TPSParameterMode;
3648   Decl: TPSParametersDecl;
3649   VCType: TPSType;
3650 begin
thennull3651   if FParser.CurrTokenId = CSTII_Function then
3652     IsFunction := True
3653   else
3654     IsFunction := False;
3655   Decl := TPSParametersDecl.Create;
3656   try
3657     FParser.Next;
3658     if FParser.CurrTokenId = CSTI_OpenRound then
3659     begin
3660       FParser.Next;
3661       if FParser.CurrTokenId <> CSTI_CloseRound then
3662       begin
3663         while True do
3664         begin
3665           if FParser.CurrTokenId = CSTII_Const then
3666           begin
3667             Modifier := pmIn;
3668             FParser.Next;
3669           end else
3670           if FParser.CurrTokenId = CSTII_Out then
3671           begin
3672             Modifier := pmOut;
3673             FParser.Next;
3674           end else
3675           if FParser.CurrTokenId = CSTII_Var then
3676           begin
3677             modifier := pmInOut;
3678             FParser.Next;
3679           end
3680           else
3681             modifier := pmIn;
3682           if FParser.CurrTokenId <> CSTI_Identifier then
3683           begin
3684             Result := nil;
3685             if FParser = Self.FParser then
3686             MakeError('', ecIdentifierExpected, '');
3687             exit;
3688           end;
3689           VNames := FParser.OriginalToken + '|';
3690           FParser.Next;
3691           while FParser.CurrTokenId = CSTI_Comma do
3692           begin
3693             FParser.Next;
3694             if FParser.CurrTokenId <> CSTI_Identifier then
3695             begin
3696               Result := nil;
3697               if FParser = Self.FParser then
3698               MakeError('', ecIdentifierExpected, '');
3699               exit;
3700             end;
3701             VNames := VNames + FParser.GetToken + '|';
3702             FParser.Next;
3703           end;
3704           if FParser.CurrTokenId <> CSTI_Colon then
3705           begin
3706             Result := nil;
3707             if FParser = Self.FParser then
3708               MakeError('', ecColonExpected, '');
3709             exit;
3710           end;
3711           FParser.Next;
3712           if FParser.CurrTokenId <> CSTI_Identifier then
3713           begin
3714             Result := nil;
3715             if FParser = self.FParser then
3716             MakeError('', ecIdentifierExpected, '');
3717             exit;
3718           end;
3719           VCType := FindType(FParser.GetToken);
3720           if VCType = nil then
3721           begin
3722             if FParser = self.FParser then
3723             MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
3724             Result := nil;
3725             exit;
3726           end;
3727           while Pos(tbtchar('|'), VNames) > 0 do
3728           begin
3729             with Decl.AddParam do
3730             begin
3731               Mode := modifier;
3732               OrgName := copy(VNames, 1, Pos(tbtchar('|'), VNames) - 1);
3733               FType := VCType;
3734             end;
3735             Delete(VNames, 1, Pos(tbtchar('|'), VNames));
3736           end;
3737           FParser.Next;
3738           if FParser.CurrTokenId = CSTI_CloseRound then
3739             break;
3740           if FParser.CurrTokenId <> CSTI_Semicolon then
3741           begin
3742             if FParser = Self.FParser then
3743             MakeError('', ecSemicolonExpected, '');
3744             Result := nil;
3745             exit;
3746           end;
3747           FParser.Next;
3748         end; {while}
3749       end; {if}
3750       FParser.Next;
3751       end; {if}
thennull3752       if IsFunction then
3753       begin
3754         if FParser.CurrTokenId <> CSTI_Colon then
3755         begin
3756           if FParser = Self.FParser then
3757           MakeError('', ecColonExpected, '');
3758           Result := nil;
3759           exit;
3760         end;
3761       FParser.Next;
3762       if FParser.CurrTokenId <> CSTI_Identifier then
3763       begin
3764         Result := nil;
3765         if FParser = Self.FParser then
3766         MakeError('', ecIdentifierExpected, '');
3767         exit;
3768       end;
3769       VCType := self.FindType(FParser.GetToken);
3770       if VCType = nil then
3771       begin
3772         if FParser = self.FParser then
3773         MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
3774         Result := nil;
3775         exit;
3776       end;
3777       FParser.Next;
3778     end
3779     else
3780       VCType := nil;
3781     Decl.Result := VcType;
3782     VCType := TPSProceduralType.Create;
3783     VCType.Name := FastUppercase(Name);
3784     VCType.OriginalName := Name;
3785     VCType.BaseType := btProcPtr;
3786     {$IFDEF PS_USESSUPPORT}
3787     VCType.DeclareUnit:=fModule;
3788     {$ENDIF}
3789     VCType.DeclarePos := FParser.CurrTokenPos;
3790     VCType.DeclareRow := FParser.Row;
3791     VCType.DeclareCol := FParser.Col;
3792     TPSProceduralType(VCType).ProcDef.Assign(Decl);
3793     FTypes.Add(VCType);
3794     Result := VCType;
3795   finally
3796     Decl.Free;
3797   end;
3798 end; {ReadTypeAddProcedure}
3799 
3800 
ReadTypenull3801 function TPSPascalCompiler.ReadType(const Name: tbtString; FParser: TPSPascalParser): TPSType; // InvalidVal = Invalid
3802 var
3803   TypeNo: TPSType;
3804   h, l: Longint;
3805   FieldName,fieldorgname,s: tbtString;
3806   RecSubVals: TPSList;
3807   FArrayStart, FArrayLength: Longint;
3808   rvv: PIFPSRecordFieldTypeDef;
3809   p, p2: TPSType;
3810   tempf: PIfRVariant;
3811 {$IFNDEF PS_NOINTERFACES}
3812   InheritedFrom: tbtString;
3813   Guid: TGUID;
3814   Intf: TPSInterface;
3815 {$ENDIF}
3816 begin
ornull3817   if (FParser.CurrTokenID = CSTII_Function) or (FParser.CurrTokenID = CSTII_Procedure) then
3818   begin
3819      Result := ReadTypeAddProcedure(Name, FParser);
3820      Exit;
3821   end else if FParser.CurrTokenId = CSTII_Set then
3822   begin
3823     FParser.Next;
3824     if FParser.CurrTokenId <> CSTII_Of then
3825     begin
3826       MakeError('', ecOfExpected, '');
3827       Result := nil;
3828       Exit;
3829     end;
3830     FParser.Next;
3831     if FParser.CurrTokenID <> CSTI_Identifier then
3832     begin
3833       MakeError('', ecIdentifierExpected, '');
3834       Result := nil;
3835       exit;
3836     end;
3837     TypeNo := FindType(FParser.GetToken);
3838     if TypeNo = nil then
3839     begin
3840       MakeError('', ecUnknownIdentifier, '');
3841       Result := nil;
3842       exit;
3843     end;
3844     if (TypeNo.BaseType = btEnum) or (TypeNo.BaseType = btChar) or (TypeNo.BaseType = btU8) then
3845     begin
3846       FParser.Next;
3847       p2 := TPSSetType.Create;
3848       p2.Name := FastUppercase(Name);
3849       p2.OriginalName := Name;
3850       p2.BaseType := btSet;
3851       {$IFDEF PS_USESSUPPORT}
3852       p2.DeclareUnit:=fModule;
3853       {$ENDIF}
3854       p2.DeclarePos := FParser.CurrTokenPos;
3855       p2.DeclareRow := FParser.Row;
3856       p2.DeclareCol := FParser.Col;
3857       TPSSetType(p2).SetType := TypeNo;
3858       FTypes.Add(p2);
3859       Result := p2;
3860     end else
3861     begin
3862       MakeError('', ecTypeMismatch, '');
3863       Result := nil;
3864     end;
3865     exit;
3866   end else if FParser.CurrTokenId = CSTI_OpenRound then
3867   begin
3868     FParser.Next;
3869     L := 0;
3870     P2 := TPSEnumType.Create;
3871     P2.Name := FastUppercase(Name);
3872     p2.OriginalName := Name;
3873     p2.BaseType := btEnum;
3874     {$IFDEF PS_USESSUPPORT}
3875     p2.DeclareUnit:=fModule;
3876     {$ENDIF}
3877     p2.DeclarePos := FParser.CurrTokenPos;
3878     p2.DeclareRow := FParser.Row;
3879     p2.DeclareCol := FParser.Col;
3880     FTypes.Add(p2);
3881 
3882     repeat
3883       if FParser.CurrTokenId <> CSTI_Identifier then
3884       begin
3885         if FParser = Self.FParser then
3886         MakeError('', ecIdentifierExpected, '');
3887         Result := nil;
3888         exit;
3889       end;
3890       s := FParser.OriginalToken;
3891       if IsDuplicate(FastUppercase(s), [dcTypes]) then
3892       begin
3893         if FParser = Self.FParser then
3894         MakeError('', ecDuplicateIdentifier, s);
3895         Result := nil;
3896         Exit;
3897       end;
3898       with AddConstant(s, p2) do
3899       begin
3900         FValue.tu32 := L;
3901         {$IFDEF PS_USESSUPPORT}
3902         DeclareUnit:=fModule;
3903         {$ENDIF}
3904         DeclarePos:=FParser.CurrTokenPos;
3905         DeclareRow:=FParser.Row;
3906         DeclareCol:=FParser.Col;
3907       end;
3908       Inc(L);
3909       FParser.Next;
3910       if FParser.CurrTokenId = CSTI_CloseRound then
3911         Break
3912       else if FParser.CurrTokenId <> CSTI_Comma then
3913       begin
3914         if FParser = Self.FParser then
3915         MakeError('', ecCloseRoundExpected, '');
3916         Result := nil;
3917         Exit;
3918       end;
3919       FParser.Next;
3920     until False;
3921     FParser.Next;
3922     TPSEnumType(p2).HighValue := L-1;
3923     Result := p2;
3924     exit;
3925   end else
3926   if FParser.CurrTokenId = CSTII_Array then
3927   begin
3928     FParser.Next;
3929     if FParser.CurrTokenID = CSTI_OpenBlock then
3930     begin
3931       FParser.Next;
3932       tempf := ReadConstant(FParser, CSTI_TwoDots);
3933       if tempf = nil then
3934       begin
3935         Result := nil;
3936         exit;
3937       end;
3938       case tempf.FType.BaseType of
3939         btU8: FArrayStart := tempf.tu8;
3940         btS8: FArrayStart := tempf.ts8;
3941         btU16: FArrayStart := tempf.tu16;
3942         btS16: FArrayStart := tempf.ts16;
3943         btU32: FArrayStart := tempf.tu32;
3944         btS32: FArrayStart := tempf.ts32;
3945         {$IFNDEF PS_NOINT64}
3946         bts64: FArrayStart := tempf.ts64;
3947         {$ENDIF}
3948       else
3949         begin
3950           DisposeVariant(tempf);
3951           MakeError('', ecTypeMismatch, '');
3952           Result := nil;
3953           exit;
3954         end;
3955       end;
3956       DisposeVariant(tempf);
3957       if FParser.CurrTokenID <> CSTI_TwoDots then
3958       begin
3959         MakeError('', ecPeriodExpected, '');
3960         Result := nil;
3961         exit;
3962       end;
3963       FParser.Next;
3964       tempf := ReadConstant(FParser, CSTI_CloseBlock);
3965       if tempf = nil then
3966       begin
3967         Result := nil;
3968         exit;
3969       end;
3970       case tempf.FType.BaseType of
3971         btU8: FArrayLength := tempf.tu8;
3972         btS8: FArrayLength := tempf.ts8;
3973         btU16: FArrayLength := tempf.tu16;
3974         btS16: FArrayLength := tempf.ts16;
3975         btU32: FArrayLength := tempf.tu32;
3976         btS32: FArrayLength := tempf.ts32;
3977         {$IFNDEF PS_NOINT64}
3978         bts64: FArrayLength := tempf.ts64;
3979         {$ENDIF}
3980       else
3981         DisposeVariant(tempf);
3982         MakeError('', ecTypeMismatch, '');
3983         Result := nil;
3984         exit;
3985       end;
3986       DisposeVariant(tempf);
3987       FArrayLength := FArrayLength - FArrayStart + 1;
3988       if (FArrayLength < 0) or (FArrayLength > MaxInt div 4) then
3989       begin
3990         MakeError('', ecTypeMismatch, '');
3991         Result := nil;
3992         exit;
3993       end;
3994       if FParser.CurrTokenID <> CSTI_CloseBlock then
3995       begin
3996         MakeError('', ecCloseBlockExpected, '');
3997         Result := nil;
3998         exit;
3999       end;
4000       FParser.Next;
4001     end else
4002     begin
4003       FArrayStart := 0;
4004       FArrayLength := -1;
4005     end;
4006     if FParser.CurrTokenId <> CSTII_Of then
4007     begin
4008       if FParser = Self.FParser then
4009       MakeError('', ecOfExpected, '');
4010       Result := nil;
4011       exit;
4012     end;
4013     FParser.Next;
4014     TypeNo := ReadType('', FParser);
4015     if TypeNo = nil then
4016     begin
4017       if FParser = Self.FParser then
4018       MakeError('', ecUnknownIdentifier, '');
4019       Result := nil;
4020       exit;
4021     end;
4022     if (Name = '') and (FArrayLength = -1) then
4023     begin
4024       if TypeNo.Used then
4025       begin
4026         for h := 0 to FTypes.Count -1 do
4027         begin
4028           p := FTypes[H];
4029           if (p.BaseType = btArray) and (TPSArrayType(p).ArrayTypeNo = TypeNo) and (Copy(p.Name, 1, 1) <> '!') then
4030           begin
4031             Result := p;
4032             exit;
4033           end;
4034         end;
4035       end;
4036     end;
4037     if FArrayLength <> -1 then
4038     begin
4039       p := TPSStaticArrayType.Create;
4040       TPSStaticArrayType(p).StartOffset := FArrayStart;
4041       TPSStaticArrayType(p).Length := FArrayLength;
4042       p.BaseType := btStaticArray;
4043     end else
4044     begin
4045       p := TPSArrayType.Create;
4046       p.BaseType := btArray;
4047     end;
4048     p.Name := FastUppercase(Name);
4049     p.OriginalName := Name;
4050     {$IFDEF PS_USESSUPPORT}
4051     p.DeclareUnit:=fModule;
4052     {$ENDIF}
4053     p.DeclarePos := FParser.CurrTokenPos;
4054     p.DeclareRow := FParser.Row;
4055     p.DeclareCol := FParser.Col;
4056     TPSArrayType(p).ArrayTypeNo := TypeNo;
4057     FTypes.Add(p);
4058     Result := p;
4059     Exit;
4060   end
4061   else if FParser.CurrTokenId = CSTII_Record then
4062   begin
4063     FParser.Next;
4064     RecSubVals := TPSList.Create;
4065     repeat
4066       repeat
4067         if FParser.CurrTokenId <> CSTI_Identifier then
4068         begin
4069           ClearRecSubVals(RecSubVals);
4070           if FParser = Self.FParser then
4071           MakeError('', ecIdentifierExpected, '');
4072           Result := nil;
4073           exit;
4074         end;
4075         FieldName := FParser.GetToken;
4076         s := S+FParser.OriginalToken+'|';
4077         FParser.Next;
4078         h := MakeHash(FieldName);
4079         for l := 0 to RecSubVals.Count - 1 do
4080         begin
4081           if (PIFPSRecordFieldTypeDef(RecSubVals[l]).FieldNameHash = h) and
4082             (PIFPSRecordFieldTypeDef(RecSubVals[l]).FieldName = FieldName) then
4083           begin
4084             if FParser = Self.FParser then
4085               MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
4086             ClearRecSubVals(RecSubVals);
4087             Result := nil;
4088             exit;
4089           end;
4090         end;
4091         if FParser.CurrTokenID = CSTI_Colon then Break else
4092         if FParser.CurrTokenID <> CSTI_Comma then
4093         begin
4094           if FParser = Self.FParser then
4095             MakeError('', ecColonExpected, '');
4096           ClearRecSubVals(RecSubVals);
4097           Result := nil;
4098           exit;
4099         end;
4100         FParser.Next;
4101       until False;
4102       FParser.Next;
4103       p := ReadType('', FParser);
4104       if p = nil then
4105       begin
4106         ClearRecSubVals(RecSubVals);
4107         Result := nil;
4108         exit;
4109       end;
4110       p := GetTypeCopyLink(p);
4111       if FParser.CurrTokenId <> CSTI_Semicolon then
4112       begin
4113         ClearRecSubVals(RecSubVals);
4114         if FParser = Self.FParser then
4115         MakeError('', ecSemicolonExpected, '');
4116         Result := nil;
4117         exit;
4118       end; {if}
4119       FParser.Next;
4120       while Pos(tbtchar('|'), s) > 0 do
4121       begin
4122         fieldorgname := copy(s, 1, Pos(tbtchar('|'), s)-1);
4123         Delete(s, 1, length(FieldOrgName)+1);
4124         rvv := TPSRecordFieldTypeDef.Create;
4125         rvv.FieldOrgName := fieldorgname;
4126         rvv.FType := p;
4127         RecSubVals.Add(rvv);
4128       end;
4129     until FParser.CurrTokenId = CSTII_End;
4130     FParser.Next; // skip CSTII_End
4131     P := TPSRecordType.Create;
4132     p.Name := FastUppercase(Name);
4133     p.OriginalName := Name;
4134     p.BaseType := btRecord;
4135     {$IFDEF PS_USESSUPPORT}
4136     p.DeclareUnit:=fModule;
4137     {$ENDIF}
4138     p.DeclarePos := FParser.CurrTokenPos;
4139     p.DeclareRow := FParser.Row;
4140     p.DeclareCol := FParser.Col;
4141     for l := 0 to RecSubVals.Count -1 do
4142     begin
4143       rvv := RecSubVals[l];
4144       with TPSRecordType(p).AddRecVal do
4145       begin
4146         FieldOrgName := rvv.FieldOrgName;
4147         FType := rvv.FType;
4148       end;
4149       rvv.Free;
4150     end;
4151     RecSubVals.Free;
4152     FTypes.Add(p);
4153     Result := p;
4154     Exit;
4155 {$IFNDEF PS_NOINTERFACES}
4156   end else if FParser.CurrTokenId = CSTII_Interface then
4157   begin
4158     FParser.Next;
4159     if FParser.CurrTokenId <> CSTI_OpenRound then
4160     begin
4161       MakeError('', ecOpenRoundExpected, '');
4162       Result := nil;
4163       Exit;
4164     end;
4165     FParser.Next;
4166     if FParser.CurrTokenID <> CSTI_Identifier then
4167     begin
4168       MakeError('', ecIdentifierExpected, '');
4169       Result := nil;
4170       exit;
4171     end;
4172     InheritedFrom := FParser.GetToken;
4173     TypeNo := FindType(InheritedFrom);
4174     if TypeNo = nil then
4175     begin
4176       MakeError('', ecUnknownType, FParser.GetToken);
4177       Result := nil;
4178       exit;
4179     end;
4180     if TypeNo.BaseType <> btInterface then
4181     begin
4182       MakeError('', ecTypeMismatch, '');
4183       Result := nil;
4184       Exit;
4185     end;
4186     FParser.Next;
4187     if FParser.CurrTokenId <> CSTI_CloseRound then
4188     begin
4189       MakeError('', ecCloseRoundExpected, '');
4190       Result := nil;
4191       Exit;
4192     end;
4193 {$IFNDEF PS_NOINTERFACEGUIDBRACKETS}
4194     FParser.Next;
4195     if FParser.CurrTokenId <> CSTI_OpenBlock then
4196     begin
4197       MakeError('', ecOpenBlockExpected, '');
4198       Result := nil;
4199       Exit;
4200     end;
4201 {$ENDIF}
4202     FParser.Next;
4203     if FParser.CurrTokenId <> CSTI_String then
4204     begin
4205       MakeError('', ecStringExpected, '');
4206       Result := nil;
4207       Exit;
4208     end;
4209     s := FParser.GetToken;
4210     try
4211       Guid := StringToGuid(String(Copy(s, 2, Length(s)-2)));
4212     except
4213       on e: Exception do
4214       begin
4215         MakeError('', ecCustomError, tbtstring(e.Message));
4216         Result := nil;
4217         Exit;
4218       end;
4219     end;
4220 {$IFNDEF PS_NOINTERFACEGUIDBRACKETS}
4221     FParser.Next;
4222     if FParser.CurrTokenId <> CSTI_CloseBlock then
4223     begin
4224       MakeError('', ecCloseBlockExpected, '');
4225       Result := nil;
4226       Exit;
4227     end;
4228 {$ENDIF}
4229     Intf := AddInterface(FindInterface(InheritedFrom), Guid, Name);
4230     FParser.Next;
4231     repeat
4232       if not Intf.RegisterMethodEx('', cdStdCall, FParser) then begin
4233         MakeError('', ecCustomError, 'Invalid method');
4234         Result := nil;
4235         Exit;
4236       end;
4237       FParser.Next;
4238     until FParser.CurrTokenId = CSTII_End;
4239     FParser.Next; // skip CSTII_End
4240     Result := Intf.FType;
4241     Exit;
4242 {$ENDIF}
4243   end else if FParser.CurrTokenId = CSTI_Identifier then
4244   begin
4245     s := FParser.GetToken;
4246     h := MakeHash(s);
4247     Typeno := nil;
4248     for l := 0 to FTypes.Count - 1 do
4249     begin
4250       p2 := FTypes[l];
4251       if (p2.NameHash = h) and (p2.Name = s) then
4252       begin
4253         FParser.Next;
4254         Typeno := GetTypeCopyLink(p2);
4255         Break;
4256       end;
4257     end;
4258     if Typeno = nil then
4259     begin
4260       Result := nil;
4261       if FParser = Self.FParser then
4262       MakeError('', ecUnknownType, FParser.OriginalToken);
4263       exit;
4264     end;
4265     if Name <> '' then
4266     begin
4267       p := TPSTypeLink.Create;
4268       p.Name := FastUppercase(Name);
4269       p.OriginalName := Name;
4270       p.BaseType := BtTypeCopy;
4271       {$IFDEF PS_USESSUPPORT}
4272       p.DeclareUnit:=fModule;
4273       {$ENDIF}
4274       p.DeclarePos := FParser.CurrTokenPos;
4275       p.DeclareRow := FParser.Row;
4276       p.DeclareCol := FParser.Col;
4277       TPSTypeLink(p).LinkTypeNo := TypeNo;
4278       FTypes.Add(p);
4279       Result := p;
4280       Exit;
4281     end else
4282     begin
4283       Result := TypeNo;
4284       exit;
4285     end;
4286   end;
4287   Result := nil;
4288   if FParser = Self.FParser then
4289   MakeError('', ecIdentifierExpected, '');
4290   Exit;
4291 end;
4292 
VarIsDuplicatenull4293 function TPSPascalCompiler.VarIsDuplicate(Proc: TPSInternalProcedure; const Varnames, s: tbtString): Boolean;
4294 var
4295   h, l: Longint;
4296   x: TPSProcedure;
4297   v: tbtString;
4298 begin
4299   h := MakeHash(s);
4300   if (s = 'RESULT') then
4301   begin
4302     Result := True;
4303     exit;
4304   end;
4305 
4306   for l := FProcs.Count - 1 downto 0 do
4307   begin
4308     x := FProcs.Data[l];
4309     if x.ClassType = TPSInternalProcedure then
4310     begin
4311       if (h = TPSInternalProcedure(x).NameHash) and (s = TPSInternalProcedure(x).Name) then
4312       begin
4313         Result := True;
4314         exit;
4315       end;
4316     end
4317     else
4318     begin
4319       if (TPSExternalProcedure(x).RegProc.NameHash = h) and (TPSExternalProcedure(x).RegProc.Name = s) then
4320       begin
4321         Result := True;
4322         exit;
4323       end;
4324     end;
4325   end;
4326   if proc <> nil then
4327   begin
4328     for l := proc.ProcVars.Count - 1 downto 0 do
4329     begin
4330       if (PIFPSProcVar(proc.ProcVars.Data[l]).NameHash = h) and
4331         (PIFPSProcVar(proc.ProcVars.Data[l]).Name = s) then
4332       begin
4333         Result := True;
4334         exit;
4335       end;
4336     end;
4337     for l := Proc.FDecl.ParamCount -1 downto 0 do
4338     begin
4339       if (Proc.FDecl.Params[l].Name = s) then
4340       begin
4341         Result := True;
4342         exit;
4343       end;
4344     end;
4345   end
4346   else
4347   begin
4348     for l := FVars.Count - 1 downto 0 do
4349     begin
4350       if (TPSVar(FVars.Data[l]).NameHash = h) and
4351         (TPSVar(FVars.Data[l]).Name = s) then
4352       begin
4353         Result := True;
4354         exit;
4355       end;
4356     end;
4357   end;
4358   v := VarNames;
4359   while Pos(tbtchar('|'), v) > 0 do
4360   begin
4361     if FastUppercase(copy(v, 1, Pos(tbtchar('|'), v) - 1)) = s then
4362     begin
4363       Result := True;
4364       exit;
4365     end;
4366     Delete(v, 1, Pos(tbtchar('|'), v));
4367   end;
4368   for l := FConstants.Count -1 downto 0 do
4369   begin
4370     if (TPSConstant(FConstants.Data[l]).NameHash = h) and
4371       (TPSConstant(FConstants.Data[l]).Name = s) then
4372     begin
4373       Result := True;
4374       exit;
4375     end;
4376   end;
4377   Result := False;
4378 end;
4379 
4380 
TPSPascalCompiler.DoVarBlocknull4381 function TPSPascalCompiler.DoVarBlock(proc: TPSInternalProcedure): Boolean;
4382 var
4383   VarName, s: tbtString;
4384   VarType: TPSType;
4385   VarNo: Cardinal;
4386   v: TPSVar;
4387   vp: PIFPSProcVar;
4388   EPos, ERow, ECol: Integer;
4389 begin
4390   Result := False;
4391   FParser.Next; // skip CSTII_Var
4392   if FParser.CurrTokenId <> CSTI_Identifier then
4393   begin
4394     MakeError('', ecIdentifierExpected, '');
4395     exit;
4396   end;
4397   repeat
4398     VarNAme := '';
4399     if VarIsDuplicate(proc, VarName, FParser.GetToken) then
4400     begin
4401       MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
4402       exit;
4403     end;
4404     VarName := FParser.OriginalToken + '|';
4405     Varno := 0;
4406     if @FOnUseVariable <> nil then
4407     begin
4408       if Proc <> nil then
4409         FOnUseVariable(Self, ivtVariable, Proc.ProcVars.Count + VarNo, FProcs.Count -1, FParser.CurrTokenPos, '')
4410       else
4411         FOnUseVariable(Self, ivtGlobal, FVars.Count + VarNo, InvalidVal, FParser.CurrTokenPos, '')
4412     end;
4413     EPos:=FParser.CurrTokenPos;
4414     ERow:=FParser.Row;
4415     ECol:=FParser.Col;
4416     FParser.Next;
4417     while FParser.CurrTokenId = CSTI_Comma do
4418     begin
4419       FParser.Next;
4420       if FParser.CurrTokenId <> CSTI_Identifier then
4421       begin
4422         MakeError('', ecIdentifierExpected, '');
4423       end;
4424       if VarIsDuplicate(proc, VarName, FParser.GetToken) then
4425       begin
4426         MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
4427         exit;
4428       end;
4429       VarName := VarName + FParser.OriginalToken + '|';
4430       Inc(varno);
4431       if @FOnUseVariable <> nil then
4432       begin
4433         if Proc <> nil then
4434           FOnUseVariable(Self, ivtVariable, Proc.ProcVars.Count + VarNo, FProcs.Count -1, FParser.CurrTokenPos, '')
4435         else
4436           FOnUseVariable(Self, ivtGlobal, FVars.Count + VarNo, InvalidVal, FParser.CurrTokenPos, '')
4437       end;
4438       FParser.Next;
4439     end;
4440     if FParser.CurrTokenId <> CSTI_Colon then
4441     begin
4442       MakeError('', ecColonExpected, '');
4443       exit;
4444     end;
4445     FParser.Next;
4446     VarType := at2ut(ReadType('', FParser));
4447     if VarType = nil then
4448     begin
4449       exit;
4450     end;
4451     while Pos(tbtchar('|'), VarName) > 0 do
4452     begin
4453       s := copy(VarName, 1, Pos(tbtchar('|'), VarName) - 1);
4454       Delete(VarName, 1, Pos(tbtchar('|'), VarName));
4455       if proc = nil then
4456       begin
4457         v := TPSVar.Create;
4458         v.OrgName := s;
4459         v.Name := FastUppercase(s);
4460         {$IFDEF PS_USESSUPPORT}
4461         v.DeclareUnit:=fModule;
4462         {$ENDIF}
4463         v.DeclarePos := EPos;
4464         v.DeclareRow := ERow;
4465         v.DeclareCol := ECol;
4466         v.FType := VarType;
4467         FVars.Add(v);
4468       end
4469       else
4470       begin
4471         vp := TPSProcVar.Create;
4472         vp.OrgName := s;
4473         vp.Name := FastUppercase(s);
4474         vp.aType := VarType;
4475         {$IFDEF PS_USESSUPPORT}
4476         vp.DeclareUnit:=fModule;
4477         {$ENDIF}
4478         vp.DeclarePos := EPos;
4479         vp.DeclareRow := ERow;
4480         vp.DeclareCol := ECol;
4481         proc.ProcVars.Add(vp);
4482       end;
4483     end;
4484     if FParser.CurrTokenId <> CSTI_Semicolon then
4485     begin
4486       MakeError('', ecSemicolonExpected, '');
4487       exit;
4488     end;
4489     FParser.Next;
4490   until FParser.CurrTokenId <> CSTI_Identifier;
4491   Result := True;
4492 end;
4493 
NewProcnull4494 function TPSPascalCompiler.NewProc(const OriginalName, Name: tbtString): TPSInternalProcedure;
4495 begin
4496   Result := TPSInternalProcedure.Create;
4497   Result.OriginalName := OriginalName;
4498   Result.Name := Name;
4499   {$IFDEF PS_USESSUPPORT}
4500   Result.DeclareUnit:=fModule;
4501   {$ENDIF}
4502   Result.DeclarePos := FParser.CurrTokenPos;
4503   Result.DeclareRow := FParser.Row;
4504   Result.DeclareCol := FParser.Col;
4505   FProcs.Add(Result);
4506 end;
4507 
IsProcDuplicLabelnull4508 function TPSPascalCompiler.IsProcDuplicLabel(Proc: TPSInternalProcedure; const s: tbtString): Boolean;
4509 var
4510   i: Longint;
4511   h: Longint;
4512   u: tbtString;
4513 begin
4514   h := MakeHash(s);
4515   if s = 'RESULT' then
4516     Result := True
4517   else if Proc.Name = s then
4518     Result := True
4519   else if IsDuplicate(s, [dcVars, dcConsts, dcProcs]) then
4520     Result := True
4521   else
4522   begin
4523     for i := 0 to Proc.Decl.ParamCount -1 do
4524     begin
4525       if Proc.Decl.Params[i].Name = s then
4526       begin
4527         Result := True;
4528         exit;
4529       end;
4530     end;
4531     for i := 0 to Proc.ProcVars.Count -1 do
4532     begin
4533       if (PIFPSProcVar(Proc.ProcVars[I]).NameHash = h) and (PIFPSProcVar(Proc.ProcVars[I]).Name = s) then
4534       begin
4535         Result := True;
4536         exit;
4537       end;
4538     end;
4539     for i := 0 to Proc.FLabels.Count -1 do
4540     begin
4541       u := Proc.FLabels[I];
4542       delete(u, 1, 4);
4543       if Longint((@u[1])^) = h then
4544       begin
4545         delete(u, 1, 4);
4546         if u = s then
4547         begin
4548           Result := True;
4549           exit;
4550         end;
4551       end;
4552     end;
4553     Result := False;
4554   end;
4555 end;
4556 
4557 
ProcessLabelnull4558 function TPSPascalCompiler.ProcessLabel(Proc: TPSInternalProcedure): Boolean;
4559 var
4560   CurrLabel: tbtString;
4561 begin
4562   FParser.Next;
4563   while true do
4564   begin
4565     if FParser.CurrTokenId <> CSTI_Identifier then
4566     begin
4567       MakeError('', ecIdentifierExpected, '');
4568       Result := False;
4569       exit;
4570     end;
4571     CurrLabel := FParser.GetToken;
4572     if IsProcDuplicLabel(Proc, CurrLabel) then
4573     begin
4574       MakeError('', ecDuplicateIdentifier, CurrLabel);
4575       Result := False;
4576       exit;
4577     end;
4578     FParser.Next;
4579     Proc.FLabels.Add(#$FF#$FF#$FF#$FF+PS_mi2s(MakeHash(CurrLabel))+CurrLabel);
4580     if FParser.CurrTokenId = CSTI_Semicolon then
4581     begin
4582       FParser.Next;
4583       Break;
4584     end;
4585     if FParser.CurrTokenId <> CSTI_Comma then
4586     begin
4587       MakeError('', ecCommaExpected, '');
4588       Result := False;
4589       exit;
4590     end;
4591     FParser.Next;
4592   end;
4593   Result := True;
4594 end;
4595 
4596 procedure TPSPascalCompiler.Debug_SavePosition(ProcNo: Cardinal; Proc: TPSInternalProcedure);
4597 var
4598   Row,
4599   Col,
4600   Pos: Cardinal;
4601   s: tbtString;
4602 begin
4603   Row := FParser.Row;
4604   Col := FParser.Col;
4605   Pos := FParser.CurrTokenPos;
4606   {$IFNDEF PS_USESSUPPORT}
4607   s := '';
4608   {$ELSE}
4609   s := fModule;
4610   {$ENDIF}
4611   if @FOnTranslateLineInfo <> nil then
4612     FOnTranslateLineInfo(Self, Pos, Row, Col, S);
4613   {$IFDEF FPC}
4614   WriteDebugData(#4 + s + #1);
4615   WriteDebugData(Ps_mi2s(ProcNo));
4616   WriteDebugData(Ps_mi2s(Length(Proc.Data)));
4617   WriteDebugData(Ps_mi2s(Pos));
4618   WriteDebugData(Ps_mi2s(Row));
4619   WriteDebugData(Ps_mi2s(Col));
4620   {$ELSE}
4621   WriteDebugData(#4 + s + #1 + PS_mi2s(ProcNo) + PS_mi2s(Length(Proc.Data)) + PS_mi2s(Pos) + PS_mi2s(Row)+ PS_mi2s(Col));
4622   {$ENDIF}
4623 end;
4624 
4625 procedure TPSPascalCompiler.Debug_WriteParams(ProcNo: Cardinal; Proc: TPSInternalProcedure);
4626 var
4627   I: Longint;
4628   s: tbtString;
4629 begin
4630   s := #2 + PS_mi2s(ProcNo);
4631   if Proc.Decl.Result <> nil then
4632   begin
4633     s := s + 'Result' + #1;
4634   end;
4635   for i := 0 to Proc.Decl.ParamCount -1 do
4636     s := s + Proc.Decl.Params[i].OrgName + #1;
4637   s := s + #0#3 + PS_mi2s(ProcNo);
4638   for I := 0 to Proc.ProcVars.Count - 1 do
4639   begin
4640     s := s + PIFPSProcVar(Proc.ProcVars[I]).OrgName + #1;
4641   end;
4642   s := s + #0;
4643   WriteDebugData(s);
4644 end;
4645 
4646 procedure TPSPascalCompiler.CheckForUnusedVars(Func: TPSInternalProcedure);
4647 var
4648   i: Integer;
4649   p: PIFPSProcVar;
4650 begin
4651   for i := 0 to Func.ProcVars.Count -1 do
4652   begin
4653     p := Func.ProcVars[I];
4654     if not p.Used then
4655     begin
4656       with MakeHint({$IFDEF PS_USESSUPPORT}p.DeclareUnit{$ELSE}''{$ENDIF}, ehVariableNotUsed, p.Name) do
4657       begin
4658         FRow := p.DeclareRow;
4659         FCol := p.DeclareCol;
4660         FPosition := p.DeclarePos;
4661       end;
4662     end;
4663   end;
4664   if (not Func.ResultUsed) and (Func.Decl.Result <> nil) then
4665   begin
4666       with MakeHint({$IFDEF PS_USESSUPPORT}Func.DeclareUnit{$ELSE}''{$ENDIF}, ehVariableNotUsed, 'Result') do
4667       begin
4668         FRow := Func.DeclareRow;
4669         FCol := Func.DeclareCol;
4670         FPosition := Func.DeclarePos;
4671       end;
4672   end;
4673 end;
4674 
TPSPascalCompiler.ProcIsDuplicnull4675 function TPSPascalCompiler.ProcIsDuplic(Decl: TPSParametersDecl; const FunctionName, FunctionParamNames: tbtString; const s: tbtString; Func: TPSInternalProcedure): Boolean;
4676 var
4677   i: Longint;
4678   u: tbtString;
4679 begin
4680   if s = 'RESULT' then
4681     Result := True
4682   else if FunctionName = s then
4683     Result := True
4684   else
4685   begin
4686     for i := 0 to Decl.ParamCount -1 do
4687     begin
4688       if Decl.Params[i].Name = s then
4689       begin
4690         Result := True;
4691         exit;
4692       end;
4693       GRFW(u);
4694     end;
4695     u := FunctionParamNames;
4696     while Pos(tbtchar('|'), u) > 0 do
4697     begin
4698       if copy(u, 1, Pos(tbtchar('|'), u) - 1) = s then
4699       begin
4700         Result := True;
4701         exit;
4702       end;
4703       Delete(u, 1, Pos(tbtchar('|'), u));
4704     end;
4705     if Func = nil then
4706     begin
4707       result := False;
4708       exit;
4709     end;
4710     for i := 0 to Func.ProcVars.Count -1 do
4711     begin
4712       if s = PIFPSProcVar(Func.ProcVars[I]).Name then
4713       begin
4714         Result := True;
4715         exit;
4716       end;
4717     end;
4718     for i := 0 to Func.FLabels.Count -1 do
4719     begin
4720       u := Func.FLabels[I];
4721       delete(u, 1, 4);
4722       if u = s then
4723       begin
4724         Result := True;
4725         exit;
4726       end;
4727     end;
4728     Result := False;
4729   end;
4730 end;
4731 procedure WriteProcVars(Func:TPSInternalProcedure; t: TPSList);
4732 var
4733   l: Longint;
4734   v: PIFPSProcVar;
4735 begin
4736   for l := 0 to t.Count - 1 do
4737   begin
4738     v := t[l];
4739     Func.Data := Func.Data  + chr(cm_pt)+ PS_mi2s(v.AType.FinalTypeNo);
4740   end;
4741 end;
4742 
4743 
ApplyAttribsToFunctionnull4744 function TPSPascalCompiler.ApplyAttribsToFunction(func: TPSProcedure): boolean;
4745 var
4746   i: Longint;
4747 begin
4748   for i := 0 to Func.Attributes.Count -1 do
4749   begin
4750     if @Func.Attributes.Items[i].AType.OnApplyAttributeToProc <> nil then
4751     begin
4752       if not Func.Attributes.Items[i].AType.OnApplyAttributeToProc(Self, Func, Func.Attributes.Items[i]) then
4753       begin
4754         Result := false;
4755         exit;
4756       end;
4757     end;
4758   end;
4759   result := true;
4760 end;
4761 
4762 
ProcessFunctionnull4763 function TPSPascalCompiler.ProcessFunction(AlwaysForward: Boolean; Att: TPSAttributes): Boolean;
4764 var
4765   FunctionType: TFuncType;
4766   OriginalName, FunctionName: tbtString;
4767   FunctionParamNames: tbtString;
4768   FunctionTempType: TPSType;
4769   ParamNo: Cardinal;
4770   FunctionDecl: TPSParametersDecl;
4771   modifier: TPSParameterMode;
4772   Func: TPSInternalProcedure;
4773   F2: TPSProcedure;
4774   EPos, ECol, ERow: Cardinal;
4775   E2Pos, E2Col, E2Row: Cardinal;
4776   pp: TPSRegProc;
4777   pp2: TPSExternalProcedure;
4778   FuncNo, I: Longint;
4779   Block: TPSBlockInfo;
4780 begin
4781   if att = nil then
4782   begin
4783     Att := TPSAttributes.Create;
4784     if not ReadAttributes(Att) then
4785     begin
4786       att.free;
4787       Result := false;
4788       exit;
4789     end;
4790   end;
4791 
4792   if FParser.CurrTokenId = CSTII_Procedure then
4793     FunctionType := ftProc
4794   else
4795     FunctionType := ftFunc;
4796   Func := nil;
4797   EPos := FParser.CurrTokenPos;
4798   ERow := FParser.Row;
4799   ECol := FParser.Col;
4800   FParser.Next;
4801   Result := False;
4802   if FParser.CurrTokenId <> CSTI_Identifier then
4803   begin
4804     MakeError('', ecIdentifierExpected, '');
4805     att.free;
4806     exit;
4807   end;
4808   if assigned(FOnFunctionStart) then
4809   {$IFDEF PS_USESSUPPORT}
4810      FOnFunctionStart(fModule + '.' + FParser.OriginalToken, EPos, ERow, ECol);
4811   {$ELSE}
4812      FOnFunctionStart(FParser.OriginalToken, EPos, ERow, ECol);
4813   {$ENDIF}
4814   EPos := FParser.CurrTokenPos;
4815   ERow := FParser.Row;
4816   ECol := FParser.Col;
4817   OriginalName := FParser.OriginalToken;
4818   FunctionName := FParser.GetToken;
4819   FuncNo := -1;
4820   for i := 0 to FProcs.Count -1 do
4821   begin
4822     f2 := FProcs[I];
4823     if (f2.ClassType = TPSInternalProcedure) and (TPSInternalProcedure(f2).Name = FunctionName) and (TPSInternalProcedure(f2).Forwarded) then
4824     begin
4825       Func := FProcs[I];
4826       FuncNo := i;
4827       Break;
4828     end;
4829   end;
4830   if (Func = nil) and IsDuplicate(FunctionName, [dcTypes, dcProcs, dcVars, dcConsts]) then
4831   begin
4832     att.free;
4833     MakeError('', ecDuplicateIdentifier, FunctionName);
4834     exit;
4835   end;
4836   FParser.Next;
4837   FunctionDecl := TPSParametersDecl.Create;
4838   try
4839     if FParser.CurrTokenId = CSTI_OpenRound then
4840     begin
4841       FParser.Next;
4842       if FParser.CurrTokenId = CSTI_CloseRound then
4843       begin
4844         FParser.Next;
4845       end
4846       else
4847       begin
4848         if FunctionType = ftFunc then
4849           ParamNo := 1
4850         else
4851           ParamNo := 0;
4852         while True do
4853         begin
4854           if FParser.CurrTokenId = CSTII_Const then
4855           begin
4856             modifier := pmIn;
4857             FParser.Next;
4858           end
4859           else
4860           if FParser.CurrTokenId = CSTII_Out then
4861           begin
4862             modifier := pmOut;
4863             FParser.Next;
4864           end
4865           else
4866           if FParser.CurrTokenId = CSTII_Var then
4867           begin
4868             modifier := pmInOut;
4869             FParser.Next;
4870           end
4871           else
4872             modifier := pmIn;
4873           if FParser.CurrTokenId <> CSTI_Identifier then
4874           begin
4875             MakeError('', ecIdentifierExpected, '');
4876             exit;
4877           end;
4878           E2Pos := FParser.CurrTokenPos;
4879           E2Row := FParser.Row;
4880           E2Col := FParser.Col;
4881           FunctionParamNames := '';
4882           if ProcIsDuplic(FunctionDecl, FunctionName, FunctionParamNames, FParser.GetToken, Func) then
4883           begin
4884             MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
4885             exit;
4886           end;
4887           FunctionParamNames := FParser.OriginalToken + '|';
4888           if @FOnUseVariable <> nil then
4889           begin
4890             FOnUseVariable(Self, ivtParam, ParamNo, FProcs.Count, FParser.CurrTokenPos, '');
4891           end;
4892           inc(ParamNo);
4893           FParser.Next;
4894           while FParser.CurrTokenId = CSTI_Comma do
4895           begin
4896             FParser.Next;
4897             if FParser.CurrTokenId <> CSTI_Identifier then
4898             begin
4899               MakeError('', ecIdentifierExpected, '');
4900               exit;
4901             end;
4902           if ProcIsDuplic(FunctionDecl, FunctionName, FunctionParamNames, FParser.GetToken, Func) then
4903             begin
4904               MakeError('', ecDuplicateIdentifier, '');
4905               exit;
4906             end;
4907             if @FOnUseVariable <> nil then
4908             begin
4909               FOnUseVariable(Self, ivtParam, ParamNo, FProcs.Count, FParser.CurrTokenPos, '');
4910             end;
4911             inc(ParamNo);
4912             FunctionParamNames := FunctionParamNames + FParser.OriginalToken +
4913               '|';
4914             FParser.Next;
4915           end;
4916           if FParser.CurrTokenId <> CSTI_Colon then
4917           begin
4918             MakeError('', ecColonExpected, '');
4919             exit;
4920           end;
4921           FParser.Next;
4922           FunctionTempType := at2ut(ReadType('', FParser));
4923           if FunctionTempType = nil then
4924           begin
4925             exit;
4926           end;
4927           while Pos(tbtchar('|'), FunctionParamNames) > 0 do
4928           begin
4929             with FunctionDecl.AddParam do
4930             begin
4931               OrgName := copy(FunctionParamNames, 1, Pos(tbtchar('|'), FunctionParamNames) - 1);
4932               Mode := modifier;
4933               aType := FunctionTempType;
4934               {$IFDEF PS_USESSUPPORT}
4935               DeclareUnit:=fModule;
4936               {$ENDIF}
4937               DeclarePos:=E2Pos;
4938               DeclareRow:=E2Row;
4939               DeclareCol:=E2Col;
4940             end;
4941             Delete(FunctionParamNames, 1, Pos(tbtchar('|'), FunctionParamNames));
4942           end;
4943           if FParser.CurrTokenId = CSTI_CloseRound then
4944             break;
4945           if FParser.CurrTokenId <> CSTI_Semicolon then
4946           begin
4947             MakeError('', ecSemicolonExpected, '');
4948             exit;
4949           end;
4950           FParser.Next;
4951         end;
4952         FParser.Next;
4953       end;
4954     end;
4955     if FunctionType = ftFunc then
4956     begin
4957       if FParser.CurrTokenId <> CSTI_Colon then
4958       begin
4959         MakeError('', ecColonExpected, '');
4960         exit;
4961       end;
4962       FParser.Next;
4963       FunctionTempType := at2ut(ReadType('', FParser));
4964       if FunctionTempType = nil then
4965         exit;
4966       FunctionDecl.Result := FunctionTempType;
4967     end;
4968     if FParser.CurrTokenId <> CSTI_Semicolon then
4969     begin
4970       MakeError('', ecSemicolonExpected, '');
4971       exit;
4972     end;
4973     FParser.Next;
4974     if (Func = nil) and (FParser.CurrTokenID = CSTII_External) then
4975     begin
4976       FParser.Next;
4977       if FParser.CurrTokenID <> CSTI_String then
4978       begin
4979         MakeError('', ecStringExpected, '');
4980         exit;
4981       end;
4982       FunctionParamNames := FParser.GetToken;
4983       FunctionParamNames := copy(FunctionParamNames, 2, length(FunctionParamNames) - 2);
4984       FParser.Next;
4985       if FParser.CurrTokenID <> CSTI_Semicolon then
4986       begin
4987         MakeError('', ecSemicolonExpected, '');
4988         exit;
4989       end;
4990       FParser.Next;
4991       if @FOnExternalProc = nil then
4992       begin
4993         MakeError('', ecSemicolonExpected, '');
4994         exit;
4995       end;
4996       pp := FOnExternalProc(Self, FunctionDecl, OriginalName, FunctionParamNames);
4997       if pp = nil then
4998       begin
4999         MakeError('', ecCustomError, '');
5000         exit;
5001       end;
5002       pp2 := TPSExternalProcedure.Create;
5003       pp2.Attributes.Assign(att, true);
5004       pp2.RegProc := pp;
5005       FProcs.Add(pp2);
5006       FRegProcs.Add(pp);
p2null5007       Result := ApplyAttribsToFunction(pp2);
5008       Exit;
5009     end else if (FParser.CurrTokenID = CSTII_Forward) or AlwaysForward then
5010     begin
5011       if Func <> nil then
5012       begin
5013         MakeError('', ecBeginExpected, '');
5014         exit;
5015       end;
5016       if not AlwaysForward then
5017       begin
5018         FParser.Next;
5019         if FParser.CurrTokenID  <> CSTI_Semicolon then
5020         begin
5021           MakeError('', ecSemicolonExpected, '');
5022           Exit;
5023         end;
5024         FParser.Next;
5025       end;
5026       Func := NewProc(OriginalName, FunctionName);
5027       Func.Attributes.Assign(Att, True);
5028       Func.Forwarded := True;
5029       {$IFDEF PS_USESSUPPORT}
5030       Func.FDeclareUnit := fModule;
5031       {$ENDIF}
5032       Func.FDeclarePos := EPos;
5033       Func.FDeclareRow := ERow;
5034       Func.FDeclarePos := ECol;
5035       Func.Decl.Assign(FunctionDecl);
uncnull5036       Result := ApplyAttribsToFunction(Func);
5037       exit;
5038     end;
5039     if (Func = nil) then
5040     begin
5041       Func := NewProc(OriginalName, FunctionName);
5042       Func.Attributes.Assign(att, True);
5043       Func.Decl.Assign(FunctionDecl);
5044       {$IFDEF PS_USESSUPPORT}
5045       Func.FDeclareUnit := fModule;
5046       {$ENDIF}
5047       Func.FDeclarePos := EPos;
5048       Func.FDeclareRow := ERow;
5049       Func.FDeclareCol := ECol;
5050       FuncNo := FProcs.Count -1;
uncnull5051       if not ApplyAttribsToFunction(Func) then
5052       begin
5053         result := false;
5054         exit;
5055       end;
5056     end else begin
5057       if not FunctionDecl.Same(Func.Decl) then
5058       begin
5059         MakeError('', ecForwardParameterMismatch, '');
5060         Result := false;
5061         exit;
5062       end;
5063       Func.Forwarded := False;
5064     end;
5065     if FParser.CurrTokenID = CSTII_Export then
5066     begin
5067       FParser.Next;
5068       if FParser.CurrTokenID <> CSTI_Semicolon then
5069       begin
5070         MakeError('', ecSemicolonExpected, '');
5071         exit;
5072       end;
5073       FParser.Next;
5074     end;
5075     while FParser.CurrTokenId <> CSTII_Begin do
5076     begin
5077       if FParser.CurrTokenId = CSTII_Var then
5078       begin
5079         if not DoVarBlock(Func) then
5080           exit;
5081       end else if FParser.CurrTokenId = CSTII_Label then
5082       begin
5083         if not ProcessLabel(Func) then
5084           Exit;
5085       end else
5086       begin
5087         MakeError('', ecBeginExpected, '');
5088         exit;
5089       end;
5090     end;
5091     Debug_WriteParams(FuncNo, Func);
5092     WriteProcVars(Func, Func.ProcVars);
5093     Block := TPSBlockInfo.Create(FGlobalBlock);
5094     Block.SubType := tProcBegin;
5095     Block.ProcNo := FuncNo;
5096     Block.Proc := Func;
5097     if not ProcessSub(Block) then
5098     begin
5099       Block.Free;
5100       exit;
5101     end;
5102     Block.Free;
5103     CheckForUnusedVars(Func);
5104     Result := ProcessLabelForwards(Func);
5105     if assigned(FOnFunctionEnd) then
5106     {$IFDEF PS_USESSUPPORT}
5107       OnFunctionEnd(fModule + '.' + OriginalName, FParser.CurrTokenPos, FParser.Row, FParser.Col);
5108     {$ELSE}
5109       OnFunctionEnd(OriginalName, FParser.CurrTokenPos, FParser.Row, FParser.Col);
5110     {$ENDIF}
5111   finally
5112     FunctionDecl.Free;
5113     att.Free;
5114   end;
5115 end;
5116 
GetParamTypenull5117 function GetParamType(BlockInfo: TPSBlockInfo; I: Longint): TPSType;
5118 begin
5119   if BlockInfo.Proc.Decl.Result <> nil then dec(i);
5120   if i = -1 then
5121     Result := BlockInfo.Proc.Decl.Result
5122   else
5123   begin
5124     Result := BlockInfo.Proc.Decl.Params[i].aType;
5125   end;
5126 end;
5127 
GetTypeNonull5128 function TPSPascalCompiler.GetTypeNo(BlockInfo: TPSBlockInfo; p: TPSValue): TPSType;
5129 begin
5130   if p.ClassType = TPSUnValueOp then
5131     Result := TPSUnValueOp(p).aType
5132   else if p.ClassType = TPSBinValueOp then
5133     Result := TPSBinValueOp(p).aType
5134   else if p.ClassType = TPSValueArray then
5135     Result := at2ut(FindType('TVariantArray'))
5136   else if p.ClassType = TPSValueData then
5137     Result := TPSValueData(p).Data.FType
5138   else if p is TPSValueProc then
5139     Result := TPSValueProc(p).ResultType
5140   else if (p is TPSValueVar) and (TPSValueVar(p).RecCount > 0) then
5141     Result := TPSValueVar(p).RecItem[TPSValueVar(p).RecCount - 1].aType
5142   else if p.ClassType = TPSValueGlobalVar then
5143     Result := TPSVar(FVars[TPSValueGlobalVar(p).GlobalVarNo]).FType
5144   else if p.ClassType = TPSValueParamVar then
5145     Result := GetParamType(BlockInfo, TPSValueParamVar(p).ParamNo)
5146   else if p is TPSValueLocalVar then
5147     Result := TPSProcVar(BlockInfo.Proc.ProcVars[TPSValueLocalVar(p).LocalVarNo]).AType
5148   else if p.classtype = TPSValueReplace then
5149     Result := GetTypeNo(BlockInfo, TPSValueReplace(p).NewValue)
5150   else
5151     Result := nil;
5152 end;
5153 
IsVarInCompatiblenull5154 function TPSPascalCompiler.IsVarInCompatible(ft1, ft2: TPSType): Boolean;
5155 begin
5156   ft1 := GetTypeCopyLink(ft1);
5157   ft2 := GetTypeCopyLink(ft2);
5158   Result := (ft1 <> ft2) and (ft2 <> nil);
5159 end;
5160 
ValidateParametersnull5161 function TPSPascalCompiler.ValidateParameters(BlockInfo: TPSBlockInfo; Params: TPSParameters; ParamTypes: TPSParametersDecl): boolean;
5162 var
5163   i, c: Longint;
5164   pType: TPSType;
5165 
5166 begin
5167   UseProc(ParamTypes);
5168   c := 0;
5169   for i := 0 to ParamTypes.ParamCount -1 do
5170   begin
5171     while (c < Longint(Params.Count)) and (Params[c].Val = nil) do
5172       Inc(c);
5173     if c >= Longint(Params.Count) then
5174     begin
5175       MakeError('', ecInvalidnumberOfParameters, '');
5176       Result := False;
5177       exit;
5178     end;
5179     Params[c].ExpectedType := ParamTypes.Params[i].aType;
5180     Params[c].ParamMode := ParamTypes.Params[i].Mode;
5181     if ParamTypes.Params[i].Mode <> pmIn then
5182     begin
5183       if not (Params[c].Val is TPSValueVar) then
5184       begin
5185         with MakeError('', ecVariableExpected, '') do
5186         begin
5187           Row := Params[c].Val.Row;
5188           Col := Params[c].Val.Col;
5189           Pos := Params[c].Val.Pos;
5190         end;
5191         result := false;
5192         exit;
5193       end;
5194         PType := Params[c].ExpectedType;
5195         if (PType = nil) or ((PType.BaseType = btArray) and (TPSArrayType(PType).ArrayTypeNo = nil) and (GetTypeNo(BlockInfo, Params[c].Val).BaseType = btArray)) or
5196           (PType = FAnyString) then
5197         begin
5198           Params[c].ExpectedType := GetTypeNo(BlockInfo, Params[c].Val);
5199           if PType <> nil then
5200           if (Params[c].ExpectedType = nil) or not (Params[c].ExpectedType.BaseType in [btString,
5201             {$IFNDEF PS_NOWIDESTRING}btWideString, btUnicodeString, btWideChar,{$ENDIF}
5202             btChar]) then begin
5203             MakeError('', ecTypeMismatch, '');
5204             Result := False;
5205             exit;
5206           end;
5207           if Params[c].ExpectedType.BaseType = btChar then
5208             Params[c].ExpectedType := FindBaseType(btString) else
5209 {$IFNDEF PS_NOWIDESTRING}
5210           if Params[c].ExpectedType.BaseType = btWideChar then
5211             Params[c].ExpectedType := FindBaseType(btUnicodeString);
5212 {$ENDIF}
5213         end else if (PType.BaseType = btArray) and (GetTypeNo(BlockInfo, Params[c].Val).BaseType = btArray) then
5214         begin
5215           if TPSArrayType(GetTypeNo(BlockInfo, Params[c].Val)).ArrayTypeNo <> TPSArrayType(PType).ArrayTypeNo then
5216           begin
5217             MakeError('', ecTypeMismatch, '');
5218             Result := False;
5219             exit;
5220           end;
5221         end else if IsVarInCompatible(PType, GetTypeNo(BlockInfo, Params[c].Val)) then
5222         begin
5223           MakeError('', ecTypeMismatch, '');
5224           Result := False;
5225           exit;
5226         end;
5227     end;
5228     Inc(c);
5229   end;
5230   for i := c to Params.Count -1 do
5231   begin
5232     if Params[i].Val <> nil then
5233     begin
5234       MakeError('', ecInvalidnumberOfParameters, '');
5235       Result := False;
5236       exit;
5237     end;
5238   end;
5239   Result := true;
5240 end;
5241 
DoTypeBlocknull5242 function TPSPascalCompiler.DoTypeBlock(FParser: TPSPascalParser): Boolean;
5243 var
5244   VOrg,VName: tbtString;
5245   Attr: TPSAttributes;
5246   FType: TPSType;
5247   i: Longint;
5248 begin
5249   Result := False;
5250   FParser.Next;
5251   repeat
5252     Attr := TPSAttributes.Create;
5253     if not ReadAttributes(Attr) then
5254     begin
5255       Attr.Free;
5256       exit;
5257     end;
5258     if (FParser.CurrTokenID = CSTII_Procedure) or (FParser.CurrTokenID = CSTII_Function) then
5259     begin
5260       Result := ProcessFunction(false, Attr);
5261       exit;
5262     end;
5263     if FParser.CurrTokenId <> CSTI_Identifier then
5264     begin
5265       MakeError('', ecIdentifierExpected, '');
5266       Attr.Free;
5267       exit;
5268     end;
5269 
5270     VName := FParser.GetToken;
5271     VOrg := FParser.OriginalToken;
5272     if IsDuplicate(VName, [dcTypes, dcProcs, dcVars]) then
5273     begin
5274       MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
5275       Attr.Free;
5276       exit;
5277     end;
5278 
5279     FParser.Next;
5280     if FParser.CurrTokenId <> CSTI_Equal then
5281     begin
5282       MakeError('', ecIsExpected, '');
5283       Attr.Free;
5284       exit;
5285     end;
5286     FParser.Next;
5287     FType := ReadType(VOrg, FParser);
5288     if Ftype = nil then
5289     begin
5290       Attr.Free;
5291       Exit;
5292     end;
5293     FType.Attributes.Assign(Attr, True);
5294     for i := 0 to FType.Attributes.Count -1 do
5295     begin
5296       if @FType.Attributes[i].FAttribType.FAAType <> nil then
5297         FType.Attributes[i].FAttribType.FAAType(Self, FType, Attr[i]);
5298     end;
5299     Attr.Free;
5300     if FParser.CurrTokenID <> CSTI_Semicolon then
5301     begin
5302       MakeError('', ecSemicolonExpected, '');
5303       Exit;
5304     end;
5305     FParser.Next;
5306   until (FParser.CurrTokenId <> CSTI_Identifier) and (FParser.CurrTokenID <> CSTI_OpenBlock);
5307   Result := True;
5308 end;
5309 
5310 procedure TPSPascalCompiler.Debug_WriteLine(BlockInfo: TPSBlockInfo);
5311 var
5312   b: Boolean;
5313 begin
5314   if @FOnWriteLine <> nil then begin
5315     {$IFNDEF PS_USESSUPPORT}
5316     b := FOnWriteLine(Self, FParser.CurrTokenPos);
5317     {$ELSE}
5318     b := FOnWriteLine(Self, FModule, FParser.CurrTokenPos);
5319     {$ENDIF}
5320   end else
5321     b := true;
5322   if b then Debug_SavePosition(BlockInfo.ProcNo, BlockInfo.Proc);
5323 end;
5324 
5325 
TPSPascalCompiler.ReadRealnull5326 function TPSPascalCompiler.ReadReal(const s: tbtString): PIfRVariant;
5327 var
5328   C: Integer;
5329 begin
5330   New(Result);
5331   InitializeVariant(Result, FindBaseType(btExtended));
5332   Val(string(s), Result^.textended, C);
5333 end;
5334 
ReadStringnull5335 function TPSPascalCompiler.ReadString: PIfRVariant;
5336 {$IFNDEF PS_NOWIDESTRING}var wchar: Boolean;{$ENDIF}
5337 
ParseStringnull5338   function ParseString({$IFNDEF PS_NOWIDESTRING}var res: tbtunicodestring{$ELSE}var res: tbtString{$ENDIF}): Boolean;
5339   var
5340     temp3: {$IFNDEF PS_NOWIDESTRING}tbtunicodestring{$ELSE}tbtString{$ENDIF};
5341 
ChrToStrnull5342     function ChrToStr(s: tbtString): {$IFNDEF PS_NOWIDESTRING}widechar{$ELSE}tbtchar{$ENDIF};
5343     var
5344       w: Longint;
5345     begin
5346       Delete(s, 1, 1); {First char : #}
5347       w := StrToInt(s);
5348       Result := {$IFNDEF PS_NOWIDESTRING}widechar{$ELSE}tbtchar{$ENDIF}(w);
5349       {$IFNDEF PS_NOWIDESTRING}if w > $FF then wchar := true;{$ENDIF}
5350     end;
5351 
PStringnull5352     function PString(s: tbtString): tbtString;
5353     var
5354       i: Longint;
5355     begin
5356       s := copy(s, 2, Length(s) - 2);
5357       i := length(s);
5358       while i > 0 do
5359       begin
5360         if (i < length(s)) and (s[i] = #39) and (s[i + 1] = #39) then
5361         begin
5362           Delete(s, i, 1);
5363           dec(i);
5364         end;
5365         dec(i);
5366       end;
5367       PString := s;
5368     end;
5369   var
5370     lastwasstring: Boolean;
5371   begin
5372     temp3 := '';
5373     while (FParser.CurrTokenId = CSTI_String) or (FParser.CurrTokenId = CSTI_Char) do
5374     begin
5375       lastwasstring := FParser.CurrTokenId = CSTI_String;
5376       if FParser.CurrTokenId = CSTI_String then
5377       begin
5378         if UTF8Decode then
5379         begin
5380         temp3 := temp3 + {$IFNDEF PS_NOWIDESTRING}{$IFDEF DELPHI6UP}System.{$IFDEF DELPHI2009UP}UTF8ToWidestring{$ELSE}UTF8Decode{$ENDIF}{$ENDIF}{$ENDIF}(PString(FParser.GetToken));
5381         {$IFNDEF PS_NOWIDESTRING}wchar:=true;{$ENDIF}
5382         end else
5383           temp3 := temp3 + {$IFNDEF PS_NOWIDESTRING}tbtUnicodestring{$ENDIF}(PString(FParser.GetToken));
5384 
5385         FParser.Next;
5386         if FParser.CurrTokenId = CSTI_String then
5387           temp3 := temp3 + #39;
5388       end {if}
5389       else
5390       begin
5391         temp3 := temp3 + ChrToStr(FParser.GetToken);
5392         FParser.Next;
5393       end; {else if}
5394       if  lastwasstring and (FParser.CurrTokenId = CSTI_String) then
5395       begin
5396         MakeError('', ecSyntaxError, '');
5397         result := false;
5398         exit;
5399       end;
5400     end; {while}
5401     res := temp3;
5402     result := true;
5403   end;
5404 var
5405 {$IFNDEF PS_NOWIDESTRING}
5406   w: tbtunicodestring;
5407 {$ENDIF}
5408   s: tbtString;
5409 begin
5410   {$IFNDEF PS_NOWIDESTRING}wchar:=false;{$ENDIF}
5411   if not ParseString({$IFDEF PS_NOWIDESTRING} s {$ELSE}  w {$ENDIF}) then
5412   begin
5413     result := nil;
5414     exit;
5415   end;
5416 {$IFNDEF PS_NOWIDESTRING}
5417   if wchar then
5418   begin
5419     New(Result);
5420     if Length(w) = 1 then
5421     begin
5422       InitializeVariant(Result, at2ut(FindBaseType(btwidechar)));
5423       Result^.twidechar := w[1];
5424     end else begin
5425       InitializeVariant(Result, at2ut(FindBaseType(btUnicodeString)));
5426       tbtunicodestring(Result^.tunistring) := w;
5427      end;
5428   end else begin
5429     s := tbtstring(w);
5430 {$ENDIF}
5431     New(Result);
5432     if Length(s) = 1 then
5433     begin
5434       InitializeVariant(Result, at2ut(FindBaseType(btchar)));
5435       Result^.tchar := s[1];
5436     end else begin
5437       InitializeVariant(Result, at2ut(FindBaseType(btstring)));
5438       tbtstring(Result^.tstring) := s;
5439     end;
5440 {$IFNDEF PS_NOWIDESTRING}
5441   end;
5442 {$ENDIF}
5443 end;
5444 
5445 
TPSPascalCompiler.ReadIntegernull5446 function TPSPascalCompiler.ReadInteger(const s: tbtString): PIfRVariant;
5447 var
5448   R: {$IFNDEF PS_NOINT64}Int64;{$ELSE}Longint;{$ENDIF}
5449 begin
5450   New(Result);
5451 {$IFNDEF PS_NOINT64}
5452   r := StrToInt64Def(string(s), 0);
5453   if (r >= Low(Integer)) and (r <= High(Integer)) then
5454   begin
5455     InitializeVariant(Result, at2ut(FindBaseType(bts32)));
5456     Result^.ts32 := r;
5457   end else if (r <= $FFFFFFFF) then
5458   begin
5459     InitializeVariant(Result, at2ut(FindBaseType(btu32)));
5460     Result^.tu32 := r;
5461   end else
5462   begin
5463     InitializeVariant(Result, at2ut(FindBaseType(bts64)));
5464     Result^.ts64 := r;
5465   end;
5466 {$ELSE}
5467   r := StrToIntDef(s, 0);
5468   InitializeVariant(Result, at2ut(FindBaseType(bts32)));
5469   Result^.ts32 := r;
5470 {$ENDIF}
5471 end;
5472 
TPSPascalCompiler.ProcessSubnull5473 function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
5474 
AllocStackReg2null5475   function AllocStackReg2(MType: TPSType): TPSValue;
5476   var
5477     x: TPSProcVar;
5478   begin
5479 {$IFDEF DEBUG}
5480     if (mtype = nil) or (not mtype.Used) then asm int 3; end;
5481 {$ENDIF}
5482     x := TPSProcVar.Create;
5483     {$IFDEF PS_USESSUPPORT}
5484     x.DeclareUnit:=fModule;
5485     {$ENDIF}
5486     x.DeclarePos := FParser.CurrTokenPos;
5487     x.DeclareRow := FParser.Row;
5488     x.DeclareCol := FParser.Col;
5489     x.Name := '';
5490     x.AType := MType;
5491     x.Use;
5492     BlockInfo.Proc.ProcVars.Add(x);
5493     Result := TPSValueAllocatedStackVar.Create;
5494     Result.SetParserPos(FParser);
5495     TPSValueAllocatedStackVar(Result).Proc := BlockInfo.Proc;
5496     with TPSValueAllocatedStackVar(Result) do
5497     begin
5498       LocalVarNo := proc.ProcVars.Count -1;
5499     end;
5500   end;
5501 
AllocStackRegnull5502   function AllocStackReg(MType: TPSType): TPSValue;
5503   begin
5504     Result := AllocStackReg2(MType);
5505     BlockWriteByte(BlockInfo, Cm_Pt);
5506     BlockWriteLong(BlockInfo, MType.FinalTypeNo);
5507   end;
5508 
AllocPointernull5509   function AllocPointer(MDestType: TPSType): TPSValue;
5510   begin
5511     Result := AllocStackReg(at2ut(FindBaseType(btPointer)));
5512     TPSProcVar(BlockInfo.Proc.ProcVars[TPSValueAllocatedStackVar(Result).LocalVarNo]).AType := MDestType;
5513   end;
5514 
5515   function WriteCalculation(InData, OutReg: TPSValue): Boolean; forward;
5516   function PreWriteOutRec(var X: TPSValue; FArrType: TPSType): Boolean; forward;
5517   function WriteOutRec(x: TPSValue; AllowData: Boolean): Boolean; forward;
5518   procedure AfterWriteOutRec(var x: TPSValue); forward;
5519 
CheckCompatTypenull5520   function CheckCompatType(V1, v2: TPSValue): Boolean;
5521   var
5522     p1, P2: TPSType;
5523   begin
5524     p1 := GetTypeNo(BlockInfo, V1);
5525     P2 := GetTypeNo(BlockInfo, v2);
5526     if (p1 = nil) or (p2 = nil) then
5527     begin
5528       if ((p1 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p1.ClassType = TPSInterfaceType) or {$ENDIF}(p1.BaseType = btProcPtr)) and (v2.ClassType = TPSValueNil)) or
5529         ((p2 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p2.ClassType = TPSInterfaceType) or {$ENDIF}(p2.BaseType = btProcPtr)) and (v1.ClassType = TPSValueNil)) then
5530       begin
5531         Result := True;
5532         exit;
5533       end else
5534       if ((p1 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p1.ClassType = TPSInterfaceType) or {$ENDIF}(p1.ClassType = TPSClassType)) and (v2.ClassType = TPSValueNil)) or
5535         ((p2 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p2.ClassType = TPSInterfaceType) or {$ENDIF}(p2.ClassType = TPSClassType)) and (v1.ClassType = TPSValueNil)) then
5536       begin
5537         Result := True;
5538         exit;
5539       end else
5540       if ((p1 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p1.ClassType = TPSInterfaceType) or {$ENDIF}(p1.ClassType = TPSUndefinedClassType)) and (v2.ClassType = TPSValueNil)) or
5541         ((p2 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p2.ClassType = TPSInterfaceType) or {$ENDIF}(p2.ClassType = TPSUndefinedClassType)) and (v1.ClassType = TPSValueNil)) then
5542       begin
5543         Result := True;
5544         exit;
5545       end else
5546       if (v1.ClassType = TPSValueProcPtr) and (p2 <> nil) and (p2.BaseType = btProcPtr) then
5547       begin
5548         Result := CheckCompatProc(p2, TPSValueProcPtr(v1).ProcPtr);
5549         exit;
5550       end else if (v2.ClassType = TPSValueProcPtr) and (p1 <> nil) and (p1.BaseType = btProcPtr) then
5551       begin
5552         Result := CheckCompatProc(p1, TPSValueProcPtr(v2).ProcPtr);
5553         exit;
5554       end;
5555       Result := False;
5556     end else
5557     if (p1 <> nil) and (p1.BaseType = btSet) and (v2 is TPSValueArray) then
5558     begin
5559       Result := True;
5560     end else
5561       Result := IsCompatibleType(p1, p2, False);
5562   end;
5563 
5564   function _ProcessFunction(ProcCall: TPSValueProc; ResultRegister: TPSValue): Boolean; forward;
ProcessFunction2null5565   function ProcessFunction2(ProcNo: Cardinal; Par: TPSParameters; ResultReg: TPSValue): Boolean;
5566   var
5567     Temp: TPSValueProcNo;
5568     i: Integer;
5569   begin
5570     Temp := TPSValueProcNo.Create;
5571     Temp.Parameters := Par;
5572     Temp.ProcNo := ProcNo;
5573     if TObject(FProcs[ProcNo]).ClassType = TPSInternalProcedure then
5574       Temp.ResultType := TPSInternalProcedure(FProcs[ProcNo]).Decl.Result
5575     else
5576       Temp.ResultType := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl.Result;
5577     if (Temp.ResultType <> nil) and (Temp.ResultType = FAnyString) then begin // workaround to make the result type match
5578       for i := 0 to Par.Count -1 do begin
5579         if Par[i].ExpectedType.BaseType in [btString{$IFNDEF PS_NOWIDESTRING}, btWideString{$ENDIF}] then
5580           Temp.ResultType := Par[i].ExpectedType;
5581       end;
5582     end;
empnull5583     Result := _ProcessFunction(Temp, ResultReg);
5584     Temp.Parameters := nil;
5585     Temp.Free;
5586   end;
5587 
MakeNilnull5588   function MakeNil(NilPos, NilRow, nilCol: Cardinal;ivar: TPSValue): Boolean;
5589   var
5590     Procno: Cardinal;
5591     PF: TPSType;
5592     Par: TPSParameters;
5593   begin
5594     Pf := GetTypeNo(BlockInfo, IVar);
5595     if not (Ivar is TPSValueVar) then
5596     begin
5597       with MakeError('', ecTypeMismatch, '') do
5598       begin
5599         FPosition := nilPos;
5600         FRow := NilRow;
5601         FCol := nilCol;
5602       end;
5603       Result := False;
5604       exit;
5605     end;
5606     if (pf.BaseType = btProcPtr) then
5607     begin
5608       Result := True;
5609     end else
5610     if (pf.BaseType = btString) or (pf.BaseType = btPChar) then
5611     begin
5612       if not PreWriteOutRec(iVar, nil) then
5613       begin
5614         Result := false;
5615         exit;
5616       end;
5617       BlockWriteByte(BlockInfo, CM_A);
5618       WriteOutRec(ivar, False);
5619       BlockWriteByte(BlockInfo, 1);
5620       BlockWriteLong(BlockInfo, GetTypeNo(BlockInfo, IVar).FinalTypeNo);
5621       BlockWriteLong(BlockInfo, 0); //empty tbtString
5622       AfterWriteOutRec(ivar);
5623       Result := True;
5624     end else if (pf.BaseType = btClass) {$IFNDEF PS_NOINTERFACES}or (pf.BaseType = btInterface){$ENDIF} then
5625     begin
5626 {$IFNDEF PS_NOINTERFACES}
5627       if (pf.BaseType = btClass) then
5628       begin
5629 {$ENDIF}
5630         if not TPSClassType(pf).Cl.SetNil(ProcNo) then
5631         begin
5632           with MakeError('', ecTypeMismatch, '') do
5633           begin
5634             FPosition := nilPos;
5635             FRow := NilRow;
5636             FCol := nilCol;
5637           end;
5638           Result := False;
5639           exit;
5640         end;
5641 {$IFNDEF PS_NOINTERFACES}
5642       end else
5643       begin
5644         if not TPSInterfaceType(pf).Intf.SetNil(ProcNo) then
5645         begin
5646           with MakeError('', ecTypeMismatch, '') do
5647           begin
5648             FPosition := nilPos;
5649             FRow := NilRow;
5650             FCol := nilCol;
5651           end;
5652           Result := False;
5653           exit;
5654         end;
5655       end;
5656 {$ENDIF}
5657       Par := TPSParameters.Create;
5658       with par.Add do
5659       begin
5660         Val := IVar;
5661         ExpectedType := GetTypeNo(BlockInfo, ivar);
5662 {$IFDEF DEBUG}
5663         if not ExpectedType.Used then asm int 3; end;
5664 {$ENDIF}
5665         ParamMode := pmInOut;
5666       end;
5667       Result := ProcessFunction2(ProcNo, Par, nil);
5668 
5669       Par[0].Val := nil; // don't free IVAR
5670 
5671       Par.Free;
5672     end else if pf.BaseType = btExtClass then
5673     begin
5674       if not TPSUndefinedClassType(pf).ExtClass.SetNil(ProcNo) then
5675       begin
5676         with MakeError('', ecTypeMismatch, '') do
5677         begin
5678           FPosition := nilPos;
5679           FRow := NilRow;
5680           FCol := nilCol;
5681         end;
5682         Result := False;
5683         exit;
5684       end;
5685       Par := TPSParameters.Create;
5686       with par.Add do
5687       begin
5688         Val := IVar;
5689         ExpectedType := GetTypeNo(BlockInfo, ivar);
5690         ParamMode := pmInOut;
5691       end;
5692       Result := ProcessFunction2(ProcNo, Par, nil);
5693 
5694       Par[0].Val := nil; // don't free IVAR
5695 
5696       Par.Free;
5697     end else begin
5698       with MakeError('', ecTypeMismatch, '') do
5699       begin
5700         FPosition := nilPos;
5701         FRow := NilRow;
5702         FCol := nilCol;
5703       end;
5704       Result := False;
5705     end;
5706   end;
DoBinCalcnull5707   function DoBinCalc(BVal: TPSBinValueOp; Output: TPSValue): Boolean;
5708   var
5709     tmpp, tmpc: TPSValue;
5710     jend, jover: Cardinal;
5711     procno: Cardinal;
5712 
5713   begin
5714     if BVal.Operator >= otGreaterEqual then
5715     begin
5716       if BVal.FVal1.ClassType = TPSValueNil then
5717       begin
5718         tmpp := AllocStackReg(GetTypeNo(BlockInfo, BVal.FVal2));
5719         if not MakeNil(BVal.FVal1.Pos, BVal.FVal1.Row, BVal.FVal1.Col, tmpp) then
5720         begin
5721           tmpp.Free;
5722           Result := False;
5723           exit;
5724         end;
5725         tmpc := TPSValueReplace.Create;
5726         with TPSValueReplace(tmpc) do
5727         begin
5728           OldValue := BVal.FVal1;
5729           NewValue := tmpp;
5730         end;
5731         BVal.FVal1 := tmpc;
5732       end;
5733       if BVal.FVal2.ClassType = TPSValueNil then
5734       begin
5735         tmpp := AllocStackReg(GetTypeNo(BlockInfo, BVal.FVal1));
5736         if not MakeNil(BVal.FVal2.Pos, BVal.FVal2.Row, BVal.FVal2.Col, tmpp) then
5737         begin
5738           tmpp.Free;;
5739           Result := False;
5740           exit;
5741         end;
5742         tmpc := TPSValueReplace.Create;
5743         with TPSValueReplace(tmpc) do
5744         begin
5745           OldValue := BVal.FVal2;
5746           NewValue := tmpp;
5747         end;
5748         BVal.FVal2 := tmpc;
5749       end;
5750       if GetTypeNo(BlockInfo, BVal.FVal1).BaseType = btExtClass then
5751       begin
5752         if not TPSUndefinedClassType(GetTypeNo(BlockInfo, BVal.FVal1)).ExtClass.CompareClass(GetTypeNo(BlockInfo, Bval.FVal2), ProcNo) then
5753         begin
5754           Result := False;
5755           exit;
5756         end;
5757         tmpp := TPSValueProcNo.Create;
5758         with TPSValueProcNo(tmpp) do
5759         begin
5760           ResultType := at2ut(FDefaultBoolType);
5761           Parameters := TPSParameters.Create;
5762           ProcNo := procno;
5763           Pos := BVal.Pos;
5764           Col := BVal.Col;
5765           Row := BVal.Row;
5766           with parameters.Add do
5767           begin
5768             Val := BVal.FVal1;
5769             ExpectedType := GetTypeNo(BlockInfo, Val);
5770           end;
5771           with parameters.Add do
5772           begin
5773             Val := BVal.FVal2;
5774             ExpectedType := GetTypeNo(BlockInfo, Val);
5775           end;
5776         end;
5777         if Bval.Operator = otNotEqual then
5778         begin
5779           tmpc := TPSUnValueOp.Create;
5780           TPSUnValueOp(tmpc).Operator := otNot;
5781           TPSUnValueOp(tmpc).Val1 := tmpp;
5782           TPSUnValueOp(tmpc).aType := GetTypeNo(BlockInfo, tmpp);
5783         end else tmpc := tmpp;
5784         Result := WriteCalculation(tmpc, Output);
5785         with TPSValueProcNo(tmpp) do
5786         begin
5787           Parameters[0].Val := nil;
5788           Parameters[1].Val := nil;
5789         end;
5790         tmpc.Free;
5791         if BVal.Val1.ClassType = TPSValueReplace then
5792         begin
5793           tmpp := TPSValueReplace(BVal.Val1).OldValue;
5794           BVal.Val1.Free;
5795           BVal.Val1 := tmpp;
5796         end;
5797         if BVal.Val2.ClassType = TPSValueReplace then
5798         begin
5799           tmpp := TPSValueReplace(BVal.Val2).OldValue;
5800           BVal.Val2.Free;
5801           BVal.Val2 := tmpp;
5802         end;
5803         exit;
5804       end;
5805       if not (PreWriteOutRec(Output, nil) and PreWriteOutRec(BVal.FVal1, GetTypeNo(BlockInfo, BVal.FVal2)) and PreWriteOutRec(BVal.FVal2, GetTypeNo(BlockInfo, BVal.FVal1))) then
5806       begin
5807         Result := False;
5808         exit;
5809       end;
5810       BlockWriteByte(BlockInfo, CM_CO);
5811       case BVal.Operator of
5812         otGreaterEqual: BlockWriteByte(BlockInfo, 0);
5813         otLessEqual: BlockWriteByte(BlockInfo, 1);
5814         otGreater: BlockWriteByte(BlockInfo, 2);
5815         otLess: BlockWriteByte(BlockInfo, 3);
5816         otEqual: BlockWriteByte(BlockInfo, 5);
5817         otNotEqual: BlockWriteByte(BlockInfo, 4);
5818         otIn: BlockWriteByte(BlockInfo, 6);
5819         otIs: BlockWriteByte(BlockInfo, 7);
5820       end;
5821 
5822       if not (WriteOutRec(Output, False) and writeOutRec(BVal.FVal1, True) and writeOutRec(BVal.FVal2, True)) then
5823       begin
5824         Result := False;
5825         exit;
5826       end;
5827       AfterWriteOutrec(BVal.FVal1);
5828       AfterWriteOutrec(BVal.FVal2);
5829       AfterWriteOutrec(Output);
5830       if BVal.Val1.ClassType = TPSValueReplace then
5831       begin
5832         tmpp := TPSValueReplace(BVal.Val1).OldValue;
5833         BVal.Val1.Free;
5834         BVal.Val1 := tmpp;
5835       end;
5836       if BVal.Val2.ClassType = TPSValueReplace then
5837       begin
5838         tmpp := TPSValueReplace(BVal.Val2).OldValue;
5839         BVal.Val2.Free;
5840         BVal.Val2 := tmpp;
5841       end;
5842     end else begin
5843       if (BVal.aType <> nil) and (BVal.aType <> GetTypeNo(BlockInfo, Output)) then begin
5844         tmpp := AllocStackReg(BVal.aType);
5845         PreWriteOutrec(tmpp, nil);
5846         DoBinCalc(BVal, tmpp);
5847         afterwriteoutrec(tmpp);
5848         result := WriteCalculation(tmpp, output);
5849         tmpp.Free;
5850         exit;
5851       end;
5852 
5853       if not PreWriteOutRec(Output, nil) then
5854       begin
5855         Result := False;
5856         exit;
5857       end;
5858       if not SameReg(Output, BVal.Val1) then
5859       begin
5860         if not WriteCalculation(BVal.FVal1, Output) then
5861         begin
5862           Result := False;
5863           exit;
5864         end;
5865       end;
5866       if (FBooleanShortCircuit) and (IsBoolean(BVal.aType)) then
5867       begin
5868         if BVal.Operator = otAnd then
5869         begin
5870           BlockWriteByte(BlockInfo, Cm_CNG);
5871           jover := Length(BlockInfo.Proc.FData);
5872           BlockWriteLong(BlockInfo, 0);
5873           WriteOutRec(Output, True);
5874           jend := Length(BlockInfo.Proc.FData);
5875         end else if BVal.Operator = otOr then
5876         begin
5877           BlockWriteByte(BlockInfo, Cm_CG);
5878           jover := Length(BlockInfo.Proc.FData);
5879           BlockWriteLong(BlockInfo, 0);
5880           WriteOutRec(Output, True);
5881           jend := Length(BlockInfo.Proc.FData);
5882         end else
5883         begin
5884           jover := 0;
5885           jend := 0;
5886         end;
5887       end else
5888       begin
5889         jover := 0;
5890         jend := 0;
5891       end;
5892       if not PreWriteOutrec(BVal.FVal2, GetTypeNo(BlockInfo, Output)) then
5893       begin
5894         Result := False;
5895         exit;
5896       end;
5897       BlockWriteByte(BlockInfo, Cm_CA);
5898       if BVAL.Operator = otIntDiv then
5899         BlockWriteByte(BlockInfo, Ord(otDiv))
5900       else
5901         BlockWriteByte(BlockInfo, Ord(BVal.Operator));
5902       if not (WriteOutRec(Output, False) and WriteOutRec(BVal.FVal2, True)) then
5903       begin
5904         Result := False;
5905         exit;
5906       end;
5907       AfterWriteOutRec(BVal.FVal2);
5908       if FBooleanShortCircuit and (IsBoolean(BVal.aType)) and (JOver <> JEnd) then
5909       begin
5910         {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
5911         unaligned(Cardinal((@BlockInfo.Proc.FData[jover+1])^)) := Cardinal(Length(BlockInfo.Proc.FData)) - jend;
5912 	{$else}
5913         Cardinal((@BlockInfo.Proc.FData[jover+1])^) := Cardinal(Length(BlockInfo.Proc.FData)) - jend;
5914 	{$endif}
5915       end;
5916       AfterWriteOutRec(Output);
5917     end;
5918     Result := True;
5919   end;
5920 
DoUnCalcnull5921   function DoUnCalc(Val: TPSUnValueOp; Output: TPSValue): Boolean;
5922   var
5923     Tmp: TPSValue;
5924   begin
5925     if not PreWriteOutRec(Output, nil) then
5926     begin
5927       Result := False;
5928       exit;
5929     end;
5930     case Val.Operator of
5931       otNot:
5932         begin
5933           if not SameReg(Val.FVal1, Output) then
5934           begin
5935             if not WriteCalculation(Val.FVal1, Output) then
5936             begin
5937               Result := False;
5938               exit;
5939             end;
5940           end;
5941           if IsBoolean(GetTypeNo(BlockInfo, Val)) then
5942             BlockWriteByte(BlockInfo, cm_bn)
5943           else
5944             BlockWriteByte(BlockInfo, cm_in);
5945           if not WriteOutRec(Output, True) then
5946           begin
5947             Result := False;
5948             exit;
5949           end;
5950         end;
5951       otMinus:
5952         begin
5953           if not SameReg(Val.FVal1, Output) then
5954           begin
5955             if not WriteCalculation(Val.FVal1, Output) then
5956             begin
5957               Result := False;
5958               exit;
5959             end;
5960           end;
5961           BlockWriteByte(BlockInfo, cm_vm);
5962           if not WriteOutRec(Output, True) then
5963           begin
5964             Result := False;
5965             exit;
5966           end;
5967         end;
5968       otCast:
5969         begin
5970           if ((Val.aType.BaseType = btChar) and (Val.aType.BaseType <> btU8)) {$IFNDEF PS_NOWIDESTRING}or
5971             ((Val.aType.BaseType = btWideChar) and (Val.aType.BaseType <> btU16)){$ENDIF} then
5972           begin
5973             Tmp := AllocStackReg(Val.aType);
5974           end else
5975             Tmp := Output;
5976           if not (PreWriteOutRec(Val.FVal1, GetTypeNo(BlockInfo, Tmp)) and PreWriteOutRec(Tmp, GetTypeNo(BlockInfo, Tmp))) then
5977           begin
5978             Result := False;
5979             if tmp <> Output then Tmp.Free;
5980             exit;
5981           end;
5982           BlockWriteByte(BlockInfo, CM_A);
5983           if not (WriteOutRec(Tmp, False) and WriteOutRec(Val.FVal1, True)) then
5984           begin
5985             Result := false;
5986             if tmp <> Output then Tmp.Free;
5987             exit;
5988           end;
5989           AfterWriteOutRec(val.Fval1);
5990           if Tmp <> Output then
5991           begin
5992             if not WriteCalculation(Tmp, Output) then
5993             begin
5994               Result := false;
5995               Tmp.Free;
5996               exit;
5997             end;
5998           end;
5999           AfterWriteOutRec(Tmp);
6000           if Tmp <> Output then
6001             Tmp.Free;
6002         end;
6003       {else donothing}
6004     end;
6005     AfterWriteOutRec(Output);
6006     Result := True;
6007   end;
6008 
6009 
GetAddressnull6010   function GetAddress(Val: TPSValue): Cardinal;
6011   begin
6012     if Val.ClassType = TPSValueGlobalVar then
6013       Result := TPSValueGlobalVar(val).GlobalVarNo
6014     else if Val.ClassType = TPSValueLocalVar then
6015       Result := PSAddrStackStart + TPSValueLocalVar(val).LocalVarNo + 1
6016     else if Val.ClassType = TPSValueParamVar then
6017       Result := PSAddrStackStart - TPSValueParamVar(val).ParamNo -1
6018     else if Val.ClassType =  TPSValueAllocatedStackVar then
6019       Result := PSAddrStackStart + TPSValueAllocatedStackVar(val).LocalVarNo + 1
6020     else
6021       Result := InvalidVal;
6022   end;
6023 
6024 
PreWriteOutRecnull6025   function PreWriteOutRec(var X: TPSValue; FArrType: TPSType): Boolean;
6026   var
6027     rr: TPSSubItem;
6028     tmpp,
6029       tmpc: TPSValue;
6030     i: Longint;
MakeSetnull6031     function MakeSet(SetType: TPSSetType; arr: TPSValueArray): Boolean;
6032     var
6033       c, i: Longint;
6034       dataval: TPSValueData;
6035       mType: TPSType;
6036     begin
6037       Result := True;
6038       dataval := TPSValueData.Create;
6039       dataval.Data := NewVariant(FarrType);
6040       for i := 0 to arr.count -1 do
6041       begin
6042         mType := GetTypeNo(BlockInfo, arr.Item[i]);
6043         if (mType <> SetType.SetType) and not (IsIntType(mType.FBaseType) and IsIntType(SetType.SetType.BaseType)) then
6044         begin
6045           with MakeError('', ecTypeMismatch, '') do
6046           begin
6047             FCol := arr.item[i].Col;
6048             FRow := arr.item[i].Row;
6049             FPosition := arr.item[i].Pos;
6050           end;
6051           DataVal.Free;
6052           Result := False;
6053           exit;
6054         end;
6055         if arr.Item[i] is TPSValueData then
6056         begin
6057           c := GetInt(TPSValueData(arr.Item[i]).Data, Result);
6058           if not Result then
6059           begin
6060             dataval.Free;
6061             exit;
6062           end;
6063           if (c < Low(Byte)) or (c > High(Byte)) then
6064           begin
6065             with MakeError('', ecTypeMismatch, '') do
6066             begin
6067               FCol := arr.item[i].Col;
6068               FRow := arr.item[i].Row;
6069               FPosition := arr.item[i].Pos;
6070             end;
6071             DataVal.Free;
6072             Result := False;
6073             exit;
6074           end;
6075           Set_MakeMember(c, dataval.Data.tstring);
6076         end else
6077         begin
6078           DataVal.Free;
6079           MakeError('', ecTypeMismatch, '');
6080           Result := False;
6081           exit;
6082         end;
6083       end;
6084       tmpc := TPSValueReplace.Create;
6085       with TPSValueReplace(tmpc) do
6086       begin
6087         OldValue := x;
6088         NewValue := dataval;
6089         PreWriteAllocated := True;
6090       end;
6091       x := tmpc;
6092     end;
6093   begin
6094     Result := True;
6095     if x.ClassType = TPSValueReplace then
6096     begin
6097       if TPSValueReplace(x).PreWriteAllocated then
6098       begin
6099         inc(TPSValueReplace(x).FReplaceTimes);
6100       end;
6101     end else
6102     if x.ClassType = TPSValueProcPtr then
6103     begin
6104       if FArrType = nil then
6105       begin
6106         MakeError('', ecTypeMismatch, '');
6107         Result := False;
6108         Exit;
6109       end;
6110       tmpp := TPSValueData.Create;
6111       TPSValueData(tmpp).Data := NewVariant(FArrType);
6112       TPSValueData(tmpp).Data.tu32 := TPSValueProcPtr(x).ProcPtr;
6113       tmpc := TPSValueReplace.Create;
6114       with TPSValueReplace(tmpc) do
6115       begin
6116         PreWriteAllocated := True;
6117         OldValue := x;
6118         NewValue := tmpp;
6119       end;
6120       x := tmpc;
6121     end else
6122     if x.ClassType = TPSValueNil then
6123     begin
6124       if FArrType = nil then
6125       begin
6126         MakeError('', ecTypeMismatch, '');
6127         Result := False;
6128         Exit;
6129       end;
6130       tmpp := AllocStackReg(FArrType);
6131       if not MakeNil(x.Pos, x.Row, x.Col, tmpp) then
6132       begin
6133         tmpp.Free;
6134         Result := False;
6135         exit;
6136       end;
6137       tmpc := TPSValueReplace.Create;
6138       with TPSValueReplace(tmpc) do
6139       begin
6140         PreWriteAllocated := True;
6141         OldValue := x;
6142         NewValue := tmpp;
6143       end;
6144       x := tmpc;
6145     end else
6146     if x.ClassType = TPSValueArray then
6147     begin
6148       if FArrType = nil then
6149       begin
6150         MakeError('', ecTypeMismatch, '');
6151         Result := False;
6152         Exit;
6153       end;
6154       if TPSType(FArrType).BaseType = btSet then
6155       begin
6156         Result := MakeSet(TPSSetType(FArrType), TPSValueArray(x));
6157         exit;
6158       end;
6159       if TPSType(FarrType).BaseType = btVariant then
6160         FArrType := at2ut(FindAndAddType(self, '!OPENARRAYOFVARIANT', 'array of Variant'));
6161       if TPSType(FarrType).BaseType <> btArray then
6162         FArrType := at2ut(FindAndAddType(self, '!OPENARRAYOFVARIANT', 'array of Variant'));
6163 
6164       tmpp := AllocStackReg(FArrType);
6165       tmpc := AllocStackReg(FindBaseType(bts32));
6166       BlockWriteByte(BlockInfo, CM_A);
6167       WriteOutrec(tmpc, False);
6168       BlockWriteByte(BlockInfo, 1);
6169       BlockWriteLong(BlockInfo, FindBaseType(bts32).FinalTypeNo);
6170       BlockWriteLong(BlockInfo, TPSValueArray(x).Count);
6171       BlockWriteByte(BlockInfo, CM_PV);
6172       WriteOutrec(tmpp, False);
6173       BlockWriteByte(BlockInfo, CM_C);
6174       BlockWriteLong(BlockInfo, FindProc('SetArrayLength'));
6175       BlockWriteByte(BlockInfo, CM_PO);
6176       tmpc.Free;
6177       rr := TPSSubNumber.Create;
6178       rr.aType := TPSArrayType(FArrType).ArrayTypeNo;
6179       TPSValueVar(tmpp).RecAdd(rr);
6180       for i := 0 to TPSValueArray(x).Count -1 do
6181       begin
6182         TPSSubNumber(rr).SubNo := i;
6183         tmpc := TPSValueArray(x).Item[i];
6184         if not PreWriteOutRec(tmpc, GetTypeNo(BlockInfo, tmpc)) then
6185         begin
6186           tmpp.Free;
6187           Result := false;
6188           exit;
6189         end;
6190         if TPSArrayType(FArrType).ArrayTypeNo.BaseType = btPointer then
6191           BlockWriteByte(BlockInfo, cm_spc)
6192         else
6193           BlockWriteByte(BlockInfo, cm_a);
6194         if not (WriteOutrec(tmpp, False) and WriteOutRec(tmpc, True)) then
6195         begin
6196           Tmpp.Free;
6197           Result := false;
6198           exit;
6199         end;
6200         AfterWriteOutRec(tmpc);
6201       end;
6202       TPSValueVar(tmpp).RecDelete(0);
6203       tmpc := TPSValueReplace.Create;
6204       with TPSValueReplace(tmpc) do
6205       begin
6206         PreWriteAllocated := True;
6207         OldValue := x;
6208         NewValue := tmpp;
6209       end;
6210       x := tmpc;
6211     end else if (x.ClassType = TPSUnValueOp) then
6212     begin
6213       tmpp := AllocStackReg(GetTypeNo(BlockInfo, x));
6214       if not DoUnCalc(TPSUnValueOp(x), tmpp) then
6215       begin
6216         Result := False;
6217         exit;
6218       end;
6219       tmpc := TPSValueReplace.Create;
6220       with TPSValueReplace(tmpc) do
6221       begin
6222         PreWriteAllocated := True;
6223         OldValue := x;
6224         NewValue := tmpp;
6225       end;
6226       x := tmpc;
6227     end else if (x.ClassType = TPSBinValueOp) then
6228     begin
6229       tmpp := AllocStackReg(GetTypeNo(BlockInfo, x));
6230       if not DoBinCalc(TPSBinValueOp(x), tmpp) then
6231       begin
6232         tmpp.Free;
6233         Result := False;
6234         exit;
6235       end;
6236       tmpc := TPSValueReplace.Create;
6237       with TPSValueReplace(tmpc) do
6238       begin
6239         PreWriteAllocated := True;
6240         OldValue := x;
6241         NewValue := tmpp;
6242       end;
6243       x := tmpc;
6244     end else if x is TPSValueProc then
6245     begin
6246       tmpp := AllocStackReg(TPSValueProc(x).ResultType);
6247       if not WriteCalculation(x, tmpp) then
6248       begin
6249         tmpp.Free;
6250         Result := False;
6251         exit;
6252       end;
6253       tmpc := TPSValueReplace.Create;
6254       with TPSValueReplace(tmpc) do
6255       begin
6256         PreWriteAllocated := True;
6257         OldValue := x;
6258         NewValue := tmpp;
6259       end;
6260       x := tmpc;
6261     end else if (x is TPSValueVar) and (TPSValueVar(x).RecCount <> 0) then
6262     begin
6263       if  TPSValueVar(x).RecCount = 1 then
6264       begin
6265         rr := TPSValueVar(x).RecItem[0];
6266         if rr.ClassType <> TPSSubValue then
6267           exit; // there is no need pre-calculate anything
6268         if (TPSSubValue(rr).SubNo is TPSValueVar) and (TPSValueVar(TPSSubValue(rr).SubNo).RecCount = 0) then
6269           exit;
6270       end; //if
6271       tmpp := AllocPointer(GetTypeNo(BlockInfo, x));
6272       BlockWriteByte(BlockInfo, cm_sp);
6273       WriteOutRec(tmpp, True);
6274       BlockWriteByte(BlockInfo, 0);
6275       BlockWriteLong(BlockInfo, GetAddress(x));
6276       for i := 0 to TPSValueVar(x).RecCount - 1 do
6277       begin
6278         rr := TPSValueVar(x).RecItem[I];
6279         if rr.ClassType = TPSSubNumber then
6280         begin
6281           BlockWriteByte(BlockInfo, cm_sp);
6282           WriteOutRec(tmpp, false);
6283           BlockWriteByte(BlockInfo, 2);
6284           BlockWriteLong(BlockInfo, GetAddress(tmpp));
6285           BlockWriteLong(BlockInfo, TPSSubNumber(rr).SubNo);
6286         end else begin // if rr.classtype = TPSSubValue then begin
6287           tmpc := AllocStackReg(FindBaseType(btU32));
6288           if not WriteCalculation(TPSSubValue(rr).SubNo, tmpc) then
6289           begin
6290             tmpc.Free;
6291             tmpp.Free;
6292             Result := False;
6293             exit;
6294           end; //if
6295           BlockWriteByte(BlockInfo, cm_sp);
6296           WriteOutRec(tmpp, false);
6297           BlockWriteByte(BlockInfo, 3);
6298           BlockWriteLong(BlockInfo, GetAddress(tmpp));
6299           BlockWriteLong(BlockInfo, GetAddress(tmpc));
6300           tmpc.Free;
6301         end;
6302       end; // for
6303       tmpc := TPSValueReplace.Create;
6304       with TPSValueReplace(tmpc) do
6305       begin
6306         OldValue := x;
6307         NewValue := tmpp;
6308         PreWriteAllocated := True;
6309       end;
6310       x := tmpc;
6311     end;
6312 
6313   end;
6314 
6315   procedure AfterWriteOutRec(var x: TPSValue);
6316   var
6317     tmp: TPSValue;
6318   begin
6319     if (x.ClassType = TPSValueReplace) and (TPSValueReplace(x).PreWriteAllocated) then
6320     begin
6321       Dec(TPSValueReplace(x).FReplaceTimes);
6322       if TPSValueReplace(x).ReplaceTimes = 0 then
6323       begin
6324         tmp := TPSValueReplace(x).OldValue;
6325         x.Free;
6326         x := tmp;
6327       end;
6328     end;
6329   end; //afterwriteoutrec
6330 
WriteOutRecnull6331   function WriteOutRec(x: TPSValue; AllowData: Boolean): Boolean;
6332   var
6333     rr: TPSSubItem;
6334   begin
6335     Result := True;
6336     if x.ClassType = TPSValueReplace then
6337       Result := WriteOutRec(TPSValueReplace(x).NewValue, AllowData)
6338     else if x is TPSValueVar then
6339     begin
6340       if TPSValueVar(x).RecCount = 0 then
6341       begin
6342         BlockWriteByte(BlockInfo, 0);
6343         BlockWriteLong(BlockInfo, GetAddress(x));
6344       end
6345       else
6346       begin
6347         rr := TPSValueVar(x).RecItem[0];
6348         if rr.ClassType = TPSSubNumber then
6349         begin
6350           BlockWriteByte(BlockInfo, 2);
6351           BlockWriteLong(BlockInfo, GetAddress(x));
6352           BlockWriteLong(BlockInfo, TPSSubNumber(rr).SubNo);
6353         end
6354         else
6355         begin
6356           BlockWriteByte(BlockInfo, 3);
6357           BlockWriteLong(BlockInfo, GetAddress(x));
6358           BlockWriteLong(BlockInfo, GetAddress(TPSSubValue(rr).SubNo));
6359         end;
6360       end;
6361     end else if x.ClassType = TPSValueData then
6362     begin
6363       if AllowData then
6364       begin
6365         BlockWriteByte(BlockInfo, 1);
6366         BlockWriteVariant(BlockInfo, TPSValueData(x).Data)
6367       end
6368       else
6369       begin
6370         Result := False;
6371         exit;
6372       end;
6373     end else
6374       Result := False;
6375   end;
6376 
6377   function ReadParameters(IsProperty: Boolean; Dest: TPSParameters): Boolean; forward;
6378 {$IFNDEF PS_NOIDISPATCH}
6379   function ReadIDispatchParameters(const ProcName: tbtString; aVariantType: TPSVariantType; FSelf: TPSValue): TPSValue; forward;
6380 {$ENDIF}
6381   function ReadProcParameters(ProcNo: Cardinal; FSelf: TPSValue): TPSValue; forward;
6382   function ReadVarParameters(ProcNoVar: TPSValue): TPSValue; forward;
6383 
6384   function calc(endOn: TPSPasToken): TPSValue; forward;
6385   procedure CheckNotificationVariant(var Val: TPSValue);
6386   var
6387     aType: TPSType;
6388     Call: TPSValueProcNo;
6389     tmp: TPSValue;
6390   begin
6391     if not (Val is TPSValueGlobalVar) then exit;
6392     aType := GetTypeNo(BlockInfo, Val);
6393     if (AType = nil) or (AType.BaseType <> btNotificationVariant) then exit;
6394     if FParser.CurrTokenId = CSTI_Assignment then
6395     begin
6396       Call := TPSValueProcNo.Create;
6397       Call.ResultType := nil;
6398       Call.SetParserPos(FParser);
6399       Call.ProcNo := FindProc('!NOTIFICATIONVARIANTSET');;
6400       Call.SetParserPos(FParser);
6401       Call.Parameters := TPSParameters.Create;
6402       Tmp := TPSValueData.Create;
6403       TPSVAlueData(tmp).Data := NewVariant(at2ut(FindBaseType(btString)));
6404       tbtString(TPSValueData(tmp).Data.tstring) := TPSVar(FVars[TPSValueGlobalVar(Val).GlobalVarNo]).OrgName;
6405       with call.Parameters.Add do
6406       begin
6407         Val := tmp;
6408         ExpectedType := TPSValueData(tmp).Data.FType;
6409       end;
6410       FParser.Next;
6411       tmp := Calc(CSTI_SemiColon);
6412       if tmp = nil then
6413       begin
6414         Val.Free;
6415         Val := nil;
6416         exit;
6417       end;
6418       with Call.Parameters.Add do
6419       begin
6420         Val := tmp;
6421         ExpectedType := at2ut(FindBaseType(btVariant));
6422       end;
6423       Val.Free;
6424       Val := Call;
6425     end else begin
6426       Call := TPSValueProcNo.Create;
6427       Call.ResultType := AT2UT(FindBaseType(btVariant));
6428       Call.SetParserPos(FParser);
6429       Call.ProcNo := FindProc('!NOTIFICATIONVARIANTGET');
6430       Call.SetParserPos(FParser);
6431       Call.Parameters := TPSParameters.Create;
6432       Tmp := TPSValueData.Create;
6433       TPSVAlueData(tmp).Data := NewVariant(at2ut(FindBaseType(btString)));
6434       tbtString(TPSValueData(tmp).Data.tstring) := TPSVar(FVars[TPSValueGlobalVar(Val).GlobalVarNo]).OrgName;
6435       with call.Parameters.Add do
6436       begin
6437         Val := tmp;
6438         ExpectedType := TPSValueData(tmp).Data.FType;
6439       end;
6440       Val.Free;
6441       Val := Call;
6442     end;
6443   end;
6444 
6445     procedure CheckProcCall(var x: TPSValue);
6446     var
6447       aType: TPSType;
6448     begin
6449       if FParser.CurrTokenId in [CSTI_Dereference, CSTI_OpenRound] then
6450       begin
6451         aType := GetTypeNo(BlockInfo, x);
6452         if (aType = nil) or (aType.BaseType <> btProcPtr) then
6453         begin
6454           MakeError('', ecTypeMismatch, '');
6455           x.Free;
6456           x := nil;
6457           Exit;
6458         end;
6459         if FParser.CurrTokenId = CSTI_Dereference then
6460           FParser.Next;
6461         x := ReadVarParameters(x);
6462       end;
6463     end;
6464 
6465     procedure CheckFurther(var x: TPSValue; ImplicitPeriod: Boolean);
6466     var
6467       t: Cardinal;
6468       rr: TPSSubItem;
6469       L: Longint;
6470       u: TPSType;
6471       Param: TPSParameter;
6472       tmp, tmpn: TPSValue;
6473       tmp3: TPSValueProcNo;
6474       tmp2: Boolean;
6475 
FindSubRnull6476       function FindSubR(const n: tbtString; FType: TPSType): Cardinal;
6477       var
6478         h, I: Longint;
6479         rvv: PIFPSRecordFieldTypeDef;
6480       begin
6481         h := MakeHash(n);
6482         for I := 0 to TPSRecordType(FType).RecValCount - 1 do
6483         begin
6484           rvv := TPSRecordType(FType).RecVal(I);
6485           if (rvv.FieldNameHash = h) and (rvv.FieldName = n) then
6486           begin
6487             Result := I;
6488             exit;
6489           end;
6490         end;
6491         Result := InvalidVal;
6492       end;
6493 
6494     begin
6495 (*      if not (x is TPSValueVar) then
6496         Exit;*)
6497       u := GetTypeNo(BlockInfo, x);
6498       if u = nil then exit;
6499       while True do
6500       begin
6501         if (u.BaseType = btClass) {$IFNDEF PS_NOINTERFACES}or (u.BaseType = btInterface){$ENDIF}
6502         {$IFNDEF PS_NOIDISPATCH}or ((u.BaseType = btNotificationVariant)){$ENDIF} or (u.BaseType = btExtClass) then exit;
6503         if FParser.CurrTokenId = CSTI_OpenBlock then
6504         begin
6505           if (u.BaseType = btString) {$IFNDEF PS_NOWIDESTRING} or
6506             (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) {$ENDIF}
6507             {$IFDEF PS_HAVEVARIANT}or (u.BaseType = btVariant){$ENDIF} then
6508           begin
6509              FParser.Next;
6510             tmp := Calc(CSTI_CloseBlock);
6511             if tmp = nil then
6512             begin
6513               x.Free;
6514               x := nil;
6515               exit;
6516             end;
6517             if not IsIntType(GetTypeNo(BlockInfo, tmp).BaseType) then
6518             begin
6519               MakeError('', ecTypeMismatch, '');
6520               tmp.Free;
6521               x.Free;
6522               x := nil;
6523               exit;
6524             end;
6525             FParser.Next;
6526             if FParser.CurrTokenId = CSTI_Assignment then
6527             begin
6528               if not (x is TPSValueVar) then begin
6529                 MakeError('', ecVariableExpected, '');
6530                 tmp.Free;
6531                 x.Free;
6532                 x := nil;
6533                 exit;
6534               end;
6535               {$IFDEF PS_HAVEVARIANT}if (u.BaseType = btVariant) then
6536                 l := FindProc('VarArraySet') else
6537               {$ENDIF}
6538               {$IFNDEF PS_NOWIDESTRING}
6539               if (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) then
6540                 l := FindProc('WStrSet')
6541               else
6542               {$ENDIF}
6543                 l := FindProc('StrSet');
6544               if l = -1 then
6545               begin
6546                 MakeError('', ecUnknownIdentifier, 'StrSet');
6547                 tmp.Free;
6548                 x.Free;
6549                 x := nil;
6550                 exit;
6551               end;
6552               tmp3 := TPSValueProcNo.Create;
6553               tmp3.ResultType := nil;
6554               tmp3.SetParserPos(FParser);
6555               tmp3.ProcNo := L;
6556               tmp3.SetParserPos(FParser);
6557               tmp3.Parameters := TPSParameters.Create;
6558               param := tmp3.Parameters.Add;
6559               with tmp3.Parameters.Add do
6560               begin
6561                 Val := tmp;
6562                 ExpectedType := GetTypeNo(BlockInfo, tmp);
6563 {$IFDEF DEBUG}
6564                 if not ExpectedType.Used then asm int 3; end;
6565 {$ENDIF}
6566               end;
6567               with tmp3.Parameters.Add do
6568               begin
6569                 Val := x;
6570                 ExpectedType := GetTypeNo(BlockInfo, x);
6571 {$IFDEF DEBUG}
6572                 if not ExpectedType.Used then asm int 3; end;
6573 {$ENDIF}
6574                 ParamMode := pmInOut;
6575               end;
6576               x := tmp3;
6577               FParser.Next;
6578               tmp := Calc(CSTI_SemiColon);
6579               if tmp = nil then
6580               begin
6581                 x.Free;
6582                 x := nil;
6583                 exit;
6584               end;
6585               {$IFDEF PS_HAVEVARIANT}if (u.BaseType <> btVariant) then {$ENDIF}
6586               begin
6587                 if (GetTypeNo(BlockInfo, Tmp).BaseType <> btChar)
6588                 {$IFNDEF PS_NOWIDESTRING} and (GetTypeno(BlockInfo, Tmp).BaseType <> btWideChar) {$ENDIF} then
6589                 begin
6590                   x.Free;
6591                   x := nil;
6592                   Tmp.Free;
6593                   MakeError('', ecTypeMismatch, '');
6594                   exit;
6595 
6596                 end;
6597               end;
6598               param.Val := tmp;
6599               {$IFDEF PS_HAVEVARIANT}
6600               if u.BaseType = btVariant then
6601                 Param.ExpectedType := u else{$ENDIF}
6602               Param.ExpectedType := GetTypeNo(BlockInfo, tmp);
6603 {$IFDEF DEBUG}
6604               if not Param.ExpectedType.Used then asm int 3; end;
6605 {$ENDIF}
6606             end else begin
6607               {$IFDEF PS_HAVEVARIANT}if (u.BaseType = btVariant) then
6608                 l := FindProc('VarArrayGet') else
6609               {$ENDIF}
6610               {$IFNDEF PS_NOWIDESTRING}
6611               if (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) then
6612                 l := FindProc('WStrGet')
6613               else
6614               {$ENDIF}
6615               l := FindProc('StrGet');
6616               if l = -1 then
6617               begin
6618                 MakeError('', ecUnknownIdentifier, 'StrGet');
6619                 tmp.Free;
6620                 x.Free;
6621                 x := nil;
6622                 exit;
6623               end;
6624               tmp3 := TPSValueProcNo.Create;
6625               {$IFDEF PS_HAVEVARIANT}if (u.BaseType = btVariant) then
6626                 tmp3.ResultType := FindBaseType(btVariant) else
6627               {$ENDIF}
6628               {$IFNDEF PS_NOWIDESTRING}
6629               if (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) then
6630                 tmp3.ResultType := FindBaseType(btWideChar)
6631               else
6632               {$ENDIF}
6633                 tmp3.ResultType := FindBaseType(btChar);
6634               tmp3.ProcNo := L;
6635               tmp3.SetParserPos(FParser);
6636               tmp3.Parameters := TPSParameters.Create;
6637               with tmp3.Parameters.Add do
6638               begin
6639                 Val := x;
6640                 ExpectedType := GetTypeNo(BlockInfo, x);
6641 {$IFDEF DEBUG}
6642                 if not ExpectedType.Used then asm int 3; end;
6643 {$ENDIF}
6644 
6645                 if x is TPSValueVar then
6646                   ParamMode := pmInOut
6647                 else
6648                   parammode := pmIn;
6649               end;
6650               with tmp3.Parameters.Add do
6651               begin
6652                 Val := tmp;
6653                 ExpectedType := GetTypeNo(BlockInfo, tmp);
6654 {$IFDEF DEBUG}
6655                 if not ExpectedType.Used then asm int 3; end;
6656 {$ENDIF}
6657               end;
6658               x := tmp3;
6659             end;
6660             Break;
6661           end else if ((u.BaseType = btArray) or (u.BaseType = btStaticArray)) and (x is TPSValueVar) then
6662           begin
6663             FParser.Next;
6664             tmp := calc(CSTI_CloseBlock);
6665             if tmp = nil then
6666             begin
6667               x.Free;
6668               x := nil;
6669               exit;
6670             end;
6671             if not IsIntType(GetTypeNo(BlockInfo, tmp).BaseType) then
6672             begin
6673               MakeError('', ecTypeMismatch, '');
6674               tmp.Free;
6675               x.Free;
6676               x := nil;
6677               exit;
6678             end;
6679             if (tmp.ClassType = TPSValueData) then
6680             begin
6681               rr := TPSSubNumber.Create;
6682               TPSValueVar(x).RecAdd(rr);
6683               if (u.BaseType = btStaticArray) then
6684                 TPSSubNumber(rr).SubNo := Cardinal(GetInt(TPSValueData(tmp).Data, tmp2) - TPSStaticArrayType(u).StartOffset)
6685               else
6686                 TPSSubNumber(rr).SubNo := GetUInt(TPSValueData(tmp).Data, tmp2);
6687               tmp.Free;
6688               rr.aType := TPSArrayType(u).ArrayTypeNo;
6689               u := rr.aType;
6690             end
6691             else
6692             begin
6693               if (u.BaseType = btStaticArray) then
6694               begin
6695                 tmpn := TPSBinValueOp.Create;
6696                 TPSBinValueOp(tmpn).Operator := otSub;
6697                 TPSBinValueOp(tmpn).Val1 := tmp;
6698                 tmp := TPSValueData.Create;
6699                 TPSValueData(tmp).Data := NewVariant(FindBaseType(btS32));
6700                 TPSValueData(tmp).Data.ts32 := TPSStaticArrayType(u).StartOffset;
6701                 TPSBinValueOp(tmpn).Val2 := tmp;
6702                 TPSBinValueOp(tmpn).aType := FindBaseType(btS32);
6703                 tmp := tmpn;
6704               end;
6705               rr := TPSSubValue.Create;
6706               TPSValueVar(x).recAdd(rr);
6707               TPSSubValue(rr).SubNo := tmp;
6708               rr.aType := TPSArrayType(u).ArrayTypeNo;
6709               u := rr.aType;
6710             end;
6711             if FParser.CurrTokenId <> CSTI_CloseBlock then
6712             begin
6713               MakeError('', ecCloseBlockExpected, '');
6714               x.Free;
6715               x := nil;
6716               exit;
6717             end;
6718             Fparser.Next;
6719           end else begin
6720             MakeError('', ecSemicolonExpected, '');
6721             x.Free;
6722             x := nil;
6723             exit;
6724           end;
6725         end
6726         else if ((FParser.CurrTokenId = CSTI_Period) or (ImplicitPeriod))
6727          {$IFDEF PS_HAVEVARIANT}and not (u.BaseType = btVariant){$ENDIF}
6728         then
6729         begin
6730           if not ImplicitPeriod then
6731             FParser.Next;
6732           if u.BaseType = btRecord then
6733           begin
6734             t := FindSubR(FParser.GetToken, u);
6735             if t = InvalidVal then
6736             begin
6737               if ImplicitPeriod then exit;
6738               MakeError('', ecUnknownIdentifier, FParser.GetToken);
6739               x.Free;
6740               x := nil;
6741               exit;
6742             end;
6743             if (x is TPSValueProcNo) then
6744             begin
6745               ImplicitPeriod := False;
6746               FParser.Next;
6747 
6748               tmp := AllocStackReg(u);
6749               WriteCalculation(x,tmp);
6750               TPSVar(BlockInfo.Proc.FProcVars[TPSValueAllocatedStackVar(tmp).LocalVarNo]).Use;
6751 
6752               rr := TPSSubNumber.Create;
6753               TPSValueVar(tmp).RecAdd(rr);
6754               TPSSubNumber(rr).SubNo := t;
6755               rr.aType := TPSRecordType(u).RecVal(t).FType;
6756               u := rr.aType;
6757 
6758               tmpn := TPSValueReplace.Create;
6759               with TPSValueReplace(tmpn) do
6760               begin
6761                 FreeOldValue := true;
6762                 FreeNewValue := true;
6763                 OldValue := tmp;
6764                 NewValue := AllocStackReg(u);
6765                 PreWriteAllocated := true;
6766               end;
6767 
6768               if not WriteCalculation(tmp,TPSValueReplace(tmpn).NewValue) then
6769               begin
6770                 {MakeError('',ecInternalError,'');}
6771                 x.Free;
6772                 x := nil;
6773                 exit;
6774               end;
6775               x.Free;
6776               x := tmpn;
6777             end else
6778             begin
6779               if not (x is TPSValueVar) then begin
6780                 MakeError('', ecVariableExpected, FParser.GetToken);
6781                 x.Free;
6782                 x := nil;
6783                 exit;
6784               end;
6785               ImplicitPeriod := False;
6786               FParser.Next;
6787               rr := TPSSubNumber.Create;
6788               TPSValueVar(x).RecAdd(rr);
6789               TPSSubNumber(rr).SubNo := t;
6790               rr.aType := TPSRecordType(u).RecVal(t).FType;
6791               u := rr.aType;
6792             end;
6793           end
6794           {$IFDEF PS_HAVEVARIANT}
6795           else if (u.BaseType = btVariant) then break else
6796           {$ELSE}
6797           ;
6798           {$ENDIF}
6799 
6800           begin
6801             x.Free;
6802             MakeError('', ecSemicolonExpected, '');
6803             x := nil;
6804             exit;
6805           end;
6806         end
6807         else
6808           break;
6809       end;
6810     end;
6811 
6812 
6813 
6814     procedure CheckClassArrayProperty(var P: TPSValue; const VarType: TPSVariableType; VarNo: Cardinal);
6815     var
6816       Tempp: TPSValue;
6817       aType: TPSClassType;
6818       procno: Cardinal;
6819       Idx: TPSDelphiClassItem;
6820       Decl: TPSParametersDecl;
6821     begin
6822       if p = nil then exit;
6823       if (GetTypeNo(BlockInfo, p) = nil) or (GetTypeNo(BlockInfo, p).BaseType <> btClass) then exit;
6824       aType := TPSClassType(GetTypeNo(BlockInfo, p));
6825       if FParser.CurrTokenID = CSTI_OpenBlock then
6826       begin
6827         if not TPSClassType(aType).Cl.Property_Find('', Idx) then
6828         begin
6829           MakeError('', ecPeriodExpected, '');
6830           p.Free;
6831           p := nil;
6832           exit;
6833         end;
6834         if VarNo <> InvalidVal then
6835         begin
6836           if @FOnUseVariable <> nil then
6837            FOnUseVariable(Self, VarType, VarNo, BlockInfo.ProcNo, FParser.CurrTokenPos, '[Default]');
6838         end;
6839         Decl := TPSParametersDecl.Create;
6840         TPSClassType(aType).Cl.Property_GetHeader(Idx,  Decl);
6841         tempp := p;
6842         P := TPSValueProcNo.Create;
6843         with TPSValueProcNo(P) do
6844         begin
6845           Parameters := TPSParameters.Create;
6846           Parameters.Add;
6847         end;
6848         if not (ReadParameters(True, TPSValueProc(P).Parameters) and
6849           ValidateParameters(BlockInfo, TPSValueProc(P).Parameters, Decl)) then
6850         begin
6851           tempp.Free;
6852           Decl.Free;
6853           p.Free;
6854           p := nil;
6855           exit;
6856         end;
6857         with TPSValueProcNo(p).Parameters[0] do
6858         begin
6859           Val := tempp;
6860           ExpectedType := GetTypeNo(BlockInfo, tempp);
6861         end;
6862         if FParser.CurrTokenId = CSTI_Assignment then
6863         begin
6864           FParser.Next;
6865           TempP := Calc(CSTI_SemiColon);
6866           if TempP = nil then
6867           begin
6868             Decl.Free;
6869             P.Free;
6870             p := nil;
6871             exit;
6872           end;
6873           with TPSValueProc(p).Parameters.Add do
6874           begin
6875             Val := Tempp;
6876             ExpectedType := at2ut(Decl.Result);
6877           end;
6878           if not TPSClassType(aType).Cl.Property_Set(Idx, procno) then
6879           begin
6880             Decl.Free;
6881             MakeError('', ecReadOnlyProperty, '');
6882             p.Free;
6883             p := nil;
6884             exit;
6885           end;
6886           TPSValueProcNo(p).ProcNo := procno;
6887           TPSValueProcNo(p).ResultType := nil;
6888         end
6889         else
6890         begin
6891           if not TPSClassType(aType).Cl.Property_Get(Idx, procno) then
6892           begin
6893             Decl.Free;
6894             MakeError('', ecWriteOnlyProperty, '');
6895             p.Free;
6896             p := nil;
6897             exit;
6898           end;
6899           TPSValueProcNo(p).ProcNo := procno;
6900           TPSValueProcNo(p).ResultType := TPSExternalProcedure(FProcs[procno]).RegProc.Decl.Result;
6901         end; // if FParser.CurrTokenId = CSTI_Assign
6902         Decl.Free;
6903       end;
6904     end;
6905 
6906     procedure CheckExtClass(var P: TPSValue; const VarType: TPSVariableType; VarNo: Cardinal; ImplicitPeriod: Boolean);
6907     var
6908       Temp, Idx: Cardinal;
6909       FType: TPSType;
6910       s: tbtString;
6911 
6912     begin
6913       FType := GetTypeNo(BlockInfo, p);
6914       if FType = nil then Exit;
6915       if FType.BaseType <> btExtClass then Exit;
6916       while (FParser.CurrTokenID = CSTI_Period) or (ImplicitPeriod) do
6917       begin
6918         if not ImplicitPeriod then
6919           FParser.Next;
6920         if FParser.CurrTokenID <> CSTI_Identifier then
6921         begin
6922           if ImplicitPeriod then exit;
6923           MakeError('', ecIdentifierExpected, '');
6924           p.Free;
6925           P := nil;
6926           Exit;
6927         end;
6928         s := FParser.GetToken;
6929         if TPSUndefinedClassType(FType).ExtClass.Func_Find(s, Idx) then
6930         begin
6931           FParser.Next;
6932           TPSUndefinedClassType(FType).ExtClass.Func_Call(Idx, Temp);
6933           P := ReadProcParameters(Temp, P);
6934           if p = nil then
6935           begin
6936             Exit;
6937           end;
6938         end else
6939         begin
6940           if ImplicitPeriod then exit;
6941           MakeError('', ecUnknownIdentifier, s);
6942           p.Free;
6943           P := nil;
6944           Exit;
6945         end;
6946         ImplicitPeriod := False;
6947         FType := GetTypeNo(BlockInfo, p);
6948         if (FType = nil) or (FType.BaseType <> btExtClass) then Exit;
6949       end; {while}
6950     end;
6951 
6952     procedure CheckClass(var P: TPSValue; const VarType: TPSVariableType; VarNo: Cardinal; ImplicitPeriod: Boolean);
6953     var
6954       Procno: Cardinal;
6955       Idx: TPSDelphiClassItem;
6956       FType: TPSType;
6957       TempP: TPSValue;
6958       Decl: TPSParametersDecl;
6959       s: tbtString;
6960 
6961       pinfo, pinfonew: tbtString;
6962       ppos: Cardinal;
6963 
6964     begin
6965       FType := GetTypeNo(BlockInfo, p);
6966       if FType = nil then exit;
6967       pinfo := '';
6968       if (FType.BaseType <> btClass) then Exit;
6969       while (FParser.CurrTokenID = CSTI_Period) or (ImplicitPeriod) do
6970       begin
6971         if not ImplicitPeriod then
6972           FParser.Next;
6973         if FParser.CurrTokenID <> CSTI_Identifier then
6974         begin
6975           if ImplicitPeriod then exit;
6976           MakeError('', ecIdentifierExpected, '');
6977           p.Free;
6978           P := nil;
6979           Exit;
6980         end;
6981         s := FParser.GetToken;
6982         if TPSClassType(FType).Cl.Func_Find(s, Idx) then
6983         begin
6984           FParser.Next;
6985           VarNo := InvalidVal;
6986           TPSClassType(FType).cl.Func_Call(Idx, Procno);
6987           P := ReadProcParameters(Procno, P);
6988           if p = nil then
6989           begin
6990             Exit;
6991           end;
6992         end else if TPSClassType(FType).cl.Property_Find(s, Idx) then
6993         begin
6994           ppos := FParser.CurrTokenPos;
6995           pinfonew := FParser.OriginalToken;
6996           FParser.Next;
6997           if VarNo <> InvalidVal then
6998           begin
6999             if pinfo = '' then
7000               pinfo := pinfonew
7001             else
7002               pinfo := pinfo + '.' + pinfonew;
7003             if @FOnUseVariable <> nil then
7004               FOnUseVariable(Self, VarType, VarNo, BlockInfo.ProcNo, ppos, pinfo);
7005           end;
7006           Decl := TPSParametersDecl.Create;
7007           TPSClassType(FType).cl.Property_GetHeader(Idx, Decl);
7008           TempP := P;
7009           p := TPSValueProcNo.Create;
7010           with TPSValueProcNo(p) do
7011           begin
7012             Parameters := TPSParameters.Create;
7013             Parameters.Add;
7014             Pos := FParser.CurrTokenPos;
7015             row := FParser.Row;
7016             Col := FParser.Col;
7017           end;
7018           if Decl.ParamCount <> 0 then
7019           begin
7020             if not (ReadParameters(True, TPSValueProc(P).Parameters) and
7021               ValidateParameters(BlockInfo, TPSValueProc(P).Parameters, Decl)) then
7022             begin
7023               Tempp.Free;
7024               Decl.Free;
7025               p.Free;
7026               P := nil;
7027               exit;
7028             end;
7029           end; // if
7030           with TPSValueProcNo(p).Parameters[0] do
7031           begin
7032             Val := TempP;
7033             ExpectedType := at2ut(GetTypeNo(BlockInfo, TempP));
7034           end;
7035           if FParser.CurrTokenId = CSTI_Assignment then
7036           begin
7037             FParser.Next;
7038             TempP := Calc(CSTI_SemiColon);
7039             if TempP = nil then
7040             begin
7041               Decl.Free;
7042               P.Free;
7043               p := nil;
7044               exit;
7045             end;
7046             with TPSValueProc(p).Parameters.Add do
7047             begin
7048               Val := Tempp;
7049               ExpectedType := at2ut(Decl.Result);
7050 {$IFDEF DEBUG}
7051               if not ExpectedType.Used then asm int 3; end;
7052 {$ENDIF}
7053             end;
7054 
7055             if not TPSClassType(FType).cl.Property_Set(Idx, Procno) then
7056             begin
7057               MakeError('', ecReadOnlyProperty, '');
7058               Decl.Free;
7059               p.Free;
7060               p := nil;
7061               exit;
7062             end;
7063             TPSValueProcNo(p).ProcNo := Procno;
7064             TPSValueProcNo(p).ResultType := nil;
7065             Decl.Free;
7066             Exit;
7067           end else begin
7068             if not TPSClassType(FType).cl.Property_Get(Idx, Procno) then
7069             begin
7070               MakeError('', ecWriteOnlyProperty, '');
7071               Decl.Free;
7072               p.Free;
7073               p := nil;
7074               exit;
7075             end;
7076             TPSValueProcNo(p).ProcNo := ProcNo;
7077             TPSValueProcNo(p).ResultType := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl.Result;
7078           end; // if FParser.CurrTokenId = CSTI_Assign
7079           Decl.Free;
7080         end else
7081         begin
7082           if ImplicitPeriod then exit;
7083           MakeError('', ecUnknownIdentifier, s);
7084           p.Free;
7085           P := nil;
7086           Exit;
7087         end;
7088         ImplicitPeriod := False;
7089         FType := GetTypeNo(BlockInfo, p);
7090         if (FType = nil) or (FType.BaseType <> btClass) then Exit;
7091       end; {while}
7092     end;
7093 {$IFNDEF PS_NOIDISPATCH}
7094     procedure CheckIntf(var P: TPSValue; const VarType: TPSVariableType; VarNo: Cardinal; ImplicitPeriod: Boolean);
7095     var
7096       Procno: Cardinal;
7097       Idx: TPSInterfaceMethod;
7098       FType: TPSType;
7099       s: tbtString;
7100 
7101       CheckArrayProperty,HasArrayProperty:boolean;
7102     begin
7103       FType := GetTypeNo(BlockInfo, p);
7104       if FType = nil then exit;
7105       if (FType.BaseType <> btInterface) and (Ftype.BaseType <> BtVariant) and (FType.BaseType = btNotificationVariant) then Exit;
7106 
7107       CheckArrayProperty:=(FParser.CurrTokenID=CSTI_OpenBlock) and
7108         (Ftype.BaseType = BtVariant);
7109       while (FParser.CurrTokenID = CSTI_Period)
7110       or (ImplicitPeriod) do begin
7111 
7112         HasArrayProperty:=CheckArrayProperty;
7113         if CheckArrayProperty then begin
7114          CheckArrayProperty:=false;
7115         end else begin
7116          if not ImplicitPeriod then
7117           FParser.Next;
7118         end;
7119         if FParser.CurrTokenID <> CSTI_Identifier then
7120         begin
7121           if ImplicitPeriod then exit;
7122           if not HasArrayProperty then begin
7123            MakeError('', ecIdentifierExpected, '');
7124            p.Free;
7125            P := nil;
7126            Exit;
7127           end;
7128         end;
7129         if (FType.BaseType = btVariant) or (FType.BaseType = btNotificationVariant) then
7130         begin
7131           if HasArrayProperty then begin
7132            s:='';
7133           end else begin
7134            s := FParser.OriginalToken;
7135            FParser.Next;
7136           end;
7137           ImplicitPeriod := False;
7138           FType := GetTypeNo(BlockInfo, p);
7139           p := ReadIDispatchParameters(s, TPSVariantType(FType), p);
7140           if (FType = nil) or (FType.BaseType <> btInterface) then Exit;
7141         end else
7142         begin
7143           s := FParser.GetToken;
7144           if (FType is TPSInterfaceType) and (TPSInterfaceType(FType).Intf.Func_Find(s, Idx)) then
7145           begin
7146             FParser.Next;
7147             TPSInterfaceType(FType).Intf.Func_Call(Idx, Procno);
7148             P := ReadProcParameters(Procno, P);
7149             if p = nil then
7150             begin
7151               Exit;
7152             end;
7153           end else
7154           begin
7155             if ImplicitPeriod then exit;
7156             MakeError('', ecUnknownIdentifier, s);
7157             p.Free;
7158             P := nil;
7159             Exit;
7160           end;
7161           ImplicitPeriod := False;
7162           FType := GetTypeNo(BlockInfo, p);
7163           if (FType = nil) or ((FType.BaseType <> btInterface) and (Ftype.BaseType <> btVariant) and (Ftype.BaseType <> btNotificationVariant)) then Exit;
7164         end;
7165       end; {while}
7166     end;
7167     {$ENDIF}
ExtCheckClassTypenull7168     function ExtCheckClassType(FType: TPSType; const ParserPos: Cardinal): TPSValue;
7169     var
7170       FType2: TPSType;
7171       ProcNo, Idx: Cardinal;
7172       Temp, ResV: TPSValue;
7173     begin
7174       if FParser.CurrTokenID = CSTI_OpenRound then
7175       begin
7176         FParser.Next;
7177         Temp := Calc(CSTI_CloseRound);
7178         if Temp = nil then
7179         begin
7180           Result := nil;
7181           exit;
7182         end;
7183         if FParser.CurrTokenID <> CSTI_CloseRound then
7184         begin
7185           temp.Free;
7186           MakeError('', ecCloseRoundExpected, '');
7187           Result := nil;
7188           exit;
7189         end;
7190         FType2 := GetTypeNo(BlockInfo, Temp);
7191         if (FType.basetype = BtClass) and (ftype2.BaseType = btClass) and (ftype <> ftype2) then
7192         begin
7193           if not TPSUndefinedClassType(FType2).ExtClass.CastToType(AT2UT(FType), ProcNo) then
7194           begin
7195             temp.Free;
7196             MakeError('', ecTypeMismatch, '');
7197             Result := nil;
7198             exit;
7199           end;
7200           Result := TPSValueProcNo.Create;
7201           TPSValueProcNo(Result).Parameters := TPSParameters.Create;
7202           TPSValueProcNo(Result).ResultType := at2ut(FType);
7203           TPSValueProcNo(Result).ProcNo := ProcNo;
7204           with TPSValueProcNo(Result).Parameters.Add do
7205           begin
7206             Val := Temp;
7207             ExpectedType := GetTypeNo(BlockInfo, temp);
7208           end;
7209           with TPSValueProcNo(Result).Parameters.Add do
7210           begin
7211             ExpectedType := at2ut(FindBaseType(btu32));
7212             Val := TPSValueData.Create;
7213             with TPSValueData(val) do
7214             begin
7215               SetParserPos(FParser);
7216               Data := NewVariant(ExpectedType);
7217               Data.tu32 := at2ut(FType).FinalTypeNo;
7218             end;
7219           end;
7220           FParser.Next;
7221           Exit;
7222         end;
7223         if not IsCompatibleType(FType, FType2, True) then
7224         begin
7225           temp.Free;
7226           MakeError('', ecTypeMismatch, '');
7227           Result := nil;
7228           exit;
7229         end;
7230         FParser.Next;
7231         Result := TPSUnValueOp.Create;
7232         with TPSUnValueOp(Result) do
7233         begin
7234           Operator := otCast;
7235           Val1 := Temp;
7236           SetParserPos(FParser);
7237           aType := AT2UT(FType);
7238         end;
7239         exit;
7240       end;
7241       if FParser.CurrTokenId <> CSTI_Period then
7242       begin
7243         Result := nil;
7244         MakeError('', ecPeriodExpected, '');
7245         Exit;
7246       end;
7247       if FType.BaseType <> btExtClass then
7248       begin
7249         Result := nil;
7250         MakeError('', ecClassTypeExpected, '');
7251         Exit;
7252       end;
7253       FParser.Next;
7254       if not TPSUndefinedClassType(FType).ExtClass.ClassFunc_Find(FParser.GetToken, Idx) then
7255       begin
7256         Result := nil;
7257         MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
7258         Exit;
7259       end;
7260       FParser.Next;
7261       TPSUndefinedClassType(FType).ExtClass.ClassFunc_Call(Idx, ProcNo);
7262       Temp := TPSValueData.Create;
7263       with TPSValueData(Temp) do
7264       begin
7265         Data := NewVariant(at2ut(FindBaseType(btu32)));
7266         Data.tu32 := at2ut(FType).FinalTypeNo;
7267       end;
7268       ResV := ReadProcParameters(ProcNo, Temp);
7269       if ResV <> nil then
7270       begin
7271         TPSValueProc(Resv).ResultType := at2ut(FType);
7272         Result := Resv;
7273       end else begin
7274         Result := nil;
7275       end;
7276     end;
7277 
CheckClassTypenull7278     function CheckClassType(TypeNo: TPSType; const ParserPos: Cardinal): TPSValue;
7279     var
7280       FType2: TPSType;
7281       ProcNo: Cardinal;
7282       Idx: IPointer;
7283       Temp, ResV: TPSValue;
7284       dta: PIfRVariant;
7285     begin
7286       if typeno.BaseType = btExtClass then
7287       begin
7288         Result := ExtCheckClassType(TypeNo, PArserPos);
7289         exit;
7290       end;
7291       if FParser.CurrTokenID = CSTI_OpenRound then
7292       begin
7293         FParser.Next;
7294         Temp := Calc(CSTI_CloseRound);
7295         if Temp = nil then
7296         begin
7297           Result := nil;
7298           exit;
7299         end;
7300         if FParser.CurrTokenID <> CSTI_CloseRound then
7301         begin
7302           temp.Free;
7303           MakeError('', ecCloseRoundExpected, '');
7304           Result := nil;
7305           exit;
7306         end;
7307         FType2 := GetTypeNo(BlockInfo, Temp);
7308         if ((typeno.BaseType = btClass){$IFNDEF PS_NOINTERFACES} or (TypeNo.basetype = btInterface){$ENDIF}) and
7309           (ftype2<>nil) and
7310           ((ftype2.BaseType = btClass){$IFNDEF PS_NOINTERFACES} or (ftype2.BaseType = btInterface){$ENDIF}) and (TypeNo <> ftype2) then
7311         begin
7312 {$IFNDEF PS_NOINTERFACES}
7313           if FType2.basetype = btClass then
7314           begin
7315 {$ENDIF}
7316           if not TPSClassType(FType2).Cl.CastToType(AT2UT(TypeNo), ProcNo) then
7317           begin
7318             temp.Free;
7319             MakeError('', ecTypeMismatch, '');
7320             Result := nil;
7321             exit;
7322           end;
7323 {$IFNDEF PS_NOINTERFACES}
7324           end else begin
7325             if not TPSInterfaceType(FType2).Intf.CastToType(AT2UT(TypeNo), ProcNo) then
7326             begin
7327               temp.Free;
7328               MakeError('', ecTypeMismatch, '');
7329               Result := nil;
7330               exit;
7331             end;
7332           end;
7333 {$ENDIF}
7334           Result := TPSValueProcNo.Create;
7335           TPSValueProcNo(Result).Parameters := TPSParameters.Create;
7336           TPSValueProcNo(Result).ResultType := at2ut(TypeNo);
7337           TPSValueProcNo(Result).ProcNo := ProcNo;
7338           with TPSValueProcNo(Result).Parameters.Add do
7339           begin
7340             Val := Temp;
7341             ExpectedType := GetTypeNo(BlockInfo, temp);
7342 {$IFDEF DEBUG}
7343             if not ExpectedType.Used then asm int 3; end;
7344 {$ENDIF}
7345           end;
7346           with TPSValueProcNo(Result).Parameters.Add do
7347           begin
7348             ExpectedType := at2ut(FindBaseType(btu32));
7349 {$IFDEF DEBUG}
7350             if not ExpectedType.Used then asm int 3; end;
7351 {$ENDIF}
7352             Val := TPSValueData.Create;
7353             with TPSValueData(val) do
7354             begin
7355               SetParserPos(FParser);
7356               Data := NewVariant(ExpectedType);
7357               Data.tu32 := at2ut(TypeNo).FinalTypeNo;
7358             end;
7359           end;
7360           FParser.Next;
7361           Exit;
7362         end;
7363         if (FType2=nil) or not IsCompatibleType(TypeNo, FType2, True) then
7364         begin
7365           temp.Free;
7366           MakeError('', ecTypeMismatch, '');
7367           Result := nil;
7368           exit;
7369         end;
7370         FParser.Next;
7371         Result := TPSUnValueOp.Create;
7372         with TPSUnValueOp(Result) do
7373         begin
7374           Operator := otCast;
7375           Val1 := Temp;
7376           SetParserPos(FParser);
7377           aType := AT2UT(TypeNo);
7378         end;
7379 
7380         exit;
7381       end else
7382       if FParser.CurrTokenId <> CSTI_Period then
7383       begin
7384         Result := TPSValueData.Create;
7385         Result.SetParserPos(FParser);
7386         New(dta);
7387         TPSValueData(Result).Data := dta;
7388         InitializeVariant(dta, at2ut(FindBaseType(btType)));
7389         dta.ttype := at2ut(TypeNo);
7390         Exit;
7391       end;
7392       if TypeNo.BaseType <> btClass then
7393       begin
7394         Result := nil;
7395         MakeError('', ecClassTypeExpected, '');
7396         Exit;
7397       end;
7398       FParser.Next;
7399       if not TPSClassType(TypeNo).Cl.ClassFunc_Find(FParser.GetToken, Idx) then
7400       begin
7401         Result := nil;
7402         MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
7403         Exit;
7404       end;
7405       FParser.Next;
7406       TPSClassType(TypeNo).Cl.ClassFunc_Call(Idx, ProcNo);
7407       Temp := TPSValueData.Create;
7408       with TPSValueData(Temp) do
7409       begin
7410         Data := NewVariant(at2ut(FindBaseType(btu32)));
7411         Data.tu32 := at2ut(TypeNo).FinalTypeNo;
7412       end;
7413       ResV := ReadProcParameters(ProcNo, Temp);
7414       if ResV <> nil then
7415       begin
7416         TPSValueProc(Resv).ResultType := at2ut(TypeNo);
7417         Result := Resv;
7418       end else begin
7419         Result := nil;
7420       end;
7421     end;
7422 
GetIdentifiernull7423   function GetIdentifier(const FType: Byte): TPSValue;
7424     {
7425       FType:
7426         0 = Anything
7427         1 = Only variables
7428         2 = Not constants
7429     }
7430 
7431 
7432   var
7433     vt: TPSVariableType;
7434     vno: Cardinal;
7435     TWith, Temp: TPSValue;
7436     l, h: Longint;
7437     s, u: tbtString;
7438     t: TPSConstant;
7439     Temp1: TPSType;
7440     temp2: CArdinal;
7441     bi: TPSBlockInfo;
7442     lOldRecCount: Integer;
7443 
7444   begin
7445     s := FParser.GetToken;
7446 
7447     if FType <> 1 then
7448     begin
7449       bi := BlockInfo;
7450       while bi <> nil do
7451       begin
7452         for l := bi.WithList.Count -1 downto 0 do
7453         begin
7454           TWith := TPSValueAllocatedStackVar.Create;
7455           TPSValueAllocatedStackVar(TWith).LocalVarNo := TPSValueAllocatedStackVar(TPSValueReplace(bi.WithList[l]).NewValue).LocalVarNo;
7456           Temp := TWith;
7457           VNo := TPSValueAllocatedStackVar(Temp).LocalVarNo;
7458           lOldRecCount := TPSValueVar(TWith).GetRecCount;
7459           vt := ivtVariable;
7460           if Temp = TWith then CheckFurther(TWith, True);
7461           if Temp = TWith then CheckClass(TWith, vt, vno, True);
7462           if Temp = TWith then  CheckExtClass(TWith, vt, vno, True);
7463           if (Temp <> TWith) or (Cardinal(lOldRecCount) <> TPSValueVar(TWith).GetRecCount) then
7464           begin
7465             repeat
7466               Temp := TWith;
7467               if TWith <> nil then CheckFurther(TWith, False);
7468               if TWith <> nil then CheckClass(TWith, vt, vno, False);
7469               if TWith <> nil then  CheckExtClass(TWith, vt, vno, False);
7470 {$IFNDEF PS_NOIDISPATCH}if TWith <> nil then CheckIntf(TWith, vt, vno, False);{$ENDIF}
7471               if TWith <> nil then CheckProcCall(TWith);
7472               if TWith <> nil then CheckClassArrayProperty(TWith, vt, vno);
7473               vno := InvalidVal;
7474             until (TWith = nil) or (Temp = TWith);
7475             Result := TWith;
7476             Exit;
7477           end;
7478           TWith.Free;
7479         end;
7480         bi := bi.FOwner;
7481       end;
7482     end;
7483 
7484     if s = 'RESULT' then
7485     begin
7486       if BlockInfo.proc.Decl.Result = nil then
7487       begin
7488         Result := nil;
7489         MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
7490       end
7491       else
7492       begin
7493         BlockInfo.Proc.ResultUse;
7494         Result := TPSValueParamVar.Create;
7495         with TPSValueParamVar(Result) do
7496         begin
7497           SetParserPos(FParser);
7498           ParamNo := 0;
7499         end;
7500         vno := 0;
7501         vt := ivtParam;
7502         if @FOnUseVariable <> nil then
7503           FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, '');
7504         FParser.Next;
7505         repeat
7506           Temp := Result;
7507           if Result <> nil then CheckFurther(Result, False);
7508           if Result <> nil then CheckClass(Result, vt, vno, False);
7509           if Result <> nil then  CheckExtClass(Result, vt, vno, False);
7510 {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
7511           if Result <> nil then CheckProcCall(Result);
7512           if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
7513           vno := InvalidVal;
7514         until (Result = nil) or (Temp = Result);
7515       end;
7516       exit;
7517     end;
7518     if BlockInfo.Proc.Decl.Result = nil then
7519       l := 0
7520     else
7521       l := 1;
7522     for h := 0 to BlockInfo.proc.Decl.ParamCount -1 do
7523     begin
7524       if BlockInfo.proc.Decl.Params[h].Name = s then
7525       begin
7526         Result := TPSValueParamVar.Create;
7527         with TPSValueParamVar(Result) do
7528         begin
7529           SetParserPos(FParser);
7530           ParamNo := l;
7531         end;
7532         vt := ivtParam;
7533         vno := L;
7534         if @FOnUseVariable <> nil then
7535           FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, '');
7536         FParser.Next;
7537         repeat
7538           Temp := Result;
7539           if Result <> nil then CheckFurther(Result, False);
7540           if Result <> nil then CheckClass(Result, vt, vno, False);
7541           if Result <> nil then  CheckExtClass(Result, vt, vno, False);
7542 {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
7543           if Result <> nil then CheckProcCall(Result);
7544           if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
7545           vno := InvalidVal;
7546         until (Result = nil) or (Temp = Result);
7547         exit;
7548       end;
7549       Inc(l);
7550       GRFW(u);
7551     end;
7552 
7553     h := MakeHash(s);
7554 
7555     for l := 0 to BlockInfo.Proc.ProcVars.Count - 1 do
7556     begin
7557       if (PIFPSProcVar(BlockInfo.Proc.ProcVars[l]).NameHash = h) and
7558         (PIFPSProcVar(BlockInfo.Proc.ProcVars[l]).Name = s) then
7559       begin
7560         PIFPSProcVar(BlockInfo.Proc.ProcVars[l]).Use;
7561         vno := l;
7562         vt := ivtVariable;
7563         if @FOnUseVariable <> nil then
7564           FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, '');
7565         Result := TPSValueLocalVar.Create;
7566         with TPSValueLocalVar(Result) do
7567         begin
7568           LocalVarNo := l;
7569           SetParserPos(FParser);
7570         end;
7571         FParser.Next;
7572         repeat
7573           Temp := Result;
7574           if Result <> nil then CheckFurther(Result, False);
7575           if Result <> nil then CheckClass(Result, vt, vno, False);
7576           if Result <> nil then  CheckExtClass(Result, vt, vno, False);
7577 {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
7578           if Result <> nil then CheckProcCall(Result);
7579           if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
7580           vno := InvalidVal;
7581         until (Result = nil) or (Temp = Result);
7582 
7583         exit;
7584       end;
7585     end;
7586 
7587     for l := 0 to FVars.Count - 1 do
7588     begin
7589       if (TPSVar(FVars[l]).NameHash = h) and
7590         (TPSVar(FVars[l]).Name = s)    {$IFDEF PS_USESSUPPORT} and
7591         (IsInLocalUnitList(TPSVar(FVars[l]).FDeclareUnit)){$ENDIF} then
7592       begin
7593         TPSVar(FVars[l]).Use;
7594         Result := TPSValueGlobalVar.Create;
7595         with TPSValueGlobalVar(Result) do
7596         begin
7597           SetParserPos(FParser);
7598           GlobalVarNo := l;
7599 
7600         end;
7601         vt := ivtGlobal;
7602         vno := l;
7603         if @FOnUseVariable <> nil then
7604           FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, '');
7605         FParser.Next;
7606         repeat
7607           Temp := Result;
7608           if Result <> nil then CheckNotificationVariant(Result);
7609           if Result <> nil then CheckFurther(Result, False);
7610           if Result <> nil then CheckClass(Result, vt, vno, False);
7611           if Result <> nil then  CheckExtClass(Result, vt, vno, False);
7612 {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
7613           if Result <> nil then CheckProcCall(Result);
7614           if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
7615           vno := InvalidVal;
7616         until (Result = nil) or (Temp = Result);
7617         exit;
7618       end;
7619     end;
7620     Temp1 := FindType(FParser.GetToken);
7621     if Temp1 <> nil then
7622     begin
7623       l := FParser.CurrTokenPos;
7624       if FType = 1 then
7625       begin
7626         Result := nil;
7627         MakeError('', ecVariableExpected, FParser.OriginalToken);
7628         exit;
7629       end;
7630       vt := ivtGlobal;
7631       vno := InvalidVal;
7632       FParser.Next;
7633       Result := CheckClassType(Temp1, l);
7634         repeat
7635           Temp := Result;
7636           if Result <> nil then CheckFurther(Result, False);
7637           if Result <> nil then CheckClass(Result, vt, vno, False);
7638           if Result <> nil then  CheckExtClass(Result, vt, vno, False);
7639 {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
7640           if Result <> nil then CheckProcCall(Result);
7641           if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
7642           vno := InvalidVal;
7643         until (Result = nil) or (Temp = Result);
7644 
7645       exit;
7646     end;
7647     Temp2 := FindProc(FParser.GetToken);
7648     if Temp2 <> InvalidVal then
7649     begin
7650       if FType = 1 then
7651       begin
7652         Result := nil;
7653         MakeError('', ecVariableExpected, FParser.OriginalToken);
7654         exit;
7655       end;
7656       FParser.Next;
7657       Result := ReadProcParameters(Temp2, nil);
7658       if Result = nil then
7659         exit;
7660       Result.SetParserPos(FParser);
7661       vt := ivtGlobal;
7662       vno := InvalidVal;
7663       repeat
7664         Temp := Result;
7665         if Result <> nil then CheckFurther(Result, False);
7666         if Result <> nil then CheckClass(Result, vt, vno, False);
7667         if Result <> nil then  CheckExtClass(Result, vt, vno, False);
7668 {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
7669         if Result <> nil then CheckProcCall(Result);
7670         if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
7671         vno := InvalidVal;
7672       until (Result = nil) or (Temp = Result);
7673       exit;
7674     end;
7675     for l := 0 to FConstants.Count -1 do
7676     begin
7677       t := TPSConstant(FConstants[l]);
7678       if (t.NameHash = h) and (t.Name = s)     {$IFDEF PS_USESSUPPORT}  and
7679         (IsInLocalUnitList(t.FDeclareUnit)) {$ENDIF} then
7680       begin
7681         if FType <> 0 then
7682         begin
7683           Result := nil;
7684           MakeError('', ecVariableExpected, FParser.OriginalToken);
7685           exit;
7686         end;
7687         fparser.next;
7688         Result := TPSValueData.Create;
7689         with TPSValueData(Result) do
7690         begin
7691           SetParserPos(FParser);
7692           Data := NewVariant(at2ut(t.Value.FType));
7693           CopyVariantContents(t.Value, Data);
7694         end;
7695         vt := ivtGlobal;
7696         vno := InvalidVal;
7697         repeat
7698           Temp := Result;
7699           if Result <> nil then CheckFurther(Result, False);
7700           if Result <> nil then CheckClass(Result, vt, vno, False);
7701           if Result <> nil then  CheckExtClass(Result, vt, vno, False);
7702 {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
7703           if Result <> nil then CheckProcCall(Result);
7704           if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
7705           vno := InvalidVal;
7706         until (Result = nil) or (Temp = Result);
7707         exit;
7708       end;
7709     end;
7710     Result := nil;
7711     MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
7712   end;
7713 
calcnull7714   function calc(endOn: TPSPasToken): TPSValue;
7715     function TryEvalConst(var P: TPSValue): Boolean; forward;
7716 
7717 
7718     function ReadExpression: TPSValue; forward;
7719     function ReadTerm: TPSValue; forward;
ReadFactornull7720     function ReadFactor: TPSValue;
7721     var
7722       NewVar: TPSValue;
7723       NewVarU: TPSUnValueOp;
7724       Proc: TPSProcedure;
7725       function ReadArray: Boolean;
7726       var
7727         tmp: TPSValue;
7728       begin
7729         FParser.Next;
7730         NewVar := TPSValueArray.Create;
7731         NewVar.SetParserPos(FParser);
7732         if FParser.CurrTokenID <> CSTI_CloseBlock then
7733         begin
7734           while True do
7735           begin
7736             tmp := nil;
7737             Tmp := ReadExpression();
7738             if Tmp = nil then
7739             begin
7740               Result := False;
7741               NewVar.Free;
7742               exit;
7743             end;
7744             if not TryEvalConst(tmp) then
7745             begin
7746               tmp.Free;
7747               NewVar.Free;
7748               Result := False;
7749               exit;
7750             end;
7751             TPSValueArray(NewVar).Add(tmp);
7752             if FParser.CurrTokenID = CSTI_CloseBlock then Break;
7753             if FParser.CurrTokenID <> CSTI_Comma then
7754             begin
7755               MakeError('', ecCloseBlockExpected, '');
7756               NewVar.Free;
7757               Result := False;
7758               exit;
7759             end;
7760             FParser.Next;
7761           end;
7762         end;
7763         FParser.Next;
7764         Result := True;
7765       end;
7766 
CallAssignednull7767       function CallAssigned(P: TPSValue): TPSValue;
7768       var
7769         temp: TPSValueProcNo;
7770       begin
7771         temp := TPSValueProcNo.Create;
7772         temp.ProcNo := FindProc('!ASSIGNED');
7773         temp.ResultType := at2ut(FDefaultBoolType);
7774         temp.Parameters := TPSParameters.Create;
7775         with Temp.Parameters.Add do
7776         begin
7777           Val := p;
7778           ExpectedType := GetTypeNo(BlockInfo, p);
7779 {$IFDEF DEBUG}
7780           if not ExpectedType.Used then asm int 3; end;
7781 {$ENDIF}
7782           FParamMode := pmIn;
7783         end;
7784         Result := Temp;
7785       end;
7786 
CallSuccnull7787       function CallSucc(P: TPSValue): TPSValue;
7788       var
7789         temp: TPSBinValueOp;
7790       begin
7791         temp := TPSBinValueOp.Create;
7792         temp.SetParserPos(FParser);
7793         temp.FOperator := otAdd;
7794         temp.FVal2 := TPSValueData.Create;
7795         TPSValueData(Temp.FVal2).Data := NewVariant(FindBaseType(bts32));
7796         TPSValueData(Temp.FVal2).Data.ts32 := 1;
7797         temp.FVal1 := p;
7798         Temp.FType := GetTypeNo(BlockInfo, P);
7799         result := temp;
7800       end;
7801 
CallPrednull7802       function CallPred(P: TPSValue): TPSValue;
7803       var
7804         temp: TPSBinValueOp;
7805       begin
7806         temp := TPSBinValueOp.Create;
7807         temp.SetParserPos(FParser);
7808         temp.FOperator := otSub;
7809         temp.FVal2 := TPSValueData.Create;
7810         TPSValueData(Temp.FVal2).Data := NewVariant(FindBaseType(bts32));
7811         TPSValueData(Temp.FVal2).Data.ts32 := 1;
7812         temp.FVal1 := p;
7813         Temp.FType := GetTypeNo(BlockInfo, P);
7814         result := temp;
7815       end;
7816 
7817     begin
7818       case fParser.CurrTokenID of
7819         CSTI_OpenBlock:
7820           begin
7821             if not ReadArray then
7822             begin
7823               Result := nil;
7824               exit;
7825             end;
7826           end;
7827         CSTII_Not:
7828         begin
7829           FParser.Next;
7830           NewVar := ReadFactor;
7831           if NewVar = nil then
7832           begin
7833             Result := nil;
7834             exit;
7835           end;
7836           NewVarU := TPSUnValueOp.Create;
7837           NewVarU.SetParserPos(FParser);
7838           NewVarU.aType := GetTypeNo(BlockInfo, NewVar);
7839           NewVarU.Operator := otNot;
7840           NewVarU.Val1 := NewVar;
7841           NewVar := NewVarU;
7842         end;
7843         CSTI_Plus:
7844         begin
7845           FParser.Next;
7846           NewVar := ReadTerm;
7847           if NewVar = nil then
7848           begin
7849             Result := nil;
7850             exit;
7851           end;
7852         end;
7853         CSTI_Minus:
7854         begin
7855           FParser.Next;
7856           NewVar := ReadTerm;
7857           if NewVar = nil then
7858           begin
7859             Result := nil;
7860             exit;
7861           end;
7862           NewVarU := TPSUnValueOp.Create;
7863           NewVarU.SetParserPos(FParser);
7864           NewVarU.aType := GetTypeNo(BlockInfo, NewVar);
7865           NewVarU.Operator := otMinus;
7866           NewVarU.Val1 := NewVar;
7867           NewVar := NewVarU;
7868         end;
7869         CSTII_Nil:
7870           begin
7871             FParser.Next;
7872             NewVar := TPSValueNil.Create;
7873             NewVar.SetParserPos(FParser);
7874           end;
7875         CSTI_AddressOf:
7876           begin
7877             FParser.Next;
7878             if FParser.CurrTokenID <> CSTI_Identifier then
7879             begin
7880               MakeError('', ecIdentifierExpected, '');
7881               Result := nil;
7882               exit;
7883             end;
7884             NewVar := TPSValueProcPtr.Create;
7885             NewVar.SetParserPos(FParser);
7886             TPSValueProcPtr(NewVar).ProcPtr := FindProc(FParser.GetToken);
7887             if TPSValueProcPtr(NewVar).ProcPtr = InvalidVal then
7888             begin
7889               MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
7890               NewVar.Free;
7891               Result := nil;
7892               exit;
7893             end;
7894             Proc := FProcs[TPSValueProcPtr(NewVar).ProcPtr];
7895             if Proc.ClassType <> TPSInternalProcedure then
7896             begin
7897               MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
7898               NewVar.Free;
7899               Result := nil;
7900               exit;
7901             end;
7902             FParser.Next;
7903           end;
7904         CSTI_OpenRound:
7905           begin
7906             FParser.Next;
7907             NewVar := ReadExpression();
7908             if NewVar = nil then
7909             begin
7910               Result := nil;
7911               exit;
7912             end;
7913             if FParser.CurrTokenId <> CSTI_CloseRound then
7914             begin
7915               NewVar.Free;
7916               Result := nil;
7917               MakeError('', ecCloseRoundExpected, '');
7918               exit;
7919             end;
7920             FParser.Next;
7921           end;
7922         CSTI_Char, CSTI_String:
7923           begin
7924             NewVar := TPSValueData.Create;
7925             NewVar.SetParserPos(FParser);
7926             TPSValueData(NewVar).Data := ReadString;
7927             if TPSValueData(NewVar).Data = nil then
7928             begin
7929               NewVar.Free;
7930               Result := nil;
7931               exit;
7932             end;
7933           end;
7934         CSTI_HexInt, CSTI_Integer:
7935           begin
7936             NewVar := TPSValueData.Create;
7937             NewVar.SetParserPos(FParser);
7938             TPSValueData(NewVar).Data := ReadInteger(FParser.GetToken);
7939             FParser.Next;
7940           end;
7941         CSTI_Real:
7942           begin
7943             NewVar := TPSValueData.Create;
7944             NewVar.SetParserPos(FParser);
7945             TPSValueData(NewVar).Data := ReadReal(FParser.GetToken);
7946             FParser.Next;
7947           end;
7948         CSTII_Ord:
7949           begin
7950             FParser.Next;
7951             if fParser.Currtokenid <> CSTI_OpenRound then
7952             begin
7953               Result := nil;
7954               MakeError('', ecOpenRoundExpected, '');
7955               exit;
7956             end;
7957             FParser.Next;
7958             NewVar := ReadExpression();
7959             if NewVar = nil then
7960             begin
7961               Result := nil;
7962               exit;
7963             end;
7964             if FParser.CurrTokenId <> CSTI_CloseRound then
7965             begin
7966               NewVar.Free;
7967               Result := nil;
7968               MakeError('', ecCloseRoundExpected, '');
7969               exit;
7970             end;
7971             if not ((GetTypeNo(BlockInfo, NewVar).BaseType = btChar) or
7972             {$IFNDEF PS_NOWIDESTRING} (GetTypeNo(BlockInfo, NewVar).BaseType = btWideChar) or{$ENDIF}
7973             (GetTypeNo(BlockInfo, NewVar).BaseType = btEnum) or (IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType))) then
7974             begin
7975               NewVar.Free;
7976               Result := nil;
7977               MakeError('', ecTypeMismatch, '');
7978               exit;
7979             end;
7980             NewVarU := TPSUnValueOp.Create;
7981             NewVarU.SetParserPos(FParser);
7982             NewVarU.Operator := otCast;
7983             NewVarU.FType := at2ut(FindBaseType(btu32));
7984             NewVarU.Val1 := NewVar;
7985             NewVar := NewVarU;
7986             FParser.Next;
7987           end;
7988         CSTII_Chr:
7989           begin
7990             FParser.Next;
7991             if fParser.Currtokenid <> CSTI_OpenRound then
7992             begin
7993               Result := nil;
7994               MakeError('', ecOpenRoundExpected, '');
7995               exit;
7996             end;
7997             FParser.Next;
7998             NewVar := ReadExpression();
7999             if NewVar = nil then
8000             begin
8001               Result := nil;
8002               exit;
8003             end;
8004             if FParser.CurrTokenId <> CSTI_CloseRound then
8005             begin
8006               NewVar.Free;
8007               Result := nil;
8008               MakeError('', ecCloseRoundExpected, '');
8009               exit;
8010             end;
8011             if not (IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType)) then
8012             begin
8013               NewVar.Free;
8014               Result := nil;
8015               MakeError('', ecTypeMismatch, '');
8016               exit;
8017             end;
8018             NewVarU := TPSUnValueOp.Create;
8019             NewVarU.SetParserPos(FParser);
8020             NewVarU.Operator := otCast;
8021             NewVarU.FType := at2ut(FindBaseType(btChar));
8022             NewVarU.Val1 := NewVar;
8023             NewVar := NewVarU;
8024             FParser.Next;
8025           end;
8026         CSTI_Identifier:
8027           begin
8028             if FParser.GetToken = 'SUCC' then
8029             begin
8030               FParser.Next;
8031               if FParser.CurrTokenID <> CSTI_OpenRound then
8032               begin
8033                 Result := nil;
8034                 MakeError('', ecOpenRoundExpected, '');
8035                 exit;
8036               end;
8037               FParser.Next;
8038               NewVar := ReadExpression;
8039               if NewVar = nil then
8040               begin
8041                 result := nil;
8042                 exit;
8043               end;
8044               if (GetTypeNo(BlockInfo, NewVar) = nil) or (not IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType) and
8045                 (GetTypeNo(BlockInfo, NewVar).BaseType <> btEnum)) then
8046               begin
8047                 NewVar.Free;
8048                 Result := nil;
8049                 MakeError('', ecTypeMismatch, '');
8050                 exit;
8051               end;
8052               if FParser.CurrTokenID <> CSTI_CloseRound then
8053               begin
8054                 NewVar.Free;
8055                 Result := nil;
8056                 MakeError('', eccloseRoundExpected, '');
8057                 exit;
8058               end;
8059               NewVar := CallSucc(NewVar);
8060               FParser.Next;
8061             end else
8062             if FParser.GetToken = 'PRED' then
8063             begin
8064               FParser.Next;
8065               if FParser.CurrTokenID <> CSTI_OpenRound then
8066               begin
8067                 Result := nil;
8068                 MakeError('', ecOpenRoundExpected, '');
8069                 exit;
8070               end;
8071               FParser.Next;
8072               NewVar := ReadExpression;
8073               if NewVar = nil then
8074               begin
8075                 result := nil;
8076                 exit;
8077               end;
8078               if (GetTypeNo(BlockInfo, NewVar) = nil) or (not IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType) and
8079                 (GetTypeNo(BlockInfo, NewVar).BaseType <> btEnum)) then
8080               begin
8081                 NewVar.Free;
8082                 Result := nil;
8083                 MakeError('', ecTypeMismatch, '');
8084                 exit;
8085               end;
8086               if FParser.CurrTokenID <> CSTI_CloseRound then
8087               begin
8088                 NewVar.Free;
8089                 Result := nil;
8090                 MakeError('', eccloseRoundExpected, '');
8091                 exit;
8092               end;
8093               NewVar := CallPred(NewVar);
8094               FParser.Next;
8095             end else
8096             if FParser.GetToken = 'ASSIGNED' then
8097             begin
8098               FParser.Next;
8099               if FParser.CurrTokenID <> CSTI_OpenRound then
8100               begin
8101                 Result := nil;
8102                 MakeError('', ecOpenRoundExpected, '');
8103                 exit;
8104               end;
8105               FParser.Next;
8106               NewVar := GetIdentifier(0);
8107               if NewVar = nil then
8108               begin
8109                 result := nil;
8110                 exit;
8111               end;
8112               if (GetTypeNo(BlockInfo, NewVar) = nil) or
8113                 ((GetTypeNo(BlockInfo, NewVar).BaseType <> btClass) and
8114                 (GetTypeNo(BlockInfo, NewVar).BaseType <> btInterface) and
8115                 (GetTypeNo(BlockInfo, NewVar).BaseType <> btPChar) and
8116                 (GetTypeNo(BlockInfo, NewVar).BaseType <> btString)) then
8117               begin
8118                 NewVar.Free;
8119                 Result := nil;
8120                 MakeError('', ecTypeMismatch, '');
8121                 exit;
8122               end;
8123               if FParser.CurrTokenID <> CSTI_CloseRound then
8124               begin
8125                 NewVar.Free;
8126                 Result := nil;
8127                 MakeError('', eccloseRoundExpected, '');
8128                 exit;
8129               end;
8130               NewVar := CallAssigned(NewVar);
8131               FParser.Next;
8132             end  else
8133             begin
8134               NewVar := GetIdentifier(0);
8135               if NewVar = nil then
8136               begin
8137                 Result := nil;
8138                 exit;
8139               end;
8140             end;
8141           end;
8142       else
8143         begin
8144           MakeError('', ecSyntaxError, '');
8145           Result := nil;
8146           exit;
8147         end;
8148       end; {case}
8149       Result := NewVar;
8150     end; // ReadFactor
8151 
GetResultTypenull8152     function GetResultType(p1, P2: TPSValue; Cmd: TPSBinOperatorType): TPSType;
8153     var
8154       pp, t1, t2: PIFPSType;
8155     begin
8156       t1 := GetTypeNo(BlockInfo, p1);
8157       t2 := GetTypeNo(BlockInfo, P2);
8158       if (t1 = nil) or (t2 = nil) then
8159       begin
8160         if ((p1.ClassType = TPSValueNil) or (p2.ClassType = TPSValueNil)) and ((t1 <> nil) or (t2 <> nil)) then
8161         begin
8162           if p1.ClassType = TPSValueNil then
8163             pp := t2
8164           else
8165             pp := t1;
8166           if (pp.BaseType = btPchar) or (pp.BaseType = btString) or (pp.BaseType = btClass) {$IFNDEF PS_NOINTERFACES}or (pp.BaseType =btInterface){$ENDIF} or (pp.BaseType = btProcPtr) then
8167             Result := AT2UT(FDefaultBoolType)
8168           else
8169             Result := nil;
8170           exit;
8171         end;
8172         Result := nil;
8173         exit;
8174       end;
8175       case Cmd of
8176         otAdd: {plus}
8177           begin
8178             if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
8179               ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
8180               (t2.BaseType = btString) or
8181               {$IFNDEF PS_NOWIDESTRING}
8182               (t2.BaseType = btwideString) or
8183               (t2.BaseType = btUnicodestring) or
8184               (t2.BaseType = btwidechar) or
8185               {$ENDIF}
8186               (t2.BaseType = btPchar) or
8187               (t2.BaseType = btChar) or
8188               (isIntRealType(t2.BaseType))) then
8189               Result := t1
8190             else
8191             if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and (
8192               ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
8193               (t1.BaseType = btString) or
8194               {$IFNDEF PS_NOWIDESTRING}
8195               (t1.BaseType = btUnicodestring) or
8196               (t1.BaseType = btwideString) or
8197               (t1.BaseType = btwidechar) or
8198               {$ENDIF}
8199               (t1.BaseType = btPchar) or
8200               (t1.BaseType = btChar) or
8201               (isIntRealType(t1.BaseType))) then
8202               Result := t2
8203             else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) then
8204               Result := t1
8205             else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
8206               Result := t1
8207             else if IsIntRealType(t1.BaseType) and
8208               IsIntRealType(t2.BaseType) then
8209             begin
8210               if IsRealType(t1.BaseType) then
8211                 Result := t1
8212               else
8213                 Result := t2;
8214             end
8215             else if (t1.basetype = btSet) and (t2.Name = 'TVARIANTARRAY') then
8216               Result := t1
8217             else if (t2.basetype = btSet) and (t1.Name = 'TVARIANTARRAY') then
8218               Result := t2
8219             else if ((t1.BaseType = btPchar) or(t1.BaseType = btString) or (t1.BaseType = btChar)) and ((t2.BaseType = btPchar) or(t2.BaseType = btString) or (t2.BaseType = btChar)) then
8220               Result := at2ut(FindBaseType(btString))
8221             {$IFNDEF PS_NOWIDESTRING}
8222             else if ((t1.BaseType = btString) or (t1.BaseType = btChar) or (t1.BaseType = btPchar)or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar) or (t1.BaseType = btUnicodeString)) and
8223             ((t2.BaseType = btString) or (t2.BaseType = btChar) or (t2.BaseType = btPchar) or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar) or (t2.BaseType = btUnicodeString)) then
8224               Result := at2ut(FindBaseType(btUnicodeString))
8225             {$ENDIF}
8226             else
8227               Result := nil;
8228           end;
8229 
8230         otSub, otMul, otIntDiv, otDiv: { -  * / }
8231           begin
8232             if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
8233               ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
8234               (isIntRealType(t2.BaseType))) then
8235             begin
8236               Result := t1;
8237 {$IFDEF PS_DELPHIDIV}
8238               if Cmd = otDiv then
8239                 result := FindBaseType(btExtended);
8240 {$ENDIF}
8241             end
8242             else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) and ((cmd = otSub) or (cmd = otMul))  then
8243               Result := t1
8244             else if (t1.basetype = btSet) and (t2.Name = 'TVARIANTARRAY') and ((cmd = otSub) or (cmd = otMul)) then
8245               Result := t1
8246             else if (t2.basetype = btSet) and (t1.Name = 'TVARIANTARRAY') and ((cmd = otSub) or (cmd = otMul)) then
8247               Result := t2
8248             else
8249             if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and (
8250               ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
8251               (isIntRealType(t1.BaseType))) then
8252             begin
8253               Result := t2;
8254 {$IFDEF PS_DELPHIDIV}
8255               if Cmd = otDiv then
8256                 result := FindBaseType(btExtended);
8257 {$ENDIF}
8258             end
8259             else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then begin
8260               Result := t1;
8261 {$IFDEF PS_DELPHIDIV}
8262               if Cmd = otDiv then
8263                 result := FindBaseType(btExtended);
8264 {$ENDIF}
8265             end else if IsIntRealType(t1.BaseType) and
8266               IsIntRealType(t2.BaseType) then
8267             begin
8268               if IsRealType(t1.BaseType) then
8269                 Result := t1
8270               else
8271                 Result := t2;
8272 {$IFDEF PS_DELPHIDIV}
8273               if Cmd = otIntDiv then //intdiv only works
8274                 result := nil;
8275 {$ENDIF}
8276             end
8277             else
8278               Result := nil;
8279           end;
8280         otAnd, otOr, otXor: {and,or,xor}
8281           begin
8282             if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
8283               ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
8284               (isIntType(t2.BaseType))) then
8285               Result := t1
8286             else
8287             if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and (
8288               ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
8289               (isIntType(t1.BaseType))) then
8290               Result := t2
8291             else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
8292               Result := t1
8293             else if (IsBoolean(t1)) and ((t2 = t1)  or ((t2.BaseType = btVariant)
8294               or (t2.BaseType = btNotificationVariant))) then
8295             begin
8296               Result := t1;
8297               if ((p1.ClassType = TPSValueData) or (p2.ClassType = TPSValueData)) then
8298               begin
8299                 if cmd = otAnd then {and}
8300                 begin
8301                   if p1.ClassType = TPSValueData then
8302                   begin
8303                     if (TPSValueData(p1).FData^.tu8 <> 0) then
8304                     begin
8305                       with MakeWarning('', ewIsNotNeeded, '"True and"') do
8306                       if p1.Pos>0 then
8307                       begin
8308                         FRow := p1.Row;
8309                         FCol := p1.Col;
8310                         FPosition := p1.Pos;
8311                       end;
8312                     end else
8313                     begin
8314                       with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'False') do
8315                       begin
8316                         FRow := p1.Row;
8317                         FCol := p1.Col;
8318                         FPosition := p1.Pos;
8319                       end;
8320                     end;
8321                   end else begin
8322                     if (TPSValueData(p2).Data.tu8 <> 0) then
8323                     begin
8324                       with MakeWarning('', ewIsNotNeeded, '"and True"') do
8325                       if p2.Pos>0 then
8326                       begin
8327                         FRow := p2.Row;
8328                         FCol := p2.Col;
8329                         FPosition := p2.Pos;
8330                       end;
8331                     end
8332                     else
8333                     begin
8334                       with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'False') do
8335                       begin
8336                         FRow := p2.Row;
8337                         FCol := p2.Col;
8338                         FPosition := p2.Pos;
8339                       end;
8340                     end;
8341                   end;
8342                 end else if cmd = otOr then {or}
8343                 begin
8344                   if p1.ClassType = TPSValueData then
8345                   begin
8346                     if (TPSValueData(p1).Data.tu8 <> 0) then
8347                     begin
8348                       with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'True') do
8349                       begin
8350                         FRow := p1.Row;
8351                         FCol := p1.Col;
8352                         FPosition := p1.Pos;
8353                       end;
8354                     end
8355                     else
8356                     begin
8357                       with MakeWarning('', ewIsNotNeeded, '"False or"') do
8358                       begin
8359                         FRow := p1.Row;
8360                         FCol := p1.Col;
8361                         FPosition := p1.Pos;
8362                       end;
8363                     end
8364                   end else begin
8365                     if (TPSValueData(p2).Data.tu8 <> 0) then
8366                     begin
8367                       with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'True') do
8368                       begin
8369                         FRow := p2.Row;
8370                         FCol := p2.Col;
8371                         FPosition := p1.Pos;
8372                       end;
8373                     end
8374                     else
8375                     begin
8376                       with MakeWarning('', ewIsNotNeeded, '"or False"') do
8377                       begin
8378                         FRow := p2.Row;
8379                         FCol := p2.Col;
8380                         FPosition := p2.Pos;
8381                       end;
8382                     end
8383                   end;
8384                 end;
8385               end;
8386             end else
8387               Result := nil;
8388           end;
8389         otMod, otShl, otShr: {mod,shl,shr}
8390           begin
8391             if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
8392               ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
8393               (isIntType(t2.BaseType))) then
8394               Result := t1
8395             else
8396             if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and (
8397               ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
8398               (isIntType(t1.BaseType))) then
8399               Result := t2
8400             else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
8401               Result :=  t1
8402             else
8403               Result := nil;
8404           end;
8405         otGreater, otLess, otGreaterEqual, otLessEqual: { >=, <=, >, <}
8406           begin
8407             if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
8408               ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
8409               (t2.BaseType = btString) or
8410               (t2.BaseType = btPchar) or
8411               (t2.BaseType = btChar) or
8412               (isIntRealType(t2.BaseType))) then
8413               Result := FDefaultBoolType
8414             else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) and ((cmd = otGreaterEqual) or (cmd = otLessEqual))  then
8415               Result := FDefaultBoolType
8416             else
8417             if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and (
8418               ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
8419               (t1.BaseType = btString) or
8420               (t1.BaseType = btPchar) or
8421               (t1.BaseType = btChar) or
8422               (isIntRealType(t1.BaseType))) then
8423               Result := FDefaultBoolType
8424             else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
8425               Result := FDefaultBoolType
8426             else if IsIntRealType(t1.BaseType) and
8427               IsIntRealType(t2.BaseType) then
8428               Result := FDefaultBoolType
8429             else if
8430             ((t1.BaseType = btString) or (t1.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar) or (t1.BaseType = btUnicodestring){$ENDIF}) and
8431             ((t2.BaseType = btString) or (t2.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar) or (t2.BaseType = btUnicodestring){$ENDIF}) then
8432               Result := FDefaultBoolType
8433             else if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) then
8434               Result := FDefaultBoolType
8435             else
8436               Result := nil;
8437           end;
8438         otEqual, otNotEqual: {=, <>}
8439           begin
8440             if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
8441               ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
8442               (t2.BaseType = btString) or
8443               (t2.BaseType = btPchar) or
8444               (t2.BaseType = btChar) or
8445               (isIntRealType(t2.BaseType))) then
8446               Result := FDefaultBoolType
8447             else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) then
8448               Result := FDefaultBoolType
8449             else
8450             if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and (
8451               ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
8452               (t1.BaseType = btString) or
8453               (t1.BaseType = btPchar) or
8454               (t1.BaseType = btChar) or
8455               (isIntRealType(t1.BaseType))) then
8456               Result := FDefaultBoolType
8457             else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
8458               Result := FDefaultBoolType
8459             else if IsIntRealType(t1.BaseType) and
8460               IsIntRealType(t2.BaseType) then
8461               Result := FDefaultBoolType
8462             else if
8463             ((t1.BaseType = btString) or (t1.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar)  or (t1.BaseType = btUnicodestring){$ENDIF}) and
8464             ((t2.BaseType = btString) or (t2.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar)  or (t2.BaseType = btUnicodestring){$ENDIF}) then
8465               Result := FDefaultBoolType
8466             else if (t1.basetype = btSet) and (t2.Name = 'TVARIANTARRAY') then
8467               Result := FDefaultBoolType
8468             else if (t2.basetype = btSet) and (t1.Name = 'TVARIANTARRAY') then
8469               Result := FDefaultBoolType
8470             else if (t1.BaseType = btEnum) and (t1 = t2) then
8471               Result := FDefaultBoolType
8472             else if (t1.BaseType = btClass) and (t2.BaseType = btClass) then
8473               Result := FDefaultBoolType
8474             else if (t1 = t2) then
8475               Result := FDefaultBoolType
8476             else if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) then
8477               Result := FDefaultBoolType
8478             else Result := nil;
8479           end;
8480         otIn:
8481           begin
8482             if (t2.Name = 'TVARIANTARRAY')  then
8483               Result := FDefaultBoolType
8484             else
8485             if (t2.BaseType = btSet) and (TPSSetType(t2).SetType = t1) then
8486               Result := FDefaultBoolType
8487             else
8488               Result := nil;
8489           end;
8490         otIs:
8491           begin
8492             if t2.BaseType = btType then
8493             begin
8494               Result := FDefaultBoolType
8495             end else
8496             Result := nil;
8497           end;
8498         otAs:
8499           begin
8500             if t2.BaseType = btType then
8501             begin
8502               Result := at2ut(TPSValueData(p2).Data.ttype);
8503             end else
8504               Result := nil;
8505           end;
8506       else
8507         Result := nil;
8508       end;
8509     end;
8510 
8511 
ReadTermnull8512     function ReadTerm: TPSValue;
8513     var
8514       F1, F2: TPSValue;
8515       fType: TPSType;
8516       F: TPSBinValueOp;
8517       Token: TPSPasToken;
8518       Op: TPSBinOperatorType;
8519     begin
8520       F1 := ReadFactor;
8521       if F1 = nil then
8522       begin
8523         Result := nil;
8524         exit;
8525       end;
8526       while FParser.CurrTokenID in [CSTI_Multiply, CSTI_Divide, CSTII_Div, CSTII_Mod, CSTII_And, CSTII_Shl, CSTII_Shr, CSTII_As] do
8527       begin
8528         Token := FParser.CurrTokenID;
8529         FParser.Next;
8530         F2 := ReadFactor;
8531         if f2 = nil then
8532         begin
8533           f1.Free;
8534           Result := nil;
8535           exit;
8536         end;
8537         case Token of
8538           CSTI_Multiply: Op := otMul;
8539           CSTI_Divide: Op := otDiv;
8540           CSTII_div: Op := otIntDiv;
8541           CSTII_mod: Op := otMod;
8542           CSTII_and: Op := otAnd;
8543           CSTII_shl: Op := otShl;
8544           CSTII_shr: Op := otShr;
8545           CSTII_As:  Op := otAs;
8546         else
8547           Op := otAdd;
8548         end;
8549         if (Op = otAs) and (f2 is TPSValueData) and (TPSValueData(f2).Data.FType.BaseType = btType) then begin
8550           fType := TPSValueData(f2).Data.ttype;
8551           f2.Free;
8552           f2 := TPSUnValueOp.Create;
8553           TPSUnValueOp(F2).Val1 := f1;
8554           TPSUnValueOp(F2).SetParserPos(FParser);
8555           TPSUnValueOp(f2).FType := fType;
8556           TPSUnValueOp(f2).Operator := otCast;
8557           f1 := f2;
8558         end else begin
8559           F := TPSBinValueOp.Create;
8560           f.Val1 := F1;
8561           f.Val2 := F2;
8562           f.Operator := Op;
8563           f.aType := GetResultType(F1, F2, Op);
8564           if f.aType = nil then
8565           begin
8566             MakeError('', ecTypeMismatch, '');
8567             f.Free;
8568             Result := nil;
8569             exit;
8570           end;
8571           f1 := f;
8572         end;
8573       end;
8574       Result := F1;
8575     end;  // ReadTerm
8576 
ReadSimpleExpressionnull8577     function ReadSimpleExpression: TPSValue;
8578     var
8579       F1, F2: TPSValue;
8580       F: TPSBinValueOp;
8581       Token: TPSPasToken;
8582       Op: TPSBinOperatorType;
8583     begin
8584       F1 := ReadTerm;
8585       if F1 = nil then
8586       begin
8587         Result := nil;
8588         exit;
8589       end;
8590       while FParser.CurrTokenID in [CSTI_Plus, CSTI_Minus, CSTII_Or, CSTII_Xor] do
8591       begin
8592         Token := FParser.CurrTokenID;
8593         FParser.Next;
8594         F2 := ReadTerm;
8595         if f2 = nil then
8596         begin
8597           f1.Free;
8598           Result := nil;
8599           exit;
8600         end;
8601         case Token of
8602           CSTI_Plus: Op := otAdd;
8603           CSTI_Minus: Op := otSub;
8604           CSTII_or: Op := otOr;
8605           CSTII_xor: Op := otXor;
8606         else
8607           Op := otAdd;
8608         end;
8609         F := TPSBinValueOp.Create;
8610         f.Val1 := F1;
8611         f.Val2 := F2;
8612         f.Operator := Op;
8613         f.aType := GetResultType(F1, F2, Op);
8614         if f.aType = nil then
8615         begin
8616           MakeError('', ecTypeMismatch, '');
8617           f.Free;
8618           Result := nil;
8619           exit;
8620         end;
8621         f1 := f;
8622       end;
8623       Result := F1;
8624     end;  // ReadSimpleExpression
8625 
8626 
ReadExpressionnull8627     function ReadExpression: TPSValue;
8628     var
8629       F1, F2: TPSValue;
8630       F: TPSBinValueOp;
8631       Token: TPSPasToken;
8632       Op: TPSBinOperatorType;
8633     begin
8634       F1 := ReadSimpleExpression;
8635       if F1 = nil then
8636       begin
8637         Result := nil;
8638         exit;
8639       end;
8640       while FParser.CurrTokenID in [ CSTI_GreaterEqual, CSTI_LessEqual, CSTI_Greater, CSTI_Less, CSTI_Equal, CSTI_NotEqual, CSTII_in, CSTII_is] do
8641       begin
8642         Token := FParser.CurrTokenID;
8643         FParser.Next;
8644         F2 := ReadSimpleExpression;
8645         if f2 = nil then
8646         begin
8647           f1.Free;
8648           Result := nil;
8649           exit;
8650         end;
8651         case Token of
8652           CSTI_GreaterEqual: Op := otGreaterEqual;
8653           CSTI_LessEqual: Op := otLessEqual;
8654           CSTI_Greater: Op := otGreater;
8655           CSTI_Less: Op := otLess;
8656           CSTI_Equal: Op := otEqual;
8657           CSTI_NotEqual: Op := otNotEqual;
8658           CSTII_in: Op := otIn;
8659           CSTII_is: Op := otIs;
8660         else
8661           Op := otAdd;
8662         end;
8663         F := TPSBinValueOp.Create;
8664         f.Val1 := F1;
8665         f.Val2 := F2;
8666         f.Operator := Op;
8667         f.aType := GetResultType(F1, F2, Op);
8668         if f.aType = nil then
8669         begin
8670           MakeError('', ecTypeMismatch, '');
8671           f.Free;
8672           Result := nil;
8673           exit;
8674         end;
8675         f1 := f;
8676       end;
8677       Result := F1;
8678     end;  // ReadExpression
8679 
TryEvalConstnull8680     function TryEvalConst(var P: TPSValue): Boolean;
8681     var
8682       preplace: TPSValue;
8683     begin
8684       if p is TPSBinValueOp then
8685       begin
8686         if not (TryEvalConst(TPSBinValueOp(p).FVal1) and TryEvalConst(TPSBinValueOp(p).FVal2)) then
8687         begin
8688           Result := False;
8689           exit;
8690         end;
8691         if (TPSBinValueOp(p).FVal1.ClassType = TPSValueData) and (TPSBinValueOp(p).FVal2.ClassType = TPSValueData) then
8692         begin
8693           if not PreCalc(True, 0, TPSValueData(TPSBinValueOp(p).Val1).Data, 0, TPSValueData(TPSBinValueOp(p).Val2).Data, TPSBinValueOp(p).Operator, p.Pos, p.Row, p.Col) then
8694           begin
8695             Result := False;
8696             exit;
8697           end;
8698           preplace := TPSValueData.Create;
8699           preplace.Pos := p.Pos;
8700           preplace.Row := p.Row;
8701           preplace.Col := p.Col;
8702           TPSValueData(preplace).Data := TPSValueData(TPSBinValueOp(p).Val1).Data;
8703           TPSValueData(TPSBinValueOp(p).Val1).Data := nil;
8704           p.Free;
8705           p := preplace;
8706         end;
8707       end else if p is TPSUnValueOp then
8708       begin
8709         if not TryEvalConst(TPSUnValueOp(p).FVal1) then
8710         begin
8711           Result := False;
8712           exit;
8713         end;
8714         if TPSUnValueOp(p).FVal1.ClassType = TPSValueData then
8715         begin
8716 //
8717           case TPSUnValueOp(p).Operator of
8718             otNot:
8719               begin
8720                 case TPSValueData(TPSUnValueOp(p).FVal1).Data^.FType.BaseType of
8721                   btEnum:
8722                     begin
8723                       if IsBoolean(TPSValueData(TPSUnValueOp(p).FVal1).Data^.FType) then
8724                       begin
8725                         TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8 := (not TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8) and 1;
8726                       end else
8727                       begin
8728                         MakeError('', ecTypeMismatch, '');
8729                         Result := False;
8730                         exit;
8731                       end;
8732                     end;
8733                   btU8: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8734                   btU16: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8735                   btU32: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu32 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu32;
8736                   bts8: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts8 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts8;
8737                   bts16: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts16 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts16;
8738                   bts32: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts32 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts32;
8739                   {$IFNDEF PS_NOINT64}
8740                   bts64: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8741                   {$ENDIF}
8742                 else
8743                   begin
8744                     MakeError('', ecTypeMismatch, '');
8745                     Result := False;
8746                     exit;
8747                   end;
8748                 end;
8749                 preplace := TPSUnValueOp(p).Val1;
8750                 TPSUnValueOp(p).Val1 := nil;
8751                 p.Free;
8752                 p := preplace;
8753               end;
8754             otMinus:
8755               begin
8756                 case TPSValueData(TPSUnValueOp(p).FVal1).Data^.FType.BaseType of
8757                   btU8: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8758                   btU16: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8759                   btU32: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu32 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu32;
8760                   bts8: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts8 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts8;
8761                   bts16: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts16 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts16;
8762                   bts32: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts32 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts32;
8763                   {$IFNDEF PS_NOINT64}
8764                   bts64: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8765                   {$ENDIF}
8766                   btSingle: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tsingle := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tsingle;
8767                   btDouble: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tdouble := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tdouble;
8768                   btExtended: TPSValueData(TPSUnValueOp(p).FVal1).Data^.textended := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.textended;
8769                   btCurrency: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tcurrency := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tcurrency;
8770                 else
8771                   begin
8772                     MakeError('', ecTypeMismatch, '');
8773                     Result := False;
8774                     exit;
8775                   end;
8776                 end;
8777                 preplace := TPSUnValueOp(p).Val1;
8778                 TPSUnValueOp(p).Val1 := nil;
8779                 p.Free;
8780                 p := preplace;
8781               end;
8782             otCast:
8783               begin
8784                 preplace := TPSValueData.Create;
8785                 TPSValueData(preplace).Data := NewVariant(TPSUnValueOp(p).FType);
8786                 case TPSUnValueOp(p).FType.BaseType of
8787                   btU8:
8788                     begin
8789                       case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
8790                         btchar: TPSValueData(preplace).Data.tu8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
8791                         {$IFNDEF PS_NOWIDESTRING}
8792                         btwidechar: TPSValueData(preplace).Data.tu8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
8793                         {$ENDIF}
8794                         btU8: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8795                         btS8: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
8796                         btU16: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8797                         btS16: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
8798                         btU32: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
8799                         btS32: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
8800                         {$IFNDEF PS_NOINT64}
8801                         btS64: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8802                         {$ENDIF}
8803                       else
8804                         begin
8805                           MakeError('', ecTypeMismatch, '');
8806                           preplace.Free;
8807                           Result := False;
8808                           exit;
8809                         end;
8810                       end;
8811                     end;
8812                   btS8:
8813                     begin
8814                       case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
8815                         btchar: TPSValueData(preplace).Data.ts8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
8816                         {$IFNDEF PS_NOWIDESTRING}
8817                         btwidechar: TPSValueData(preplace).Data.ts8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
8818                         {$ENDIF}
8819                         btU8: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8820                         btS8: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
8821                         btU16: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8822                         btS16: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
8823                         btU32: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
8824                         btS32: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
8825                         {$IFNDEF PS_NOINT64}
8826                         btS64: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8827                         {$ENDIF}
8828                       else
8829                         begin
8830                           MakeError('', ecTypeMismatch, '');
8831                           preplace.Free;
8832                           Result := False;
8833                           exit;
8834                         end;
8835                       end;
8836                     end;
8837                   btU16:
8838                     begin
8839                       case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
8840                         btchar: TPSValueData(preplace).Data.tu16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
8841                         {$IFNDEF PS_NOWIDESTRING}
8842                         btwidechar: TPSValueData(preplace).Data.tu16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
8843                         {$ENDIF}
8844                         btU8: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8845                         btS8: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
8846                         btU16: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8847                         btS16: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
8848                         btU32: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
8849                         btS32: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
8850                         {$IFNDEF PS_NOINT64}
8851                         btS64: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8852                         {$ENDIF}
8853                       else
8854                         begin
8855                           MakeError('', ecTypeMismatch, '');
8856                           preplace.Free;
8857                           Result := False;
8858                           exit;
8859                         end;
8860                       end;
8861                     end;
8862                   bts16:
8863                     begin
8864                       case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
8865                         btchar: TPSValueData(preplace).Data.ts16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
8866                         {$IFNDEF PS_NOWIDESTRING}
8867                         btwidechar: TPSValueData(preplace).Data.ts16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
8868                         {$ENDIF}
8869                         btU8: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8870                         btS8: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
8871                         btU16: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8872                         btS16: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
8873                         btU32: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
8874                         btS32: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
8875                         {$IFNDEF PS_NOINT64}
8876                         btS64: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8877                         {$ENDIF}
8878                       else
8879                         begin
8880                           MakeError('', ecTypeMismatch, '');
8881                           preplace.Free;
8882                           Result := False;
8883                           exit;
8884                         end;
8885                       end;
8886                     end;
8887                   btU32:
8888                     begin
8889                       case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
8890                         btchar: TPSValueData(preplace).Data.tu32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
8891                         {$IFNDEF PS_NOWIDESTRING}
8892                         btwidechar: TPSValueData(preplace).Data.tu32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
8893                         {$ENDIF}
8894                         btU8: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8895                         btS8: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
8896                         btU16: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8897                         btS16: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
8898                         btU32: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
8899                         btS32: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
8900                         {$IFNDEF PS_NOINT64}
8901                         btS64: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8902                         {$ENDIF}
8903                       else
8904                         begin
8905                           MakeError('', ecTypeMismatch, '');
8906                           preplace.Free;
8907                           Result := False;
8908                           exit;
8909                         end;
8910                       end;
8911                     end;
8912                   btS32:
8913                     begin
8914                       case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
8915                         btchar: TPSValueData(preplace).Data.ts32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
8916                         {$IFNDEF PS_NOWIDESTRING}
8917                         btwidechar: TPSValueData(preplace).Data.ts32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
8918                         {$ENDIF}
8919                         btU8: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8920                         btS8: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
8921                         btU16: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8922                         btS16: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
8923                         btU32: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
8924                         btS32: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
8925                         {$IFNDEF PS_NOINT64}
8926                         btS64: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8927                         {$ENDIF}
8928                       else
8929                         begin
8930                           MakeError('', ecTypeMismatch, '');
8931                           preplace.Free;
8932                           Result := False;
8933                           exit;
8934                         end;
8935                       end;
8936                     end;
8937                   {$IFNDEF PS_NOINT64}
8938                   btS64:
8939                     begin
8940                       case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
8941                         btchar: TPSValueData(preplace).Data.ts64 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
8942                         {$IFNDEF PS_NOWIDESTRING}
8943                         btwidechar: TPSValueData(preplace).Data.ts64 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
8944                         {$ENDIF}
8945                         btU8: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8946                         btS8: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
8947                         btU16: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8948                         btS16: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
8949                         btU32: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
8950                         btS32: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
8951                         btS64: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8952                       else
8953                         begin
8954                           MakeError('', ecTypeMismatch, '');
8955                           preplace.Free;
8956                           Result := False;
8957                           exit;
8958                         end;
8959                       end;
8960                     end;
8961                   {$ENDIF}
8962                   btChar:
8963                     begin
8964                       case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
8965                         btchar: TPSValueData(preplace).Data.tchar := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar;
8966                         btU8: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8);
8967                         btS8: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8);
8968                         btU16: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16);
8969                         btS16: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16);
8970                         btU32: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32);
8971                         btS32: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32);
8972                         {$IFNDEF PS_NOINT64}
8973                         btS64: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64);
8974                         {$ENDIF}
8975                       else
8976                         begin
8977                           MakeError('', ecTypeMismatch, '');
8978                           Result := False;
8979                           preplace.Free;
8980                           exit;
8981                         end;
8982                       end;
8983                     end;
8984                 else
8985                   begin
8986                     MakeError('', ecTypeMismatch, '');
8987                     Result := False;
8988                     preplace.Free;
8989                     exit;
8990                   end;
8991                 end;
8992                 p.Free;
8993                 p := preplace;
8994               end;
8995             else
8996               begin
8997                 MakeError('', ecTypeMismatch, '');
8998                 Result := False;
8999                 exit;
9000               end;
9001           end; // case
9002         end; // if
9003       end;
9004       Result := True;
9005     end;
9006 
9007   var
9008     Temp, Val: TPSValue;
9009     vt: TPSVariableType;
9010 
9011 begin
9012     Val := ReadExpression;
9013     if Val = nil then
9014     begin
9015       Result := nil;
9016       exit;
9017     end;
9018     vt := ivtGlobal;
9019     repeat
9020       Temp := Val;
9021       if Val <> nil then CheckFurther(Val, False);
9022       if Val <> nil then CheckClass(Val, vt, InvalidVal, False);
9023       if Val <> nil then  CheckExtClass(Val, vt, InvalidVal, False);
9024 {$IFNDEF PS_NOIDISPATCH}if Val <> nil then CheckIntf(Val, vt, InvalidVal, False);{$ENDIF}
9025       if Val <> nil then CheckProcCall(Val);
9026       if Val<> nil then CheckClassArrayProperty(Val, vt, InvalidVal);
9027     until (Val = nil) or (Temp = Val);
9028 
9029     if not TryEvalConst(Val) then
9030     begin
9031       Val.Free;
9032       Result := nil;
9033       exit;
9034     end;
9035     Result := Val;
9036   end;
9037 
ReadParametersnull9038   function ReadParameters(IsProperty: Boolean; Dest: TPSParameters): Boolean;
9039   var
9040     sr,cr: TPSPasToken;
9041   begin
9042     if IsProperty then
9043     begin
9044       sr := CSTI_OpenBlock;
9045       cr := CSTI_CloseBlock;
9046     end else begin
9047       sr := CSTI_OpenRound;
9048       cr := CSTI_CloseRound;
9049     end;
9050     if FParser.CurrTokenId = sr then
9051     begin
9052       FParser.Next;
9053       if FParser.CurrTokenId = cr then
9054       begin
9055         FParser.Next;
9056         Result := True;
9057         exit;
9058       end;
9059     end else
9060     begin
9061       result := True;
9062       exit;
9063     end;
9064     repeat
9065       with Dest.Add do
9066       begin
9067         Val := calc(CSTI_CloseRound);
9068         if Val = nil then
9069         begin
9070           result := false;
9071           exit;
9072         end;
9073       end;
9074       if FParser.CurrTokenId = cr then
9075       begin
9076         FParser.Next;
9077         Break;
9078       end;
9079       if FParser.CurrTokenId <> CSTI_Comma then
9080       begin
9081         MakeError('', ecCommaExpected, '');
9082         Result := false;
9083         exit;
9084       end; {if}
9085       FParser.Next;
9086     until False;
9087     Result := true;
9088   end;
9089 
ReadProcParametersnull9090   function ReadProcParameters(ProcNo: Cardinal; FSelf: TPSValue): TPSValue;
9091   var
9092     Decl: TPSParametersDecl;
9093   begin
9094     if TPSProcedure(FProcs[ProcNo]).ClassType = TPSInternalProcedure then
9095       Decl := TPSInternalProcedure(FProcs[ProcNo]).Decl
9096     else
9097       Decl := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl;
9098     UseProc(Decl);
9099     Result := TPSValueProcNo.Create;
9100     TPSValueProcNo(Result).ProcNo := ProcNo;
9101     TPSValueProcNo(Result).ResultType := Decl.Result;
9102     with TPSValueProcNo(Result) do
9103     begin
9104       SetParserPos(FParser);
9105       Parameters := TPSParameters.Create;
9106       if FSelf <> nil then
9107       begin
9108         Parameters.Add;
9109       end;
9110     end;
9111 
9112     if not ReadParameters(False, TPSValueProc(Result).Parameters) then
9113     begin
9114       FSelf.Free;
9115       Result.Free;
9116       Result := nil;
9117       exit;
9118     end;
9119 
9120     if not ValidateParameters(BlockInfo, TPSValueProc(Result).Parameters, Decl) then
9121     begin
9122       FSelf.Free;
9123       Result.Free;
9124       Result := nil;
9125       exit;
9126     end;
9127     if FSelf <> nil then
9128     begin
9129       with TPSValueProcNo(Result).Parameters[0] do
9130       begin
9131         Val := FSelf;
9132         ExpectedType := GetTypeNo(BlockInfo, FSelf);
9133       end;
9134     end;
9135   end;
9136   {$IFNDEF PS_NOIDISPATCH}
9137 
ReadIDispatchParametersnull9138   function ReadIDispatchParameters(const ProcName: tbtString; aVariantType: TPSVariantType; FSelf: TPSValue): TPSValue;
9139   var
9140     Par: TPSParameters;
9141     PropSet: Boolean;
9142     i: Longint;
9143     Temp: TPSValue;
9144   begin
9145     Par := TPSParameters.Create;
9146     try
9147       if not ReadParameters(FParser.CurrTokenID = CSTI_OpenBlock, Par) then
9148       begin
9149         FSelf.Free;
9150         Result := nil;
9151         exit;
9152       end;
9153 
9154       if FParser.CurrTokenID = CSTI_Assignment then
9155       begin
9156         FParser.Next;
9157         PropSet := True;
9158         Temp := calc(CSTI_SemiColon);
9159         if temp = nil then
9160         begin
9161           FSelf.Free;
9162           Result := nil;
9163           exit;
9164         end;
9165         with par.Add do
9166         begin
9167           FValue := Temp;
9168         end;
9169       end else
9170       begin
9171         PropSet := False;
9172       end;
9173 
9174       Result := TPSValueProcNo.Create;
9175       TPSValueProcNo(Result).ResultType := aVariantType;
9176       with TPSValueProcNo(Result) do
9177       begin
9178         SetParserPos(FParser);
9179         Parameters := TPSParameters.Create;
9180         if FSelf <> nil then
9181         begin
9182           with Parameters.Add do
9183           begin
9184             Val := FSelf;
9185             ExpectedType := aVariantType.GetDynIvokeSelfType(Self);
9186           end;
9187           with Parameters.Add do
9188           begin
9189             Val := TPSValueData.Create;
9190             TPSValueData(Val).Data := NewVariant(FDefaultBoolType);
9191             TPSValueData(Val).Data.tu8 := Ord(PropSet);
9192             ExpectedType := FDefaultBoolType;
9193           end;
9194 
9195           with Parameters.Add do
9196           begin
9197             Val := TPSValueData.Create;
9198             TPSValueData(Val).Data := NewVariant(FindBaseType(btString));
9199             tbtString(TPSValueData(Val).data.tString) := Procname;
9200             ExpectedType := FindBaseType(btString);
9201           end;
9202 
9203           with Parameters.Add do
9204           begin
9205             val := TPSValueArray.Create;
9206             ExpectedType := aVariantType.GetDynInvokeParamType(Self);
9207             temp := Val;
9208           end;
9209           for i := 0 to Par.Count -1 do
9210           begin
9211             TPSValueArray(Temp).Add(par.Item[i].Val);
9212             par.Item[i].val := nil;
9213           end;
9214         end;
9215       end;
9216       TPSValueProcNo(Result).ProcNo := aVariantType.GetDynInvokeProcNo(Self, ProcName, TPSValueProcNo(Result).Parameters);
9217     finally
9218       Par.Free;
9219     end;
9220 
9221   end;
9222 
9223   {$ENDIF}
9224 
ReadVarParametersnull9225   function ReadVarParameters(ProcNoVar: TPSValue): TPSValue;
9226   var
9227     Decl: TPSParametersDecl;
9228   begin
9229     Decl := TPSProceduralType(GetTypeNo(BlockInfo, ProcnoVar)).ProcDef;
9230     UseProc(Decl);
9231 
9232     Result := TPSValueProcVal.Create;
9233 
9234     with TPSValueProcVal(Result) do
9235     begin
9236       ResultType := Decl.Result;
9237       ProcNo := ProcNoVar;
9238       Parameters := TPSParameters.Create;
9239     end;
9240 
9241     if not ReadParameters(False, TPSValueProc(Result).Parameters) then
9242     begin
9243       Result.Free;
9244       Result := nil;
9245       exit;
9246     end;
9247 
9248     if not ValidateParameters(BlockInfo, TPSValueProc(Result).Parameters, Decl) then
9249     begin
9250       Result.Free;
9251       Result := nil;
9252       exit;
9253     end;
9254   end;
9255 
9256 
WriteCalculationnull9257   function WriteCalculation(InData, OutReg: TPSValue): Boolean;
9258 
CheckOutregnull9259     function CheckOutreg(Where, Outreg: TPSValue; aRoot: Boolean): Boolean;
9260     var
9261       i: Longint;
9262     begin
9263       Result := False;
9264       if Outreg is TPSValueReplace
9265         then Outreg:=TPSValueReplace(Outreg).OldValue;
9266       if Where is TPSValueVar then begin
9267         if TPSValueVar(Where).GetRecCount > 0 then result := true;
9268         if SAmeReg(Where, OutReg) and not aRoot then
9269           result := true;
9270       end else
9271       if Where.ClassType = TPSUnValueOp then
9272       begin
9273         if CheckOutReg(TPSUnValueOp(Where).Val1, OutReg, aRoot) then
9274           Result := True;
9275       end else if Where.ClassType = TPSBinValueOp then
9276       begin
9277         if CheckOutreg(TPSBinValueOp(Where).Val1, OutReg, aRoot) or CheckOutreg(TPSBinValueOp(Where).Val2, OutReg, False) then
9278           Result := True;
9279       end else if Where is TPSValueVar then
9280       begin
9281         if SameReg(Where, OutReg) then
9282           Result := True;
9283       end else if Where is TPSValueProc then
9284       begin
9285         for i := 0 to TPSValueProc(Where).Parameters.Count -1 do
9286         begin
9287           if Checkoutreg(TPSValueProc(Where).Parameters[i].Val, Outreg, false) then
9288           begin
9289             Result := True;
9290             break;
9291           end;
9292         end;
9293       end;
9294     end;
9295   begin
9296     if not CheckCompatType(Outreg, InData) then
9297     begin
9298       MakeError('', ecTypeMismatch, '');
9299       Result := False;
9300       exit;
9301     end;
9302     if SameReg(OutReg, InData) then
9303     begin
9304       Result := True;
9305       exit;
9306     end;
9307     if InData is TPSValueProc then
9308     begin
PSValueProcnull9309       Result := _ProcessFunction(TPSValueProc(indata), OutReg)
9310     end else begin
9311       if not PreWriteOutRec(OutReg, nil) then
9312       begin
9313         Result := False;
9314         exit;
9315       end;
9316       if (not CheckOutReg(InData, OutReg, true)) and (InData is TPSBinValueOp) or (InData is TPSUnValueOp) then
9317       begin
9318         if InData is TPSBinValueOp then
9319         begin
9320           if not DoBinCalc(TPSBinValueOp(InData), OutReg) then
9321           begin
9322             AfterWriteOutRec(OutReg);
9323             Result := False;
9324             exit;
9325           end;
9326         end else
9327         begin
9328           if not DoUnCalc(TPSUnValueOp(InData), OutReg) then
9329           begin
9330             AfterWriteOutRec(OutReg);
9331             Result := False;
9332             exit;
9333           end;
9334         end;
9335       end else if (InData is TPSBinValueOp) and (not CheckOutReg(TPSBinValueOp(InData).Val2, OutReg, false)) then
9336       begin
9337         if not DoBinCalc(TPSBinValueOp(InData), OutReg) then
9338         begin
9339           AfterWriteOutRec(OutReg);
9340           Result := False;
9341           exit;
9342         end;
9343       end else begin
9344         if not PreWriteOutRec(InData, GetTypeNo(BlockInfo, OutReg)) then
9345         begin
9346           Result := False;
9347           exit;
9348         end;
9349         BlockWriteByte(BlockInfo, CM_A);
9350         if not (WriteOutRec(OutReg, False) and WriteOutRec(InData, True)) then
9351         begin
9352           Result := False;
9353           exit;
9354         end;
9355         AfterWriteOutRec(InData);
9356       end;
9357       AfterWriteOutRec(OutReg);
9358       Result := True;
9359     end;
9360   end; {WriteCalculation}
9361 
9362 
_ProcessFunctionnull9363   function _ProcessFunction(ProcCall: TPSValueProc; ResultRegister: TPSValue): Boolean;
9364   var
9365     res: TPSType;
9366     tmp: TPSParameter;
9367     lTv: TPSValue;
9368     resreg: TPSValue;
9369     l: Longint;
9370 
Cleanupnull9371     function Cleanup: Boolean;
9372     var
9373       i: Longint;
9374     begin
9375       for i := 0 to ProcCall.Parameters.Count -1 do
9376       begin
9377         if ProcCall.Parameters[i].TempVar <> nil then
9378           ProcCall.Parameters[i].TempVar.Free;
9379         ProcCall.Parameters[i].TempVar := nil;
9380       end;
9381       if ProcCall is TPSValueProcVal then
9382         AfterWriteOutRec(TPSValueProcVal(ProcCall).fProcNo);
9383       if ResReg <> nil then
9384         AfterWriteOutRec(resreg);
9385       if ResReg <> nil then
9386       begin
9387         if ResReg <> ResultRegister then
9388         begin
9389           if ResultRegister <> nil then
9390           begin
9391             if not WriteCalculation(ResReg, ResultRegister) then
9392             begin
9393               Result := False;
9394               resreg.Free;
9395               exit;
9396             end;
9397           end;
9398           resreg.Free;
9399         end;
9400       end;
9401       Result := True;
9402     end;
9403 
9404   begin
9405     Res := ProcCall.ResultType;
9406     if ProcCall.ResultType = FAnyString then
9407     begin
9408       for l := ProcCall.Parameters.Count - 1 downto 0 do
9409       begin
9410         Tmp := ProcCall.Parameters[l];
9411         if (Tmp.ParamMode <> pmOut) and (Tmp.ExpectedType = FAnyString) then
9412         begin
9413           Res := GetTypeNo(BlockInfo, tmp.Val);
9414           Break;
9415         end;
9416       end;
9417     end;
9418     Result := False;
9419     if (res = nil) and (ResultRegister <> nil) then
9420     begin
9421       MakeError('', ecNoResult, '');
9422       exit;
9423     end
9424     else if (res <> nil)  then
9425     begin
9426       if (ResultRegister = nil) or (Res <> GetTypeNo(BlockInfo, ResultRegister)) then
9427       begin
9428         resreg := AllocStackReg(res);
9429 
9430       end else resreg := ResultRegister;
9431     end
9432     else
9433       resreg := nil;
9434     if ResReg <> nil then
9435     begin
9436       if not PreWriteOutRec(resreg, nil) then
9437       begin
9438         Cleanup;
9439         exit;
9440       end;
9441     end;
9442     if Proccall is TPSValueProcVal then
9443     begin
9444       if not PreWriteOutRec(TPSValueProcVal(ProcCall).fProcNo, nil) then
9445       begin
9446         Cleanup;
9447         exit;
9448       end;
9449     end;
9450     for l := ProcCall.Parameters.Count - 1 downto 0 do
9451     begin
9452       Tmp := ProcCall.Parameters[l];
9453       if (Tmp.ParamMode <> pmIn)  then
9454       begin
9455         if IsVarInCompatible(GetTypeNo(BlockInfo, tmp.Val), tmp.ExpectedType) then
9456         begin
9457           with MakeError('', ecTypeMismatch, '') do
9458           begin
9459             pos := tmp.Val.Pos;
9460             row := tmp.Val.row;
9461             col := tmp.Val.col;
9462           end;
9463           Cleanup;
9464           exit;
9465         end;
9466         if Copy(tmp.ExpectedType.Name, 1, 10) = '!OPENARRAY' then begin
9467           tmp.TempVar := AllocPointer(tmp.ExpectedType);
9468           lTv := AllocStackReg(tmp.ExpectedType);
9469           if not PreWriteOutRec(Tmp.FValue, nil) then
9470           begin
9471             cleanup;
9472             exit;
9473           end;
9474           BlockWriteByte(BlockInfo, CM_A);
9475           WriteOutRec(lTv, False);
9476           WriteOutRec(Tmp.FValue, False);
9477           AfterWriteOutRec(Tmp.FValue);
9478 
9479           BlockWriteByte(BlockInfo, cm_sp);
9480           WriteOutRec(tmp.TempVar, False);
9481           WriteOutRec(lTv, False);
9482 
9483           lTv.Free;
9484 //          BlockWriteByte(BlockInfo, CM_PO); // pop the temp var
9485 
9486         end else begin
9487         tmp.TempVar := AllocPointer(GetTypeNo(BlockInfo, Tmp.FValue));
9488         if not PreWriteOutRec(Tmp.FValue, nil) then
9489         begin
9490           cleanup;
9491           exit;
9492         end;
9493         BlockWriteByte(BlockInfo, cm_sp);
9494         WriteOutRec(tmp.TempVar, False);
9495         WriteOutRec(Tmp.FValue, False);
9496         AfterWriteOutRec(Tmp.FValue);
9497         end;
9498       end
9499       else
9500       begin
9501         if (Tmp.ExpectedType = nil) or (Tmp.ExpectedType = FAnyString) then
9502           Tmp.ExpectedType := GetTypeNo(BlockInfo, tmp.Val);
9503         if Tmp.ExpectedType.BaseType = btPChar then
9504         begin
9505           Tmp.TempVar := AllocStackReg(at2ut(FindBaseType(btstring)))
9506         end else
9507         begin
9508         Tmp.TempVar := AllocStackReg(Tmp.ExpectedType);
9509         end;
9510         if not WriteCalculation(Tmp.Val, Tmp.TempVar) then
9511         begin
9512           Cleanup;
9513           exit;
9514         end;
9515       end;
9516     end; {for}
9517     if res <> nil then
9518     begin
9519       BlockWriteByte(BlockInfo, CM_PV);
9520 
9521       if not WriteOutRec(resreg, False) then
9522       begin
9523         Cleanup;
9524         MakeError('', ecInternalError, '00015');
9525         exit;
9526       end;
9527     end;
9528     if ProcCall is TPSValueProcVal then
9529     begin
9530       BlockWriteByte(BlockInfo, Cm_cv);
9531       WriteOutRec(TPSValueProcVal(ProcCall).ProcNo, True);
9532     end else begin
9533       BlockWriteByte(BlockInfo, CM_C);
9534       BlockWriteLong(BlockInfo, TPSValueProcNo(ProcCall).ProcNo);
9535     end;
9536     if res <> nil then
9537       BlockWriteByte(BlockInfo, CM_PO);
9538     if not Cleanup then
9539     begin
9540       Result := False;
9541       exit;
9542     end;
9543     Result := True;
9544   end; {ProcessVarFunction}
9545 
HasInvalidJumpsnull9546 	function HasInvalidJumps(StartPos, EndPos: Cardinal): Boolean;
9547   var
9548     I, J: Longint;
9549     Ok: LongBool;
9550     FLabelsInBlock: TIfStringList;
9551     s: tbtString;
9552 	begin
9553 		FLabelsInBlock := TIfStringList.Create;
9554 		for i := 0 to BlockInfo.Proc.FLabels.Count -1 do
9555 		begin
9556 			s := BlockInfo.Proc.FLabels[I];
9557 			if (Cardinal((@s[1])^) >= StartPos) and (Cardinal((@s[1])^) <= EndPos) then
9558 			begin
9559 				Delete(s, 1, 8);
9560 				FLabelsInBlock.Add(s);
9561 			end;
9562 		end;
9563 		for i := 0 to BlockInfo.Proc.FGotos.Count -1 do
9564 		begin
9565 			s := BlockInfo.Proc.FGotos[I];
9566 			if (Cardinal((@s[1])^) >= StartPos) and (Cardinal((@s[1])^) <= EndPos) then
9567 			begin
9568 				Delete(s, 1, 4);
9569 				s := BlockInfo.Proc.FLabels[Cardinal((@s[1])^)];
9570 				Delete(s,1,8);
9571 				OK := False;
9572         for J := 0 to FLabelsInBlock.Count -1 do
9573         begin
9574           if FLabelsInBlock[J] = s then
9575           begin
9576             Ok := True;
9577             Break;
9578           end;
9579         end;
9580         if not Ok then
9581         begin
9582           MakeError('', ecInvalidJump, '');
9583           Result := True;
9584           FLabelsInBlock.Free;
9585           exit;
9586         end;
9587       end else begin
9588 				Delete(s, 1, 4);
9589 				s := BlockInfo.Proc.FLabels[Cardinal((@s[1])^)];
9590 				Delete(s,1,8);
9591 				OK := True;
9592         for J := 0 to FLabelsInBlock.Count -1 do
9593         begin
9594           if FLabelsInBlock[J] = s then
9595           begin
9596             Ok := False;
9597             Break;
9598           end;
9599         end;
9600         if not Ok then
9601         begin
9602           MakeError('', ecInvalidJump, '');
9603           Result := True;
9604           FLabelsInBlock.Free;
9605           exit;
9606         end;
9607       end;
9608     end;
9609     FLabelsInBlock.Free;
9610     Result := False;
9611   end;
9612 
ProcessFornull9613   function ProcessFor: Boolean;
9614     { Process a for x := y to z do }
9615   var
9616     VariableVar: TPSValue;
9617       TempBool,
9618       InitVal,
9619       finVal: TPSValue;
9620     Block: TPSBlockInfo;
9621     Backwards: Boolean;
9622     FPos, NPos, EPos, RPos: Longint;
9623     OldCO, OldBO: TPSList;
9624     I: Longint;
9625 		iOldWithCount: Integer;
9626 		iOldTryCount: Integer;
9627 		iOldExFnlCount: Integer;
9628     lType: TPSType;
9629   begin
9630     Debug_WriteLine(BlockInfo);
9631     Result := False;
9632     FParser.Next;
9633     if FParser.CurrTokenId <> CSTI_Identifier then
9634     begin
9635       MakeError('', ecIdentifierExpected, '');
9636       exit;
9637     end;
9638     VariableVar := GetIdentifier(1);
9639     if VariableVar = nil then
9640       exit;
9641     lType := GetTypeNo(BlockInfo, VariableVar);
9642     if lType = nil then begin
9643       MakeError('', ecTypeMismatch, '');
9644       VariableVar.Free;
9645       exit;
9646     end;
9647     case lType.BaseType of
9648       btU8, btS8, btU16, btS16, btU32, btS32, {$IFNDEF PS_NOINT64} btS64, {$ENDIF} btVariant, btEnum: ;
9649     else
9650       begin
9651         MakeError('', ecTypeMismatch, '');
9652         VariableVar.Free;
9653         exit;
9654       end;
9655     end;
9656     if FParser.CurrTokenId <> CSTI_Assignment then
9657     begin
9658       MakeError('', ecAssignmentExpected, '');
9659       VariableVar.Free;
9660       exit;
9661     end;
9662     FParser.Next;
9663     InitVal := calc(CSTII_DownTo);
9664     if InitVal = nil then
9665     begin
9666       VariableVar.Free;
9667       exit;
9668     end;
9669     if FParser.CurrTokenId = CSTII_To then
9670       Backwards := False
9671     else if FParser.CurrTokenId = CSTII_DownTo then
9672       Backwards := True
9673     else
9674     begin
9675       MakeError('', ecToExpected, '');
9676       VariableVar.Free;
9677       InitVal.Free;
9678       exit;
9679     end;
9680     FParser.Next;
9681     finVal := calc(CSTII_do);
9682     if finVal = nil then
9683     begin
9684       VariableVar.Free;
9685       InitVal.Free;
9686       exit;
9687     end;
9688     lType := GetTypeNo(BlockInfo, finVal);
9689     if lType = nil then begin
9690       MakeError('', ecTypeMismatch, '');
9691       VariableVar.Free;
9692       InitVal.Free;
9693       exit;
9694     end;
9695     case lType.BaseType of
9696       btVariant, btEnum, btU8, btS8, btU16, btS16, btU32, {$IFNDEF PS_NOINT64} btS64, {$ENDIF} btS32: ;
9697     else
9698       begin
9699         MakeError('', ecTypeMismatch, '');
9700         VariableVar.Free;
9701         InitVal.Free;
9702         exit;
9703       end;
9704     end;
9705     if FParser.CurrTokenId <> CSTII_do then
9706     begin
9707       MakeError('', ecDoExpected, '');
9708       finVal.Free;
9709       InitVal.Free;
9710       VariableVar.Free;
9711       exit;
9712     end;
9713     FParser.Next;
9714     if not WriteCalculation(InitVal, VariableVar) then
9715     begin
9716       VariableVar.Free;
9717       InitVal.Free;
9718       finVal.Free;
9719       exit;
9720     end;
9721     InitVal.Free;
9722     TempBool := AllocStackReg(at2ut(FDefaultBoolType));
9723     NPos := Length(BlockInfo.Proc.Data);
9724     if not (PreWriteOutRec(VariableVar, nil) and PreWriteOutRec(finVal, nil)) then
9725     begin
9726       TempBool.Free;
9727       VariableVar.Free;
9728       finVal.Free;
9729       exit;
9730     end;
9731     BlockWriteByte(BlockInfo, CM_CO);
9732     if Backwards then
9733     begin
9734       BlockWriteByte(BlockInfo, 0); { >= }
9735     end
9736     else
9737     begin
9738       BlockWriteByte(BlockInfo, 1); { <= }
9739     end;
9740     if not (WriteOutRec(TempBool, False) and WriteOutRec(VariableVar, True) and WriteOutRec(finVal, True)) then
9741     begin
9742       TempBool.Free;
9743       VariableVar.Free;
9744       finVal.Free;
9745       exit;
9746     end;
9747     AfterWriteOutRec(finVal);
9748     AfterWriteOutRec(VariableVar);
9749     finVal.Free;
9750     BlockWriteByte(BlockInfo, Cm_CNG);
9751     EPos := Length(BlockInfo.Proc.Data);
9752     BlockWriteLong(BlockInfo, $12345678);
9753     WriteOutRec(TempBool, False);
9754     RPos := Length(BlockInfo.Proc.Data);
9755     OldCO := FContinueOffsets;
9756     FContinueOffsets := TPSList.Create;
9757     OldBO := FBreakOffsets;
9758     FBreakOffsets := TPSList.Create;
9759     Block := TPSBlockInfo.Create(BlockInfo);
9760     Block.SubType := tOneLiner;
9761 
9762 		iOldWithCount := FWithCount;
9763 		FWithCount := 0;
9764 		iOldTryCount := FTryCount;
9765 		FTryCount := 0;
9766 		iOldExFnlCount := FExceptFinallyCount;
9767     FExceptFinallyCount := 0;
9768 
9769     if not ProcessSub(Block) then
9770     begin
9771       Block.Free;
9772       TempBool.Free;
9773       VariableVar.Free;
9774       FBreakOffsets.Free;
9775       FContinueOffsets.Free;
9776       FContinueOffsets := OldCO;
9777       FBreakOffsets := OldBo;
9778 
9779 			FWithCount := iOldWithCount;
9780 			FTryCount := iOldTryCount;
9781       FExceptFinallyCount := iOldExFnlCount;
9782 
9783 			exit;
9784 		end;
9785 		Block.Free;
9786 		FPos := Length(BlockInfo.Proc.Data);
9787 		if not PreWriteOutRec(VariableVar, nil) then
9788 		begin
9789 			TempBool.Free;
9790 			VariableVar.Free;
9791 			FBreakOffsets.Free;
9792 			FContinueOffsets.Free;
9793 			FContinueOffsets := OldCO;
9794 			FBreakOffsets := OldBo;
9795 
9796 			FWithCount := iOldWithCount;
9797 			FTryCount := iOldTryCount;
9798       FExceptFinallyCount := iOldExFnlCount;
9799 
9800       exit;
9801     end;
9802     if Backwards then
9803       BlockWriteByte(BlockInfo, cm_dec)
9804     else
9805       BlockWriteByte(BlockInfo, cm_inc);
9806     if not WriteOutRec(VariableVar, False) then
9807     begin
9808       TempBool.Free;
9809       VariableVar.Free;
9810       FBreakOffsets.Free;
9811       FContinueOffsets.Free;
9812       FContinueOffsets := OldCO;
9813       FBreakOffsets := OldBo;
9814 
9815 			FWithCount := iOldWithCount;
9816 			FTryCount := iOldTryCount;
9817       FExceptFinallyCount := iOldExFnlCount;
9818 
9819       exit;
9820     end;
9821     AfterWriteOutRec(VariableVar);
9822     BlockWriteByte(BlockInfo, Cm_G);
9823     BlockWriteLong(BlockInfo, Longint(NPos - Length(BlockInfo.Proc.Data) - 4));
9824     {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
9825     unaligned(Longint((@BlockInfo.Proc.Data[EPos + 1])^)) := Length(BlockInfo.Proc.Data) - RPos;
9826     {$else}
9827     Longint((@BlockInfo.Proc.Data[EPos + 1])^) := Length(BlockInfo.Proc.Data) - RPos;
9828     {$endif}
9829     for i := 0 to FBreakOffsets.Count -1 do
9830     begin
9831       EPos := IPointer(FBreakOffsets[I]);
9832       {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
9833       unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(EPos);
9834       {$else}
9835       Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos);
9836       {$endif}
9837     end;
9838     for i := 0 to FContinueOffsets.Count -1 do
9839     begin
9840       EPos := IPointer(FContinueOffsets[I]);
9841       {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
9842       unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Longint(FPos) - Longint(EPos);
9843       {$else}
9844       Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(FPos) - Longint(EPos);
9845       {$endif}
9846     end;
9847     FBreakOffsets.Free;
9848     FContinueOffsets.Free;
9849     FContinueOffsets := OldCO;
9850     FBreakOffsets := OldBo;
9851 
9852 		FWithCount := iOldWithCount;
9853     FTryCount := iOldTryCount;
9854     FExceptFinallyCount := iOldExFnlCount;
9855 
9856 		TempBool.Free;
9857 		VariableVar.Free;
9858 		if HasInvalidJumps(RPos, Length(BlockInfo.Proc.Data)) then
9859     begin
9860       Result := False;
9861       exit;
9862     end;
9863     Result := True;
9864   end; {ProcessFor}
9865 
ProcessWhilenull9866   function ProcessWhile: Boolean;
9867   var
9868     vin, vout: TPSValue;
9869     SPos, EPos: Cardinal;
9870     OldCo, OldBO: TPSList;
9871     I: Longint;
9872     Block: TPSBlockInfo;
9873 
9874 		iOldWithCount: Integer;
9875     iOldTryCount: Integer;
9876     iOldExFnlCount: Integer;
9877 
9878   begin
9879     Result := False;
9880     Debug_WriteLine(BlockInfo);
9881     FParser.Next;
9882     vout := calc(CSTII_do);
9883     if vout = nil then
9884       exit;
9885     if FParser.CurrTokenId <> CSTII_do then
9886     begin
9887       vout.Free;
9888       MakeError('', ecDoExpected, '');
9889       exit;
9890     end;
9891     vin := AllocStackReg(at2ut(FDefaultBoolType));
9892     SPos := Length(BlockInfo.Proc.Data); // start position
9893     OldCo := FContinueOffsets;
9894     FContinueOffsets := TPSList.Create;
9895     OldBO := FBreakOffsets;
9896     FBreakOffsets := TPSList.Create;
9897     if not WriteCalculation(vout, vin) then
9898     begin
9899       vout.Free;
9900       vin.Free;
9901       FBreakOffsets.Free;
9902       FContinueOffsets.Free;
9903       FContinueOffsets := OldCO;
9904       FBreakOffsets := OldBo;
9905       exit;
9906     end;
9907     vout.Free;
9908     FParser.Next; // skip DO
9909     BlockWriteByte(BlockInfo, Cm_CNG); // only goto if expression is false
9910     BlockWriteLong(BlockInfo, $12345678);
9911     EPos := Length(BlockInfo.Proc.Data);
9912     if not WriteOutRec(vin, False) then
9913     begin
9914       MakeError('', ecInternalError, '00017');
9915       vin.Free;
9916       FBreakOffsets.Free;
9917       FContinueOffsets.Free;
9918       FContinueOffsets := OldCO;
9919       FBreakOffsets := OldBo;
9920       exit;
9921     end;
9922     Block := TPSBlockInfo.Create(BlockInfo);
9923     Block.SubType := tOneLiner;
9924 
9925     iOldWithCount := FWithCount;
9926     FWithCount := 0;
9927     iOldTryCount := FTryCount;
9928     FTryCount := 0;
9929     iOldExFnlCount := FExceptFinallyCount;
9930     FExceptFinallyCount := 0;
9931 
9932     if not ProcessSub(Block) then
9933     begin
9934       Block.Free;
9935       vin.Free;
9936       FBreakOffsets.Free;
9937       FContinueOffsets.Free;
9938       FContinueOffsets := OldCO;
9939       FBreakOffsets := OldBo;
9940 
9941       FWithCount := iOldWithCount;
9942 			FTryCount := iOldTryCount;
9943       FExceptFinallyCount := iOldExFnlCount;
9944 
9945       exit;
9946     end;
9947     Block.Free;
9948     Debug_WriteLine(BlockInfo);
9949     BlockWriteByte(BlockInfo, Cm_G);
9950     BlockWriteLong(BlockInfo, Longint(SPos) - Length(BlockInfo.Proc.Data) - 4);
9951     {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
9952     unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(EPos) - 5;
9953     {$else}
9954     Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos) - 5;
9955     {$endif}
9956     for i := 0 to FBreakOffsets.Count -1 do
9957     begin
9958       EPos := Cardinal(FBreakOffsets[I]);
9959       {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
9960       unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(EPos);
9961       {$else}
9962       Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos);
9963       {$endif}
9964     end;
9965     for i := 0 to FContinueOffsets.Count -1 do
9966     begin
9967       EPos := Cardinal(FContinueOffsets[I]);
9968       {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
9969       unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Longint(SPos) - Longint(EPos);
9970       {$else}
9971       Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(SPos) - Longint(EPos);
9972       {$endif}
9973     end;
9974     FBreakOffsets.Free;
9975     FContinueOffsets.Free;
9976     FContinueOffsets := OldCO;
9977     FBreakOffsets := OldBo;
9978 
9979     FWithCount := iOldWithCount;
9980     FTryCount := iOldTryCount;
9981     FExceptFinallyCount := iOldExFnlCount;
9982 
9983     vin.Free;
9984 		if HasInvalidJumps(EPos, Length(BlockInfo.Proc.Data)) then
9985     begin
9986       Result := False;
9987       exit;
9988     end;
9989     Result := True;
9990   end;
9991 
ProcessRepeatnull9992   function ProcessRepeat: Boolean;
9993   var
9994     vin, vout: TPSValue;
9995     CPos, SPos, EPos: Cardinal;
9996     I: Longint;
9997     OldCo, OldBO: TPSList;
9998     Block: TPSBlockInfo;
9999 
10000     iOldWithCount: Integer;
10001     iOldTryCount: Integer;
10002     iOldExFnlCount: Integer;
10003 
10004   begin
10005     Result := False;
10006     Debug_WriteLine(BlockInfo);
10007     FParser.Next;
10008     OldCo := FContinueOffsets;
10009     FContinueOffsets := TPSList.Create;
10010     OldBO := FBreakOffsets;
10011     FBreakOffsets := TPSList.Create;
10012     vin := AllocStackReg(at2ut(FDefaultBoolType));
10013     SPos := Length(BlockInfo.Proc.Data);
10014     Block := TPSBlockInfo.Create(BlockInfo);
10015     Block.SubType := tRepeat;
10016 
10017     iOldWithCount := FWithCount;
10018     FWithCount := 0;
10019     iOldTryCount := FTryCount;
10020     FTryCount := 0;
10021     iOldExFnlCount := FExceptFinallyCount;
10022     FExceptFinallyCount := 0;
10023 
10024     if not ProcessSub(Block) then
10025     begin
10026       Block.Free;
10027       FBreakOffsets.Free;
10028       FContinueOffsets.Free;
10029       FContinueOffsets := OldCO;
10030       FBreakOffsets := OldBo;
10031 
10032       FWithCount := iOldWithCount;
10033       FTryCount := iOldTryCount;
10034       FExceptFinallyCount := iOldExFnlCount;
10035 
10036       vin.Free;
10037       exit;
10038     end;
10039     Block.Free;
10040     FParser.Next; //cstii_until
10041     vout := calc(CSTI_Semicolon);
10042     if vout = nil then
10043     begin
10044       FBreakOffsets.Free;
10045       FContinueOffsets.Free;
10046       FContinueOffsets := OldCO;
10047       FBreakOffsets := OldBo;
10048 
10049       FWithCount := iOldWithCount;
10050       FTryCount := iOldTryCount;
10051       FExceptFinallyCount := iOldExFnlCount;
10052 
10053       vin.Free;
10054       exit;
10055     end;
10056     CPos := Length(BlockInfo.Proc.Data);
10057     if not WriteCalculation(vout, vin) then
10058     begin
10059       vout.Free;
10060       vin.Free;
10061       FBreakOffsets.Free;
10062       FContinueOffsets.Free;
10063       FContinueOffsets := OldCO;
10064       FBreakOffsets := OldBo;
10065 
10066       FWithCount := iOldWithCount;
10067       FTryCount := iOldTryCount;
10068       FExceptFinallyCount := iOldExFnlCount;
10069 
10070       exit;
10071     end;
10072     vout.Free;
10073     BlockWriteByte(BlockInfo, Cm_CNG);
10074     BlockWriteLong(BlockInfo, $12345678);
10075     EPos := Length(BlockInfo. Proc.Data);
10076     if not WriteOutRec(vin, False) then
10077     begin
10078       MakeError('', ecInternalError, '00016');
10079       vin.Free;
10080       FBreakOffsets.Free;
10081       FContinueOffsets.Free;
10082       FContinueOffsets := OldCO;
10083       FBreakOffsets := OldBo;
10084 
10085       FWithCount := iOldWithCount;
10086       FTryCount := iOldTryCount;
10087       FExceptFinallyCount := iOldExFnlCount;
10088 
10089       exit;
10090     end;
10091     {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10092     unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Longint(SPos) -
10093       Length(BlockInfo.Proc.Data);
10094     {$else}
10095     Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(SPos) -
10096       Length(BlockInfo.Proc.Data);
10097     {$endif}
10098     for i := 0 to FBreakOffsets.Count -1 do
10099     begin
10100       EPos := Cardinal(FBreakOffsets[I]);
10101       {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10102       unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo. Proc.Data) - Longint(EPos);
10103       {$else}
10104       Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo. Proc.Data) - Longint(EPos);
10105       {$endif}
10106     end;
10107     for i := 0 to FContinueOffsets.Count -1 do
10108     begin
10109       EPos := Cardinal(FContinueOffsets[I]);
10110       {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10111       unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Longint(CPos) - Longint(EPos);
10112       {$else}
10113       Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(CPos) - Longint(EPos);
10114       {$endif}
10115     end;
10116     FBreakOffsets.Free;
10117     FContinueOffsets.Free;
10118     FContinueOffsets := OldCO;
10119     FBreakOffsets := OldBo;
10120 
10121     FWithCount := iOldWithCount;
10122     FTryCount := iOldTryCount;
10123     FExceptFinallyCount := iOldExFnlCount;
10124 
10125     vin.Free;
10126     if HasInvalidJumps(SPos, Length(BlockInfo. Proc.Data)) then
10127     begin
10128       Result := False;
10129       exit;
10130     end;
10131     Result := True;
10132   end; {ProcessRepeat}
10133 
ProcessIfnull10134   function ProcessIf: Boolean;
10135   var
10136     vout, vin: TPSValue;
10137     SPos, EPos: Cardinal;
10138     Block: TPSBlockInfo;
10139   begin
10140     Result := False;
10141     Debug_WriteLine(BlockInfo);
10142     FParser.Next;
10143     vout := calc(CSTII_Then);
10144     if vout = nil then
10145       exit;
10146     if FParser.CurrTokenId <> CSTII_Then then
10147     begin
10148       vout.Free;
10149       MakeError('', ecThenExpected, '');
10150       exit;
10151     end;
10152     vin := AllocStackReg(at2ut(FDefaultBoolType));
10153     if not WriteCalculation(vout, vin) then
10154     begin
10155       vout.Free;
10156       vin.Free;
10157       exit;
10158     end;
10159     vout.Free;
10160     BlockWriteByte(BlockInfo, cm_sf);
10161     if not WriteOutRec(vin, False) then
10162     begin
10163       MakeError('', ecInternalError, '00018');
10164       vin.Free;
10165       exit;
10166     end;
10167     BlockWriteByte(BlockInfo, 1);
10168     vin.Free;
10169     BlockWriteByte(BlockInfo, cm_fg);
10170     BlockWriteLong(BlockInfo, $12345678);
10171     SPos := Length(BlockInfo.Proc.Data);
10172     FParser.Next; // skip then
10173     Block := TPSBlockInfo.Create(BlockInfo);
10174     Block.SubType := tifOneliner;
10175     if not ProcessSub(Block) then
10176     begin
10177       Block.Free;
10178       exit;
10179     end;
10180     Block.Free;
10181     if FParser.CurrTokenId = CSTII_Else then
10182     begin
10183       BlockWriteByte(BlockInfo, Cm_G);
10184       BlockWriteLong(BlockInfo, $12345678);
10185       EPos := Length(BlockInfo.Proc.Data);
10186       {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10187       unaligned(Longint((@BlockInfo.Proc.Data[SPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(SPos);
10188       {$else}
10189       Longint((@BlockInfo.Proc.Data[SPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(SPos);
10190       {$endif}
10191       FParser.Next;
10192       Block := TPSBlockInfo.Create(BlockInfo);
10193       Block.SubType := tOneLiner;
10194       if not ProcessSub(Block) then
10195       begin
10196         Block.Free;
10197         exit;
10198       end;
10199       Block.Free;
10200       {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10201       unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(EPos);
10202       {$else}
10203       Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos);
10204       {$endif}
10205     end
10206     else
10207     begin
10208       {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10209       unaligned(Longint((@BlockInfo.Proc.Data[SPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(SPos) + 5 - 5;
10210       {$else}
10211       Longint((@BlockInfo.Proc.Data[SPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(SPos) + 5 - 5;
10212       {$endif}
10213     end;
10214     Result := True;
10215   end; {ProcessIf}
10216 
_ProcessLabelnull10217   function _ProcessLabel: Longint; {0 = failed; 1 = successful; 2 = no label}
10218   var
10219     I, H: Longint;
10220     s: tbtString;
10221   begin
10222     h := MakeHash(FParser.GetToken);
10223     for i := 0 to BlockInfo.Proc.FLabels.Count -1 do
10224     begin
10225       s := BlockInfo.Proc.FLabels[I];
10226       delete(s, 1, 4);
10227       if Longint((@s[1])^) = h then
10228       begin
10229         delete(s, 1, 4);
10230         if s = FParser.GetToken then
10231         begin
10232           s := BlockInfo.Proc.FLabels[I];
10233           Cardinal((@s[1])^) := Length(BlockInfo.Proc.Data);
10234           BlockInfo.Proc.FLabels[i] := s;
10235           FParser.Next;
10236           if fParser.CurrTokenId = CSTI_Colon then
10237           begin
10238             Result := 1;
10239             FParser.Next;
10240             exit;
10241           end else begin
10242             MakeError('', ecColonExpected, '');
10243             Result := 0;
10244             Exit;
10245           end;
10246         end;
10247       end;
10248     end;
10249     result := 2;
10250   end;
10251 
ProcessIdentifiernull10252   function ProcessIdentifier: Boolean;
10253   var
10254     vin, vout: TPSValue;
10255   begin
10256     Result := False;
10257     Debug_WriteLine(BlockInfo);
10258     vin := Calc(CSTI_Assignment);//GetIdentifier(2);
10259     if vin <> nil then
10260     begin
10261       if vin is TPSValueVar then
10262       begin // assignment needed
10263         if FParser.CurrTokenId <> CSTI_Assignment then
10264         begin
10265           MakeError('', ecAssignmentExpected, '');
10266           vin.Free;
10267           exit;
10268         end;
10269         FParser.Next;
10270         vout := calc(CSTI_Semicolon);
10271         if vout = nil then
10272         begin
10273           vin.Free;
10274           exit;
10275         end;
10276         if not WriteCalculation(vout, vin) then
10277         begin
10278           vin.Free;
10279           vout.Free;
10280           exit;
10281         end;
10282         vin.Free;
10283         vout.Free;
10284       end else if vin is TPSValueProc then
10285       begin
PSValueProcnull10286         Result := _ProcessFunction(TPSValueProc(vin), nil);
10287         vin.Free;
10288         Exit;
10289       end else
10290       begin
10291         MakeError('', ecInternalError, '20');
10292         vin.Free;
10293         REsult := False;
10294         exit;
10295       end;
10296     end
10297     else
10298     begin
10299       Result := False;
10300       exit;
10301     end;
10302     Result := True;
10303   end; {ProcessIdentifier}
10304 
ProcessCasenull10305   function ProcessCase: Boolean;
10306   var
10307     V1, V2, TempRec, Val, CalcItem: TPSValue;
10308     p: TPSBinValueOp;
10309     SPos, CurrP: Cardinal;
10310     I: Longint;
10311     EndReloc: TPSList;
10312     Block: TPSBlockInfo;
10313 
NewRecnull10314     function NewRec(val: TPSValue): TPSValueReplace;
10315     begin
10316       Result := TPSValueReplace.Create;
10317       Result.SetParserPos(FParser);
10318       Result.FNewValue := Val;
10319       Result.FreeNewValue := False;
10320     end;
10321 
Combinenull10322     function Combine(v1, v2: TPSValue; Op: TPSBinOperatorType): TPSValue;
10323     begin
10324       if V1 = nil then
10325       begin
10326         Result := v2;
10327       end else if v2 = nil then
10328       begin
10329         Result := V1;
10330       end else
10331       begin
10332         Result := TPSBinValueOp.Create;
10333         TPSBinValueOp(Result).FType := FDefaultBoolType;
10334         TPSBinValueOp(Result).Operator := Op;
10335         Result.SetParserPos(FParser);
10336         TPSBinValueOp(Result).FVal1 := V1;
10337         TPSBinValueOp(Result).FVal2 := V2;
10338       end;
10339     end;
10340 
10341 
10342   begin
10343     Debug_WriteLine(BlockInfo);
10344     FParser.Next;
10345     Val := calc(CSTII_of);
10346     if Val = nil then
10347     begin
10348       ProcessCase := False;
10349       exit;
10350     end; {if}
10351     if FParser.CurrTokenId <> CSTII_Of then
10352     begin
10353       MakeError('', ecOfExpected, '');
10354       val.Free;
10355       ProcessCase := False;
10356       exit;
10357     end; {if}
10358     FParser.Next;
10359     TempRec := AllocStackReg(GetTypeNo(BlockInfo, Val));
10360     if not WriteCalculation(Val, TempRec) then
10361     begin
10362       TempRec.Free;
10363       val.Free;
10364       ProcessCase := False;
10365       exit;
10366     end; {if}
10367     val.Free;
10368     EndReloc := TPSList.Create;
10369     CalcItem := AllocStackReg(at2ut(FDefaultBoolType));
10370     SPos := Length(BlockInfo.Proc.Data);
10371     repeat
10372       V1 := nil;
10373       while true do
10374       begin
10375         Val := calc(CSTI_Colon);
10376         if (Val = nil) then
10377         begin
10378           V1.Free;
10379           CalcItem.Free;
10380           TempRec.Free;
10381           EndReloc.Free;
10382           ProcessCase := False;
10383           exit;
10384         end; {if}
10385         if fParser.CurrTokenID = CSTI_TwoDots then begin
10386           FParser.Next;
10387           V2 := Calc(CSTI_colon);
10388           if V2 = nil then begin
10389             V1.Free;
10390             CalcItem.Free;
10391             TempRec.Free;
10392             EndReloc.Free;
10393             ProcessCase := False;
10394             Val.Free;
10395             exit;
10396           end;
10397           p := TPSBinValueOp.Create;
10398           p.SetParserPos(FParser);
10399           p.Operator := otGreaterEqual;
10400           p.aType := at2ut(FDefaultBoolType);
10401           p.Val2 := Val;
10402           p.Val1 := NewRec(TempRec);
10403           Val := p;
10404           p := TPSBinValueOp.Create;
10405           p.SetParserPos(FParser);
10406           p.Operator := otLessEqual;
10407           p.aType := at2ut(FDefaultBoolType);
10408           p.Val2 := V2;
10409           p.Val1 := NewRec(TempRec);
10410           P := TPSBinValueOp(Combine(Val,P, otAnd));
10411         end else begin
10412           p := TPSBinValueOp.Create;
10413           p.SetParserPos(FParser);
10414           p.Operator := otEqual;
10415           p.aType := at2ut(FDefaultBoolType);
10416           p.Val1 := Val;
10417           p.Val2 := NewRec(TempRec);
10418         end;
10419         V1 := Combine(V1, P, otOr);
10420         if FParser.CurrTokenId = CSTI_Colon then Break;
10421         if FParser.CurrTokenID <> CSTI_Comma then
10422         begin
10423           MakeError('', ecColonExpected, '');
10424           V1.Free;
10425           CalcItem.Free;
10426           TempRec.Free;
10427           EndReloc.Free;
10428           ProcessCase := False;
10429           exit;
10430         end;
10431         FParser.Next;
10432       end;
10433       FParser.Next;
10434       if not WriteCalculation(V1, CalcItem) then
10435       begin
10436         CalcItem.Free;
10437         v1.Free;
10438         EndReloc.Free;
10439         ProcessCase := False;
10440         exit;
10441       end;
10442       v1.Free;
10443       BlockWriteByte(BlockInfo, Cm_CNG);
10444       BlockWriteLong(BlockInfo, $12345678);
10445       CurrP := Length(BlockInfo.Proc.Data);
10446       WriteOutRec(CalcItem, False);
10447       Block := TPSBlockInfo.Create(BlockInfo);
10448       Block.SubType := tifOneliner;
10449       if not ProcessSub(Block) then
10450       begin
10451         Block.Free;
10452         CalcItem.Free;
10453         TempRec.Free;
10454         EndReloc.Free;
10455         ProcessCase := False;
10456         exit;
10457       end;
10458       Block.Free;
10459       BlockWriteByte(BlockInfo, Cm_G);
10460       BlockWriteLong(BlockInfo, $12345678);
10461       EndReloc.Add(Pointer(Length(BlockInfo.Proc.Data)));
10462       {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10463       unaligned(Cardinal((@BlockInfo.Proc.Data[CurrP - 3])^)) := Cardinal(Length(BlockInfo.Proc.Data)) - CurrP - 5;
10464       {$else}
10465       Cardinal((@BlockInfo.Proc.Data[CurrP - 3])^) := Cardinal(Length(BlockInfo.Proc.Data)) - CurrP - 5;
10466       {$endif}
10467       if FParser.CurrTokenID = CSTI_Semicolon then FParser.Next;
10468       if FParser.CurrTokenID = CSTII_Else then
10469       begin
10470         FParser.Next;
10471         Block := TPSBlockInfo.Create(BlockInfo);
10472         Block.SubType := tOneliner;
10473         if not ProcessSub(Block) then
10474         begin
10475           Block.Free;
10476           CalcItem.Free;
10477           TempRec.Free;
10478           EndReloc.Free;
10479           ProcessCase := False;
10480           exit;
10481         end;
10482         Block.Free;
10483         if FParser.CurrTokenID = CSTI_Semicolon then FParser.Next;
10484         if FParser.CurrtokenId <> CSTII_End then
10485         begin
10486           MakeError('', ecEndExpected, '');
10487           CalcItem.Free;
10488           TempRec.Free;
10489           EndReloc.Free;
10490           ProcessCase := False;
10491           exit;
10492         end;
10493       end;
10494     until FParser.CurrTokenID = CSTII_End;
10495     FParser.Next;
10496     for i := 0 to EndReloc.Count -1 do
10497     begin
10498       {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10499       unaligned(Cardinal((@BlockInfo.Proc.Data[Cardinal(EndReloc[I])- 3])^)) := Cardinal(Length(BlockInfo.Proc.Data)) - Cardinal(EndReloc[I]);
10500       {$else}
10501       Cardinal((@BlockInfo.Proc.Data[Cardinal(EndReloc[I])- 3])^) := Cardinal(Length(BlockInfo.Proc.Data)) - Cardinal(EndReloc[I]);
10502       {$endif}
10503     end;
10504     CalcItem.Free;
10505     TempRec.Free;
10506     EndReloc.Free;
10507     if FContinueOffsets <> nil then
10508     begin
10509       for i := 0 to FContinueOffsets.Count -1 do
10510       begin
10511         if Cardinal(FContinueOffsets[i]) >= SPos then
10512         begin
10513           {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10514           unaligned(Byte((@BlockInfo.Proc.Data[Longint(FContinueOffsets[i]) - 4])^)) := Cm_P2G;
10515 	  {$else}
10516           Byte((@BlockInfo.Proc.Data[Longint(FContinueOffsets[i]) - 4])^) := Cm_P2G;
10517 	  {$endif}
10518         end;
10519       end;
10520     end;
10521     if FBreakOffsets <> nil then
10522     begin
10523       for i := 0 to FBreakOffsets.Count -1 do
10524       begin
10525         if Cardinal(FBreakOffsets[i]) >= SPos then
10526         begin
10527           {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10528           unaligned(Byte((@BlockInfo.Proc.Data[Longint(FBreakOffsets[i]) - 4])^)) := Cm_P2G;
10529 	  {$else}
10530           Byte((@BlockInfo.Proc.Data[Longint(FBreakOffsets[i]) - 4])^) := Cm_P2G;
10531 	  {$endif}
10532         end;
10533       end;
10534     end;
10535     if HasInvalidJumps(SPos, Length(BlockInfo.Proc.Data)) then
10536     begin
10537       Result := False;
10538       exit;
10539     end;
10540     Result := True;
10541   end; {ProcessCase}
ProcessGotonull10542 	function ProcessGoto: Boolean;
10543   var
10544     I, H: Longint;
10545     s: tbtString;
10546   begin
10547     Debug_WriteLine(BlockInfo);
10548     FParser.Next;
10549     h := MakeHash(FParser.GetToken);
10550 		for i := 0 to BlockInfo.Proc.FLabels.Count -1 do
10551     begin
10552       s := BlockInfo.Proc.FLabels[I];
10553       delete(s, 1, 4);
10554       if Longint((@s[1])^) = h then
10555       begin
10556         delete(s, 1, 4);
10557         if s = FParser.GetToken then
10558         begin
10559           FParser.Next;
10560           BlockWriteByte(BlockInfo, Cm_G);
10561           BlockWriteLong(BlockInfo, $12345678);
10562           BlockInfo.Proc.FGotos.Add(PS_mi2s(length(BlockInfo.Proc.Data))+PS_mi2s(i));
10563           Result := True;
10564           exit;
10565         end;
10566       end;
10567     end;
10568     MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
10569     Result := False;
10570   end; {ProcessGoto}
10571 
ProcessWithnull10572   function ProcessWith: Boolean;
10573   var
10574     Block: TPSBlockInfo;
10575     aVar, aReplace: TPSValue;
10576     aType: TPSType;
10577 
10578     iStartOffset: Integer;
10579 
10580     tmp: TPSValue;
10581   begin
10582     Debug_WriteLine(BlockInfo);
10583     Block := TPSBlockInfo.Create(BlockInfo);
10584     Block.SubType := tOneLiner;
10585 
10586     FParser.Next;
10587     repeat
10588       aVar := GetIdentifier(0);
10589       if aVar = nil then
10590       begin
10591         block.Free;
10592         Result := False;
10593         exit;
10594       end;
10595       AType := GetTypeNo(BlockInfo, aVar);
10596       if (AType = nil) or ((aType.BaseType <> btRecord) and (aType.BaseType <> btClass)) then
10597       begin
10598         MakeError('', ecClassTypeExpected, '');
10599         Block.Free;
10600         Result := False;
10601         exit;
10602       end;
10603 
10604       aReplace := TPSValueReplace.Create;
10605       aReplace.SetParserPos(FParser);
10606       TPSValueReplace(aReplace).FreeOldValue := True;
10607       TPSValueReplace(aReplace).FreeNewValue := True;
10608       TPSValueReplace(aReplace).OldValue := aVar;
10609 
10610       //if aVar.InheritsFrom(TPSVar) then TPSVar(aVar).Use;
10611       tmp := AllocPointer(GetTypeNo(BlockInfo, aVar));
10612       TPSProcVar(BlockInfo.Proc.ProcVars[TPSValueAllocatedStackVar(tmp).LocalVarNo]).Use;
10613       PreWriteOutRec(tmp,GetTypeNo(BlockInfo, tmp));
10614       PreWriteOutRec(aVar,GetTypeNo(BlockInfo, aVar));
10615       BlockWriteByte(BlockInfo, cm_sp);
10616       WriteOutRec(tmp, false);
10617       WriteOutRec(aVar, false);
10618       TPSValueReplace(aReplace).NewValue := tmp;
10619 
10620 
10621 
10622       Block.WithList.Add(aReplace);
10623 
10624       if FParser.CurrTokenID = CSTII_do then
10625       begin
10626         FParser.Next;
10627         Break;
10628       end else
10629       if FParser.CurrTokenId <> CSTI_Comma then
10630       begin
10631         MakeError('', ecDoExpected, '');
10632         Block.Free;
10633         Result := False;
10634         exit;
10635       end;
10636       FParser.Next;
10637     until False;
10638 
10639 
10640     inc(FWithCount);
10641 
10642     iStartOffset := Length(Block.Proc.Data);
10643 
10644     if not (ProcessSub(Block) and (not HasInvalidJumps(iStartOffset,Length(BlockInfo.Proc.Data) + 1)) )  then
10645     begin
10646       dec(FWithCount);
10647       Block.Free;
10648       Result := False;
10649       exit;
10650     end;
10651     dec(FWithCount);
10652 
10653     AfterWriteOutRec(aVar);
10654     AfterWriteOutRec(tmp);
10655     Block.Free;
10656     Result := True;
10657   end;
10658 
ProcessTrynull10659   function ProcessTry: Boolean;
10660   var
10661     FStartOffset: Cardinal;
10662     iBlockStartOffset: Integer;
10663     Block: TPSBlockInfo;
10664   begin
10665     FParser.Next;
10666     BlockWriteByte(BlockInfo, cm_puexh);
10667     FStartOffset := Length(BlockInfo.Proc.Data) + 1;
10668     BlockWriteLong(BlockInfo, InvalidVal);
10669     BlockWriteLong(BlockInfo, InvalidVal);
10670     BlockWriteLong(BlockInfo, InvalidVal);
10671     BlockWriteLong(BlockInfo, InvalidVal);
10672     Block := TPSBlockInfo.Create(BlockInfo);
10673     Block.SubType := tTry;
10674     inc(FTryCount);
10675     if ProcessSub(Block) and (not HasInvalidJumps(FStartOffset,Length(BlockInfo.Proc.Data) + 1))  then
10676     begin
10677       dec(FTryCount);
10678       Block.Free;
10679       BlockWriteByte(BlockInfo, cm_poexh);
10680       BlockWriteByte(BlockInfo, 0);
10681       if FParser.CurrTokenID = CSTII_Except then
10682       begin
10683         FParser.Next;
10684         Cardinal((@BlockInfo.Proc.Data[FStartOffset + 4])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
10685         iBlockStartOffset := Length(BlockInfo.Proc.Data) ;
10686         Block := TPSBlockInfo.Create(BlockInfo);
10687         Block.SubType := tTryEnd;
10688         inc(FExceptFinallyCount);
10689         if ProcessSub(Block) and (not HasInvalidJumps(iBlockStartOffset,Length(BlockInfo.Proc.Data) + 1))  then
10690         begin
10691           dec(FExceptFinallyCount);
10692           Block.Free;
10693           BlockWriteByte(BlockInfo, cm_poexh);
10694           BlockWriteByte(BlockInfo, 2);
10695           if FParser.CurrTokenId = CSTII_Finally then
10696           begin
10697             Cardinal((@BlockInfo.Proc.Data[FStartOffset + 8])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
10698             iBlockStartOffset := Length(BlockInfo.Proc.Data) ;
10699             Block := TPSBlockInfo.Create(BlockInfo);
10700             Block.SubType := tTryEnd;
10701             FParser.Next;
10702            inc(FExceptFinallyCount);
10703             if ProcessSub(Block)  and (not HasInvalidJumps(iBlockStartOffset,Length(BlockInfo.Proc.Data) + 1))  then
10704             begin
10705               dec(FExceptFinallyCount);
10706               Block.Free;
10707               if FParser.CurrTokenId = CSTII_End then
10708               begin
10709                 BlockWriteByte(BlockInfo, cm_poexh);
10710                 BlockWriteByte(BlockInfo, 3);
10711               end else begin
10712                 MakeError('', ecEndExpected, '');
10713                 Result := False;
10714                 exit;
10715               end;
10716             end else
10717             begin
10718               Block.Free;
10719               Result := False;
10720               dec(FExceptFinallyCount);
10721               exit;
10722             end;
10723           end else if FParser.CurrTokenID <> CSTII_End then
10724           begin
10725             MakeError('', ecEndExpected, '');
10726             Result := False;
10727             exit;
10728           end;
10729           FParser.Next;
10730         end else
10731         begin
10732           Block.Free;
10733           Result := False;
10734           dec(FExceptFinallyCount);
10735           exit;
10736         end;
10737       end else if FParser.CurrTokenId = CSTII_Finally then
10738       begin
10739         FParser.Next;
10740         Cardinal((@BlockInfo.Proc.Data[FStartOffset])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
10741         iBlockStartOffset := Length(BlockInfo.Proc.Data) ;
10742         Block := TPSBlockInfo.Create(BlockInfo);
10743         Block.SubType := tTryEnd;
10744         inc(FExceptFinallyCount);
10745         if ProcessSub(Block)  and (not HasInvalidJumps(iBlockStartOffset,Length(BlockInfo.Proc.Data) + 1)) then
10746         begin
10747           dec(FExceptFinallyCount);
10748           Block.Free;
10749           BlockWriteByte(BlockInfo, cm_poexh);
10750           BlockWriteByte(BlockInfo, 1);
10751           if FParser.CurrTokenId = CSTII_Except then
10752           begin
10753             Cardinal((@BlockInfo.Proc.Data[FStartOffset + 4])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
10754             iBlockStartOffset := Length(BlockInfo.Proc.Data) ;
10755             FParser.Next;
10756             Block := TPSBlockInfo.Create(BlockInfo);
10757             Block.SubType := tTryEnd;
10758             inc(FExceptFinallyCount);
10759             if ProcessSub(Block) and (not HasInvalidJumps(iBlockStartOffset,Length(BlockInfo.Proc.Data) + 1)) then
10760             begin
10761               dec(FExceptFinallyCount);
10762               Block.Free;
10763               if FParser.CurrTokenId = CSTII_End then
10764               begin
10765                 BlockWriteByte(BlockInfo, cm_poexh);
10766                 BlockWriteByte(BlockInfo, 2);
10767               end else begin
10768                 MakeError('', ecEndExpected, '');
10769                 Result := False;
10770                 exit;
10771               end;
10772             end else
10773             begin
10774               Block.Free;
10775               Result := False;
10776               dec(FExceptFinallyCount);
10777               exit;
10778             end;
10779           end else if FParser.CurrTokenID <> CSTII_End then
10780           begin
10781             MakeError('', ecEndExpected, '');
10782             Result := False;
10783             exit;
10784           end;
10785           FParser.Next;
10786         end else
10787         begin
10788           Block.Free;
10789           Result := False;
10790           dec(FExceptFinallyCount);
10791           exit;
10792         end;
10793       end;
10794     end else
10795     begin
10796       Block.Free;
10797       Result := False;
10798       dec(FTryCount);
10799       exit;
10800     end;
10801     Cardinal((@BlockInfo.Proc.Data[FStartOffset + 12])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
10802     Result := True;
10803   end; {ProcessTry}
10804 
10805 var
10806   i: Integer;
10807   Block: TPSBlockInfo;
10808 
10809 begin
10810   ProcessSub := False;
10811   if (BlockInfo.SubType = tProcBegin) or (BlockInfo.SubType= tMainBegin) or
10812 {$IFDEF PS_USESSUPPORT}
10813      (BlockInfo.SubType = tUnitInit) or (BlockInfo.SubType= tUnitFinish) or // NvdS
10814 {$endif}
10815      (BlockInfo.SubType= tSubBegin) then
10816   begin
10817     FParser.Next; // skip CSTII_Begin
10818   end;
10819   while True do
10820   begin
10821     case FParser.CurrTokenId of
10822       CSTII_Goto:
10823         begin
10824           if not ProcessGoto then
10825             Exit;
10826           if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10827             break;
10828         end;
10829       CSTII_With:
10830         begin
10831           if not ProcessWith then
10832             Exit;
10833           if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10834             break;
10835         end;
10836       CSTII_Try:
10837         begin
10838           if not ProcessTry then
10839             Exit;
10840           if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10841             break;
10842         end;
10843       CSTII_Finally, CSTII_Except:
10844         begin
10845           if (BlockInfo.SubType = tTry) or (BlockInfo.SubType = tTryEnd) then
10846             Break
10847           else
10848             begin
10849               MakeError('', ecEndExpected, '');
10850               Exit;
10851             end;
10852         end;
10853       CSTII_Begin:
10854         begin
10855           Block := TPSBlockInfo.Create(BlockInfo);
10856           Block.SubType := tSubBegin;
10857           if not ProcessSub(Block) then
10858           begin
10859             Block.Free;
10860             Exit;
10861           end;
10862           Block.Free;
10863 
10864           FParser.Next; // skip END
10865           if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10866             break;
10867         end;
10868       CSTI_Semicolon:
10869         begin
10870 
10871           if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10872             break
10873           else FParser.Next;
10874         end;
10875       CSTII_until:
10876         begin
10877           Debug_WriteLine(BlockInfo);
10878           if BlockInfo.SubType = tRepeat then
10879           begin
10880             break;
10881           end
10882           else
10883           begin
10884             MakeError('', ecIdentifierExpected, '');
10885             exit;
10886           end;
10887           if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10888             break;
10889         end;
10890       CSTII_Else:
10891         begin
10892           if BlockInfo.SubType = tifOneliner then
10893             break
10894           else
10895           begin
10896             MakeError('', ecIdentifierExpected, '');
10897             exit;
10898           end;
10899         end;
10900       CSTII_repeat:
10901         begin
10902           if not ProcessRepeat then
10903             exit;
10904           if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10905             break;
10906         end;
10907       CSTII_For:
10908         begin
10909           if not ProcessFor then
10910             exit;
10911           if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10912             break;
10913         end;
10914       CSTII_While:
10915         begin
10916           if not ProcessWhile then
10917             exit;
10918           if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10919             break;
10920         end;
10921       CSTII_Exit:
10922         begin
10923           Debug_WriteLine(BlockInfo);
10924           BlockWriteByte(BlockInfo, Cm_R);
10925           FParser.Next;
10926           if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10927             break;
10928         end;
10929       CSTII_Case:
10930         begin
10931           if not ProcessCase then
10932             exit;
10933           if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10934             break;
10935         end;
10936       CSTII_If:
10937         begin
10938           if not ProcessIf then
10939             exit;
10940           if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10941             break;
10942         end;
10943       CSTI_OpenRound,
10944       CSTI_Identifier:
10945         begin
10946           case _ProcessLabel of
10947             0: Exit;
10948             1: ;
10949             else
10950             begin
10951               if FParser.GetToken = 'BREAK' then
10952               begin
10953                 if FBreakOffsets = nil then
10954                 begin
10955                   MakeError('', ecNotInLoop, '');
10956                   exit;
10957                 end;
10958                 for i := 0 to FExceptFinallyCount - 1 do
10959                 begin
10960                   BlockWriteByte(BlockInfo, cm_poexh);
10961                   BlockWriteByte(BlockInfo, 1);
10962                 end;
10963 
10964                 for i := 0 to FTryCount - 1 do
10965                 begin
10966                   BlockWriteByte(BlockInfo, cm_poexh);
10967                   BlockWriteByte(BlockInfo, 0);
10968                   BlockWriteByte(BlockInfo, cm_poexh);
10969                   BlockWriteByte(BlockInfo, 1);
10970                 end;
10971 
10972                 for i := 0 to FWithCount - 1 do
10973 									BlockWriteByte(BlockInfo,cm_po);
10974                 BlockWriteByte(BlockInfo, Cm_G);
10975                 BlockWriteLong(BlockInfo, $12345678);
10976                 FBreakOffsets.Add(Pointer(Length(BlockInfo.Proc.Data)));
10977                 FParser.Next;
10978                 if (BlockInfo.SubType= tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10979                   break;
10980               end else if FParser.GetToken = 'CONTINUE' then
10981               begin
10982                 if FBreakOffsets = nil then
10983                 begin
10984                   MakeError('', ecNotInLoop, '');
10985                   exit;
10986                 end;
10987                 for i := 0 to FExceptFinallyCount - 1 do
10988                 begin
10989                   BlockWriteByte(BlockInfo, cm_poexh);
10990                   BlockWriteByte(BlockInfo, 1);
10991                 end;
10992 
10993                 for i := 0 to FTryCount - 1 do
10994                 begin
10995                   BlockWriteByte(BlockInfo, cm_poexh);
10996                   BlockWriteByte(BlockInfo, 0);
10997                   BlockWriteByte(BlockInfo, cm_poexh);
10998                   BlockWriteByte(BlockInfo, 1);
10999                 end;
11000 
11001                 for i := 0 to FWithCount - 1 do
11002 									BlockWriteByte(BlockInfo,cm_po);
11003                 BlockWriteByte(BlockInfo, Cm_G);
11004                 BlockWriteLong(BlockInfo, $12345678);
11005                 FContinueOffsets.Add(Pointer(Length(BlockInfo.Proc.Data)));
11006                 FParser.Next;
11007                 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
11008                   break;
11009               end else
11010               if not ProcessIdentifier then
11011                 exit;
11012               if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
11013                 break;
11014             end;
11015           end; {case}
11016 
11017           if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
11018             break;
11019 
11020         end;
11021     {$IFDEF PS_USESSUPPORT}
11022       CSTII_Finalization:                            //NvdS
11023         begin                                        //
11024           if (BlockInfo.SubType = tUnitInit) then    //
11025           begin                                      //
11026             break;                                   //
11027           end                                        //
11028           else                                       //
11029           begin                                      //
11030             MakeError('', ecIdentifierExpected, ''); //
11031             exit;                                    //
11032           end;                                       //
11033         end;                                         //nvds
11034     {$endif}
11035       CSTII_End:
11036         begin
11037           if (BlockInfo.SubType = tTryEnd) or (BlockInfo.SubType = tMainBegin) or
11038              (BlockInfo.SubType = tSubBegin) or (BlockInfo.SubType = tifOneliner) or
11039              (BlockInfo.SubType = tProcBegin) or (BlockInfo.SubType = TOneLiner)
11040     {$IFDEF PS_USESSUPPORT} or (BlockInfo.SubType = tUnitInit) or (BlockInfo.SubType = tUnitFinish) {$endif} then //nvds
11041           begin
11042             break;
11043           end
11044           else
11045           begin
11046             MakeError('', ecIdentifierExpected, '');
11047             exit;
11048           end;
11049         end;
11050       CSTI_EOF:
11051         begin
11052           MakeError('', ecUnexpectedEndOfFile, '');
11053           exit;
11054         end;
11055     else
11056       begin
11057         MakeError('', ecIdentifierExpected, '');
11058         exit;
11059       end;
11060     end;
11061   end;
11062   if (BlockInfo.SubType = tMainBegin) or (BlockInfo.SubType = tProcBegin)
11063  {$IFDEF PS_USESSUPPORT} or (BlockInfo.SubType = tUnitInit) or (BlockInfo.SubType = tUnitFinish) {$endif} then  //nvds
11064   begin
11065     Debug_WriteLine(BlockInfo);
11066     BlockWriteByte(BlockInfo, Cm_R);
11067     {$IFDEF PS_USESSUPPORT}
11068     if FParser.CurrTokenId = CSTII_End then //nvds
11069     begin
11070     {$endif}
11071       FParser.Next; // skip end
11072       if ((BlockInfo.SubType = tMainBegin)
11073     {$IFDEF PS_USESSUPPORT} or (BlockInfo.SubType = tUnitInit) or (BlockInfo.SubType = tUnitFinish){$endif}) //nvds
11074          and (FParser.CurrTokenId <> CSTI_Period) then
11075       begin
11076         MakeError('', ecPeriodExpected, '');
11077         exit;
11078       end;
11079       if (BlockInfo.SubType = tProcBegin) and (FParser.CurrTokenId <> CSTI_Semicolon) then
11080       begin
11081         MakeError('', ecSemicolonExpected, '');
11082         exit;
11083       end;
11084       FParser.Next;
11085     {$IFDEF PS_USESSUPPORT}
11086     end;   //nvds
11087     {$endif}
11088   end
11089   else if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
11090   begin
11091     if (FParser.CurrTokenID <> CSTII_Else) and (FParser.CurrTokenID <> CSTII_End) then
11092       if FParser.CurrTokenID <> CSTI_Semicolon then
11093       begin
11094         MakeError('', ecSemicolonExpected, '');
11095         exit;
11096       end;
11097   end;
11098 
11099   ProcessSub := True;
11100 end;
11101 procedure TPSPascalCompiler.UseProc(procdecl: TPSParametersDecl);
11102 var
11103   i: Longint;
11104 begin
11105   if procdecl.Result <> nil then
11106     procdecl.Result := at2ut(procdecl.Result);
11107   for i := 0 to procdecl.ParamCount -1 do
11108   begin
11109     procdecl.Params[i].aType := at2ut(procdecl.Params[i].aType);
11110   end;
11111 end;
11112 
at2utnull11113 function TPSPascalCompiler.at2ut(p: TPSType): TPSType;
11114 var
11115   i: Longint;
11116 begin
11117   p := GetTypeCopyLink(p);
11118   if p = nil then
11119   begin
11120     Result := nil;
11121     exit;
11122   end;
11123   if not p.Used then
11124   begin
11125     p.Use;
11126     case p.BaseType of
11127       btStaticArray, btArray: TPSArrayType(p).ArrayTypeNo := at2ut(TPSArrayType(p).ArrayTypeNo);
11128       btRecord:
11129         begin
11130           for i := 0 to TPSRecordType(p).RecValCount -1 do
11131           begin
11132             TPSRecordType(p).RecVal(i).aType := at2ut(TPSRecordType(p).RecVal(i).aType);
11133           end;
11134         end;
11135       btSet: TPSSetType(p).SetType := at2ut(TPSSetType(p).SetType);
11136       btProcPtr:
11137         begin
11138           UseProc(TPSProceduralType(p).ProcDef);
11139         end;
11140     end;
11141     p.FFinalTypeNo := FCurrUsedTypeNo;
11142     inc(FCurrUsedTypeNo);
11143   end;
11144   Result := p;
11145 end;
11146 
TPSPascalCompiler.ProcessLabelForwardsnull11147 function TPSPascalCompiler.ProcessLabelForwards(Proc: TPSInternalProcedure): Boolean;
11148 var
11149   i: Longint;
11150   s, s2: tbtString;
11151 begin
11152   for i := 0 to Proc.FLabels.Count -1 do
11153   begin
11154     s := Proc.FLabels[I];
11155     if Longint((@s[1])^) = -1 then
11156     begin
11157       delete(s, 1, 8);
11158       MakeError('', ecUnSetLabel, s);
11159       Result := False;
11160       exit;
11161     end;
11162   end;
11163   for i := Proc.FGotos.Count -1 downto 0 do
11164   begin
11165     s := Proc.FGotos[I];
11166     s2 := Proc.FLabels[Cardinal((@s[5])^)];
11167     Cardinal((@Proc.Data[Cardinal((@s[1])^)-3])^) :=  Cardinal((@s2[1])^) - Cardinal((@s[1])^) ;
11168   end;
11169   Result := True;
11170 end;
11171 
11172 
11173 type
11174   TCompilerState = (csStart, csProgram, csUnit, csUses, csInterface, csInterfaceUses, csImplementation);
11175 
TPSPascalCompiler.Compilenull11176 function TPSPascalCompiler.Compile(const s: tbtString): Boolean;
11177 var
11178   Position: TCompilerState;
11179   i: Longint;
11180   {$IFDEF PS_USESSUPPORT}
11181   OldFileName: tbtString;
11182   OldParser  : TPSPascalParser;
11183   OldIsUnit  : Boolean;
11184   OldUnit    : TPSUnit;
11185   {$ENDIF}
11186 
11187   procedure Cleanup;
11188   var
11189     I: Longint;
11190     PT: TPSType;
11191   begin
11192     {$IFDEF PS_USESSUPPORT}
11193     if fInCompile>1 then
11194     begin
11195       dec(fInCompile);
11196       exit;
11197     end;
11198     {$ENDIF}
11199 
11200     if @FOnBeforeCleanup <> nil then
11201       FOnBeforeCleanup(Self);        // no reason it actually read the result of this call
11202     FGlobalBlock.Free;
11203     FGlobalBlock := nil;
11204 
11205     for I := 0 to FRegProcs.Count - 1 do
11206       TObject(FRegProcs[I]).Free;
11207     FRegProcs.Free;
11208     for i := 0 to FConstants.Count -1 do
11209     begin
11210       TPSConstant(FConstants[I]).Free;
11211     end;
11212     Fconstants.Free;
11213     for I := 0 to FVars.Count - 1 do
11214     begin
11215       TPSVar(FVars[I]).Free;
11216     end;
11217     FVars.Free;
11218     FVars := nil;
11219     for I := 0 to FProcs.Count - 1 do
11220       TPSProcedure(FProcs[I]).Free;
11221     FProcs.Free;
11222     FProcs := nil;
11223     //reverse free types: a custom type's attribute value type may point to a base type
11224     for I := FTypes.Count - 1 downto 0 do
11225     begin
11226       PT := FTypes[I];
11227       pt.Free;
11228     end;
11229     FTypes.Free;
11230 
11231 {$IFNDEF PS_NOINTERFACES}
11232     for i := FInterfaces.Count -1 downto 0 do
11233       TPSInterface(FInterfaces[i]).Free;
11234     FInterfaces.Free;
11235 {$ENDIF}
11236 
11237     for i := FClasses.Count -1 downto 0 do
11238     begin
11239       TPSCompileTimeClass(FClasses[I]).Free;
11240     end;
11241     FClasses.Free;
11242     for i := FAttributeTypes.Count -1 downto 0 do
11243     begin
11244       TPSAttributeType(FAttributeTypes[i]).Free;
11245     end;
11246     FAttributeTypes.Free;
11247     FAttributeTypes := nil;
11248 
11249     {$IFDEF PS_USESSUPPORT}
11250     for I := 0 to FUnitInits.Count - 1 do        //nvds
11251     begin                                        //nvds
11252       TPSBlockInfo(FUnitInits[I]).free;          //nvds
11253     end;                                         //nvds
11254     FUnitInits.Free;                             //nvds
11255     FUnitInits := nil;                           //
11256     for I := 0 to FUnitFinits.Count - 1 do       //nvds
11257     begin                                        //nvds
11258       TPSBlockInfo(FUnitFinits[I]).free;         //nvds
11259     end;                                         //nvds
11260     FUnitFinits.Free;                            //
11261     FUnitFinits := nil;                          //
11262 
11263     FreeAndNil(fUnits);
11264     FreeAndNil(FUses);
11265     fInCompile:=0;
11266     {$ENDIF}
11267   end;
11268 
11269   function MakeOutput: Boolean;
11270 
11271     procedure WriteByte(b: Byte);
11272     begin
11273       FOutput := FOutput + tbtChar(b);
11274     end;
11275 
11276     procedure WriteData(const Data; Len: Longint);
11277     var
11278       l: Longint;
11279     begin
11280       if Len < 0 then Len := 0;
11281       l := Length(FOutput);
11282       SetLength(FOutput, l + Len);
11283       Move(Data, FOutput[l + 1], Len);
11284     end;
11285 
11286     procedure WriteLong(l: Cardinal);
11287     begin
11288       WriteData(l, 4);
11289     end;
11290 
11291     procedure WriteVariant(p: PIfRVariant);
11292     begin
11293       WriteLong(p^.FType.FinalTypeNo);
11294       case p.FType.BaseType of
11295       btType: WriteLong(p^.ttype.FinalTypeNo);
11296       {$IFNDEF PS_NOWIDESTRING}
11297       btWideString:
11298         begin
11299           WriteLong(Length(tbtWideString(p^.twidestring)));
11300           WriteData(tbtwidestring(p^.twidestring)[1], 2*Length(tbtWideString(p^.twidestring)));
11301         end;
11302       btUnicodeString:
11303         begin
11304           WriteLong(Length(tbtUnicodestring(p^.twidestring)));
11305           WriteData(tbtUnicodestring(p^.twidestring)[1], 2*Length(tbtUnicodestring(p^.twidestring)));
11306         end;
11307       btWideChar: WriteData(p^.twidechar, 2);
11308       {$ENDIF}
11309       btSingle: WriteData(p^.tsingle, sizeof(tbtSingle));
11310       btDouble: WriteData(p^.tsingle, sizeof(tbtDouble));
11311       btExtended: WriteData(p^.tsingle, sizeof(tbtExtended));
11312       btCurrency: WriteData(p^.tsingle, sizeof(tbtCurrency));
11313       btChar: WriteData(p^.tchar, 1);
11314       btSet:
11315         begin
11316           WriteData(tbtString(p^.tstring)[1], Length(tbtString(p^.tstring)));
11317         end;
11318       btString:
11319         begin
11320           WriteLong(Length(tbtString(p^.tstring)));
11321           WriteData(tbtString(p^.tstring)[1], Length(tbtString(p^.tstring)));
11322         end;
11323       btenum:
11324         begin
11325           if TPSEnumType(p^.FType).HighValue <=256 then
11326             WriteData( p^.tu32, 1)
11327           else if TPSEnumType(p^.FType).HighValue <=65536 then
11328             WriteData(p^.tu32, 2)
11329           else
11330             WriteData(p^.tu32, 4);
11331         end;
11332       bts8,btu8: WriteData(p^.tu8, 1);
11333       bts16,btu16: WriteData(p^.tu16, 2);
11334       bts32,btu32: WriteData(p^.tu32, 4);
11335       {$IFNDEF PS_NOINT64}
11336       bts64: WriteData(p^.ts64, 8);
11337       {$ENDIF}
11338       btProcPtr: WriteData(p^.tu32, 4);
11339       {$IFDEF DEBUG}
11340       else
11341           asm int 3; end;
11342       {$ENDIF}
11343       end;
11344     end;
11345 
11346     procedure WriteAttributes(attr: TPSAttributes);
11347     var
11348       i, j: Longint;
11349     begin
11350       WriteLong(attr.Count);
11351       for i := 0 to Attr.Count -1 do
11352       begin
11353         j := Length(attr[i].FAttribType.Name);
11354         WriteLong(j);
11355         WriteData(Attr[i].FAttribType.Name[1], j);
11356         WriteLong(Attr[i].Count);
11357         for j := 0 to Attr[i].Count -1 do
11358         begin
11359           WriteVariant(Attr[i][j]);
11360         end;
11361       end;
11362     end;
11363 
11364     procedure WriteTypes;
11365     var
11366       l, n: Longint;
11367       bt: TPSBaseType;
11368       x: TPSType;
11369       s: tbtString;
11370       FExportName: tbtString;
11371       Items: TPSList;
11372       procedure WriteTypeNo(TypeNo: Cardinal);
11373       begin
11374         WriteData(TypeNo, 4);
11375       end;
11376     begin
11377       Items := TPSList.Create;
11378       try
11379         for l := 0 to FCurrUsedTypeNo -1 do
11380           Items.Add(nil);
11381         for l := 0 to FTypes.Count -1 do
11382         begin
11383           x := FTypes[l];
11384           if x.Used then
11385             Items[x.FinalTypeNo] := x;
11386         end;
11387         for l := 0 to Items.Count - 1 do
11388         begin
11389           x := Items[l];
11390           if x.FExportName then
11391             FExportName := x.Name
11392           else
11393             FExportName := '';
11394           if (x.BaseType = btExtClass) and (x is TPSUndefinedClassType) then
11395           begin
11396             x := GetTypeCopyLink(TPSUndefinedClassType(x).ExtClass.SelfType);
11397           end;
11398           bt := x.BaseType;
11399           if (x.BaseType = btType) or (x.BaseType = btNotificationVariant) then
11400           begin
11401             bt := btU32;
11402           end else
11403           if (x.BaseType = btEnum) then begin
11404             if TPSEnumType(x).HighValue <= 256 then
11405               bt := btU8
11406             else if TPSEnumType(x).HighValue <= 65536 then
11407               bt := btU16
11408             else
11409               bt := btU32;
11410           end;
11411           if FExportName <> '' then
11412           begin
11413             WriteByte(bt + 128);
11414           end
11415           else
11416             WriteByte(bt);
11417 {$IFNDEF PS_NOINTERFACES} if x.BaseType = btInterface then
11418           begin
11419             WriteData(TPSInterfaceType(x).Intf.Guid, Sizeof(TGuid));
11420           end else {$ENDIF} if x.BaseType = btClass then
11421           begin
11422             WriteLong(Length(TPSClassType(X).Cl.FClassName));
11423             WriteData(TPSClassType(X).Cl.FClassName[1], Length(TPSClassType(X).Cl.FClassName));
11424           end else
11425           if (x.BaseType = btProcPtr) then
11426           begin
11427             s := DeclToBits(TPSProceduralType(x).ProcDef);
11428             WriteLong(Length(s));
11429             WriteData(s[1], Length(s));
11430           end else
11431           if (x.BaseType = btSet) then
11432           begin
11433             WriteLong(TPSSetType(x).BitSize);
11434           end else
11435           if (x.BaseType = btArray) or (x.basetype = btStaticArray) then
11436           begin
11437             WriteLong(TPSArrayType(x).ArrayTypeNo.FinalTypeNo);
11438             if (x.baseType = btstaticarray) then begin
11439               WriteLong(TPSStaticArrayType(x).Length);
11440               WriteLong(TPSStaticArrayType(x).StartOffset);      //<-additional StartOffset
11441             end;
11442           end else if x.BaseType = btRecord then
11443           begin
11444             n := TPSRecordType(x).RecValCount;
11445             WriteData( n, 4);
11446             for n := 0 to TPSRecordType(x).RecValCount - 1 do
11447               WriteTypeNo(TPSRecordType(x).RecVal(n).FType.FinalTypeNo);
11448           end;
11449           if FExportName <> '' then
11450           begin
11451             WriteLong(Length(FExportName));
11452             WriteData(FExportName[1], length(FExportName));
11453           end;
11454           WriteAttributes(x.Attributes);
11455         end;
11456       finally
11457         Items.Free;
11458       end;
11459     end;
11460 
11461     procedure WriteVars;
11462     var
11463       l,j : Longint;
11464       x: TPSVar;
11465     begin
11466       for l := 0 to FVars.Count - 1 do
11467       begin
11468         x := FVars[l];
11469         if x.SaveAsPointer then
11470         begin
11471           for j := FTypes.count -1 downto 0 do
11472           begin
11473             if TPSType(FTypes[j]).BaseType = btPointer then
11474             begin
11475               WriteLong(TPSType(FTypes[j]).FinalTypeNo);
11476               break;
11477             end;
11478           end;
11479         end else
11480           WriteLong(x.FType.FinalTypeNo);
11481         if x.exportname <> '' then
11482         begin
11483           WriteByte( 1);
11484           WriteLong(Length(X.ExportName));
11485           WriteData( X.ExportName[1], length(X.ExportName));
11486         end else
11487           WriteByte( 0);
11488       end;
11489     end;
11490 
11491     procedure WriteProcs;
11492     var
11493       l: Longint;
11494       xp: TPSProcedure;
11495       xo: TPSInternalProcedure;
11496       xe: TPSExternalProcedure;
11497       s: tbtString;
11498       att: Byte;
11499     begin
11500       for l := 0 to FProcs.Count - 1 do
11501       begin
11502         xp := FProcs[l];
11503         if xp.Attributes.Count <> 0 then att := 4 else att := 0;
11504         if xp.ClassType = TPSInternalProcedure then
11505         begin
11506           xo := TPSInternalProcedure(xp);
11507           xo.OutputDeclPosition := Length(FOutput);
11508           WriteByte(att or 2); // exported
11509           WriteLong(0); // offset is unknown at this time
11510           WriteLong(0); // length is also unknown at this time
11511           WriteLong(Length(xo.Name));
11512           WriteData( xo.Name[1], length(xo.Name));
11513           s := MakeExportDecl(xo.Decl);
11514           WriteLong(Length(s));
11515           WriteData( s[1], length(S));
11516         end
11517         else
11518         begin
11519           xe := TPSExternalProcedure(xp);
11520           if xe.RegProc.ImportDecl <> '' then
11521           begin
11522             WriteByte( att or 3); // imported
11523             if xe.RegProc.FExportName then
11524             begin
11525               WriteByte(Length(xe.RegProc.Name));
11526               WriteData(xe.RegProc.Name[1], Length(xe.RegProc.Name) and $FF);
11527             end else begin
11528               WriteByte(0);
11529             end;
11530             WriteLong(Length(xe.RegProc.ImportDecl));
11531             WriteData(xe.RegProc.ImportDecl[1], Length(xe.RegProc.ImportDecl));
11532           end else begin
11533             WriteByte(att or 1); // imported
11534             WriteByte(Length(xe.RegProc.Name));
11535             WriteData(xe.RegProc.Name[1], Length(xe.RegProc.Name) and $FF);
11536           end;
11537         end;
11538         if xp.Attributes.Count <> 0 then
11539           WriteAttributes(xp.Attributes);
11540       end;
11541     end;
11542 
11543     procedure WriteProcs2;
11544     var
11545       l: Longint;
11546       L2: Cardinal;
11547       x: TPSProcedure;
11548     begin
11549       for l := 0 to FProcs.Count - 1 do
11550       begin
11551         x := FProcs[l];
11552         if x.ClassType = TPSInternalProcedure then
11553         begin
11554           if TPSInternalProcedure(x).Data = '' then
11555             TPSInternalProcedure(x).Data := Chr(Cm_R);
11556           L2 := Length(FOutput);
11557           Move(L2, FOutput[TPSInternalProcedure(x).OutputDeclPosition + 2], 4);
11558           // write position
11559           WriteData(TPSInternalProcedure(x).Data[1], Length(TPSInternalProcedure(x).Data));
11560           L2 := Cardinal(Length(FOutput)) - L2;
11561           Move(L2, FOutput[TPSInternalProcedure(x).OutputDeclPosition + 6], 4); // write length
11562         end;
11563       end;
11564     end;
11565 
11566 
11567 
11568     {$IFDEF PS_USESSUPPORT}
11569     function FindMainProc: Cardinal;
11570     var
11571       l: Longint;
11572       Proc : TPSInternalProcedure;
11573       ProcData : tbtString;
11574       Calls : Integer;
11575 
11576       procedure WriteProc(const aData: Longint);
11577       var
11578         l: Longint;
11579       begin
11580         ProcData := ProcData + Chr(cm_c);
11581         l := Length(ProcData);
11582         SetLength(ProcData, l + 4);
11583         Move(aData, ProcData[l + 1], 4);
11584         inc(Calls);
11585       end;
11586     begin
11587       ProcData := ''; Calls := 1;
11588       for l := 0 to FUnitInits.Count-1 do
11589         if (FUnitInits[l] <> nil) and
11590            (TPSBlockInfo(FUnitInits[l]).Proc.Data<>'') then
11591           WriteProc(TPSBlockInfo(FUnitInits[l]).FProcNo);
11592 
11593       WriteProc(FGlobalBlock.FProcNo);
11594 
11595       for l := FUnitFinits.Count-1 downto 0 do
11596         if (FUnitFinits[l] <> nil) and
11597            (TPSBlockInfo(FUnitFinits[l]).Proc.Data<>'') then
11598           WriteProc(TPSBlockInfo(FUnitFinits[l]).FProcNo);
11599 
11600       if Calls = 1 then begin
11601         Result := FGlobalBlock.FProcNo;
11602       end else
11603       begin
11604         Proc := NewProc('Master proc', '!MASTERPROC');
11605         Result := FindProc('!MASTERPROC');
11606         Proc.data := Procdata + Chr(cm_R);
11607       end;
11608     end;
11609     {$ELSE}
11610     function FindMainProc: Cardinal;
11611     var
11612       l: Longint;
11613     begin
11614       for l := 0 to FProcs.Count - 1 do
11615       begin
11616         if (TPSProcedure(FProcs[l]).ClassType = TPSInternalProcedure) and
11617           (TPSInternalProcedure(FProcs[l]).Name = PSMainProcName) then
11618         begin
11619           Result := l;
11620           exit;
11621         end;
11622       end;
11623       Result := InvalidVal;
11624     end;
11625     {$ENDIF}
11626 
11627     procedure CreateDebugData;
11628     var
11629       I: Longint;
11630       p: TPSProcedure;
11631       pv: TPSVar;
11632       s: tbtString;
11633     begin
11634       s := #0;
11635       for I := 0 to FProcs.Count - 1 do
11636       begin
11637         p := FProcs[I];
11638         if p.ClassType = TPSInternalProcedure then
11639         begin
11640           if TPSInternalProcedure(p).Name = PSMainProcName then
11641             s := s + #1
11642           else
11643             s := s + TPSInternalProcedure(p).OriginalName + #1;
11644         end
11645         else
11646         begin
11647           s := s+ TPSExternalProcedure(p).RegProc.OrgName + #1;
11648         end;
11649       end;
11650       s := s + #0#1;
11651       for I := 0 to FVars.Count - 1 do
11652       begin
11653         pv := FVars[I];
11654         s := s + pv.OrgName + #1;
11655       end;
11656       s := s + #0;
11657       WriteDebugData(s);
11658     end;
11659 
11660   var                       //nvds
11661     MainProc : Cardinal;    //nvds
11662 
11663   begin
11664     if @FOnBeforeOutput <> nil then
11665     begin
11666       if not FOnBeforeOutput(Self) then
11667       begin
11668         Result := false;
11669         exit;
11670       end;
11671     end;
11672     MainProc := FindMainProc; //NvdS (need it here becose FindMainProc can create a New proc.
11673     CreateDebugData;
11674     WriteLong(PSValidHeader);
11675     WriteLong(PSCurrentBuildNo);
11676     WriteLong(FCurrUsedTypeNo);
11677     WriteLong(FProcs.Count);
11678     WriteLong(FVars.Count);
11679     WriteLong(MainProc);  //nvds
11680     WriteLong(0);
11681     WriteTypes;
11682     WriteProcs;
11683     WriteVars;
11684     WriteProcs2;
11685 
11686     Result := true;
11687   end;
11688 
11689   function CheckExports: Boolean;
11690   var
11691     i: Longint;
11692     p: TPSProcedure;
11693   begin
11694     if @FOnExportCheck = nil then
11695     begin
11696       result := true;
11697       exit;
11698     end;
11699     for i := 0 to FProcs.Count -1 do
11700     begin
11701       p := FProcs[I];
11702       if p.ClassType = TPSInternalProcedure then
11703       begin
11704         if not FOnExportCheck(Self, TPSInternalProcedure(p), MakeDecl(TPSInternalProcedure(p).Decl)) then
11705         begin
11706           Result := false;
11707           exit;
11708         end;
11709       end;
11710     end;
11711     Result := True;
11712   end;
11713   function DoConstBlock: Boolean;
11714   var
11715     COrgName: tbtString;
11716     CTemp, CValue: PIFRVariant;
11717     Cp: TPSConstant;
11718     TokenPos, TokenRow, TokenCol: Integer;
11719   begin
11720     FParser.Next;
11721     repeat
11722       if FParser.CurrTokenID <> CSTI_Identifier then
11723       begin
11724         MakeError('', ecIdentifierExpected, '');
11725         Result := False;
11726         Exit;
11727       end;
11728       TokenPos := FParser.CurrTokenPos;
11729       TokenRow := FParser.Row;
11730       TokenCol := FParser.Col;
11731       COrgName := FParser.OriginalToken;
11732       if IsDuplicate(FastUpperCase(COrgName), [dcVars, dcProcs, dcConsts]) then
11733       begin
11734         MakeError('', ecDuplicateIdentifier, COrgName);
11735         Result := False;
11736         exit;
11737       end;
11738       FParser.Next;
11739       if FParser.CurrTokenID <> CSTI_Equal then
11740       begin
11741         MakeError('', ecIsExpected, '');
11742         Result := False;
11743         Exit;
11744       end;
11745       FParser.Next;
11746       CValue := ReadConstant(FParser, CSTI_SemiColon);
11747       if CValue = nil then
11748       begin
11749         Result := False;
11750         Exit;
11751       end;
11752       if FParser.CurrTokenID <> CSTI_Semicolon then
11753       begin
11754         MakeError('', ecSemicolonExpected, '');
11755         Result := False;
11756         exit;
11757       end;
11758       cp := TPSConstant.Create;
11759       cp.Orgname := COrgName;
11760       cp.Name := FastUpperCase(COrgName);
11761       {$IFDEF PS_USESSUPPORT}
11762       cp.DeclareUnit:=fModule;
11763       {$ENDIF}
11764       cp.DeclarePos := TokenPos;
11765       cp.DeclareRow := TokenRow;
11766       cp.DeclareCol := TokenCol;
11767       New(CTemp);
11768       InitializeVariant(CTemp, CValue.FType);
11769       CopyVariantContents(cvalue, CTemp);
11770       cp.Value := CTemp;
11771       FConstants.Add(cp);
11772       DisposeVariant(CValue);
11773       FParser.Next;
11774     until FParser.CurrTokenId <> CSTI_Identifier;
11775     Result := True;
11776   end;
11777 
11778   function ProcessUses: Boolean;
11779   var
11780     {$IFNDEF PS_USESSUPPORT}
11781     FUses: TIfStringList;
11782     {$ENDIF}
11783     I: Longint;
11784     s: tbtString;
11785     {$IFDEF PS_USESSUPPORT}
11786     Parse: Boolean;
11787     ParseUnit: tbtString;
11788     ParserPos: TPSPascalParser;
11789     {$ENDIF}
11790   begin
11791     FParser.Next;
11792     {$IFNDEF PS_USESSUPPORT}
11793     FUses := TIfStringList.Create;
11794     FUses.Add('System');
11795     {$ENDIF}
11796     repeat
11797       if FParser.CurrTokenID <> CSTI_Identifier then
11798       begin
11799         MakeError('', ecIdentifierExpected, '');
11800         {$IFNDEF PS_USESSUPPORT}
11801         FUses.Free;
11802         {$ENDIF}
11803         Result := False;
11804         exit;
11805       end;
11806       s := FParser.GetToken;
11807       {$IFDEF PS_USESSUPPORT}
11808       Parse:=true;
11809       {$ENDIF}
11810       for i := 0 to FUses.Count -1 do
11811       begin
11812         if FUses[I] = s then
11813         begin
11814           {$IFNDEF PS_USESSUPPORT}
11815           MakeError('', ecDuplicateIdentifier, s);
11816           FUses.Free;
11817           Result := False;
11818           exit;
11819           {$ELSE}
11820           Parse:=false;
11821           {$ENDIF}
11822         end;
11823       end;
11824     {$IFDEF PS_USESSUPPORT}
11825       if fUnits.GetUnit(S).HasUses(fModule) then
11826       begin
11827         MakeError('', ecCrossReference, s);
11828         Result := False;
11829         exit;
11830       end;
11831 
11832       fUnit.AddUses(S);
11833 
11834       if Parse then
11835       begin
11836       {$ENDIF}
11837         FUses.Add(s);
11838         if @FOnUses <> nil then
11839         begin
11840           try
11841             {$IFDEF PS_USESSUPPORT}
11842             OldFileName:=fModule;
11843             fModule:=FParser.OriginalToken;
11844             ParseUnit:=FParser.OriginalToken;
11845             ParserPos:=FParser;
11846             {$ENDIF}
11847             if not OnUses(Self, FParser.GetToken) then
11848             begin
11849               {$IFNDEF PS_USESSUPPORT}
11850               FUses.Free;
11851               {$ELSE}
11852               FParser:=ParserPos;
11853               fModule:=OldFileName;
11854               MakeError(OldFileName, ecUnitNotFoundOrContainsErrors, ParseUnit);
11855               {$ENDIF}
11856               Result := False;
11857               exit;
11858             end;
11859             {$IFDEF PS_USESSUPPORT}
11860             fModule:=OldFileName;
11861             {$ENDIF}
11862           except
11863             on e: Exception do
11864             begin
11865               MakeError('', ecCustomError, tbtstring(e.Message));
11866               {$IFNDEF PS_USESSUPPORT}
11867               FUses.Free;
11868               {$ENDIF}
11869               Result := False;
11870               exit;
11871             end;
11872           end;
11873         end;
11874       {$IFDEF PS_USESSUPPORT}
11875       end;
11876       {$ENDIF}
11877       FParser.Next;
11878       if FParser.CurrTokenID = CSTI_Semicolon then break
11879       else if FParser.CurrTokenId <> CSTI_Comma then
11880       begin
11881         MakeError('', ecSemicolonExpected, '');
11882         Result := False;
11883         {$IFNDEF PS_USESSUPPORT}
11884         FUses.Free;
11885         {$ENDIF}
11886         exit;
11887       end;
11888       FParser.Next;
11889     until False;
11890     {$IFNDEF PS_USESSUPPORT}
11891     FUses.Free;
11892     {$ENDIF}
11893     FParser.next;
11894     Result := True;
11895   end;
11896 
11897 var
11898   Proc: TPSProcedure;
11899   {$IFDEF PS_USESSUPPORT}
11900   Block : TPSBlockInfo; //nvds
11901   {$ENDIF}
11902 begin
11903   Result := False;
11904   FWithCount := -1;
11905 
11906   {$IFDEF PS_USESSUPPORT}
11907   if fInCompile=0 then
11908   begin
11909   {$ENDIF}
11910     FUnitName := '';
11911     FCurrUsedTypeNo := 0;
11912     FIsUnit := False;
11913     Clear;
11914     FParserHadError := False;
11915     FParser.SetText(s);
11916     FAttributeTypes := TPSList.Create;
11917     FProcs := TPSList.Create;
11918     FConstants := TPSList.Create;
11919     FVars := TPSList.Create;
11920     FTypes := TPSList.Create;
11921     FRegProcs := TPSList.Create;
11922     FClasses := TPSList.Create;
11923 
11924     {$IFDEF PS_USESSUPPORT}
11925     FUnitInits := TPSList.Create; //nvds
11926     FUnitFinits:= TPSList.Create; //nvds
11927 
11928     FUses:=TIFStringList.Create;
11929     FUnits:=TPSUnitList.Create;
11930     {$ENDIF}
11931   {$IFNDEF PS_NOINTERFACES}  FInterfaces := TPSList.Create;{$ENDIF}
11932 
11933     FGlobalBlock := TPSBlockInfo.Create(nil);
11934     FGlobalBlock.SubType := tMainBegin;
11935 
11936     FGlobalBlock.Proc := NewProc(PSMainProcNameOrg, PSMainProcName);
11937     FGlobalBlock.ProcNo := FindProc(PSMainProcName);
11938 
11939     {$IFDEF PS_USESSUPPORT}
11940     OldFileName:=fModule;
11941     fModule:='System';
11942     FUses.Add('System');
11943     {$ENDIF}
11944     {$IFNDEF PS_NOSTANDARDTYPES}
11945     DefineStandardTypes;
11946     DefineStandardProcedures;
11947 	{$ENDIF}
11948     if @FOnUses <> nil then
11949     begin
11950       try
11951         if not OnUses(Self, 'SYSTEM') then
11952         begin
11953           Cleanup;
11954           exit;
11955         end;
11956       except
11957         on e: Exception do
11958         begin
11959           MakeError('', ecCustomError, tbtstring(e.Message));
11960           Cleanup;
11961           exit;
11962         end;
11963       end;
11964     end;
11965   {$IFDEF PS_USESSUPPORT}
11966     fModule:=OldFileName;
11967     OldParser:=nil;
11968     OldUnit:=nil;
11969     OldIsUnit:=false; // defaults
11970   end
11971   else
11972   begin
11973     OldParser:=FParser;
11974     OldIsUnit:=FIsUnit;
11975     OldUnit:=fUnit;
11976     FParser:=TPSPascalParser.Create;
11977     FParser.SetText(s);
11978   end;
11979 
11980   fUnit:=fUnits.GetUnit(fModule);
11981 
11982   inc(fInCompile);
11983   {$ENDIF}
11984 
11985   Position := csStart;
11986   repeat
11987     if FParser.CurrTokenId = CSTI_EOF then
11988     begin
11989       if FParserHadError then
11990       begin
11991         Cleanup;
11992         exit;
11993       end;
11994       if FAllowNoEnd then
11995         Break
11996       else
11997       begin
11998         MakeError('', ecUnexpectedEndOfFile, '');
11999         Cleanup;
12000         exit;
12001       end;
12002     end;
12003     if (FParser.CurrTokenId = CSTII_Program) and (Position = csStart) then
12004     begin
12005       {$IFDEF PS_USESSUPPORT}
12006       if fInCompile>1 then
12007       begin
12008         MakeError('', ecNotAllowed, 'program');
12009         Cleanup;
12010         exit;
12011       end;
12012       {$ENDIF}
12013       Position := csProgram;
12014       FParser.Next;
12015       if FParser.CurrTokenId <> CSTI_Identifier then
12016       begin
12017         MakeError('', ecIdentifierExpected, '');
12018         Cleanup;
12019         exit;
12020       end;
12021       FParser.Next;
12022       if FParser.CurrTokenId <> CSTI_Semicolon then
12023       begin
12024         MakeError('', ecSemicolonExpected, '');
12025         Cleanup;
12026         exit;
12027       end;
12028       FParser.Next;
12029     end else
12030     if (Fparser.CurrTokenID = CSTII_Implementation) and ((Position = csinterface) or (position = csInterfaceUses)) then
12031     begin
12032       Position := csImplementation;
12033       FParser.Next;
12034     end else
12035     if (Fparser.CurrTokenID = CSTII_Interface) and (Position = csUnit) then
12036     begin
12037       Position := csInterface;
12038       FParser.Next;
12039     end else
12040     if (FParser.CurrTokenId = CSTII_Unit) and (Position = csStart) and (FAllowUnit) then
12041     begin
12042       Position := csUnit;
12043       FIsUnit := True;
12044       FParser.Next;
12045       if FParser.CurrTokenId <> CSTI_Identifier then
12046       begin
12047         MakeError('', ecIdentifierExpected, '');
12048         Cleanup;
12049         exit;
12050       end;
12051       if fInCompile = 1 then
12052         FUnitName := FParser.OriginalToken;
12053       FParser.Next;
12054       if FParser.CurrTokenId <> CSTI_Semicolon then
12055       begin
12056         MakeError('', ecSemicolonExpected, '');
12057         Cleanup;
12058         exit;
12059       end;
12060       FParser.Next;
12061     end
12062     else if (FParser.CurrTokenID = CSTII_Uses) and ((Position < csuses) or (Position = csInterface)) then
12063     begin
12064       if (Position = csInterface) or (Position =csInterfaceUses)
12065         then Position := csInterfaceUses
12066         else Position := csUses;
12067       if not ProcessUses then
12068       begin
12069          Cleanup;
12070         exit;
12071       end;
12072     end else if (FParser.CurrTokenId = CSTII_Procedure) or
12073       (FParser.CurrTokenId = CSTII_Function) or (FParser.CurrTokenID = CSTI_OpenBlock) then
12074     begin
12075       if (Position = csInterface) or (position = csInterfaceUses) then
12076       begin
12077         if not ProcessFunction(True, nil) then
12078         begin
12079           Cleanup;
12080           exit;
12081         end;
12082       end else begin
12083         Position := csUses;
12084         if not ProcessFunction(False, nil) then
12085         begin
12086           Cleanup;
12087           exit;
12088         end;
12089       end;
12090     end
12091     else if (FParser.CurrTokenId = CSTII_Label) then
12092     begin
12093       if (Position = csInterface) or (Position =csInterfaceUses)
12094         then Position := csInterfaceUses
12095         else Position := csUses;
12096       if not ProcessLabel(FGlobalBlock.Proc) then
12097       begin
12098         Cleanup;
12099         exit;
12100       end;
12101     end
12102     else if (FParser.CurrTokenId = CSTII_Var) then
12103     begin
12104       if (Position = csInterface) or (Position =csInterfaceUses)
12105         then Position := csInterfaceUses
12106         else Position := csUses;
12107       if not DoVarBlock(nil) then
12108       begin
12109         Cleanup;
12110         exit;
12111       end;
12112     end
12113     else if (FParser.CurrTokenId = CSTII_Const) then
12114     begin
12115       if (Position = csInterface) or (Position =csInterfaceUses)
12116         then Position := csInterfaceUses
12117         else Position := csUses;
12118       if not DoConstBlock then
12119       begin
12120         Cleanup;
12121         exit;
12122       end;
12123     end
12124     else if (FParser.CurrTokenId = CSTII_Type) then
12125     begin
12126       if (Position = csInterface) or (Position =csInterfaceUses)
12127         then Position := csInterfaceUses
12128         else Position := csUses;
12129       if not DoTypeBlock(FParser) then
12130       begin
12131         Cleanup;
12132         exit;
12133       end;
12134     end
12135     else if (FParser.CurrTokenId = CSTII_Begin)
12136       {$IFDEF PS_USESSUPPORT}
12137              or ((FParser.CurrTokenID = CSTII_initialization) and FIsUnit) {$ENDIF}  then //nvds
12138     begin
12139       {$IFDEF PS_USESSUPPORT}
12140       if FIsUnit then
12141       begin
12142         Block := TPSBlockInfo.Create(nil); //nvds
12143         Block.SubType := tUnitInit;        //nvds
12144         Block.Proc := NewProc(PSMainProcNameOrg+'_'+fModule, FastUpperCase(PSMainProcName+'_'+fModule)); //nvds
12145         Block.ProcNo := FindProc(PSMainProcName+'_'+fModule);  //nvds
12146         Block.Proc.DeclareUnit:= fModule;
12147         Block.Proc.DeclarePos := FParser.CurrTokenPos;
12148         Block.Proc.DeclareRow := FParser.Row;
12149         Block.Proc.DeclareCol := FParser.Col;
12150         Block.Proc.Use;
12151         FUnitInits.Add(Block);
12152         if ProcessSub(Block) then
12153         begin
12154           if (Fparser.CurrTokenId = CSTI_EOF) THEN break;
12155         end
12156         else
12157         begin
12158           Cleanup;
12159           exit;
12160         end;
12161       end
12162       else
12163       begin
12164         FGlobalBlock.Proc.DeclareUnit:= fModule;
12165       {$ENDIF}
12166         FGlobalBlock.Proc.DeclarePos := FParser.CurrTokenPos;
12167         FGlobalBlock.Proc.DeclareRow := FParser.Row;
12168         FGlobalBlock.Proc.DeclareCol := FParser.Col;
12169         if ProcessSub(FGlobalBlock) then
12170         begin
12171           break;
12172         end
12173         else
12174         begin
12175           Cleanup;
12176           exit;
12177         end;
12178       {$IFDEF PS_USESSUPPORT}
12179       end;
12180       {$ENDIF}
12181     end
12182     {$IFDEF PS_USESSUPPORT}
12183     else if ((FParser.CurrTokenID = CSTII_finalization) and FIsUnit) then //NvdS
12184     begin
12185       Block := TPSBlockInfo.Create(nil);
12186       Block.SubType := tUnitFinish;
12187       Block.Proc := NewProc('!Finish_'+fModule, '!FINISH_'+FastUppercase(fModule));
12188       Block.ProcNo := FindProc('!FINISH_'+FastUppercase(fModule));
12189       Block.Proc.DeclareUnit:= fModule;
12190 
12191       Block.Proc.DeclarePos := FParser.CurrTokenPos;
12192       Block.Proc.DeclareRow := FParser.Row;
12193       Block.Proc.DeclareCol := FParser.Col;
12194       Block.Proc.use;
12195       FUnitFinits.Add(Block);
12196       if ProcessSub(Block) then
12197       begin
12198         break;
12199       end else begin
12200         Cleanup;
12201         Result :=  False; //Cleanup;
12202         exit;
12203       end;
12204     end
12205     {$endif}
12206     else if (Fparser.CurrTokenId = CSTII_End) and (FAllowNoBegin or FIsUnit) then
12207     begin
12208       FParser.Next;
12209       if FParser.CurrTokenID <> CSTI_Period then
12210       begin
12211         MakeError('', ecPeriodExpected, '');
12212         Cleanup;
12213         exit;
12214       end;
12215       break;
12216     end else
12217     begin
12218       MakeError('', ecBeginExpected, '');
12219       Cleanup;
12220       exit;
12221     end;
12222   until False;
12223 
12224   {$IFDEF PS_USESSUPPORT}
12225   dec(fInCompile);
12226   if fInCompile=0 then
12227   begin
12228   {$ENDIF}
12229     if not ProcessLabelForwards(FGlobalBlock.Proc) then
12230     begin
12231       Cleanup;
12232       exit;
12233     end;
12234     // NVDS: Do we need to check here also do a ProcessLabelForwards() for each Initialisation/finalization block?
12235 
12236     for i := 0 to FProcs.Count -1 do
12237     begin
12238       Proc := FProcs[I];
12239       if (Proc.ClassType = TPSInternalProcedure) and (TPSInternalProcedure(Proc).Forwarded) then
12240       begin
12241         with MakeError('', ecUnsatisfiedForward, TPSInternalProcedure(Proc).Name) do
12242         begin
12243           FPosition := TPSInternalProcedure(Proc).DeclarePos;
12244           FRow := TPSInternalProcedure(Proc).DeclareRow;
12245           FCol := TPSInternalProcedure(Proc).DeclareCol;
12246         end;
12247         Cleanup;
12248         Exit;
12249       end;
12250     end;
12251     if not CheckExports then
12252     begin
12253       Cleanup;
12254       exit;
12255     end;
12256     for i := 0 to FVars.Count -1 do
12257     begin
12258       if not TPSVar(FVars[I]).Used then
12259       begin
12260         with MakeHint({$IFDEF PS_USESSUPPORT}TPSVar(FVars[I]).DeclareUnit{$ELSE}''{$ENDIF}, ehVariableNotUsed, TPSVar(FVars[I]).Name) do
12261         begin
12262           FPosition := TPSVar(FVars[I]).DeclarePos;
12263           FRow := TPSVar(FVars[I]).DeclareRow;
12264           FCol := TPSVar(FVars[I]).DeclareCol;
12265         end;
12266       end;
12267     end;
12268 
12269     Result := MakeOutput;
12270     Cleanup;
12271   {$IFDEF PS_USESSUPPORT}
12272   end
12273   else
12274   begin
12275     fParser.Free;
12276     fParser:=OldParser;
12277     fIsUnit:=OldIsUnit;
12278     fUnit:=OldUnit;
12279     result:=true;
12280   end;
12281   {$ENDIF}
12282 end;
12283 
12284 constructor TPSPascalCompiler.Create;
12285 begin
12286   inherited Create;
12287   FParser := TPSPascalParser.Create;
12288   FParser.OnParserError := ParserError;
12289   FAutoFreeList := TPSList.Create;
12290   FOutput := '';
12291   FAllowDuplicateRegister := true;
12292   {$IFDEF PS_USESSUPPORT}
12293   FAllowUnit := true;
12294   {$ENDIF}
12295   FMessages := TPSList.Create;
12296 end;
12297 
12298 destructor TPSPascalCompiler.Destroy;
12299 begin
12300   Clear;
12301   FAutoFreeList.Free;
12302 
12303   FMessages.Free;
12304   FParser.Free;
12305   inherited Destroy;
12306 end;
12307 
GetOutputnull12308 function TPSPascalCompiler.GetOutput(var s: tbtString): Boolean;
12309 begin
12310   if Length(FOutput) <> 0 then
12311   begin
12312     s := FOutput;
12313     Result := True;
12314   end
12315   else
12316     Result := False;
12317 end;
12318 
GetMsgnull12319 function TPSPascalCompiler.GetMsg(l: Longint): TPSPascalCompilerMessage;
12320 begin
12321   Result := FMessages[l];
12322 end;
12323 
GetMsgCountnull12324 function TPSPascalCompiler.GetMsgCount: Longint;
12325 begin
12326   Result := FMessages.Count;
12327 end;
12328 
12329 procedure TPSPascalCompiler.DefineStandardTypes;
12330 var
12331   i: Longint;
12332 begin
12333   AddType('Byte', btU8);
12334   FDefaultBoolType := AddTypeS('Boolean', '(False, True)');
12335   FDefaultBoolType.ExportName := True;
12336   with TPSEnumType(AddType('LongBool', btEnum)) do
12337   begin
12338     HighValue := 2147483647; // make sure it's gonna be a 4 byte var
12339   end;
12340   with TPSEnumType(AddType('WordBool', btEnum)) do
12341   begin
12342     HighValue := 65535; // make sure it's gonna be a 2 byte var
12343   end;
12344   with TPSEnumType(AddType('ByteBool', btEnum)) do
12345   begin
12346     HighValue := 255; // make sure it's gonna be a 1 byte var
12347   end;
12348   //following 2 IFDEFs should actually be UNICODE IFDEFs...
12349   AddType({$IFDEF PS_PANSICHAR}'AnsiChar'{$ELSE}'Char'{$ENDIF}, btChar);
12350   {$IFDEF PS_PANSICHAR}
12351   AddType('Char', btWideChar);
12352   {$ENDIF}
12353   {$IFNDEF PS_NOWIDESTRING}
12354   AddType('WideChar', btWideChar);
12355   AddType('WideString', btWideString);
12356   AddType('UnicodeString', btUnicodeString);
12357   {$ENDIF}
12358   AddType('AnsiString', btString);
12359   {$IFNDEF PS_NOWIDESTRING}
12360     {$IFDEF DELPHI2009UP}
12361     AddType('string', btUnicodeString);
12362     AddType('NativeString', btUnicodeString);
12363     {$ELSE}
12364     AddType('string', btString);
12365     AddType('NativeString', btString);
12366     {$ENDIF}
12367   {$ELSE}
12368   AddType('string', btString);
12369   AddType('NativeString', btString);
12370   {$ENDIF}
12371   FAnyString := AddType('AnyString', btString);
12372   AddType('ShortInt', btS8);
12373   AddType('Word', btU16);
12374   AddType('SmallInt', btS16);
12375   AddType('LongInt', btS32);
12376   at2ut(AddType('___Pointer', btPointer));
12377   AddType('LongWord', btU32);
12378   AddTypeCopyN('Integer', 'LongInt');
12379   AddTypeCopyN('Cardinal', 'LongWord');
12380   AddType('tbtString', btString);
12381   {$IFNDEF PS_NOINT64}
12382   AddType('Int64', btS64);
12383   {$ENDIF}
12384   AddType('Single', btSingle);
12385   AddType('Double', btDouble);
12386   AddType('Extended', btExtended);
12387   AddType('Currency', btCurrency);
12388   AddType({$IFDEF PS_PANSICHAR}'PAnsiChar'{$ELSE}'PChar'{$ENDIF}, btPChar);
12389   AddType('Variant', btVariant);
12390   AddType('!NotificationVariant', btNotificationVariant);
12391   for i := FTypes.Count -1 downto 0 do AT2UT(FTypes[i]);
12392   TPSArrayType(AddType('TVariantArray', btArray)).ArrayTypeNo := FindType('Variant');
12393 
donull12394   with AddFunction('function Assigned(I: LongInt): Boolean;') do
12395   begin
12396     Name := '!ASSIGNED';
12397   end;
12398 
donull12399   with AddFunction('procedure _T(Name: tbtString; V: Variant);') do
12400   begin
12401     Name := '!NOTIFICATIONVARIANTSET';
12402   end;
donull12403   with AddFunction('function _T(Name: tbtString): Variant;') do
12404   begin
12405     Name := '!NOTIFICATIONVARIANTGET';
12406   end;
12407 end;
12408 
12409 
TPSPascalCompiler.FindTypenull12410 function TPSPascalCompiler.FindType(const Name: tbtString): TPSType;
12411 var
12412   i, n: Longint;
12413   RName: tbtString;
12414 begin
12415   if FProcs = nil then begin Result := nil; exit;end;
12416   RName := Fastuppercase(Name);
12417   n := makehash(rname);
12418   for i := FTypes.Count - 1 downto 0 do
12419   begin
12420     Result := FTypes.Data[I];
12421     if (Result.NameHash = n) and (Result.name = rname) then
12422     begin
12423       Result := GetTypeCopyLink(Result);
12424       exit;
12425     end;
12426   end;
12427   result := nil;
12428 end;
12429 
TPSPascalCompiler.AddConstantnull12430 function TPSPascalCompiler.AddConstant(const Name: tbtString; FType: TPSType): TPSConstant;
12431 var
12432   pc: TPSConstant;
12433   val: PIfRVariant;
12434 begin
12435   if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
12436 
12437   FType := GetTypeCopyLink(FType);
12438   if FType = nil then
12439     Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterConst, [name]);
12440 
12441   if not(AllowDuplicateRegister) and IsDuplicate(FastUpperCase(Name),[dcProcs, dcVars, dcConsts]) then
12442       Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Name]);
12443 
12444   pc := TPSConstant.Create;
12445   pc.OrgName := name;
12446   pc.Name := FastUppercase(name);
12447   pc.DeclarePos:=InvalidVal;
12448   {$IFDEF PS_USESSUPPORT}
12449   pc.DeclareUnit:=fModule;
12450   {$ENDIF}
12451   New(Val);
12452   InitializeVariant(Val, FType);
12453   pc.Value := Val;
12454   FConstants.Add(pc);
12455   result := pc;
12456 end;
12457 
TPSPascalCompiler.ReadAttributesnull12458 function TPSPascalCompiler.ReadAttributes(Dest: TPSAttributes): Boolean;
12459 var
12460   Att: TPSAttributeType;
12461   at: TPSAttribute;
12462   varp: PIfRVariant;
12463   h, i: Longint;
12464   s: tbtString;
12465 begin
12466   if FParser.CurrTokenID <> CSTI_OpenBlock then begin Result := true; exit; end;
12467   FParser.Next;
12468   if FParser.CurrTokenID <> CSTI_Identifier then
12469   begin
12470     MakeError('', ecIdentifierExpected, '');
12471     Result := False;
12472     exit;
12473   end;
12474   s := FParser.GetToken;
12475   h := MakeHash(s);
12476   att := nil;
12477   for i := FAttributeTypes.count -1 downto 0 do
12478   begin
12479     att := FAttributeTypes[i];
12480     if (att.FNameHash = h) and (att.FName = s) then
12481       Break;
12482     att := nil;
12483   end;
12484   if att = nil then
12485   begin
12486     MakeError('', ecUnknownIdentifier, '');
12487     Result := False;
12488     exit;
12489   end;
12490   FParser.Next;
12491   i := 0;
12492   at := Dest.Add(att);
12493   while att.Fields[i].Hidden do
12494   begin
12495     at.AddValue(NewVariant(at2ut(att.Fields[i].FieldType)));
12496     inc(i);
12497   end;
12498   if FParser.CurrTokenId <> CSTI_OpenRound then
12499   begin
12500     MakeError('', ecOpenRoundExpected, '');
12501     Result := False;
12502     exit;
12503   end;
12504   FParser.Next;
12505   if i < Att.FieldCount then
12506   begin
12507     while i < att.FieldCount do
12508     begin
12509       varp := ReadConstant(FParser, CSTI_CloseRound);
12510       if varp = nil then
12511       begin
12512         Result := False;
12513         exit;
12514       end;
12515       at.AddValue(varp);
12516       if not IsCompatibleType(varp.FType, Att.Fields[i].FieldType, False) then
12517       begin
12518         MakeError('', ecTypeMismatch, '');
12519         Result := False;
12520         exit;
12521       end;
12522       Inc(i);
12523       while (i < Att.FieldCount) and (att.Fields[i].Hidden)  do
12524       begin
12525         at.AddValue(NewVariant(at2ut(att.Fields[i].FieldType)));
12526         inc(i);
12527       end;
12528       if i >= Att.FieldCount then
12529       begin
12530         break;
12531       end else
12532       begin
12533         if FParser.CurrTokenID <> CSTI_Comma then
12534         begin
12535           MakeError('', ecCommaExpected, '');
12536           Result := False;
12537           exit;
12538         end;
12539       end;
12540       FParser.Next;
12541     end;
12542   end;
12543   if FParser.CurrTokenID <> CSTI_CloseRound then
12544   begin
12545     MakeError('', ecCloseRoundExpected, '');
12546     Result := False;
12547     exit;
12548   end;
12549   FParser.Next;
12550   if FParser.CurrTokenID <> CSTI_CloseBlock then
12551   begin
12552     MakeError('', ecCloseBlockExpected, '');
12553     Result := False;
12554     exit;
12555   end;
12556   FParser.Next;
12557   Result := True;
12558 end;
12559 
12560 type
12561   TConstOperation = class(TObject)
12562   private
12563     FDeclPosition, FDeclRow, FDeclCol: Cardinal;
12564   public
12565     property DeclPosition: Cardinal read FDeclPosition write FDeclPosition;
12566     property DeclRow: Cardinal read FDeclRow write FDeclRow;
12567     property DeclCol: Cardinal read FDeclCol write FDeclCol;
12568     procedure SetPos(Parser: TPSPascalParser);
12569   end;
12570 
12571   TUnConstOperation = class(TConstOperation)
12572   private
12573     FOpType: TPSUnOperatorType;
12574     FVal1: TConstOperation;
12575   public
12576     property OpType: TPSUnOperatorType read FOpType write FOpType;
12577     property Val1: TConstOperation read FVal1 write FVal1;
12578 
12579     destructor Destroy; override;
12580   end;
12581 
12582   TBinConstOperation = class(TConstOperation)
12583   private
12584     FOpType: TPSBinOperatorType;
12585     FVal2: TConstOperation;
12586     FVal1: TConstOperation;
12587   public
12588     property OpType: TPSBinOperatorType read FOpType write FOpType;
12589     property Val1: TConstOperation read FVal1 write FVal1;
12590     property Val2: TConstOperation read FVal2 write FVal2;
12591 
12592     destructor Destroy; override;
12593   end;
12594 
12595   TConstData = class(TConstOperation)
12596   private
12597     FData: PIfRVariant;
12598   public
12599     property Data: PIfRVariant read FData write FData;
12600     destructor Destroy; override;
12601   end;
12602 
12603 
IsBooleannull12604 function TPSPascalCompiler.IsBoolean(aType: TPSType): Boolean;
12605 begin
12606   Result := (AType = FDefaultBoolType)
12607     or (AType.Name = 'LONGBOOL')
12608     or (AType.Name = 'WORDBOOL')
12609     or (AType.Name = 'BYTEBOOL');
12610 end;
12611 
12612 
TPSPascalCompiler.ReadConstantnull12613 function TPSPascalCompiler.ReadConstant(FParser: TPSPascalParser; StopOn: TPSPasToken): PIfRVariant;
12614 
12615   function ReadExpression: TConstOperation; forward;
12616   function ReadTerm: TConstOperation; forward;
ReadFactornull12617   function ReadFactor: TConstOperation;
12618   var
12619     NewVar: TConstOperation;
12620     NewVarU: TUnConstOperation;
GetConstantIdentifiernull12621     function GetConstantIdentifier: PIfRVariant;
12622     var
12623       s: tbtString;
12624       sh: Longint;
12625       i: Longint;
12626       p: TPSConstant;
12627     begin
12628       s := FParser.GetToken;
12629       sh := MakeHash(s);
12630       for i := FConstants.Count -1 downto 0 do
12631       begin
12632         p := FConstants[I];
12633         if (p.NameHash = sh) and (p.Name = s) then
12634         begin
12635           New(Result);
12636           InitializeVariant(Result, p.Value.FType);
12637           CopyVariantContents(P.Value, Result);
12638           FParser.Next;
12639           exit;
12640         end;
12641       end;
12642       MakeError('', ecUnknownIdentifier, '');
12643       Result := nil;
12644     end;
12645   begin
12646     case fParser.CurrTokenID of
12647       CSTII_Not:
12648       begin
12649         FParser.Next;
12650         NewVar := ReadFactor;
12651         if NewVar = nil then
12652         begin
12653           Result := nil;
12654           exit;
12655         end;
12656         NewVarU := TUnConstOperation.Create;
12657         NewVarU.OpType := otNot;
12658         NewVarU.Val1 := NewVar;
12659         NewVar := NewVarU;
12660       end;
12661       CSTI_Minus:
12662       begin
12663         FParser.Next;
12664         NewVar := ReadTerm;
12665         if NewVar = nil then
12666         begin
12667           Result := nil;
12668           exit;
12669         end;
12670         NewVarU := TUnConstOperation.Create;
12671         NewVarU.OpType := otMinus;
12672         NewVarU.Val1 := NewVar;
12673         NewVar := NewVarU;
12674       end;
12675       CSTI_OpenRound:
12676         begin
12677           FParser.Next;
12678           NewVar := ReadExpression;
12679           if NewVar = nil then
12680           begin
12681             Result := nil;
12682             exit;
12683           end;
12684           if FParser.CurrTokenId <> CSTI_CloseRound then
12685           begin
12686             NewVar.Free;
12687             Result := nil;
12688             MakeError('', ecCloseRoundExpected, '');
12689             exit;
12690           end;
12691           FParser.Next;
12692         end;
12693       CSTI_Char, CSTI_String:
12694         begin
12695           NewVar := TConstData.Create;
12696           NewVar.SetPos(FParser);
12697           TConstData(NewVar).Data := ReadString;
12698         end;
12699       CSTI_HexInt, CSTI_Integer:
12700         begin
12701           NewVar := TConstData.Create;
12702           NewVar.SetPos(FParser);
12703           TConstData(NewVar).Data := ReadInteger(FParser.GetToken);
12704           FParser.Next;
12705         end;
12706       CSTI_Real:
12707         begin
12708           NewVar := TConstData.Create;
12709           NewVar.SetPos(FParser);
12710           TConstData(NewVar).Data := ReadReal(FParser.GetToken);
12711           FParser.Next;
12712         end;
12713       CSTI_Identifier:
12714         begin
12715           NewVar := TConstData.Create;
12716           NewVar.SetPos(FParser);
12717           TConstData(NewVar).Data := GetConstantIdentifier;
12718           if TConstData(NewVar).Data = nil then
12719           begin
12720             NewVar.Free;
12721             Result := nil;
12722             exit;
12723           end
12724         end;
12725     else
12726       begin
12727         MakeError('', ecSyntaxError, '');
12728         Result := nil;
12729         exit;
12730       end;
12731     end; {case}
12732     Result := NewVar;
12733   end; // ReadFactor
12734 
ReadTermnull12735   function ReadTerm: TConstOperation;
12736   var
12737     F1, F2: TConstOperation;
12738     F: TBinConstOperation;
12739     Token: TPSPasToken;
12740     Op: TPSBinOperatorType;
12741   begin
12742     F1 := ReadFactor;
12743     if F1 = nil then
12744     begin
12745       Result := nil;
12746       exit;
12747     end;
12748     while FParser.CurrTokenID in [CSTI_Multiply, CSTI_Divide, CSTII_Div, CSTII_Mod, CSTII_And, CSTII_Shl, CSTII_Shr] do
12749     begin
12750       Token := FParser.CurrTokenID;
12751       FParser.Next;
12752       F2 := ReadFactor;
12753       if f2 = nil then
12754       begin
12755         f1.Free;
12756         Result := nil;
12757         exit;
12758       end;
12759       case Token of
12760         CSTI_Multiply: Op := otMul;
12761         CSTI_Divide: Op := otDiv;
12762         CSTII_Div: Op := otIntDiv;
12763         CSTII_mod: Op := otMod;
12764         CSTII_and: Op := otAnd;
12765         CSTII_shl: Op := otShl;
12766         CSTII_shr: Op := otShr;
12767       else
12768         Op := otAdd;
12769       end;
12770       F := TBinConstOperation.Create;
12771       f.Val1 := F1;
12772       f.Val2 := F2;
12773       f.OpType := Op;
12774       f1 := f;
12775     end;
12776     Result := F1;
12777   end;  // ReadTerm
12778 
ReadSimpleExpressionnull12779   function ReadSimpleExpression: TConstOperation;
12780   var
12781     F1, F2: TConstOperation;
12782     F: TBinConstOperation;
12783     Token: TPSPasToken;
12784     Op: TPSBinOperatorType;
12785   begin
12786     F1 := ReadTerm;
12787     if F1 = nil then
12788     begin
12789       Result := nil;
12790       exit;
12791     end;
12792     while FParser.CurrTokenID in [CSTI_Plus, CSTI_Minus, CSTII_Or, CSTII_Xor] do
12793     begin
12794       Token := FParser.CurrTokenID;
12795       FParser.Next;
12796       F2 := ReadTerm;
12797       if f2 = nil then
12798       begin
12799         f1.Free;
12800         Result := nil;
12801         exit;
12802       end;
12803       case Token of
12804         CSTI_Plus: Op := otAdd;
12805         CSTI_Minus: Op := otSub;
12806         CSTII_or: Op := otOr;
12807         CSTII_xor: Op := otXor;
12808       else
12809         Op := otAdd;
12810       end;
12811       F := TBinConstOperation.Create;
12812       f.Val1 := F1;
12813       f.Val2 := F2;
12814       f.OpType := Op;
12815       f1 := f;
12816     end;
12817     Result := F1;
12818   end;  // ReadSimpleExpression
12819 
12820 
ReadExpressionnull12821   function ReadExpression: TConstOperation;
12822   var
12823     F1, F2: TConstOperation;
12824     F: TBinConstOperation;
12825     Token: TPSPasToken;
12826     Op: TPSBinOperatorType;
12827   begin
12828     F1 := ReadSimpleExpression;
12829     if F1 = nil then
12830     begin
12831       Result := nil;
12832       exit;
12833     end;
12834     while FParser.CurrTokenID in [ CSTI_GreaterEqual, CSTI_LessEqual, CSTI_Greater, CSTI_Less, CSTI_Equal, CSTI_NotEqual] do
12835     begin
12836       Token := FParser.CurrTokenID;
12837       FParser.Next;
12838       F2 := ReadSimpleExpression;
12839       if f2 = nil then
12840       begin
12841         f1.Free;
12842         Result := nil;
12843         exit;
12844       end;
12845       case Token of
12846         CSTI_GreaterEqual: Op := otGreaterEqual;
12847         CSTI_LessEqual: Op := otLessEqual;
12848         CSTI_Greater: Op := otGreater;
12849         CSTI_Less: Op := otLess;
12850         CSTI_Equal: Op := otEqual;
12851         CSTI_NotEqual: Op := otNotEqual;
12852       else
12853         Op := otAdd;
12854       end;
12855       F := TBinConstOperation.Create;
12856       f.Val1 := F1;
12857       f.Val2 := F2;
12858       f.OpType := Op;
12859       f1 := f;
12860     end;
12861     Result := F1;
12862   end;  // ReadExpression
12863 
12864 
EvalConstnull12865   function EvalConst(P: TConstOperation): PIfRVariant;
12866   var
12867     p1, p2: PIfRVariant;
12868   begin
12869     if p is TBinConstOperation then
12870     begin
12871       p1 := EvalConst(TBinConstOperation(p).Val1);
12872       if p1 = nil then begin Result := nil; exit; end;
12873       p2 := EvalConst(TBinConstOperation(p).Val2);
12874       if p2 = nil then begin DisposeVariant(p1); Result := nil; exit; end;
12875       if not PreCalc(False, 0, p1, 0, p2, TBinConstOperation(p).OpType, p.DeclPosition, p.DeclRow, p.DeclCol) then
12876       begin
12877         DisposeVariant(p1);
12878         DisposeVariant(p2);
12879 //        MakeError('', ecTypeMismatch, '');
12880         result := nil;
12881         exit;
12882       end;
12883       DisposeVariant(p2);
12884       Result := p1;
12885     end else if p is TUnConstOperation then
12886     begin
12887       with TUnConstOperation(P) do
12888       begin
12889         p1 := EvalConst(Val1);
12890         case OpType of
12891           otNot:
12892             case p1.FType.BaseType of
12893               btU8: p1.tu8 := not p1.tu8;
12894               btU16: p1.tu16 := not p1.tu16;
12895               btU32: p1.tu32 := not p1.tu32;
12896               bts8: p1.ts8 := not p1.ts8;
12897               bts16: p1.ts16 := not p1.ts16;
12898               bts32: p1.ts32 := not p1.ts32;
12899               {$IFNDEF PS_NOINT64}
12900               bts64: p1.ts64 := not p1.ts64;
12901               {$ENDIF}
12902             else
12903               begin
12904                 MakeError('', ecTypeMismatch, '');
12905                 DisposeVariant(p1);
12906                 Result := nil;
12907                 exit;
12908               end;
12909             end;
12910           otMinus:
12911             case p1.FType.BaseType of
12912               btU8: p1.tu8 := -p1.tu8;
12913               btU16: p1.tu16 := -p1.tu16;
12914               btU32: p1.tu32 := -p1.tu32;
12915               bts8: p1.ts8 := -p1.ts8;
12916               bts16: p1.ts16 := -p1.ts16;
12917               bts32: p1.ts32 := -p1.ts32;
12918               {$IFNDEF PS_NOINT64}
12919               bts64: p1.ts64 := -p1.ts64;
12920               {$ENDIF}
12921               btDouble: p1.tdouble := - p1.tDouble;
12922               btSingle: p1.tsingle := - p1.tsingle;
12923               btCurrency: p1.tcurrency := - p1.tcurrency;
12924               btExtended: p1.textended := - p1.textended;
12925             else
12926               begin
12927                 MakeError('', ecTypeMismatch, '');
12928                 DisposeVariant(p1);
12929                 Result := nil;
12930                 exit;
12931               end;
12932             end;
12933         else
12934           begin
12935             DisposeVariant(p1);
12936             Result := nil;
12937             exit;
12938           end;
12939         end;
12940       end;
12941       Result := p1;
12942     end else
12943     begin
12944       if ((p as TConstData).Data.FType.BaseType = btString)
12945       and (length(tbtstring((p as TConstData).Data.tstring)) =1) then
12946       begin
12947         New(p1);
12948         InitializeVariant(p1, FindBaseType(btChar));
12949         p1.tchar := tbtstring((p as TConstData).Data.tstring)[1];
12950         Result := p1;
12951       end else begin
12952         New(p1);
12953         InitializeVariant(p1, (p as TConstData).Data.FType);
12954         CopyVariantContents((p as TConstData).Data, p1);
12955         Result := p1;
12956       end;
12957     end;
12958   end;
12959 
12960 var
12961   Val: TConstOperation;
12962 begin
12963   Val := ReadExpression;
12964   if val = nil then
12965   begin
12966     Result := nil;
12967     exit;
12968   end;
12969   Result := EvalConst(Val);
12970   Val.Free;
12971 end;
12972 
12973 procedure TPSPascalCompiler.WriteDebugData(const s: tbtString);
12974 begin
12975   FDebugOutput := FDebugOutput + s;
12976 end;
12977 
TPSPascalCompiler.GetDebugOutputnull12978 function TPSPascalCompiler.GetDebugOutput(var s: tbtString): Boolean;
12979 begin
12980   if Length(FDebugOutput) <> 0 then
12981   begin
12982     s := FDebugOutput;
12983     Result := True;
12984   end
12985   else
12986     Result := False;
12987 end;
12988 
TPSPascalCompiler.AddUsedFunctionnull12989 function TPSPascalCompiler.AddUsedFunction(var Proc: TPSInternalProcedure): Cardinal;
12990 begin
12991   if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
12992   Proc := TPSInternalProcedure.Create;
12993   FProcs.Add(Proc);
12994   Result := FProcs.Count - 1;
12995 end;
12996 
12997 {$IFNDEF PS_NOINTERFACES}
12998 const
12999   IUnknown_Guid: TGuid = (D1: 0; d2: 0; d3: 0; d4: ($c0,00,00,00,00,00,00,$46));
13000   IDispatch_Guid: Tguid = (D1: $20400; D2: $0; D3: $0; D4:($C0, $0, $0, $0, $0, $0, $0, $46));
13001 {$ENDIF}
13002 
13003 procedure TPSPascalCompiler.DefineStandardProcedures;
13004 var
13005   p: TPSRegProc;
13006 begin
13007   { The following needs to be in synch in these 3 functions:
13008     -UPSCompiler.TPSPascalCompiler.DefineStandardProcedures
13009     -UPSRuntime.DefProc
13010     -UPSRuntime.TPSExec.RegisterStandardProcs
13011   }
13012   {$IFNDEF PS_NOINT64}
13013   AddFunction('function IntToStr(I: Int64): string;');
13014   {$ELSE}
13015   AddFunction('function IntToStr(I: Integer): string;');
13016   {$ENDIF}
13017   AddFunction('function StrToInt(S: string): LongInt;');
AddFunctionnull13018   AddFunction('function StrToIntDef(S: string; def: LongInt): LongInt;');
13019   AddFunction('function Copy(S: AnyString; iFrom, iCount: LongInt): AnyString;');
AddFunctionnull13020   AddFunction('function Pos(SubStr, S: AnyString): LongInt;');
13021   AddFunction('procedure Delete(var S: AnyString; iFrom, iCount: LongInt);');
AddFunctionnull13022   AddFunction('procedure Insert(S: AnyString; var s2: AnyString; iPos: LongInt);');
Decl.AddParam.OrgNamenull13023   AddFunction('function GetArrayLength: Integer;').Decl.AddParam.OrgName := 'Arr';
13024   p := AddFunction('procedure SetArrayLength;');
withnull13025   with P.Decl.AddParam do
13026   begin
13027     OrgName := 'arr';
13028     Mode := pmInOut;
13029   end;
13030   with P.Decl.AddParam do
13031   begin
13032     OrgName := 'count';
13033     aType := FindBaseType(btS32);
13034   end;
13035   AddFunction('function StrGet(var S: string; I: Integer): Char;');
AddFunctionnull13036   AddFunction('function StrGet2(S: string; I: Integer): Char;');
13037   AddFunction('procedure StrSet(C: Char; I: Integer; var S: string);');
13038   {$IFNDEF PS_NOWIDESTRING}
13039   AddFunction('function WStrGet(var S: AnyString; I: Integer): WideChar;');
13040   AddFunction('procedure WStrSet(C: AnyString; I: Integer; var S: AnyString);');
13041   {$ENDIF}
13042   AddDelphiFunction('function VarArrayGet(var S: Variant; I: Integer): Variant;');
13043   AddDelphiFunction('procedure VarArraySet(C: Variant; I: Integer; var S: Variant);');
AddFunctionnull13044   AddFunction('function AnsiUpperCase(S: string): string;');
13045   AddFunction('function AnsiLowerCase(S: string): string;');
AddFunctionnull13046   AddFunction('function UpperCase(S: AnyString): AnyString;');
13047   AddFunction('function LowerCase(S: AnyString): AnyString;');
AddFunctionnull13048   AddFunction('function Trim(S: AnyString): AnyString;');
Decl.AddParam.OrgNamenull13049   AddFunction('function Length: Integer;').Decl.AddParam.OrgName := 'S';
Declnull13050   with AddFunction('procedure SetLength;').Decl do
13051   begin
13052     with AddParam do
13053     begin
13054       OrgName:='s';
13055       Mode:=pmInOut;
13056     end;
13057     with AddParam do
13058     begin
13059       OrgName:='NewLength';
13060       aType:=FindBaseType(btS32);  //Integer
13061     end;
13062   end;
13063   {$IFNDEF PS_NOINT64}
Decl.AddParam.OrgNamenull13064   AddFunction('function Low: Int64;').Decl.AddParam.OrgName := 'X';
Decl.AddParam.OrgNamenull13065   AddFunction('function High: Int64;').Decl.AddParam.OrgName := 'X';
13066   {$ELSE}
Decl.AddParam.OrgNamenull13067   AddFunction('function Low: Integer;').Decl.AddParam.OrgName := 'X';
Decl.AddParam.OrgNamenull13068   AddFunction('function High: Integer;').Decl.AddParam.OrgName := 'X';
13069   {$ENDIF}
Declnull13070   with AddFunction('procedure Dec;').Decl do begin
13071     with AddParam do
13072     begin
13073       OrgName:='x';
13074       Mode:=pmInOut;
13075     end;
13076   end;
Declnull13077   with AddFunction('procedure Inc;').Decl do begin
13078     with AddParam do
13079     begin
13080       OrgName:='x';
13081       Mode:=pmInOut;
13082     end;
13083   end;
Declnull13084   with AddFunction('procedure Include;').Decl do begin
13085     with AddParam do
13086     begin
13087       OrgName:='s';
13088       Mode:=pmInOut;
13089     end;
13090     with AddParam do
13091     begin
13092       OrgName:='m';
13093       Mode:=pmIn;
13094     end;
13095   end;
Declnull13096   with AddFunction('procedure Exclude;').Decl do begin
13097     with AddParam do
13098     begin
13099       OrgName:='s';
13100       Mode:=pmInOut;
13101     end;
13102     with AddParam do
13103     begin
13104       OrgName:='m';
13105       Mode:=pmIn;
13106     end;
13107   end;
13108   AddFunction('function Sin(E: Extended): Extended;');
AddFunctionnull13109   AddFunction('function Cos(E: Extended): Extended;');
13110   AddFunction('function Sqrt(E: Extended): Extended;');
AddFunctionnull13111   AddFunction('function Round(E: Extended): LongInt;');
13112   AddFunction('function Trunc(E: Extended): LongInt;');
AddFunctionnull13113   AddFunction('function Int(E: Extended): Extended;');
13114   AddFunction('function Pi: Extended;');
AddFunctionnull13115   AddFunction('function Abs(E: Extended): Extended;');
13116   AddFunction('function StrToFloat(S: string): Extended;');
AddFunctionnull13117   AddFunction('function FloatToStr(E: Extended): string;');
13118   AddFunction('function PadL(S: AnyString; I: LongInt): AnyString;');
AddFunctionnull13119   AddFunction('function PadR(S: AnyString; I: LongInt): AnyString;');
13120   AddFunction('function PadZ(S: AnyString; I: LongInt): AnyString;');
AddFunctionnull13121   AddFunction('function Replicate(C: Char; I: LongInt): string;');
13122   AddFunction('function StringOfChar(C: Char; I: LongInt): string;');
AddTypeSnull13123   AddTypeS('TVarType', 'Word');
13124   AddConstantN('varEmpty', 'Word').Value.tu16 := varempty;
13125   AddConstantN('varNull', 'Word').Value.tu16 := varnull;
13126   AddConstantN('varSmallInt', 'Word').Value.tu16 := varsmallint;
13127   AddConstantN('varInteger', 'Word').Value.tu16 := varinteger;
13128   AddConstantN('varSingle', 'Word').Value.tu16 := varsingle;
13129   AddConstantN('varDouble', 'Word').Value.tu16 := vardouble;
13130   AddConstantN('varCurrency', 'Word').Value.tu16 := varcurrency;
13131   AddConstantN('varDate', 'Word').Value.tu16 := vardate;
13132   AddConstantN('varOleStr', 'Word').Value.tu16 := varolestr;
13133   AddConstantN('varDispatch', 'Word').Value.tu16 := vardispatch;
13134   AddConstantN('varError', 'Word').Value.tu16 := varerror;
13135   AddConstantN('varBoolean', 'Word').Value.tu16 := varboolean;
13136   AddConstantN('varVariant', 'Word').Value.tu16 := varvariant;
13137   AddConstantN('varUnknown', 'Word').Value.tu16 := varunknown;
13138 {$IFDEF DELPHI6UP}
13139   AddConstantN('varShortInt', 'Word').Value.tu16 := varshortint;
13140   AddConstantN('varByte', 'Word').Value.tu16 := varbyte;
13141   AddConstantN('varWord', 'Word').Value.tu16 := varword;
13142   AddConstantN('varLongWord', 'Word').Value.tu16 := varlongword;
13143   AddConstantN('varInt64', 'Word').Value.tu16 := varint64;
13144 {$ENDIF}
13145 {$IFDEF DELPHI5UP}
13146   AddConstantN('varStrArg', 'Word').Value.tu16 := varstrarg;
13147   AddConstantN('varAny', 'Word').Value.tu16 := varany;
13148 {$ENDIF}
13149   AddConstantN('varString', 'Word').Value.tu16 := varstring;
13150   AddConstantN('varTypeMask', 'Word').Value.tu16 := vartypemask;
13151   AddConstantN('varArray', 'Word').Value.tu16 := vararray;
13152   AddConstantN('varByRef', 'Word').Value.tu16 := varByRef;
13153 {$IFDEF UNICODE}
13154   AddConstantN('varUString', 'Word').Value.tu16 := varUString;
13155 {$ENDIF}
13156   AddDelphiFunction('function Unassigned: Variant;');
AddDelphiFunctionnull13157   AddDelphiFunction('function VarIsEmpty(const V: Variant): Boolean;');
13158 {$IFDEF DELPHI7UP}
13159   AddDelphiFunction('function VarIsClear(const V: Variant): Boolean;');
13160 {$ENDIF}
13161   AddDelphiFunction('function Null: Variant;');
13162   AddDelphiFunction('function VarIsNull(const V: Variant): Boolean;');
AddDelphiFunctionnull13163   AddDelphiFunction('function VarType(const V: Variant): TVarType;');
13164  addTypeS('TIFException', '(ErNoError, erCannotImport, erInvalidType, ErInternalError, '+
13165    'erInvalidHeader, erInvalidOpcode, erInvalidOpcodeParameter, erNoMainProc, erOutOfGlobalVarsRange, '+
13166     'erOutOfProcRange, ErOutOfRange, erOutOfStackRange, ErTypeMismatch, erUnexpectedEof, '+
13167     'erVersionError, ErDivideByZero, ErMathError,erCouldNotCallProc, erOutofRecordRange, '+
13168     'erOutOfMemory, erException, erNullPointerException, erNullVariantError, erInterfaceNotSupported, erCustomError)');
13169   AddFunction('procedure RaiseLastException;');
AddFunctionnull13170   AddFunction('procedure RaiseException(Ex: TIFException; Param: string);');
13171   AddFunction('function ExceptionType: TIFException;');
AddFunctionnull13172   AddFunction('function ExceptionParam: string;');
13173   AddFunction('function ExceptionProc: Cardinal;');
AddFunctionnull13174   AddFunction('function ExceptionPos: Cardinal;');
13175   AddFunction('function ExceptionToString(er: TIFException; Param: string): string;');
13176   {$IFNDEF PS_NOINT64}
13177   AddFunction('function StrToInt64(S: string): Int64;');
13178   AddFunction('function Int64ToStr(I: Int64): string;');
AddFunctionnull13179   AddFunction('function StrToInt64Def(S: string; def: Int64): Int64;');
13180   {$ENDIF}
13181 
Decl.AddParamnull13182   with AddFunction('function SizeOf: LongInt;').Decl.AddParam do
13183   begin
13184     OrgName := 'Data';
13185   end;
13186 {$IFNDEF PS_NOINTERFACES}
13187   with AddInterface(nil, IUnknown_Guid, 'IUnknown') do
13188   begin
13189     RegisterDummyMethod; // Query Interface
13190     RegisterDummyMethod; // _AddRef
13191     RegisterDummyMethod; // _Release
13192   end;
13193   with AddInterface(nil, IUnknown_Guid, 'IInterface') do
13194   begin
13195     RegisterDummyMethod; // Query Interface
13196     RegisterDummyMethod; // _AddRef
13197     RegisterDummyMethod; // _Release
13198   end;
13199 
13200  {$IFNDEF PS_NOIDISPATCH}
13201   with AddInterface(FindInterface('IUnknown'), IDispatch_Guid, 'IDispatch') do
13202   begin
13203     RegisterDummyMethod; // GetTypeCount
13204     RegisterDummyMethod; // GetTypeInfo
13205     RegisterDummyMethod; // GetIdsOfName
13206     RegisterDummyMethod; // Invoke
13207   end;
13208   with TPSInterfaceType(FindType('IDispatch')) do
13209   begin
13210     ExportName := True;
13211   end;
13212   AddDelphiFunction('function IdispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: string; Par: array of Variant): Variant;');
13213  {$ENDIF}
13214 {$ENDIF}
13215 end;
13216 
TPSPascalCompiler.GetTypeCountnull13217 function TPSPascalCompiler.GetTypeCount: Longint;
13218 begin
13219   if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13220   Result := FTypes.Count;
13221 end;
13222 
TPSPascalCompiler.GetTypenull13223 function TPSPascalCompiler.GetType(I: Longint): TPSType;
13224 begin
13225   if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13226   Result := FTypes[I];
13227 end;
13228 
GetVarCountnull13229 function TPSPascalCompiler.GetVarCount: Longint;
13230 begin
13231   if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13232   Result := FVars.Count;
13233 end;
13234 
TPSPascalCompiler.GetVarnull13235 function TPSPascalCompiler.GetVar(I: Longint): TPSVar;
13236 begin
13237   if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13238   Result := FVars[i];
13239 end;
13240 
GetProcCountnull13241 function TPSPascalCompiler.GetProcCount: Longint;
13242 begin
13243   if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13244   Result := FProcs.Count;
13245 end;
13246 
GetProcnull13247 function TPSPascalCompiler.GetProc(I: Longint): TPSProcedure;
13248 begin
13249   if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13250   Result := FProcs[i];
13251 end;
13252 
13253 
13254 
13255 
TPSPascalCompiler.AddUsedFunction2null13256 function TPSPascalCompiler.AddUsedFunction2(var Proc: TPSExternalProcedure): Cardinal;
13257 begin
13258   if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13259   Proc := TPSExternalProcedure.Create;
13260   FProcs.Add(Proc);
13261   Result := FProcs.Count -1;
13262 end;
13263 
AddVariablenull13264 function TPSPascalCompiler.AddVariable(const Name: tbtString; FType: TPSType): TPSVar;
13265 var
13266   P: TPSVar;
13267   s:tbtString;
13268 begin
13269   if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13270   if FType = nil then raise EPSCompilerException.CreateFmt(RPS_InvalidTypeForVar, [Name]);
13271   s := Fastuppercase(Name);
13272   if IsDuplicate(s,[dcVars]) then raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Name]);
13273 
13274   p := TPSVar.Create;
13275   p.OrgName := Name;
13276   p.Name := s;
13277   p.FType := AT2UT(FType);
13278   p.exportname := p.Name;
13279   FVars.Add(p);
13280   Result := P;
13281 end;
13282 
TPSPascalCompiler.AddAttributeTypenull13283 function TPSPascalCompiler.AddAttributeType: TPSAttributeType;
13284 begin
13285   if FAttributeTypes = nil then Raise Exception.Create(RPS_OnUseEventOnly);
13286   Result := TPSAttributeType.Create;
13287   FAttributeTypes.Add(Result);
13288 end;
13289 
TPSPascalCompiler.FindAttributeTypenull13290 function TPSPascalCompiler.FindAttributeType(const Name: tbtString): TPSAttributeType;
13291 var
13292   h, i: Integer;
13293   n: tbtString;
13294 begin
13295   if FAttributeTypes = nil then Raise Exception.Create(RPS_OnUseEventOnly);
13296   n := FastUpperCase(Name);
13297   h := MakeHash(n);
13298   for i := FAttributeTypes.Count -1 downto 0 do
13299   begin
13300     result := TPSAttributeType(FAttributeTypes[i]);
13301     if (Result.NameHash = h) and (Result.Name = n) then
13302       exit;
13303   end;
13304   result := nil;
13305 end;
TPSPascalCompiler.GetConstCountnull13306 function TPSPascalCompiler.GetConstCount: Longint;
13307 begin
13308   if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13309   result := FConstants.Count;
13310 end;
13311 
GetConstnull13312 function TPSPascalCompiler.GetConst(I: Longint): TPSConstant;
13313 begin
13314   if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13315   Result := TPSConstant(FConstants[i]);
13316 end;
13317 
GetRegProcCountnull13318 function TPSPascalCompiler.GetRegProcCount: Longint;
13319 begin
13320   if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13321   Result := FRegProcs.Count;
13322 end;
13323 
GetRegProcnull13324 function TPSPascalCompiler.GetRegProc(I: Longint): TPSRegProc;
13325 begin
13326   if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13327   Result := TPSRegProc(FRegProcs[i]);
13328 end;
13329 
13330 
13331 procedure TPSPascalCompiler.AddToFreeList(Obj: TObject);
13332 begin
13333   FAutoFreeList.Add(Obj);
13334 end;
13335 
TPSPascalCompiler.AddConstantNnull13336 function TPSPascalCompiler.AddConstantN(const Name,
13337   FType: tbtString): TPSConstant;
13338 begin
13339   Result := AddConstant(Name, FindType(FType));
13340 end;
13341 
TPSPascalCompiler.AddTypeCopynull13342 function TPSPascalCompiler.AddTypeCopy(const Name: tbtString;
13343   TypeNo: TPSType): TPSType;
13344 begin
13345   if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13346   TypeNo := GetTypeCopyLink(TypeNo);
13347   if Typeno = nil then raise EPSCompilerException.Create(RPS_InvalidType);
13348   Result := AddType(Name, BtTypeCopy);
13349   TPSTypeLink(Result).LinkTypeNo := TypeNo;
13350 end;
13351 
TPSPascalCompiler.AddTypeCopyNnull13352 function TPSPascalCompiler.AddTypeCopyN(const Name,
13353   FType: tbtString): TPSType;
13354 begin
13355   Result := AddTypeCopy(Name, FindType(FType));
13356 end;
13357 
13358 
TPSPascalCompiler.AddUsedVariablenull13359 function TPSPascalCompiler.AddUsedVariable(const Name: tbtString;
13360   FType: TPSType): TPSVar;
13361 begin
13362   Result := AddVariable(Name, FType);
13363   if Result <> nil then
13364     Result.Use;
13365 end;
13366 
TPSPascalCompiler.AddUsedVariableNnull13367 function TPSPascalCompiler.AddUsedVariableN(const Name,
13368   FType: tbtString): TPSVar;
13369 begin
13370   Result := AddVariable(Name, FindType(FType));
13371   if Result <> nil then
13372     Result.Use;
13373 end;
13374 
AddVariableNnull13375 function TPSPascalCompiler.AddVariableN(const Name,
13376   FType: tbtString): TPSVar;
13377 begin
13378   Result := AddVariable(Name, FindType(FType));
13379 end;
13380 
TPSPascalCompiler.AddUsedPtrVariablenull13381 function TPSPascalCompiler.AddUsedPtrVariable(const Name: tbtString; FType: TPSType): TPSVar;
13382 begin
13383   Result := AddVariable(Name, FType);
13384   if Result <> nil then
13385   begin
13386     result.SaveAsPointer := True;
13387     Result.Use;
13388   end;
13389 end;
13390 
AddUsedPtrVariableNnull13391 function TPSPascalCompiler.AddUsedPtrVariableN(const Name, FType: tbtString): TPSVar;
13392 begin
13393   Result := AddVariable(Name, FindType(FType));
13394   if Result <> nil then
13395   begin
13396     result.SaveAsPointer := True;
13397     Result.Use;
13398   end;
13399 end;
13400 
AddTypeSnull13401 function TPSPascalCompiler.AddTypeS(const Name, Decl: tbtString): TPSType;
13402 var
13403   Parser: TPSPascalParser;
13404 begin
13405   if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13406   Parser := TPSPascalParser.Create;
13407   Parser.SetText(Decl);
13408 
13409   if not(AllowDuplicateRegister) and (FindType(Name)<>nil) then
13410       Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Name]);
13411 
13412   Result := ReadType(Name, Parser);
13413   if Result<>nil then
13414   begin
13415     Result.ExportName := True;
13416     Result.DeclarePos:=InvalidVal;
13417     {$IFDEF PS_USESSUPPORT}
13418     Result.DeclareUnit:=fModule;
13419     {$ENDIF}
13420     Result.DeclareRow:=0;
13421     Result.DeclareCol:=0;
13422   end;
13423   Parser.Free;
13424   if result = nil then Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterType, [name]);
13425 end;
13426 
13427 
TPSPascalCompiler.CheckCompatProcnull13428 function TPSPascalCompiler.CheckCompatProc(P: TPSType; ProcNo: Cardinal): Boolean;
13429 var
13430   i: Longint;
13431   s1, s2: TPSParametersDecl;
13432 begin
13433   if p.BaseType <> btProcPtr then begin
13434     Result := False;
13435     Exit;
13436   end;
13437 
13438   S1 := TPSProceduralType(p).ProcDef;
13439 
13440   if TPSProcedure(FProcs[ProcNo]).ClassType = TPSInternalProcedure then
13441     s2 := TPSInternalProcedure(FProcs[ProcNo]).Decl
13442   else
13443     s2 := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl;
13444   if (s1.Result <> s2.Result) or (s1.ParamCount <> s2.ParamCount) then
13445   begin
13446     Result := False;
13447     Exit;
13448   end;
13449   for i := 0 to s1.ParamCount -1 do
13450   begin
13451     if (s1.Params[i].Mode <> s2.Params[i].Mode) or (s1.Params[i].aType <> s2.Params[i].aType) then
13452     begin
13453       Result := False;
13454       Exit;
13455     end;
13456   end;
13457   Result := True;
13458 end;
13459 
MakeExportDeclnull13460 function TPSPascalCompiler.MakeExportDecl(decl: TPSParametersDecl): tbtString;
13461 var
13462   i: Longint;
13463 begin
13464   if Decl.Result = nil then result := '-1' else
13465   result := IntToStr(Decl.Result.FinalTypeNo);
13466 
13467   for i := 0 to decl.ParamCount -1 do
13468   begin
13469     if decl.GetParam(i).Mode = pmIn then
13470       Result := Result + ' @'
13471     else
13472       Result := Result + ' !';
13473     Result := Result + inttostr(decl.GetParam(i).aType.FinalTypeNo);
13474   end;
13475 end;
13476 
13477 
TPSPascalCompiler.IsIntBoolTypenull13478 function TPSPascalCompiler.IsIntBoolType(aType: TPSType): Boolean;
13479 begin
13480   if Isboolean(aType) then begin Result := True; exit;end;
13481 
13482   case aType.BaseType of
13483     btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF PS_NOINT64}, btS64{$ENDIF}: Result := True;
13484   else
13485     Result := False;
13486   end;
13487 end;
13488 
13489 
13490 procedure TPSPascalCompiler.ParserError(Parser: TObject;
13491   Kind: TPSParserErrorKind);
13492 begin
13493   FParserHadError := True;
13494   case Kind of
13495     ICOMMENTERROR: MakeError('', ecCommentError, '');
13496     ISTRINGERROR: MakeError('', ecStringError, '');
13497     ICHARERROR: MakeError('', ecCharError, '');
13498   else
13499     MakeError('', ecSyntaxError, '');
13500   end;
13501 end;
13502 
13503 
AddDelphiFunctionnull13504 function TPSPascalCompiler.AddDelphiFunction(const Decl: tbtString): TPSRegProc;
13505 var
13506   p: TPSRegProc;
13507   pDecl: TPSParametersDecl;
13508   DOrgName: tbtString;
13509   FT: TPMFuncType;
13510   i: Longint;
13511 
13512 begin
13513   pDecl := TPSParametersDecl.Create;
13514   p := nil;
13515   try
13516     if not ParseMethod(Self, '', Decl, DOrgName, pDecl, FT) then
13517       Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Decl]);
13518 
13519     if (FindProc(DOrgName)<>InvalidVal) and not(FAllowDuplicateRegister) then
13520       Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Decl]);
13521 
13522     p := TPSRegProc.Create;
13523     P.Name := FastUppercase(DOrgName);
13524     p.OrgName := DOrgName;
13525     p.ExportName := True;
13526     p.Decl.Assign(pDecl);
13527 
13528     FRegProcs.Add(p);
13529 
13530     if pDecl.Result = nil then
13531     begin
13532       p.ImportDecl := p.ImportDecl + #0;
13533     end else
13534       p.ImportDecl := p.ImportDecl + #1;
13535     for i := 0 to pDecl.ParamCount -1 do
13536     begin
13537       if pDecl.Params[i].Mode <> pmIn then
13538         p.ImportDecl := p.ImportDecl + #1
13539       else
13540         p.ImportDecl := p.ImportDecl + #0;
13541     end;
13542   finally
13543     pDecl.Free;
13544   end;
13545   Result := p;
13546 end;
13547 
13548 {$IFNDEF PS_NOINTERFACES}
AddInterfacenull13549 function TPSPascalCompiler.AddInterface(InheritedFrom: TPSInterface; Guid: TGuid; const Name: tbtString): TPSInterface;
13550 var
13551   f: TPSType;
13552 begin
13553   if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13554   f := FindType(Name);
13555   if (f<>nil) and not(FAllowDuplicateRegister) then
13556     Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Name]);
13557 
13558   if (f <> nil) and (f is TPSInterfaceType) then
13559   begin
13560     result := TPSInterfaceType(f).Intf;
13561     Result.Guid := Guid;
13562     Result.InheritedFrom := InheritedFrom;
13563     exit;
13564   end;
13565   f := AddType(Name, btInterface);
13566   Result := TPSInterface.Create(Self, InheritedFrom, GUID, FastUppercase(Name), f);
13567   FInterfaces.Add(Result);
13568   TPSInterfaceType(f).Intf := Result;
13569 end;
13570 
TPSPascalCompiler.FindInterfacenull13571 function TPSPascalCompiler.FindInterface(const Name: tbtString): TPSInterface;
13572 var
13573   n: tbtString;
13574   i, nh: Longint;
13575 begin
13576   if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13577   n := FastUpperCase(Name);
13578   nh := MakeHash(n);
13579   for i := FInterfaces.Count -1 downto 0 do
13580   begin
13581     Result := FInterfaces[i];
13582     if (Result.NameHash = nh) and (Result.Name = N) then
13583       exit;
13584   end;
13585   raise EPSCompilerException.CreateFmt(RPS_UnknownInterface, [Name]);
13586 end;
13587 {$ENDIF}
TPSPascalCompiler.AddClassnull13588 function TPSPascalCompiler.AddClass(InheritsFrom: TPSCompileTimeClass; aClass: TClass): TPSCompileTimeClass;
13589 var
13590   f: TPSType;
13591 begin
13592   if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13593   Result := FindClass(tbtstring(aClass.ClassName));
13594   if (Result<>nil) and not(FAllowDuplicateRegister) then
13595     Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [aClass.ClassName]);
13596   if Result <> nil then
13597   begin
13598     if InheritsFrom <> nil then
13599       Result.FInheritsFrom := InheritsFrom;
13600     exit;
13601   end;
13602   f := AddType(tbtstring(aClass.ClassName), btClass);
13603   Result := TPSCompileTimeClass.CreateC(aClass, Self, f);
13604   Result.FInheritsFrom := InheritsFrom;
13605   FClasses.Add(Result);
13606   TPSClassType(f).Cl := Result;
13607   f.ExportName := True;
13608 end;
13609 
TPSPascalCompiler.AddClassNnull13610 function TPSPascalCompiler.AddClassN(InheritsFrom: TPSCompileTimeClass; const aClass: tbtString): TPSCompileTimeClass;
13611 var
13612   f: TPSType;
13613 begin
13614   if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13615   Result := FindClass(aClass);
13616   if (Result<>nil) and (Result.FInheritsFrom<>nil) and not(FAllowDuplicateRegister) then
13617     Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [aClass]);
13618   if Result <> nil then
13619   begin
13620     if InheritsFrom <> nil then
13621       Result.FInheritsFrom := InheritsFrom;
13622     exit;
13623   end;
13624   f := AddType(aClass, btClass);
13625   Result := TPSCompileTimeClass.Create(FastUppercase(aClass), Self, f);
13626   TPSClassType(f).Cl := Result;
13627   Result.FInheritsFrom := InheritsFrom;
13628   FClasses.Add(Result);
13629   TPSClassType(f).Cl := Result;
13630   f.ExportName := True;
13631 end;
13632 
TPSPascalCompiler.FindClassnull13633 function TPSPascalCompiler.FindClass(const aClass: tbtString): TPSCompileTimeClass;
13634 var
13635   i: Longint;
13636   Cl: tbtString;
13637   H: Longint;
13638   x: TPSCompileTimeClass;
13639 begin
13640   cl := FastUpperCase(aClass);
13641   H := MakeHash(Cl);
13642   for i :=0 to FClasses.Count -1 do
13643   begin
13644     x := FClasses[I];
13645     if (X.FClassNameHash = H) and (X.FClassName = Cl) then
13646     begin
13647       Result := X;
13648       Exit;
13649     end;
13650   end;
13651   Result := nil;
13652 end;
13653 
13654 
13655 
13656 {  }
13657 
TransDoubleToStrnull13658 function TransDoubleToStr(D: Double): tbtString;
13659 begin
13660   SetLength(Result, SizeOf(Double));
13661   Double((@Result[1])^) := D;
13662 end;
13663 
TransSingleToStrnull13664 function TransSingleToStr(D: Single): tbtString;
13665 begin
13666   SetLength(Result, SizeOf(Single));
13667   Single((@Result[1])^) := D;
13668 end;
13669 
TransExtendedToStrnull13670 function TransExtendedToStr(D: Extended): tbtString;
13671 begin
13672   SetLength(Result, SizeOf(Extended));
13673   Extended((@Result[1])^) := D;
13674 end;
13675 
TransLongintToStrnull13676 function TransLongintToStr(D: Longint): tbtString;
13677 begin
13678   SetLength(Result, SizeOf(Longint));
13679   Longint((@Result[1])^) := D;
13680 end;
13681 
TransCardinalToStrnull13682 function TransCardinalToStr(D: Cardinal): tbtString;
13683 begin
13684   SetLength(Result, SizeOf(Cardinal));
13685   Cardinal((@Result[1])^) := D;
13686 end;
13687 
TransWordToStrnull13688 function TransWordToStr(D: Word): tbtString;
13689 begin
13690   SetLength(Result, SizeOf(Word));
13691   Word((@Result[1])^) := D;
13692 end;
13693 
TransSmallIntToStrnull13694 function TransSmallIntToStr(D: SmallInt): tbtString;
13695 begin
13696   SetLength(Result, SizeOf(SmallInt));
13697   SmallInt((@Result[1])^) := D;
13698 end;
13699 
TransByteToStrnull13700 function TransByteToStr(D: Byte): tbtString;
13701 begin
13702   SetLength(Result, SizeOf(Byte));
13703   Byte((@Result[1])^) := D;
13704 end;
13705 
TransShortIntToStrnull13706 function TransShortIntToStr(D: ShortInt): tbtString;
13707 begin
13708   SetLength(Result, SizeOf(ShortInt));
13709   ShortInt((@Result[1])^) := D;
13710 end;
13711 
GetConstantnull13712 function TPSPascalCompiler.GetConstant(const Name: tbtString): TPSConstant;
13713 var
13714   h, i: Longint;
13715   n: tbtString;
13716 
13717 begin
13718   n := FastUppercase(name);
13719   h := MakeHash(n);
13720   for i := 0 to FConstants.Count -1 do
13721   begin
13722     result := TPSConstant(FConstants[i]);
13723     if (Result.NameHash = h) and (Result.Name = n) then exit;
13724   end;
13725   result := nil;
13726 end;
13727 
13728 {$IFDEF PS_USESSUPPORT}
IsInLocalUnitListnull13729 function TPSPascalCompiler.IsInLocalUnitList(s: tbtstring): Boolean;
13730 begin
13731   s:=FastUpperCase(s);
13732   if (s = '') or (s=FastUpperCase(fModule)) or (s='SYSTEM') then
13733   begin
13734     result:=true;
13735     exit;
13736   end;
13737   result:=fUnit.HasUses(S);
13738 end;
13739 {$ENDIF}
13740 
13741 { TPSType }
13742 
13743 constructor TPSType.Create;
13744 begin
13745   inherited Create;
13746   FAttributes := TPSAttributes.Create;
13747   FFinalTypeNo := InvalidVal;
13748 end;
13749 
13750 destructor TPSType.Destroy;
13751 begin
13752   FAttributes.Free;
13753   inherited Destroy;
13754 end;
13755 
13756 procedure TPSType.SetName(const Value: tbtString);
13757 begin
13758   FName := Value;
13759   FNameHash := MakeHash(Value);
13760 end;
13761 
13762 procedure TPSType.Use;
13763 begin
13764   FUsed := True;
13765 end;
13766 
13767 { TPSRecordType }
13768 
TPSRecordType.AddRecValnull13769 function TPSRecordType.AddRecVal: PIFPSRecordFieldTypeDef;
13770 begin
13771   Result := TPSRecordFieldTypeDef.Create;
13772   FRecordSubVals.Add(Result);
13773 end;
13774 
13775 constructor TPSRecordType.Create;
13776 begin
13777   inherited Create;
13778   FRecordSubVals := TPSList.Create;
13779 end;
13780 
13781 destructor TPSRecordType.Destroy;
13782 var
13783   i: Longint;
13784 begin
13785   for i := FRecordSubVals.Count -1 downto 0 do
13786     TPSRecordFieldTypeDef(FRecordSubVals[I]).Free;
13787   FRecordSubVals.Free;
13788   inherited Destroy;
13789 end;
13790 
TPSRecordType.RecValnull13791 function TPSRecordType.RecVal(I: Longint): PIFPSRecordFieldTypeDef;
13792 begin
13793   Result := FRecordSubVals[I]
13794 end;
13795 
TPSRecordType.RecValCountnull13796 function TPSRecordType.RecValCount: Longint;
13797 begin
13798   Result := FRecordSubVals.Count;
13799 end;
13800 
13801 
13802 { TPSRegProc }
13803 
13804 constructor TPSRegProc.Create;
13805 begin
13806   inherited Create;
13807   FDecl := TPSParametersDecl.Create;
13808 end;
13809 
13810 destructor TPSRegProc.Destroy;
13811 begin
13812   FDecl.Free;
13813   inherited Destroy;
13814 end;
13815 
13816 procedure TPSRegProc.SetName(const Value: tbtString);
13817 begin
13818   FName := Value;
13819   FNameHash := MakeHash(FName);
13820 end;
13821 
13822 { TPSRecordFieldTypeDef }
13823 
13824 procedure TPSRecordFieldTypeDef.SetFieldOrgName(const Value: tbtString);
13825 begin
13826   FFieldOrgName := Value;
13827   FFieldName := FastUppercase(Value);
13828   FFieldNameHash := MakeHash(FFieldName);
13829 end;
13830 
13831 { TPSProcVar }
13832 
13833 procedure TPSProcVar.SetName(const Value: tbtString);
13834 begin
13835   FName := Value;
13836   FNameHash := MakeHash(FName);
13837 end;
13838 
13839 procedure TPSProcVar.Use;
13840 begin
13841   FUsed := True;
13842 end;
13843 
13844 
13845 
13846 { TPSInternalProcedure }
13847 
13848 constructor TPSInternalProcedure.Create;
13849 begin
13850   inherited Create;
13851   FProcVars := TPSList.Create;
13852   FLabels := TIfStringList.Create;
13853   FGotos := TIfStringList.Create;
13854   FDecl := TPSParametersDecl.Create;
13855 end;
13856 
13857 destructor TPSInternalProcedure.Destroy;
13858 var
13859   i: Longint;
13860 begin
13861   FDecl.Free;
13862   for i := FProcVars.Count -1 downto 0 do
13863     TPSProcVar(FProcVars[I]).Free;
13864   FProcVars.Free;
13865   FGotos.Free;
13866   FLabels.Free;
13867   inherited Destroy;
13868 end;
13869 
13870 procedure TPSInternalProcedure.ResultUse;
13871 begin
13872   FResultUsed := True;
13873 end;
13874 
13875 procedure TPSInternalProcedure.SetName(const Value: tbtString);
13876 begin
13877   FName := Value;
13878   FNameHash := MakeHash(FName);
13879 end;
13880 
13881 procedure TPSInternalProcedure.Use;
13882 begin
13883   FUsed := True;
13884 end;
13885 
13886 { TPSProcedure }
13887 constructor TPSProcedure.Create;
13888 begin
13889   inherited Create;
13890   FAttributes := TPSAttributes.Create;
13891 end;
13892 
13893 destructor TPSProcedure.Destroy;
13894 begin
13895   FAttributes.Free;
13896   inherited Destroy;
13897 end;
13898 
13899 { TPSVar }
13900 
13901 procedure TPSVar.SetName(const Value: tbtString);
13902 begin
13903   FName := Value;
13904   FNameHash := MakeHash(Value);
13905 end;
13906 
13907 procedure TPSVar.Use;
13908 begin
13909   FUsed := True;
13910 end;
13911 
13912 { TPSConstant }
13913 
13914 destructor TPSConstant.Destroy;
13915 begin
13916   DisposeVariant(Value);
13917   inherited Destroy;
13918 end;
13919 
13920 procedure TPSConstant.SetChar(c: tbtChar);
13921 begin
13922   if (FValue <> nil) then
13923   begin
13924     case FValue.FType.BaseType of
13925       btChar: FValue.tchar := c;
13926       btString: tbtString(FValue.tstring) := c;
13927       {$IFNDEF PS_NOWIDESTRING}
13928       btWideString: tbtwidestring(FValue.twidestring) := tbtWidestring(c);
13929       btUnicodeString: tbtUnicodestring(FValue.twidestring) := tbtUnicodestring(c);
13930       {$ENDIF}
13931     else
13932       raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
13933     end;
13934   end else
13935     raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
13936 end;
13937 
13938 procedure TPSConstant.SetExtended(const Val: Extended);
13939 begin
13940   if (FValue <> nil) then
13941   begin
13942     case FValue.FType.BaseType of
13943       btSingle: FValue.tsingle := Val;
13944       btDouble: FValue.tdouble := Val;
13945       btExtended: FValue.textended := Val;
13946       btCurrency: FValue.tcurrency := Val;
13947     else
13948       raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
13949     end;
13950   end else
13951     raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
13952 end;
13953 
13954 procedure TPSConstant.SetInt(const Val: Longint);
13955 begin
13956   if (FValue <> nil) then
13957   begin
13958     case FValue.FType.BaseType of
13959       btEnum: FValue.tu32 := Val;
13960       btU32, btS32: FValue.ts32 := Val;
13961       btU16, btS16: FValue.ts16 := Val;
13962       btU8, btS8: FValue.ts8 := Val;
13963       btSingle: FValue.tsingle := Val;
13964       btDouble: FValue.tdouble := Val;
13965       btExtended: FValue.textended := Val;
13966       btCurrency: FValue.tcurrency := Val;
13967       {$IFNDEF PS_NOINT64}
13968       bts64: FValue.ts64 := Val;
13969       {$ENDIF}
13970     else
13971       raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
13972     end;
13973   end else
13974     raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
13975 end;
13976 {$IFNDEF PS_NOINT64}
13977 procedure TPSConstant.SetInt64(const Val: Int64);
13978 begin
13979   if (FValue <> nil) then
13980   begin
13981     case FValue.FType.BaseType of
13982       btEnum: FValue.tu32 := Val;
13983       btU32, btS32: FValue.ts32 := Val;
13984       btU16, btS16: FValue.ts16 := Val;
13985       btU8, btS8: FValue.ts8 := Val;
13986       btSingle: FValue.tsingle := Val;
13987       btDouble: FValue.tdouble := Val;
13988       btExtended: FValue.textended := Val;
13989       btCurrency: FValue.tcurrency := Val;
13990       bts64: FValue.ts64 := Val;
13991     else
13992       raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
13993     end;
13994   end else
13995     raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
13996 end;
13997 {$ENDIF}
13998 procedure TPSConstant.SetName(const Value: tbtString);
13999 begin
14000   FName := Value;
14001   FNameHash := MakeHash(Value);
14002 end;
14003 
14004 
14005 procedure TPSConstant.SetSet(const val);
14006 begin
14007   if (FValue <> nil) then
14008   begin
14009     case FValue.FType.BaseType of
14010       btSet:
14011         begin
14012           if length(tbtstring(FValue.tstring)) <> TPSSetType(FValue.FType).ByteSize then
14013             SetLength(tbtstring(FValue.tstring), TPSSetType(FValue.FType).ByteSize);
14014           Move(Val, FValue.tstring^, TPSSetType(FValue.FType).ByteSize);
14015         end;
14016     else
14017       raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
14018     end;
14019   end else
14020     raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
14021 end;
14022 
14023 procedure TPSConstant.SetString(const Val: tbtString);
14024 begin
14025   if (FValue <> nil) then
14026   begin
14027     case FValue.FType.BaseType of
14028       btChar: FValue.tchar := (Val+#0)[1];
14029       btString: tbtString(FValue.tstring) := val;
14030       {$IFNDEF PS_NOWIDESTRING}
14031       btWideChar: FValue.twidechar := WideChar((Val+#0)[1]);
14032       btWideString: tbtwidestring(FValue.twidestring) := tbtwidestring(val);
14033       btUnicodeString: tbtunicodestring(FValue.tunistring) := tbtunicodestring(val);
14034       {$ENDIF}
14035     else
14036       raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
14037     end;
14038   end else
14039     raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
14040 end;
14041 
14042 procedure TPSConstant.SetUInt(const Val: Cardinal);
14043 begin
14044   if (FValue <> nil) then
14045   begin
14046     case FValue.FType.BaseType of
14047       btEnum: FValue.tu32 := Val;
14048       btU32, btS32: FValue.tu32 := Val;
14049       btU16, btS16: FValue.tu16 := Val;
14050       btU8, btS8: FValue.tu8 := Val;
14051       btSingle: FValue.tsingle := Val;
14052       btDouble: FValue.tdouble := Val;
14053       btExtended: FValue.textended := Val;
14054       btCurrency: FValue.tcurrency := Val;
14055       {$IFNDEF PS_NOINT64}
14056       bts64: FValue.ts64 := Val;
14057       {$ENDIF}
14058     else
14059       raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
14060     end;
14061   end else
14062     raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
14063 end;
14064 
14065 {$IFNDEF PS_NOWIDESTRING}
14066 procedure TPSConstant.SetWideChar(const val: WideChar);
14067 begin
14068   if (FValue <> nil) then
14069   begin
14070     case FValue.FType.BaseType of
14071       btString: tbtString(FValue.tstring) := tbtstring(val);
14072       btWideChar: FValue.twidechar := val;
14073       btWideString: tbtwidestring(FValue.twidestring) := val;
14074       btUnicodeString: tbtUnicodestring(FValue.tUniString) := val;
14075     else
14076       raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
14077     end;
14078   end else
14079     raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
14080 end;
14081 
14082 procedure TPSConstant.SetWideString(const val: tbtwidestring);
14083 begin
14084   if (FValue <> nil) then
14085   begin
14086     case FValue.FType.BaseType of
14087       btString: tbtString(FValue.tstring) := tbtstring(val);
14088       btWideString: tbtwidestring(FValue.twidestring) := val;
14089       btUnicodeString: tbtunicodestring(FValue.tunistring) := val;
14090     else
14091       raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
14092     end;
14093   end else
14094     raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
14095 end;
14096 procedure TPSConstant.SetUnicodeString(const val: tbtunicodestring);
14097 begin
14098   if (FValue <> nil) then
14099   begin
14100     case FValue.FType.BaseType of
14101       btString: tbtString(FValue.tstring) := tbtstring(val);
14102       btWideString: tbtwidestring(FValue.twidestring) := val;
14103       btUnicodeString: tbtunicodestring(FValue.tunistring) := val;
14104     else
14105       raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
14106     end;
14107   end else
14108     raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
14109 end;
14110 {$ENDIF}
14111 { TPSPascalCompilerError }
14112 
TPSPascalCompilerError.ErrorTypenull14113 function TPSPascalCompilerError.ErrorType: tbtString;
14114 begin
14115   Result := tbtstring(RPS_Error);
14116 end;
14117 
TPSPascalCompilerError.ShortMessageToStringnull14118 function TPSPascalCompilerError.ShortMessageToString: tbtString;
14119 begin
14120   case Error of
14121     ecUnknownIdentifier: Result := tbtstring(Format (RPS_UnknownIdentifier, [Param]));
14122     ecIdentifierExpected: Result := tbtstring(RPS_IdentifierExpected);
14123     ecCommentError: Result := tbtstring(RPS_CommentError);
14124     ecStringError: Result := tbtstring(RPS_StringError);
14125     ecCharError: Result := tbtstring(RPS_CharError);
14126     ecSyntaxError: Result := tbtstring(RPS_SyntaxError);
14127     ecUnexpectedEndOfFile: Result := tbtstring(RPS_EOF);
14128     ecSemicolonExpected: Result := tbtstring(RPS_SemiColonExpected);
14129     ecBeginExpected: Result := tbtstring(RPS_BeginExpected);
14130     ecPeriodExpected: Result := tbtstring(RPS_PeriodExpected);
14131     ecDuplicateIdentifier: Result := tbtstring(Format (RPS_DuplicateIdent, [Param]));
14132     ecColonExpected: Result := tbtstring(RPS_ColonExpected);
14133     ecUnknownType: Result := tbtstring(Format (RPS_UnknownType, [Param]));
14134     ecCloseRoundExpected: Result := tbtstring(RPS_CloseRoundExpected);
14135     ecTypeMismatch: Result := tbtstring(RPS_TypeMismatch);
14136     ecInternalError: Result := tbtstring(Format (RPS_InternalError, [Param]));
14137     ecAssignmentExpected: Result := tbtstring(RPS_AssignmentExpected);
14138     ecThenExpected: Result := tbtstring(RPS_ThenExpected);
14139     ecDoExpected: Result := tbtstring(RPS_DoExpected);
14140     ecNoResult: Result := tbtstring(RPS_NoResult);
14141     ecOpenRoundExpected: Result := tbtstring(RPS_OpenRoundExpected);
14142     ecCommaExpected: Result := tbtstring(RPS_CommaExpected);
14143     ecToExpected: Result := tbtstring(RPS_ToExpected);
14144     ecIsExpected: Result := tbtstring(RPS_IsExpected);
14145     ecOfExpected: Result := tbtstring(RPS_OfExpected);
14146     ecCloseBlockExpected: Result := tbtstring(RPS_CloseBlockExpected);
14147     ecVariableExpected: Result := tbtstring(RPS_VariableExpected);
14148     ecStringExpected: result := tbtstring(RPS_StringExpected);
14149     ecEndExpected: Result := tbtstring(RPS_EndExpected);
14150     ecUnSetLabel: Result := tbtstring(Format (RPS_UnSetLabel, [Param]));
14151     ecNotInLoop: Result := tbtstring(RPS_NotInLoop);
14152     ecInvalidJump: Result := tbtstring(RPS_InvalidJump);
14153     ecOpenBlockExpected: Result := tbtstring(RPS_OpenBlockExpected);
14154     ecWriteOnlyProperty: Result := tbtstring(RPS_WriteOnlyProperty);
14155     ecReadOnlyProperty: Result := tbtstring(RPS_ReadOnlyProperty);
14156     ecClassTypeExpected: Result := tbtstring(RPS_ClassTypeExpected);
14157     ecCustomError: Result := Param;
14158     ecDivideByZero: Result := tbtstring(RPS_DivideByZero);
14159     ecMathError: Result := tbtstring(RPS_MathError);
14160     ecUnsatisfiedForward: Result := tbtstring(Format (RPS_UnsatisfiedForward, [Param]));
14161     ecForwardParameterMismatch: Result := tbtstring(RPS_ForwardParameterMismatch);
14162     ecInvalidnumberOfParameters: Result := tbtstring(RPS_InvalidNumberOfParameter);
14163     {$IFDEF PS_USESSUPPORT}
14164     ecNotAllowed : Result:=tbtstring(Format(RPS_NotAllowed,[Param]));
14165     ecUnitNotFoundOrContainsErrors: Result:=tbtstring(Format(RPS_UnitNotFound,[Param]));
14166     ecCrossReference: Result:=tbtstring(Format(RPS_CrossReference,[Param]));
14167     {$ENDIF}
14168   else
14169     Result := tbtstring(RPS_UnknownError);
14170   end;
14171   Result := Result;
14172 end;
14173 
14174 
14175 { TPSPascalCompilerHint }
14176 
TPSPascalCompilerHint.ErrorTypenull14177 function TPSPascalCompilerHint.ErrorType: tbtString;
14178 begin
14179   Result := tbtstring(RPS_Hint);
14180 end;
14181 
TPSPascalCompilerHint.ShortMessageToStringnull14182 function TPSPascalCompilerHint.ShortMessageToString: tbtString;
14183 begin
14184   case Hint of
14185     ehVariableNotUsed: Result := tbtstring(Format (RPS_VariableNotUsed, [Param]));
14186     ehFunctionNotUsed: Result := tbtstring(Format (RPS_FunctionNotUsed, [Param]));
14187     ehCustomHint: Result := Param;
14188   else
14189     Result := tbtstring(RPS_UnknownHint);
14190   end;
14191 end;
14192 
14193 { TPSPascalCompilerWarning }
14194 
ErrorTypenull14195 function TPSPascalCompilerWarning.ErrorType: tbtString;
14196 begin
14197   Result := tbtstring(RPS_Warning);
14198 end;
14199 
TPSPascalCompilerWarning.ShortMessageToStringnull14200 function TPSPascalCompilerWarning.ShortMessageToString: tbtString;
14201 begin
14202   case Warning of
14203     ewCustomWarning: Result := Param;
14204     ewCalculationAlwaysEvaluatesTo: Result := tbtstring(Format (RPS_CalculationAlwaysEvaluatesTo, [Param]));
14205     ewIsNotNeeded: Result := tbtstring(Format (RPS_IsNotNeeded, [Param]));
14206     ewAbstractClass: Result := tbtstring(RPS_AbstractClass);
14207   else
14208     Result := tbtstring(RPS_UnknownWarning);
14209   end;
14210 end;
14211 
14212 { TPSPascalCompilerMessage }
14213 
TPSPascalCompilerMessage.MessageToStringnull14214 function TPSPascalCompilerMessage.MessageToString: tbtString;
14215 begin
14216   Result := '['+ErrorType+'] '+FModuleName+'('+IntToStr(FRow)+':'+IntToStr(FCol)+'): '+ShortMessageToString;
14217 end;
14218 
14219 procedure TPSPascalCompilerMessage.SetParserPos(Parser: TPSPascalParser);
14220 begin
14221   FPosition := Parser.CurrTokenPos;
14222   FRow := Parser.Row;
14223   FCol := Parser.Col;
14224 end;
14225 
14226 procedure TPSPascalCompilerMessage.SetCustomPos(Pos, Row, Col: Cardinal);
14227 begin
14228   FPosition := Pos;
14229   FRow := Row;
14230   FCol := Col;
14231 end;
14232 
14233 { TUnConstOperation }
14234 
14235 destructor TUnConstOperation.Destroy;
14236 begin
14237   FVal1.Free;
14238   inherited Destroy;
14239 end;
14240 
14241 
14242 { TBinConstOperation }
14243 
14244 destructor TBinConstOperation.Destroy;
14245 begin
14246   FVal1.Free;
14247   FVal2.Free;
14248   inherited Destroy;
14249 end;
14250 
14251 { TConstData }
14252 
14253 destructor TConstData.Destroy;
14254 begin
14255   DisposeVariant(FData);
14256   inherited Destroy;
14257 end;
14258 
14259 
14260 { TConstOperation }
14261 
14262 procedure TConstOperation.SetPos(Parser: TPSPascalParser);
14263 begin
14264   FDeclPosition := Parser.CurrTokenPos;
14265   FDeclRow := Parser.Row;
14266   FDeclCol := Parser.Col;
14267 end;
14268 
14269 { TPSValue }
14270 
14271 procedure TPSValue.SetParserPos(P: TPSPascalParser);
14272 begin
14273   FPos := P.CurrTokenPos;
14274   FRow := P.Row;
14275   FCol := P.Col;
14276 end;
14277 
14278 { TPSValueData }
14279 
14280 destructor TPSValueData.Destroy;
14281 begin
14282   DisposeVariant(FData);
14283   inherited Destroy;
14284 end;
14285 
14286 
14287 { TPSValueReplace }
14288 
14289 constructor TPSValueReplace.Create;
14290 begin
14291   FFreeNewValue := True;
14292   FReplaceTimes := 1;
14293 end;
14294 
14295 destructor TPSValueReplace.Destroy;
14296 begin
14297   if FFreeOldValue then
14298     FOldValue.Free;
14299   if FFreeNewValue then
14300     FNewValue.Free;
14301   inherited Destroy;
14302 end;
14303 
14304 
14305 
14306 { TPSUnValueOp }
14307 
14308 destructor TPSUnValueOp.Destroy;
14309 begin
14310   FVal1.Free;
14311   inherited Destroy;
14312 end;
14313 
14314 { TPSBinValueOp }
14315 
14316 destructor TPSBinValueOp.Destroy;
14317 begin
14318   FVal1.Free;
14319   FVal2.Free;
14320   inherited Destroy;
14321 end;
14322 
14323 
14324 
14325 
14326 { TPSSubValue }
14327 
14328 destructor TPSSubValue.Destroy;
14329 begin
14330   FSubNo.Free;
14331   inherited Destroy;
14332 end;
14333 
14334 { TPSValueVar }
14335 
14336 constructor TPSValueVar.Create;
14337 begin
14338   inherited Create;
14339   FRecItems := TPSList.Create;
14340 end;
14341 
14342 destructor TPSValueVar.Destroy;
14343 var
14344   i: Longint;
14345 begin
14346   for i := 0 to FRecItems.Count -1 do
14347   begin
14348     TPSSubItem(FRecItems[I]).Free;
14349   end;
14350   FRecItems.Free;
14351   inherited Destroy;
14352 end;
14353 
TPSValueVar.GetRecCountnull14354 function TPSValueVar.GetRecCount: Cardinal;
14355 begin
14356   Result := FRecItems.Count;
14357 end;
14358 
TPSValueVar.GetRecItemnull14359 function TPSValueVar.GetRecItem(I: Cardinal): TPSSubItem;
14360 begin
14361   Result := FRecItems[I];
14362 end;
14363 
TPSValueVar.RecAddnull14364 function TPSValueVar.RecAdd(Val: TPSSubItem): Cardinal;
14365 begin
14366   Result := FRecItems.Add(Val);
14367 end;
14368 
14369 procedure TPSValueVar.RecDelete(I: Cardinal);
14370 var
14371   rr :TPSSubItem;
14372 begin
14373   rr := FRecItems[i];
14374   FRecItems.Delete(I);
14375   rr.Free;
14376 end;
14377 
14378 { TPSValueProc }
14379 
14380 destructor TPSValueProc.Destroy;
14381 begin
14382   FSelfPtr.Free;
14383   FParameters.Free;
14384 end;
14385 { TPSParameter }
14386 
14387 destructor TPSParameter.Destroy;
14388 begin
14389   FTempVar.Free;
14390   FValue.Free;
14391   inherited Destroy;
14392 end;
14393 
14394 
14395   { TPSParameters }
14396 
Addnull14397 function TPSParameters.Add: TPSParameter;
14398 begin
14399   Result := TPSParameter.Create;
14400   FItems.Add(Result);
14401 end;
14402 
14403 constructor TPSParameters.Create;
14404 begin
14405   inherited Create;
14406   FItems := TPSList.Create;
14407 end;
14408 
14409 procedure TPSParameters.Delete(I: Cardinal);
14410 var
14411   p: TPSParameter;
14412 begin
14413   p := FItems[I];
14414   FItems.Delete(i);
14415   p.Free;
14416 end;
14417 
14418 destructor TPSParameters.Destroy;
14419 var
14420   i: Longint;
14421 begin
14422   for i := FItems.Count -1 downto 0 do
14423   begin
14424     TPSParameter(FItems[I]).Free;
14425   end;
14426   FItems.Free;
14427   inherited Destroy;
14428 end;
14429 
GetCountnull14430 function TPSParameters.GetCount: Cardinal;
14431 begin
14432   Result := FItems.Count;
14433 end;
14434 
GetItemnull14435 function TPSParameters.GetItem(I: Longint): TPSParameter;
14436 begin
14437   Result := FItems[I];
14438 end;
14439 
14440 
14441 { TPSValueArray }
14442 
Addnull14443 function TPSValueArray.Add(Item: TPSValue): Cardinal;
14444 begin
14445   Result := FItems.Add(Item);
14446 end;
14447 
14448 constructor TPSValueArray.Create;
14449 begin
14450   inherited Create;
14451   FItems := TPSList.Create;
14452 end;
14453 
14454 procedure TPSValueArray.Delete(I: Cardinal);
14455 begin
14456   FItems.Delete(i);
14457 end;
14458 
14459 destructor TPSValueArray.Destroy;
14460 var
14461   i: Longint;
14462 begin
14463   for i := FItems.Count -1 downto 0 do
14464     TPSValue(FItems[I]).Free;
14465   FItems.Free;
14466 
14467   inherited Destroy;
14468 end;
14469 
TPSValueArray.GetCountnull14470 function TPSValueArray.GetCount: Cardinal;
14471 begin
14472   Result := FItems.Count;
14473 end;
14474 
GetItemnull14475 function TPSValueArray.GetItem(I: Cardinal): TPSValue;
14476 begin
14477   Result := FItems[I];
14478 end;
14479 
14480 
14481 { TPSValueAllocatedStackVar }
14482 
14483 destructor TPSValueAllocatedStackVar.Destroy;
14484 var
14485   pv: TPSProcVar;
14486 begin
14487   {$IFDEF DEBUG}
14488   if Cardinal(LocalVarNo +1) <> proc.ProcVars.Count then
14489   begin
14490     Abort;
14491     exit;
14492   end;
14493   {$ENDIF}
14494   if Proc <> nil then
14495   begin
14496     pv := Proc.ProcVars[Proc.ProcVars.Count -1];
14497     Proc.ProcVars.Delete(Proc.ProcVars.Count -1);
14498     pv.Free;
14499     Proc.Data := Proc.Data + tbtChar(CM_PO);
14500   end;
14501   inherited Destroy;
14502 end;
14503 
14504 
14505 
14506 
AddImportedClassVariablenull14507 function AddImportedClassVariable(Sender: TPSPascalCompiler; const VarName, VarType: tbtString): Boolean;
14508 var
14509   P: TPSVar;
14510 begin
14511   P := Sender.AddVariableN(VarName, VarType);
14512   if p = nil then
14513   begin
14514     Result := False;
14515     Exit;
14516   end;
14517   SetVarExportName(P, FastUppercase(VarName));
14518   p.Use;
14519   Result := True;
14520 end;
14521 
14522 
14523 {'class:'+CLASSNAME+'|'+FUNCNAME+'|'+chr(CallingConv)+chr(hasresult)+params
14524 
14525 For property write functions there is an '@' after the funcname.
14526 }
14527 
14528 const
14529   ProcHDR = 'procedure a;';
14530 
14531 
14532 
14533 { TPSCompileTimeClass }
14534 
TPSCompileTimeClass.CastToTypenull14535 function TPSCompileTimeClass.CastToType(IntoType: TPSType;
14536   var ProcNo: Cardinal): Boolean;
14537 var
14538   P: TPSExternalProcedure;
14539 begin
14540   if (IntoType <> nil) and (IntoType.BaseType <> btClass) and (IntoType.BaseType <> btInterface) then
14541   begin
14542     Result := False;
14543     exit;
14544   end;
14545   if FCastProc <> InvalidVal then
14546   begin
14547     Procno := FCastProc;
14548     Result := True;
14549     exit;
14550   end;
14551   ProcNo := FOwner. AddUsedFunction2(P);
rocHDRnull14552   P.RegProc := FOwner.AddFunction(ProcHDR);
14553   P.RegProc.Name := '';
14554 
14555   with P.RegProc.Decl.AddParam do
14556   begin
14557     OrgName := 'Org';
14558     aType := Self.FType;
14559   end;
14560   with P.RegProc.Decl.AddParam do
14561   begin
14562     OrgName := 'TypeNo';
14563     aType := FOwner.at2ut(FOwner.FindBaseType(btU32));
14564   end;
14565   P.RegProc.Decl.Result := IntoType;
14566   P.RegProc.ImportDecl := 'class:+';
14567   FCastProc := ProcNo;
14568   Result := True;
14569 end;
14570 
14571 
ClassFunc_Callnull14572 function TPSCompileTimeClass.ClassFunc_Call(Index: IPointer;
14573   var ProcNo: Cardinal): Boolean;
14574 var
14575   C: TPSDelphiClassItemConstructor;
14576   P: TPSExternalProcedure;
14577   s: tbtString;
14578   i: Longint;
14579 
14580 begin
14581   if FIsAbstract then
14582     FOwner.MakeWarning('', ewAbstractClass, '');
14583   C := Pointer(Index);
14584   if c.MethodNo = InvalidVal then
14585   begin
14586     ProcNo := FOwner.AddUsedFunction2(P);
rocHDRnull14587     P.RegProc := FOwner.AddFunction(ProcHDR);
14588     P.RegProc.Name := '';
14589     P.RegProc.Decl.Assign(c.Decl);
14590     s := 'class:' + C.Owner.FClassName + '|' + C.Name + '|'+ chr(0);
14591     if c.Decl.Result = nil then
14592       s := s + #0
14593     else
14594       s := s + #1;
14595     for i := 0 to C.Decl.ParamCount -1 do
14596     begin
14597       if c.Decl.Params[i].Mode <> pmIn then
14598         s := s + #1
14599       else
14600         s := s + #0;
14601     end;
14602     P.RegProc.ImportDecl := s;
14603     C.MethodNo := ProcNo;
14604   end else begin
14605      ProcNo := c.MethodNo;
14606   end;
14607   Result := True;
14608 end;
14609 
TPSCompileTimeClass.ClassFunc_Findnull14610 function TPSCompileTimeClass.ClassFunc_Find(const Name: tbtString;
14611   var Index: IPointer): Boolean;
14612 var
14613   H: Longint;
14614   I: Longint;
14615   CurrClass: TPSCompileTimeClass;
14616   C: TPSDelphiClassItem;
14617 begin
14618   H := MakeHash(Name);
14619   CurrClass := Self;
14620   while CurrClass <> nil do
14621   begin
14622     for i := CurrClass.FClassItems.Count -1 downto 0 do
14623     begin
14624       C := CurrClass.FClassItems[I];
14625       if (c is TPSDelphiClassItemConstructor) and (C.NameHash = H) and (C.Name = Name) then
14626       begin
14627         Index := IPointer(C);
14628         Result := True;
14629         exit;
14630       end;
14631     end;
14632     CurrClass := CurrClass.FInheritsFrom;
14633   end;
14634   Result := False;
14635 end;
14636 
14637 
TPSCompileTimeClass.CreateCnull14638 class function TPSCompileTimeClass.CreateC(FClass: TClass; aOwner: TPSPascalCompiler; aType: TPSType): TPSCompileTimeClass;
14639 begin
14640   Result := TPSCompileTimeClass.Create(FastUpperCase(tbtstring(FClass.ClassName)), aOwner, aType);
14641   Result.FClass := FClass;
14642 end;
14643 
14644 constructor TPSCompileTimeClass.Create(ClassName: tbtString; aOwner: TPSPascalCompiler; aType: TPSType);
14645 begin
14646   inherited Create;
14647   FType := aType;
14648   FCastProc := InvalidVal;
14649   FNilProc := InvalidVal;
14650 
14651   FDefaultProperty := InvalidVal;
14652   FClassName := Classname;
14653   FClassNameHash := MakeHash(FClassName);
14654   FClassItems := TPSList.Create;
14655   FOwner := aOwner;
14656 end;
14657 
14658 destructor TPSCompileTimeClass.Destroy;
14659 var
14660   I: Longint;
14661 begin
14662   for i := FClassItems.Count -1 downto 0 do
14663     TPSDelphiClassItem(FClassItems[I]).Free;
14664   FClassItems.Free;
14665   inherited Destroy;
14666 end;
14667 
14668 
TPSCompileTimeClass.Func_Callnull14669 function TPSCompileTimeClass.Func_Call(Index: TPSDelphiClassItem;
14670   var ProcNo: Cardinal): Boolean;
14671 var
14672   C: TPSDelphiClassItemMethod;
14673   P: TPSExternalProcedure;
14674   i: Longint;
14675   s: tbtString;
14676 
14677 begin
14678   C := Index as TPSDelphiClassItemMethod;
14679   if c.MethodNo = InvalidVal then
14680   begin
14681     ProcNo := FOwner.AddUsedFunction2(P);
rocHDRnull14682     P.RegProc := FOwner.AddFunction(ProcHDR);
14683     P.RegProc.Name := '';
14684     p.RegProc.Decl.Assign(c.Decl);
14685     s := 'class:' + C.Owner.FClassName + '|' + C.Name + '|'+ chr(0);
14686     if c.Decl.Result = nil then
14687       s := s + #0
14688     else
14689       s := s + #1;
14690     for i := 0 to c.Decl.ParamCount -1 do
14691     begin
14692       if c.Decl.Params[i].Mode <> pmIn then
14693         s := s + #1
14694       else
14695         s := s + #0;
14696     end;
14697     P.RegProc.ImportDecl := s;
14698     C.MethodNo := ProcNo;
14699   end else begin
14700      ProcNo := c.MethodNo;
14701   end;
14702   Result := True;
14703 end;
14704 
TPSCompileTimeClass.Func_Findnull14705 function TPSCompileTimeClass.Func_Find(const Name: tbtString;
14706   var Index: TPSDelphiClassItem): Boolean;
14707 var
14708   H: Longint;
14709   I: Longint;
14710   CurrClass: TPSCompileTimeClass;
14711   C: TPSDelphiClassItem;
14712 begin
14713   H := MakeHash(Name);
14714   CurrClass := Self;
14715   while CurrClass <> nil do
14716   begin
14717     for i := CurrClass.FClassItems.Count -1 downto 0 do
14718     begin
14719       C := CurrClass.FClassItems[I];
14720       if (c is TPSDelphiClassItemMethod) and (C.NameHash = H) and (C.Name = Name) then
14721       begin
14722         Index := C;
14723         Result := True;
14724         exit;
14725       end;
14726     end;
14727     CurrClass := CurrClass.FInheritsFrom;
14728   end;
14729   Result := False;
14730 end;
14731 
TPSCompileTimeClass.GetCountnull14732 function TPSCompileTimeClass.GetCount: Longint;
14733 begin
14734   Result := FClassItems.Count;
14735 end;
14736 
GetItemnull14737 function TPSCompileTimeClass.GetItem(i: Longint): TPSDelphiClassItem;
14738 begin
14739   Result := FClassItems[i];
14740 end;
14741 
TPSCompileTimeClass.IsCompatibleWithnull14742 function TPSCompileTimeClass.IsCompatibleWith(aType: TPSType): Boolean;
14743 var
14744   Temp: TPSCompileTimeClass;
14745 begin
14746   if (atype.BaseType <> btClass) then
14747   begin
14748     Result := False;
14749     exit;
14750   end;
14751   temp := TPSClassType(aType).Cl;
14752   while Temp <> nil do
14753   begin
14754     if Temp = Self then
14755     begin
14756       Result := True;
14757       exit;
14758     end;
14759     Temp := Temp.FInheritsFrom;
14760   end;
14761   Result := False;
14762 end;
14763 
TPSCompileTimeClass.Property_Findnull14764 function TPSCompileTimeClass.Property_Find(const Name: tbtString;
14765   var Index: TPSDelphiClassItem): Boolean;
14766 var
14767   H: Longint;
14768   I: Longint;
14769   CurrClass: TPSCompileTimeClass;
14770   C: TPSDelphiClassItem;
14771 begin
14772   if Name = '' then
14773   begin
14774     CurrClass := Self;
14775     while CurrClass <> nil do
14776     begin
14777       if CurrClass.FDefaultProperty <> InvalidVal then
14778       begin
14779         Index := TPSDelphiClassItem(CurrClass.FClassItems[Currclass.FDefaultProperty]);
14780         result := True;
14781         exit;
14782       end;
14783       CurrClass := CurrClass.FInheritsFrom;
14784     end;
14785     Result := False;
14786     exit;
14787   end;
14788   H := MakeHash(Name);
14789   CurrClass := Self;
14790   while CurrClass <> nil do
14791   begin
14792     for i := CurrClass.FClassItems.Count -1 downto 0 do
14793     begin
14794       C := CurrClass.FClassItems[I];
14795       if (c is TPSDelphiClassItemProperty) and (C.NameHash = H) and (C.Name = Name) then
14796       begin
14797         Index := C;
14798         Result := True;
14799         exit;
14800       end;
14801     end;
14802     CurrClass := CurrClass.FInheritsFrom;
14803   end;
14804   Result := False;
14805 end;
14806 
Property_Getnull14807 function TPSCompileTimeClass.Property_Get(Index: TPSDelphiClassItem;
14808   var ProcNo: Cardinal): Boolean;
14809 var
14810   C: TPSDelphiClassItemProperty;
14811   P: TPSExternalProcedure;
14812   s: tbtString;
14813 
14814 begin
14815   C := Index as TPSDelphiClassItemProperty;
14816   if c.AccessType = iptW then
14817   begin
14818     Result := False;
14819     exit;
14820   end;
14821   if c.ReadProcNo = InvalidVal then
14822   begin
14823     ProcNo := FOwner.AddUsedFunction2(P);
rocHDRnull14824     P.RegProc := FOwner.AddFunction(ProcHDR);
14825     P.RegProc.Name := '';
14826     P.RegProc.Decl.Result := C.Decl.Result;
14827     s := 'class:' + C.Owner.FClassName + '|' + C.Name + '|'+#0#0#0#0;
14828     Longint((@(s[length(s)-3]))^) := c.Decl.ParamCount +1;
14829     P.RegProc.ImportDecl := s;
14830     C.ReadProcNo := ProcNo;
14831   end else begin
14832      ProcNo := c.ReadProcNo;
14833   end;
14834   Result := True;
14835 end;
14836 
Property_GetHeadernull14837 function TPSCompileTimeClass.Property_GetHeader(Index: TPSDelphiClassItem;
14838   Dest: TPSParametersDecl): Boolean;
14839 var
14840   c: TPSDelphiClassItemProperty;
14841 begin
14842   C := Index as TPSDelphiClassItemProperty;
14843   FOwner.UseProc(c.Decl);
14844   Dest.Assign(c.Decl);
14845   Result := True;
14846 end;
14847 
Property_Setnull14848 function TPSCompileTimeClass.Property_Set(Index: TPSDelphiClassItem;
14849   var ProcNo: Cardinal): Boolean;
14850 var
14851   C: TPSDelphiClassItemProperty;
14852   P: TPSExternalProcedure;
14853   s: tbtString;
14854 
14855 begin
14856   C := Index as TPSDelphiClassItemProperty;
14857   if c.AccessType = iptR then
14858   begin
14859     Result := False;
14860     exit;
14861   end;
14862   if c.WriteProcNo = InvalidVal then
14863   begin
14864     ProcNo := FOwner.AddUsedFunction2(P);
rocHDRnull14865     P.RegProc := FOwner.AddFunction(ProcHDR);
14866     P.RegProc.Name := '';
14867     s := 'class:' + C.Owner.FClassName + '|' + C.Name + '@|'#0#0#0#0;
14868     Longint((@(s[length(s)-3]))^) := C.Decl.ParamCount+1;
14869     P.RegProc.ImportDecl := s;
14870     C.WriteProcNo := ProcNo;
14871   end else begin
14872      ProcNo := c.WriteProcNo;
14873   end;
14874   Result := True;
14875 end;
14876 
TPSCompileTimeClass.RegisterMethodnull14877 function TPSCompileTimeClass.RegisterMethod(const Decl: tbtString): Boolean;
14878 var
14879   DOrgName: tbtString;
14880   DDecl: TPSParametersDecl;
14881   FT: TPMFuncType;
14882   p: TPSDelphiClassItemMethod;
14883 begin
14884   DDecl := TPSParametersDecl.Create;
14885   try
14886     if not ParseMethod(FOwner, FClassName, Decl, DOrgName, DDecl, FT) then
14887     begin
14888       Result := False;
14889       {$IFDEF DEBUG} raise EPSCompilerException.CreateFmt(RPS_UnableToRegister, [Decl]); {$ENDIF}
14890       exit;
14891     end;
14892     if ft = mftConstructor then
14893       p := TPSDelphiClassItemConstructor.Create(Self)
14894     else
14895       p := TPSDelphiClassItemMethod.Create(self);
14896     p.OrgName := DOrgName;
14897     p.Decl.Assign(DDecl);
14898     p.MethodNo := InvalidVal;
14899     FClassItems.Add(p);
14900     Result := True;
14901   finally
14902     DDecl.Free;
14903   end;
14904 end;
14905 
14906 procedure TPSCompileTimeClass.RegisterProperty(const PropertyName,
14907   PropertyType: tbtString; PropAC: TPSPropType);
14908 var
14909   FType: TPSType;
14910   Param: TPSParameterDecl;
14911   p: TPSDelphiClassItemProperty;
14912   PT: tbtString;
14913 begin
14914   pt := PropertyType;
14915   p := TPSDelphiClassItemProperty.Create(Self);
14916   p.AccessType := PropAC;
14917   p.ReadProcNo := InvalidVal;
14918   p.WriteProcNo := InvalidVal;
14919   p.OrgName := PropertyName;
14920   repeat
14921     FType := FOwner.FindType(FastUpperCase(grfw(pt)));
14922     if FType = nil then
14923     begin
14924       p.Free;
14925       Exit;
14926     end;
14927     if p.Decl.Result = nil  then p.Decl.Result := FType else
14928     begin
14929       param := p.Decl.AddParam;
14930       Param.OrgName := 'param'+IntToStr(p.Decl.ParamCount);
14931       Param.aType := FType;
14932     end;
14933   until pt = '';
14934   FClassItems.Add(p);
14935 end;
14936 
14937 
14938 procedure TPSCompileTimeClass.RegisterPublishedProperties;
14939 var
14940   p: PPropList;
14941   i, Count: Longint;
14942   a: TPSPropType;
14943 begin
14944   if (Fclass = nil) or (Fclass.ClassInfo = nil) then exit;
14945   Count := GetTypeData(fclass.ClassInfo)^.PropCount;
14946   GetMem(p, Count * SizeOf(Pointer));
14947   GetPropInfos(fclass.ClassInfo, p);
14948   for i := Count -1 downto 0 do
14949   begin
14950     if p^[i]^.PropType^.Kind in [tkLString, tkInteger, tkChar, tkEnumeration, tkFloat, tkString, tkSet, tkClass, tkMethod{$IFNDEF PS_NOWIDESTRING}, tkWString{$ENDIF}{$IFDEF DELPHI2009UP}, tkUString{$ENDIF}] then
14951     begin
14952       if (p^[i]^.GetProc <> nil) then
14953       begin
14954         if p^[i]^.SetProc = nil then
14955           a := iptr
14956         else
14957           a := iptrw;
14958       end else
14959       begin
14960         a := iptW;
14961         if p^[i]^.SetProc = nil then continue;
14962       end;
14963       RegisterProperty(p^[i]^.Name, p^[i]^.PropType^.Name, a);
14964     end;
14965   end;
14966   FreeMem(p);
14967 end;
14968 
TPSCompileTimeClass.RegisterPublishedPropertynull14969 function TPSCompileTimeClass.RegisterPublishedProperty(const Name: tbtString): Boolean;
14970 var
14971   p: PPropInfo;
14972   a: TPSPropType;
14973 begin
14974   if (Fclass = nil) or (Fclass.ClassInfo = nil) then begin Result := False; exit; end;
14975   p := GetPropInfo(fclass.ClassInfo, string(Name));
14976   if p = nil then begin Result := False; exit; end;
14977   if (p^.GetProc <> nil) then
14978   begin
14979     if p^.SetProc = nil then
14980       a := iptr
14981     else
14982       a := iptrw;
14983   end else
14984   begin
14985     a := iptW;
14986     if p^.SetProc = nil then begin result := False; exit; end;
14987   end;
14988   RegisterProperty(p^.Name, p^.PropType^.Name, a);
14989   Result := True;
14990 end;
14991 
14992 
14993 procedure TPSCompileTimeClass.SetDefaultPropery(const Name: tbtString);
14994 var
14995   i,h: Longint;
14996   p: TPSDelphiClassItem;
14997   s: tbtString;
14998 
14999 begin
15000   s := FastUppercase(name);
15001   h := MakeHash(s);
15002   for i := FClassItems.Count -1 downto 0 do
15003   begin
15004     p := FClassItems[i];
15005     if (p.NameHash = h) and (p.Name = s) then
15006     begin
15007       if p is TPSDelphiClassItemProperty then
15008       begin
15009         if p.Decl.ParamCount = 0 then
15010           raise EPSCompilerException.CreateFmt(RPS_NotArrayProperty, [Name]);
15011         FDefaultProperty := I;
15012         exit;
15013       end else raise EPSCompilerException.CreateFmt(RPS_NotProperty, [Name]);
15014     end;
15015   end;
15016   raise EPSCompilerException.CreateFmt(RPS_UnknownProperty, [Name]);
15017 end;
15018 
SetNilnull15019 function TPSCompileTimeClass.SetNil(var ProcNo: Cardinal): Boolean;
15020 var
15021   P: TPSExternalProcedure;
15022 
15023 begin
15024   if FNilProc <> InvalidVal then
15025   begin
15026     Procno := FNilProc;
15027     Result := True;
15028     exit;
15029   end;
15030   ProcNo := FOwner.AddUsedFunction2(P);
rocHDRnull15031   P.RegProc := FOwner.AddFunction(ProcHDR);
15032   P.RegProc.Name := '';
15033   with P.RegProc.Decl.AddParam do
15034   begin
15035     OrgName := 'VarNo';
15036     aType := FOwner.at2ut(FType);
15037   end;
15038   P.RegProc.ImportDecl := 'class:-';
15039   FNilProc := Procno;
15040   Result := True;
15041 end;
15042 
15043 { TPSSetType }
15044 
GetBitSizenull15045 function TPSSetType.GetBitSize: Longint;
15046 begin
15047   case SetType.BaseType of
15048     btEnum: begin Result := TPSEnumType(setType).HighValue+1; end;
15049     btChar, btU8: Result := 256;
15050   else
15051     Result := 0;
15052   end;
15053 end;
15054 
TPSSetType.GetByteSizenull15055 function TPSSetType.GetByteSize: Longint;
15056 var
15057   r: Longint;
15058 begin
15059   r := BitSize;
15060   if r mod 8 <> 0 then inc(r, 7);
15061    Result := r div 8;
15062 end;
15063 
15064 
15065 { TPSBlockInfo }
15066 
15067 procedure TPSBlockInfo.Clear;
15068 var
15069   i: Longint;
15070 begin
15071   for i := WithList.Count -1 downto 0 do
15072   begin
15073     TPSValue(WithList[i]).Free;
15074     WithList.Delete(i);
15075   end;
15076 end;
15077 
15078 constructor TPSBlockInfo.Create(Owner: TPSBlockInfo);
15079 begin
15080   inherited Create;
15081   FOwner := Owner;
15082   FWithList := TPSList.Create;
15083   if FOwner <> nil then
15084   begin
15085     FProcNo := FOwner.ProcNo;
15086     FProc := FOwner.Proc;
15087   end;
15088 end;
15089 
15090 destructor TPSBlockInfo.Destroy;
15091 begin
15092   Clear;
15093   FWithList.Free;
15094   inherited Destroy;
15095 end;
15096 
15097 { TPSAttributeTypeField }
15098 procedure TPSAttributeTypeField.SetFieldOrgName(const Value: tbtString);
15099 begin
15100   FFieldOrgName := Value;
15101   FFieldName := FastUpperCase(Value);
15102   FFieldNameHash := MakeHash(FFieldName);
15103 end;
15104 
15105 constructor TPSAttributeTypeField.Create(AOwner: TPSAttributeType);
15106 begin
15107   inherited Create;
15108   FOwner := AOwner;
15109 end;
15110 
15111 { TPSAttributeType }
15112 
GetFieldnull15113 function TPSAttributeType.GetField(I: Longint): TPSAttributeTypeField;
15114 begin
15115   Result := TPSAttributeTypeField(FFields[i]);
15116 end;
15117 
TPSAttributeType.GetFieldCountnull15118 function TPSAttributeType.GetFieldCount: Longint;
15119 begin
15120   Result := FFields.Count;
15121 end;
15122 
15123 procedure TPSAttributeType.SetName(const s: tbtString);
15124 begin
15125   FOrgname := s;
15126   FName := FastUppercase(s);
15127   FNameHash := MakeHash(FName);
15128 end;
15129 
15130 constructor TPSAttributeType.Create;
15131 begin
15132   inherited Create;
15133   FFields := TPSList.Create;
15134 end;
15135 
15136 destructor TPSAttributeType.Destroy;
15137 var
15138   i: Longint;
15139 begin
15140   for i := FFields.Count -1 downto 0 do
15141   begin
15142     TPSAttributeTypeField(FFields[i]).Free;
15143   end;
15144   FFields.Free;
15145   inherited Destroy;
15146 end;
15147 
AddFieldnull15148 function TPSAttributeType.AddField: TPSAttributeTypeField;
15149 begin
15150   Result := TPSAttributeTypeField.Create(self);
15151   FFields.Add(Result);
15152 end;
15153 
15154 procedure TPSAttributeType.DeleteField(I: Longint);
15155 var
15156   Fld: TPSAttributeTypeField;
15157 begin
15158   Fld := FFields[i];
15159   FFields.Delete(i);
15160   Fld.Free;
15161 end;
15162 
15163 { TPSAttribute }
TPSAttribute.GetValueCountnull15164 function TPSAttribute.GetValueCount: Longint;
15165 begin
15166   Result := FValues.Count;
15167 end;
15168 
TPSAttribute.GetValuenull15169 function TPSAttribute.GetValue(I: Longint): PIfRVariant;
15170 begin
15171   Result := FValues[i];
15172 end;
15173 
15174 constructor TPSAttribute.Create(AttribType: TPSAttributeType);
15175 begin
15176   inherited Create;
15177   FValues := TPSList.Create;
15178   FAttribType := AttribType;
15179 end;
15180 
15181 procedure TPSAttribute.DeleteValue(i: Longint);
15182 var
15183   Val: PIfRVariant;
15184 begin
15185   Val := FValues[i];
15186   FValues.Delete(i);
15187   DisposeVariant(Val);
15188 end;
15189 
AddValuenull15190 function TPSAttribute.AddValue(v: PIFRVariant): Longint;
15191 begin
15192   Result := FValues.Add(v);
15193 end;
15194 
15195 
15196 destructor TPSAttribute.Destroy;
15197 var
15198   i: Longint;
15199 begin
15200   for i := FValues.Count -1 downto 0 do
15201   begin
15202     DisposeVariant(FValues[i]);
15203   end;
15204   FValues.Free;
15205   inherited Destroy;
15206 end;
15207 
15208 
15209 procedure TPSAttribute.Assign(Item: TPSAttribute);
15210 var
15211   i: Longint;
15212   p: PIfRVariant;
15213 begin
15214   for i := FValues.Count -1 downto 0 do
15215   begin
15216     DisposeVariant(FValues[i]);
15217   end;
15218   FValues.Clear;
15219   FAttribType := Item.FAttribType;
15220   for i := 0 to Item.FValues.Count -1 do
15221   begin
15222     p := DuplicateVariant(Item.FValues[i]);
15223     FValues.Add(p);
15224   end;
15225 end;
15226 
15227 { TPSAttributes }
15228 
TPSAttributes.GetCountnull15229 function TPSAttributes.GetCount: Longint;
15230 begin
15231   Result := FItems.Count;
15232 end;
15233 
GetItemnull15234 function TPSAttributes.GetItem(I: Longint): TPSAttribute;
15235 begin
15236   Result := TPSAttribute(FItems[i]);
15237 end;
15238 
15239 procedure TPSAttributes.Delete(i: Longint);
15240 var
15241   item: TPSAttribute;
15242 begin
15243   item := TPSAttribute(FItems[i]);
15244   FItems.Delete(i);
15245   Item.Free;
15246 end;
15247 
Addnull15248 function TPSAttributes.Add(AttribType: TPSAttributeType): TPSAttribute;
15249 begin
15250   Result := TPSAttribute.Create(AttribType);
15251   FItems.Add(Result);
15252 end;
15253 
15254 constructor TPSAttributes.Create;
15255 begin
15256   inherited Create;
15257   FItems := TPSList.Create;
15258 end;
15259 
15260 destructor TPSAttributes.Destroy;
15261 var
15262   i: Longint;
15263 begin
15264   for i := FItems.Count -1 downto 0 do
15265   begin
15266     TPSAttribute(FItems[i]).Free;
15267   end;
15268   FItems.Free;
15269   inherited Destroy;
15270 end;
15271 
15272 procedure TPSAttributes.Assign(attr: TPSAttributes; Move: Boolean);
15273 var
15274   newitem, item: TPSAttribute;
15275   i: Longint;
15276 begin
15277   for i := ATtr.FItems.Count -1 downto 0 do
15278   begin
15279     Item := Attr.Fitems[i];
15280     if Move then
15281     begin
15282       FItems.Add(Item);
15283       Attr.FItems.Delete(i);
15284     end else
15285     begin
15286       newitem := TPSAttribute.Create(Item.FAttribType );
15287       newitem.Assign(item);
15288       FItems.Add(NewItem);
15289     end;
15290   end;
15291 
15292 end;
15293 
15294 
TPSAttributes.FindAttributenull15295 function TPSAttributes.FindAttribute(
15296   const Name: tbtString): TPSAttribute;
15297 var
15298   h, i: Longint;
15299 
15300 begin
15301   h := MakeHash(name);
15302   for i := FItems.Count -1 downto 0 do
15303   begin
15304     Result := FItems[i];
15305     if (Result.FAttribType.NameHash = h) and (Result.FAttribType.Name = Name) then
15306       exit;
15307   end;
15308   result := nil;
15309 end;
15310 
15311 { TPSParameterDecl }
15312 procedure TPSParameterDecl.SetName(const s: tbtString);
15313 begin
15314   FOrgName := s;
15315   FName := FastUppercase(s);
15316 end;
15317 
15318 
15319 { TPSParametersDecl }
15320 
15321 procedure TPSParametersDecl.Assign(Params: TPSParametersDecl);
15322 var
15323   i: Longint;
15324   np, orgp: TPSParameterDecl;
15325 begin
15326   for i := FParams.Count -1 downto 0 do
15327   begin
15328     TPSParameterDecl(Fparams[i]).Free;
15329   end;
15330   FParams.Clear;
15331   FResult := Params.Result;
15332 
15333   for i := 0 to Params.FParams.count -1 do
15334   begin
15335     orgp := Params.FParams[i];
15336     np := AddParam;
15337     np.OrgName := orgp.OrgName;
15338     np.Mode := orgp.Mode;
15339     np.aType := orgp.aType;
15340     np.DeclarePos:=orgp.DeclarePos;
15341     np.DeclareRow:=orgp.DeclareRow;
15342     np.DeclareCol:=orgp.DeclareCol;
15343   end;
15344 end;
15345 
15346 
GetParamnull15347 function TPSParametersDecl.GetParam(I: Longint): TPSParameterDecl;
15348 begin
15349   Result := FParams[i];
15350 end;
15351 
TPSParametersDecl.GetParamCountnull15352 function TPSParametersDecl.GetParamCount: Longint;
15353 begin
15354   Result := FParams.Count;
15355 end;
15356 
TPSParametersDecl.AddParamnull15357 function TPSParametersDecl.AddParam: TPSParameterDecl;
15358 begin
15359   Result := TPSParameterDecl.Create;
15360   FParams.Add(Result);
15361 end;
15362 
15363 procedure TPSParametersDecl.DeleteParam(I: Longint);
15364 var
15365   param: TPSParameterDecl;
15366 begin
15367   param := FParams[i];
15368   FParams.Delete(i);
15369   Param.Free;
15370 end;
15371 
15372 constructor TPSParametersDecl.Create;
15373 begin
15374   inherited Create;
15375   FParams := TPSList.Create;
15376 end;
15377 
15378 destructor TPSParametersDecl.Destroy;
15379 var
15380   i: Longint;
15381 begin
15382   for i := FParams.Count -1 downto 0 do
15383   begin
15384     TPSParameterDecl(Fparams[i]).Free;
15385   end;
15386   FParams.Free;
15387   inherited Destroy;
15388 end;
15389 
Samenull15390 function TPSParametersDecl.Same(d: TPSParametersDecl): boolean;
15391 var
15392   i: Longint;
15393 begin
15394   if (d = nil) or (d.ParamCount <> ParamCount) or (d.Result <> Self.Result) then
15395     Result := False
15396   else begin
15397     for i := 0 to d.ParamCount -1 do
15398     begin
15399       if (d.Params[i].Mode <> Params[i].Mode) or (d.Params[i].aType <> Params[i].aType) then
15400       begin
15401         Result := False;
15402         exit;
15403       end;
15404     end;
15405     Result := True;
15406   end;
15407 end;
15408 
15409 { TPSProceduralType }
15410 
15411 constructor TPSProceduralType.Create;
15412 begin
15413   inherited Create;
15414   FProcDef := TPSParametersDecl.Create;
15415 
15416 end;
15417 
15418 destructor TPSProceduralType.Destroy;
15419 begin
15420   FProcDef.Free;
15421   inherited Destroy;
15422 end;
15423 
15424 { TPSDelphiClassItem }
15425 
15426 procedure TPSDelphiClassItem.SetName(const s: tbtString);
15427 begin
15428   FOrgName := s;
15429   FName := FastUpperCase(s);
15430   FNameHash := MakeHash(FName);
15431 end;
15432 
15433 constructor TPSDelphiClassItem.Create(Owner: TPSCompileTimeClass);
15434 begin
15435   inherited Create;
15436   FOwner := Owner;
15437   FDecl := TPSParametersDecl.Create;
15438 end;
15439 
15440 destructor TPSDelphiClassItem.Destroy;
15441 begin
15442   FDecl.Free;
15443   inherited Destroy;
15444 end;
15445 
15446 {$IFNDEF PS_NOINTERFACES}
15447 { TPSInterface }
15448 
TPSInterface.CastToTypenull15449 function TPSInterface.CastToType(IntoType: TPSType;
15450   var ProcNo: Cardinal): Boolean;
15451 var
15452   P: TPSExternalProcedure;
15453 begin
15454   if (IntoType <> nil) and (IntoType.BaseType <> btInterface) then
15455   begin
15456     Result := False;
15457     exit;
15458   end;
15459   if FCastProc <> InvalidVal then
15460   begin
15461     ProcNo := FCastProc;
15462     Result := True;
15463     exit;
15464   end;
15465   ProcNo := FOwner.AddUsedFunction2(P);
rocHDRnull15466   P.RegProc := FOwner.AddFunction(ProcHDR);
15467   P.RegProc.Name := '';
15468   with P.RegProc.Decl.AddParam do
15469   begin
15470     OrgName := 'Org';
15471     aType := Self.FType;
15472   end;
15473   with P.RegProc.Decl.AddParam do
15474   begin
15475     OrgName := 'TypeNo';
15476     aType := FOwner.at2ut(FOwner.FindBaseType(btU32));
15477   end;
15478   P.RegProc.Decl.Result := FOwner.at2ut(IntoType);
15479 
15480   P.RegProc.ImportDecl := 'class:+';
15481   FCastProc := ProcNo;
15482   Result := True;
15483 end;
15484 
15485 constructor TPSInterface.Create(Owner: TPSPascalCompiler; InheritedFrom: TPSInterface; Guid: TGuid; const Name: tbtString; aType: TPSType);
15486 begin
15487   inherited Create;
15488   FCastProc := InvalidVal;
15489   FNilProc := InvalidVal;
15490 
15491   FType := aType;
15492   FOWner := Owner;
15493   FGuid := GUID;
15494   Self.InheritedFrom := InheritedFrom;
15495 
15496   FItems := TPSList.Create;
15497   FName := Name;
15498   FNameHash := MakeHash(Name);
15499 end;
15500 
15501 procedure TPSInterface.SetInheritedFrom(p: TPSInterface);
15502 begin
15503   FInheritedFrom := p;
15504 end;
15505 
15506 destructor TPSInterface.Destroy;
15507 var
15508   i: Longint;
15509 begin
15510   for i := FItems.Count -1 downto 0 do
15511   begin
15512     TPSInterfaceMethod(FItems[i]).Free;
15513   end;
15514   FItems.Free;
15515   inherited Destroy;
15516 end;
15517 
TPSInterface.Func_Callnull15518 function TPSInterface.Func_Call(Index: TPSInterfaceMethod;
15519   var ProcNo: Cardinal): Boolean;
15520 var
15521   c: TPSInterfaceMethod;
15522   P: TPSExternalProcedure;
15523   s: tbtString;
15524   i: Longint;
15525 begin
15526   c := TPSInterfaceMethod(Index);
15527   if c.FScriptProcNo <> InvalidVal then
15528   begin
15529     Procno := c.FScriptProcNo;
15530     Result := True;
15531     exit;
15532   end;
15533   ProcNo := FOwner.AddUsedFunction2(P);
rocHDRnull15534   P.RegProc := FOwner.AddFunction(ProcHDR);
15535   P.RegProc.Name := '';
15536   FOwner.UseProc(C.Decl);
15537   P.RegProc.Decl.Assign(c.Decl);
15538   s := tbtstring('intf:.') + PS_mi2s(c.AbsoluteProcOffset) + tbtchar(ord(c.CC));
15539   if c.Decl.Result = nil then
15540     s := s + #0
15541   else
15542     s := s + #1;
15543   for i := 0 to C.Decl.ParamCount -1 do
15544   begin
15545     if c.Decl.Params[i].Mode <> pmIn then
15546       s := s + #1
15547     else
15548       s := s + #0;
15549   end;
15550   P.RegProc.ImportDecl := s;
15551   C.FScriptProcNo := ProcNo;
15552   Result := True;
15553 end;
15554 
TPSInterface.Func_Findnull15555 function TPSInterface.Func_Find(const Name: tbtString;
15556   var Index: TPSInterfaceMethod): Boolean;
15557 var
15558   H: Longint;
15559   I: Longint;
15560   CurrClass: TPSInterface;
15561   C: TPSInterfaceMethod;
15562 begin
15563   H := MakeHash(Name);
15564   CurrClass := Self;
15565   while CurrClass <> nil do
15566   begin
15567     for i := CurrClass.FItems.Count -1 downto 0 do
15568     begin
15569       C := CurrClass.FItems[I];
15570       if (C.NameHash = H) and (C.Name = Name) then
15571       begin
15572         Index := c;
15573         Result := True;
15574         exit;
15575       end;
15576     end;
15577     CurrClass := CurrClass.FInheritedFrom;
15578   end;
15579   Result := False;
15580 end;
15581 
TPSInterface.IsCompatibleWithnull15582 function TPSInterface.IsCompatibleWith(aType: TPSType): Boolean;
15583 var
15584   Temp: TPSInterface;
15585 begin
15586   if (atype.BaseType = btClass) then // just support it, we'll see what happens
15587   begin
15588     Result := true;
15589     exit;
15590   end;
15591   if atype.BaseType <> btInterface then
15592   begin
15593     Result := False;
15594     exit;
15595   end;
15596   temp := TPSInterfaceType(atype).FIntf;
15597   while Temp <> nil do
15598   begin
15599     if Temp = Self then
15600     begin
15601       Result := True;
15602       exit;
15603     end;
15604     Temp := Temp.FInheritedFrom;
15605   end;
15606   Result := False;
15607 end;
15608 
15609 procedure TPSInterface.RegisterDummyMethod;
15610 begin
15611   FItems.Add(TPSInterfaceMethod.Create(self));
15612 end;
15613 
RegisterMethodnull15614 function TPSInterface.RegisterMethod(const Declaration: tbtString;
15615   const cc: TPSCallingConvention): Boolean;
15616 begin
15617   Result := RegisterMethodEx(Declaration, cc, nil);
15618 end;
15619 
RegisterMethodExnull15620 function TPSInterface.RegisterMethodEx(const Declaration: tbtString;
15621   const cc: TPSCallingConvention; const CustomParser: TPSPascalParser): Boolean;
15622 var
15623   M: TPSInterfaceMethod;
15624   DOrgName: tbtString;
15625   Func: TPMFuncType;
15626 begin
15627   M := TPSInterfaceMethod.Create(Self);
15628   if not ParseMethodEx(FOwner, '', Declaration, DOrgname, m.Decl, Func, CustomParser) then
15629   begin
15630     FItems.Add(m); // in any case, add a dummy item
15631     Result := False;
15632     exit;
15633   end;
15634   m.FName := FastUppercase(DOrgName);
15635   m.FOrgName := DOrgName;
15636   m.FNameHash := MakeHash(m.FName);
15637   m.FCC := CC;
15638   m.FScriptProcNo := InvalidVal;
15639   FItems.Add(M);
15640   Result := True;
15641 end;
15642 
15643 
SetNilnull15644 function TPSInterface.SetNil(var ProcNo: Cardinal): Boolean;
15645 var
15646   P: TPSExternalProcedure;
15647 
15648 begin
15649   if FNilProc <> InvalidVal then
15650   begin
15651     Procno := FNilProc;
15652     Result := True;
15653     exit;
15654   end;
15655   ProcNo := FOwner.AddUsedFunction2(P);
15656   P.RegProc := FOwner.AddFunction(ProcHDR);
15657   P.RegProc.Name := '';
15658   with p.RegProc.Decl.AddParam do
15659   begin
15660     Mode := pmInOut;
15661     OrgName := 'VarNo';
15662     aType := FOwner.at2ut(Self.FType);
15663   end;
15664   P.RegProc.ImportDecl := 'class:-';
15665   FNilProc := Procno;
15666   Result := True;
15667 end;
15668 
15669 { TPSInterfaceMethod }
15670 
15671 constructor TPSInterfaceMethod.Create(Owner: TPSInterface);
15672 begin
15673   inherited Create;
15674   FDecl := TPSParametersDecl.Create;
15675   FOwner := Owner;
15676   FOffsetCache := InvalidVal;
15677 end;
15678 
GetAbsoluteProcOffsetnull15679 function TPSInterfaceMethod.GetAbsoluteProcOffset: Cardinal;
15680 var
15681   ps: TPSInterface;
15682 begin
15683   if FOffsetCache = InvalidVal then
15684   begin
15685     FOffsetCache := FOwner.FItems.IndexOf(Self);
15686     ps := FOwner.FInheritedFrom;
15687     while ps <> nil do
15688     begin
15689       FOffsetCache := FOffsetCache + ps.FItems.Count;
15690       ps := ps.FInheritedFrom;
15691     end;
15692   end;
15693   result := FOffsetCache;
15694 end;
15695 
15696 
15697 destructor TPSInterfaceMethod.Destroy;
15698 begin
15699   FDecl.Free;
15700   inherited Destroy;
15701 end;
15702 {$ENDIF}
15703 
15704 { TPSVariantType }
15705 
GetDynInvokeParamTypenull15706 function TPSVariantType.GetDynInvokeParamType(Owner: TPSPascalCompiler) : TPSType;
15707 begin
15708   Result := Owner.at2ut(FindAndAddType(owner, '!OPENARRAYOFVARIANT', 'array of Variant'));
15709 end;
15710 
GetDynInvokeProcNonull15711 function TPSVariantType.GetDynInvokeProcNo(Owner: TPSPascalCompiler; const Name: tbtString;
15712   Params: TPSParameters): Cardinal;
15713 begin
15714   Result := Owner.FindProc('IdispatchInvoke');
15715 end;
15716 
GetDynIvokeResulTypenull15717 function TPSVariantType.GetDynIvokeResulType(
15718   Owner: TPSPascalCompiler): TPSType;
15719 begin
15720   Result := Owner.FindType('VARIANT');
15721 end;
15722 
GetDynIvokeSelfTypenull15723 function TPSVariantType.GetDynIvokeSelfType(Owner: TPSPascalCompiler): TPSType;
15724 begin
15725   Result := Owner.at2ut(Owner.FindType('IDISPATCH'));
15726 end;
15727 
15728 
15729 { TPSExternalClass }
SetNilnull15730 function TPSExternalClass.SetNil(var ProcNo: Cardinal): Boolean;
15731 begin
15732   Result := False;
15733 end;
15734 
15735 constructor TPSExternalClass.Create(Se: TIFPSPascalCompiler; TypeNo: TPSType);
15736 begin
15737   inherited Create;
15738   Self.SE := se;
15739   Self.FTypeNo := TypeNo;
15740 end;
15741 
Func_Callnull15742 function TPSExternalClass.Func_Call(Index: Cardinal;
15743   var ProcNo: Cardinal): Boolean;
15744 begin
15745   Result := False;
15746 end;
15747 
Func_Findnull15748 function TPSExternalClass.Func_Find(const Name: tbtString;
15749   var Index: Cardinal): Boolean;
15750 begin
15751   Result := False;
15752 end;
15753 
IsCompatibleWithnull15754 function TPSExternalClass.IsCompatibleWith(
15755   Cl: TPSExternalClass): Boolean;
15756 begin
15757   Result := False;
15758 end;
15759 
SelfTypenull15760 function TPSExternalClass.SelfType: TPSType;
15761 begin
15762   Result := nil;
15763 end;
15764 
CastToTypenull15765 function TPSExternalClass.CastToType(IntoType: TPSType;
15766   var ProcNo: Cardinal): Boolean;
15767 begin
15768   Result := False;
15769 end;
15770 
CompareClassnull15771 function TPSExternalClass.CompareClass(OtherTypeNo: TPSType;
15772   var ProcNo: Cardinal): Boolean;
15773 begin
15774   Result := false;
15775 end;
15776 
ClassFunc_Findnull15777 function TPSExternalClass.ClassFunc_Find(const Name: tbtString; var Index: Cardinal): Boolean;
15778 begin
15779   result := false;
15780 end;
15781 
ClassFunc_Callnull15782 function TPSExternalClass.ClassFunc_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean;
15783 begin
15784   result := false;
15785 end;
15786 
15787 
15788 { TPSValueProcVal }
15789 
15790 destructor TPSValueProcVal.Destroy;
15791 begin
15792   FProcNo.Free;
15793   inherited;
15794 end;
15795 
15796 
15797 {
15798 
15799 Internal error counter: 00020 (increase and then use)
15800 
15801 }
15802 end.
15803