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;
436 {$IFDEF PS_USESSUPPORT}
437 FDeclareUnit: tbtString;
438 {$ENDIF}
439 FDeclarePos: Cardinal;
440 FDeclareRow: Cardinal;
441 FDeclareCol: Cardinal;
GetValueCountnull442 function GetValueCount: Longint;
GetValuenull443 function GetValue(I: Longint): PIfRVariant;
444 public
445
446 constructor Create(AttribType: TPSAttributeType);
447
448 procedure Assign(Item: TPSAttribute);
449
450 property AType: TPSAttributeType read FAttribType;
451
452 property Count: Longint read GetValueCount;
453
454 property Values[i: Longint]: PIfRVariant read GetValue; default;
455
456 {$IFDEF PS_USESSUPPORT}
457 property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit;
458 {$ENDIF}
459
460 property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
461
462 property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
463
464 property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
465
466 procedure DeleteValue(i: Longint);
467
AddValuenull468 function AddValue(v: PIFRVariant): Longint;
469
470 destructor Destroy; override;
471 end;
472
473
474 TPSAttributes = class(TObject)
475 private
476 FItems: TPSList;
GetCountnull477 function GetCount: Longint;
GetItemnull478 function GetItem(I: Longint): TPSAttribute;
479 public
480
481 procedure Assign(attr: TPSAttributes; Move: Boolean);
482
483 property Count: Longint read GetCount;
484
485 property Items[i: Longint]: TPSAttribute read GetItem; default;
486
487 procedure Delete(i: Longint);
488
Addnull489 function Add(AttribType: TPSAttributeType): TPSAttribute;
490
FindAttributenull491 function FindAttribute(const Name: tbtString): TPSAttribute;
492
493 constructor Create;
494
495 destructor Destroy; override;
496 end;
497
498
499 TPSProcVar = class(TObject)
500 private
501 FNameHash: Longint;
502 FName: tbtString;
503 FOrgName: tbtString;
504 FType: TPSType;
505 FUsed: Boolean;
506 {$IFDEF PS_USESSUPPORT}
507 FDeclareUnit: tbtString;
508 {$ENDIF}
509 FDeclarePos, FDeclareRow, FDeclareCol: Cardinal;
510 procedure SetName(const Value: tbtString);
511 public
512
513 property OrgName: tbtString read FOrgName write FOrgname;
514
515 property NameHash: Longint read FNameHash;
516
517 property Name: tbtString read FName write SetName;
518
519 property AType: TPSType read FType write FType;
520
521 property Used: Boolean read FUsed;
522
523 {$IFDEF PS_USESSUPPORT}
524 property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit;
525 {$ENDIF}
526
527 property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
528
529 property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
530
531 property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
532
533 procedure Use;
534 end;
535
536 PIFPSProcVar = TPSProcVar;
537
538 TPSExternalProcedure = class(TPSProcedure)
539 private
540 FRegProc: TPSRegProc;
541 public
542
543 property RegProc: TPSRegProc read FRegProc write FRegProc;
544 end;
545
546
547 TPSInternalProcedure = class(TPSProcedure)
548 private
549 FForwarded: Boolean;
550 FData: tbtString;
551 FNameHash: Longint;
552 FName: tbtString;
553 FDecl: TPSParametersDecl;
554 FProcVars: TPSList;
555 FUsed: Boolean;
556 FOutputDeclPosition: Cardinal;
557 FResultUsed: Boolean;
558 FLabels: TIfStringList;
559 FGotos: TIfStringList;
560 FDeclareRow: Cardinal;
561 {$IFDEF PS_USESSUPPORT}
562 FDeclareUnit: tbtString;
563 {$ENDIF}
564 FDeclarePos: Cardinal;
565 FDeclareCol: Cardinal;
566 FOriginalName: tbtString;
567 procedure SetName(const Value: tbtString);
568 public
569
570 constructor Create;
571
572 destructor Destroy; override;
573 {Attributes}
574
575
576 property Forwarded: Boolean read FForwarded write FForwarded;
577
578 property Data: tbtString read FData write FData;
579
580 property Decl: TPSParametersDecl read FDecl;
581
582 property OriginalName: tbtString read FOriginalName write FOriginalName;
583
584 property Name: tbtString read FName write SetName;
585
586 property NameHash: Longint read FNameHash;
587
588 property ProcVars: TPSList read FProcVars;
589
590 property Used: Boolean read FUsed;
591
592 {$IFDEF PS_USESSUPPORT}
593 property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit;
594 {$ENDIF}
595
596 property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
597
598 property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
599
600 property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
601
602 property OutputDeclPosition: Cardinal read FOutputDeclPosition write FOutputDeclPosition;
603
604 property ResultUsed: Boolean read FResultUsed;
605
606
607 property Labels: TIfStringList read FLabels;
608
609 property Gotos: TIfStringList read FGotos;
610
611 procedure Use;
612
613 procedure ResultUse;
614 end;
615
616 TPSVar = class(TObject)
617 private
618 FNameHash: Longint;
619 FOrgName: tbtString;
620 FName: tbtString;
621 FType: TPSType;
622 FUsed: Boolean;
623 FExportName: tbtString;
624 FDeclareRow: Cardinal;
625 {$IFDEF PS_USESSUPPORT}
626 FDeclareUnit: tbtString;
627 {$ENDIF}
628 FDeclarePos: Cardinal;
629 FDeclareCol: Cardinal;
630 FSaveAsPointer: Boolean;
631 procedure SetName(const Value: tbtString);
632 public
633
634 property SaveAsPointer: Boolean read FSaveAsPointer write FSaveAsPointer;
635
636 property ExportName: tbtString read FExportName write FExportName;
637
638 property Used: Boolean read FUsed;
639
640 property aType: TPSType read FType write FType;
641
642 property OrgName: tbtString read FOrgName write FOrgName;
643
644 property Name: tbtString read FName write SetName;
645
646 property NameHash: Longint read FNameHash;
647
648 {$IFDEF PS_USESSUPPORT}
649 property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit;
650 {$ENDIF}
651
652 property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
653
654 property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
655
656 property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
657
658 procedure Use;
659 end;
660
661 PIFPSVar = TPSVar;
662
663 TPSConstant = class(TObject)
664 private
665
666 FOrgName: tbtString;
667
668 FNameHash: Longint;
669
670 FName: tbtString;
671
672 FDeclareRow: Cardinal;
673 {$IFDEF PS_USESSUPPORT}
674 FDeclareUnit: tbtString;
675 {$ENDIF}
676 FDeclarePos: Cardinal;
677 FDeclareCol: Cardinal;
678
679 FValue: PIfRVariant;
680 procedure SetName(const Value: tbtString);
681 public
682
683 property OrgName: tbtString read FOrgName write FOrgName;
684
685 property Name: tbtString read FName write SetName;
686
687 property NameHash: Longint read FNameHash;
688
689 property Value: PIfRVariant read FValue write FValue;
690
691 {$IFDEF PS_USESSUPPORT}
692 property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit;
693 {$ENDIF}
694
695 property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
696
697 property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
698
699 property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
700
701
702 procedure SetSet(const val);
703
704
705 procedure SetInt(const Val: Longint);
706
707 procedure SetUInt(const Val: Cardinal);
708 {$IFNDEF PS_NOINT64}
709
710 procedure SetInt64(const Val: Int64);
711 {$ENDIF}
712
713 procedure SetString(const Val: tbtString);
714
715 procedure SetChar(c: tbtChar);
716 {$IFNDEF PS_NOWIDESTRING}
717
718 procedure SetWideChar(const val: WideChar);
719
720 procedure SetWideString(const val: tbtwidestring);
721 procedure SetUnicodeString(const val: tbtunicodestring);
722 {$ENDIF}
723
724 procedure SetExtended(const Val: Extended);
725
726
727 destructor Destroy; override;
728 end;
729
730 PIFPSConstant = TPSConstant;
731
732 TPSPascalCompilerErrorType = (
733 ecUnknownIdentifier,
734 ecIdentifierExpected,
735 ecCommentError,
736 ecStringError,
737 ecCharError,
738 ecSyntaxError,
739 ecUnexpectedEndOfFile,
740 ecSemicolonExpected,
741 ecBeginExpected,
742 ecPeriodExpected,
743 ecDuplicateIdentifier,
744 ecColonExpected,
745 ecUnknownType,
746 ecCloseRoundExpected,
747 ecTypeMismatch,
748 ecInternalError,
749 ecAssignmentExpected,
750 ecThenExpected,
751 ecDoExpected,
752 ecNoResult,
753 ecOpenRoundExpected,
754 ecCommaExpected,
755 ecToExpected,
756 ecIsExpected,
757 ecOfExpected,
758 ecCloseBlockExpected,
759 ecVariableExpected,
760 ecStringExpected,
761 ecEndExpected,
762 ecUnSetLabel,
763 ecNotInLoop,
764 ecInvalidJump,
765 ecOpenBlockExpected,
766 ecWriteOnlyProperty,
767 ecReadOnlyProperty,
768 ecClassTypeExpected,
769 ecCustomError,
770 ecDivideByZero,
771 ecMathError,
772 ecUnsatisfiedForward,
773 ecForwardParameterMismatch,
774 ecInvalidnumberOfParameters
775 {$IFDEF PS_USESSUPPORT}
776 , ecNotAllowed,
777 ecUnitNotFoundOrContainsErrors,
778 ecCrossReference
779 {$ENDIF}
780 , ecUnClosedAttributes
781 );
782
783 TPSPascalCompilerHintType = (
784 ehVariableNotUsed,
785 ehFunctionNotUsed,
786 ehCustomHint
787 );
788
789 TPSPascalCompilerWarningType = (
790 ewCalculationAlwaysEvaluatesTo,
791 ewIsNotNeeded,
792 ewAbstractClass,
793 ewCustomWarning
794 );
795
796 TPSPascalCompilerMessage = class(TObject)
797 protected
798
799 FRow: Cardinal;
800
801 FCol: Cardinal;
802
803 FModuleName: tbtString;
804
805 FParam: tbtString;
806
807 FPosition: Cardinal;
808
809 procedure SetParserPos(Parser: TPSPascalParser);
810 public
811
812 property ModuleName: tbtString read FModuleName write FModuleName;
813
814 property Param: tbtString read FParam write FParam;
815
816 property Pos: Cardinal read FPosition write FPosition;
817
818 property Row: Cardinal read FRow write FRow;
819
820 property Col: Cardinal read FCol write FCol;
821
ErrorTypenull822 function ErrorType: tbtString; virtual; abstract;
823
824 procedure SetCustomPos(Pos, Row, Col: Cardinal);
825
MessageToStringnull826 function MessageToString: tbtString; virtual;
827
ShortMessageToStringnull828 function ShortMessageToString: tbtString; virtual; abstract;
829 end;
830
831 TPSPascalCompilerError = class(TPSPascalCompilerMessage)
832 protected
833
834 FError: TPSPascalCompilerErrorType;
835 public
836
837 property Error: TPSPascalCompilerErrorType read FError;
838
ErrorTypenull839 function ErrorType: tbtString; override;
ShortMessageToStringnull840 function ShortMessageToString: tbtString; override;
841 end;
842
843 TPSPascalCompilerHint = class(TPSPascalCompilerMessage)
844 protected
845
846 FHint: TPSPascalCompilerHintType;
847 public
848
849 property Hint: TPSPascalCompilerHintType read FHint;
850
ErrorTypenull851 function ErrorType: tbtString; override;
ShortMessageToStringnull852 function ShortMessageToString: tbtString; override;
853 end;
854
855 TPSPascalCompilerWarning = class(TPSPascalCompilerMessage)
856 protected
857
858 FWarning: TPSPascalCompilerWarningType;
859 public
860
861 property Warning: TPSPascalCompilerWarningType read FWarning;
862
ErrorTypenull863 function ErrorType: tbtString; override;
ShortMessageToStringnull864 function ShortMessageToString: tbtString; override;
865 end;
866 TPSDuplicCheck = set of (dcTypes, dcProcs, dcVars, dcConsts);
867
868 TPSBlockInfo = class(TObject)
869 private
870 FOwner: TPSBlockInfo;
871 FWithList: TPSList;
872 FProcNo: Cardinal;
873 FProc: TPSInternalProcedure;
874 FSubType: TPSSubOptType;
875 public
876
877 property WithList: TPSList read FWithList;
878
879 property ProcNo: Cardinal read FProcNo write FProcNo;
880
881 property Proc: TPSInternalProcedure read FProc write FProc;
882
883 property SubType: TPSSubOptType read FSubType write FSubType;
884
885 procedure Clear;
886
887 constructor Create(Owner: TPSBlockInfo);
888
889 destructor Destroy; override;
890 end;
891
892
893
894 TPSBinOperatorType = (otAdd, otSub, otMul, otDiv, otMod, otShl, otShr, otAnd, otOr, otXor, otAs, otIntDiv,
895 otGreaterEqual, otLessEqual, otGreater, otLess, otEqual,
896 otNotEqual, otIs, otIn);
897
898 TPSUnOperatorType = (otNot, otMinus, otCast);
899
900 TPSOnUseVariable = procedure (Sender: TPSPascalCompiler; VarType: TPSVariableType; VarNo: Longint; ProcNo, Position: Cardinal; const PropData: tbtString);
901
902 TPSOnUseRegProc = procedure (Sender: TPSPascalCompiler; Position: Cardinal; const Name: tbtString);
903
endernull904 TPSOnUses = function(Sender: TPSPascalCompiler; const Name: tbtString): Boolean;
905
endernull906 TPSOnExportCheck = function(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; const ProcDecl: tbtString): Boolean;
907
908 {$IFNDEF PS_USESSUPPORT}
909 TPSOnWriteLineEvent = function (Sender: TPSPascalCompiler; Position: Cardinal): Boolean;
910 {$ELSE}
911 TPSOnWriteLineEvent = function (Sender: TPSPascalCompiler; FileName: tbtString; Position: Cardinal): Boolean;
912 {$ENDIF}
913
914 TPSOnExternalProc = function (Sender: TPSPascalCompiler; Decl: TPSParametersDecl; const Name, FExternal: tbtString): TPSRegProc;
915
916 TPSOnTranslateLineInfoProc = procedure (Sender: TPSPascalCompiler; var Pos, Row, Col: Cardinal; var Name: tbtString);
917 TPSOnNotify = function (Sender: TPSPascalCompiler): Boolean;
918
919 TPSOnFunction = procedure(name: tbtString; Pos, Row, Col: Integer) of object;
920
921
922 TPSPascalCompiler = class
923 protected
924 FAnyString: TPSType;
925 FAnyMethod: TPSType;
926 FUnitName: tbtString;
927 FID: Pointer;
928 FOnExportCheck: TPSOnExportCheck;
929 FDefaultBoolType: TPSType;
930 FRegProcs: TPSList;
931 FConstants: TPSList;
932 FProcs: TPSList;
933 FTypes: TPSList;
934 FAttributeTypes: TPSList;
935 FVars: TPSList;
936 FOutput: tbtString;
937 FParser: TPSPascalParser;
938 FParserHadError: Boolean;
939 FMessages: TPSList;
940 FOnUses: TPSOnUses;
941 FUtf8Decode: Boolean;
942 FIsUnit: Boolean;
943 FAllowNoBegin: Boolean;
944 FAllowNoEnd: Boolean;
945 FAllowUnit: Boolean;
946 FAllowDuplicateRegister : Boolean;
947 FBooleanShortCircuit: Boolean;
948 FDebugOutput: tbtString;
949 FOnExternalProc: TPSOnExternalProc;
950 FOnUseVariable: TPSOnUseVariable;
951 FOnUseRegProc: TPSOnUseRegProc;
952 FOnBeforeOutput: TPSOnNotify;
953 FOnBeforeCleanup: TPSOnNotify;
954 FOnWriteLine: TPSOnWriteLineEvent;
955 FContinueOffsets, FBreakOffsets: TPSList;
956 FOnTranslateLineInfo: TPSOnTranslateLineInfoProc;
957 FAutoFreeList: TPSList;
958 FClasses: TPSList;
959 FOnFunctionStart: TPSOnFunction;
FOnFunctionEndnull960 FOnFunctionEnd: TPSOnFunction;
961 FAttributesOpenTokenID, FAttributesCloseTokenID: TPsPasToken;
962
963 FWithCount: Integer;
964 FTryCount: Integer;
965 FExceptFinallyCount: Integer;
966
967
968 {$IFDEF PS_USESSUPPORT}
969 FUnitInits : TPSList; //nvds
970 FUnitFinits: TPSList; //nvds
971 FUses : TPSStringList;
972 fUnits : TPSUnitList;
973 fUnit : TPSUnit;
974 fModule : tbtString;
975 {$ENDIF}
976 fInCompile : Integer;
977 {$IFNDEF PS_NOINTERFACES}
978 FInterfaces: TPSList;
979 {$ENDIF}
980
981 FCurrUsedTypeNo: Cardinal;
982 FGlobalBlock: TPSBlockInfo;
983
IsBooleannull984 function IsBoolean(aType: TPSType): Boolean;
985 {$IFNDEF PS_NOWIDESTRING}
986
GetWideStringnull987 function GetWideString(Src: PIfRVariant; var s: Boolean): tbtwidestring;
GetUnicodeStringnull988 function GetUnicodeString(Src: PIfRVariant; var s: Boolean): tbtunicodestring;
989 {$ENDIF}
PreCalcnull990 function PreCalc(FUseUsedTypes: Boolean; Var1Mod: Byte; var1: PIFRVariant; Var2Mod: Byte;
991 Var2: PIfRVariant; Cmd: TPSBinOperatorType; Pos, Row, Col: Cardinal): Boolean;
992
FindBaseTypenull993 function FindBaseType(BaseType: TPSBaseType): TPSType;
994
IsIntBoolTypenull995 function IsIntBoolType(aType: TPSType): Boolean;
GetTypeCopyLinknull996 function GetTypeCopyLink(p: TPSType): TPSType;
997
at2utnull998 function at2ut(p: TPSType): TPSType;
999 procedure UseProc(procdecl: TPSParametersDecl);
1000
1001
GetMsgCountnull1002 function GetMsgCount: Longint;
1003
GetMsgnull1004 function GetMsg(l: Longint): TPSPascalCompilerMessage;
1005
1006
MakeExportDeclnull1007 function MakeExportDecl(decl: TPSParametersDecl): tbtString;
1008
1009
1010 procedure DefineStandardTypes;
1011
1012 procedure DefineStandardProcedures;
1013
ReadRealnull1014 function ReadReal(const s: tbtString): PIfRVariant;
ReadStringnull1015 function ReadString: PIfRVariant;
ReadIntegernull1016 function ReadInteger(const s: tbtString): PIfRVariant;
ReadAttributesnull1017 function ReadAttributes(Dest: TPSAttributes): Boolean;
ReadConstantnull1018 function ReadConstant(FParser: TPSPascalParser; StopOn: TPSPasToken): PIfRVariant;
1019
ApplyAttribsToFunctionnull1020 function ApplyAttribsToFunction(func: TPSProcedure): boolean;
ProcessFunctionnull1021 function ProcessFunction(AlwaysForward: Boolean; Att: TPSAttributes): Boolean;
ValidateParametersnull1022 function ValidateParameters(BlockInfo: TPSBlockInfo; Params: TPSParameters; ParamTypes: TPSParametersDecl): boolean;
1023
IsVarInCompatiblenull1024 function IsVarInCompatible(ft1, ft2: TPSType): Boolean;
GetTypeNonull1025 function GetTypeNo(BlockInfo: TPSBlockInfo; p: TPSValue): TPSType;
DoVarBlocknull1026 function DoVarBlock(proc: TPSInternalProcedure): Boolean;
DoTypeBlocknull1027 function DoTypeBlock(FParser: TPSPascalParser): Boolean;
ReadTypenull1028 function ReadType(const Name: tbtString; FParser: TPSPascalParser): TPSType;
ProcessLabelnull1029 function ProcessLabel(Proc: TPSInternalProcedure): Boolean;
ProcessSubnull1030 function ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
ProcessLabelForwardsnull1031 function ProcessLabelForwards(Proc: TPSInternalProcedure): Boolean;
1032
1033 procedure WriteDebugData(const s: tbtString);
1034
1035 procedure Debug_SavePosition(ProcNo: Cardinal; Proc: TPSInternalProcedure);
1036
1037 procedure Debug_WriteParams(ProcNo: Cardinal; Proc: TPSInternalProcedure);
1038
1039 procedure Debug_WriteLine(BlockInfo: TPSBlockInfo);
1040
1041
IsCompatibleTypenull1042 function IsCompatibleType(p1, p2: TPSType; Cast: Boolean): Boolean;
1043
IsDuplicatenull1044 function IsDuplicate(const s: tbtString; const check: TPSDuplicCheck): Boolean;
1045 {$IFDEF PS_USESSUPPORT}
IsInLocalUnitListnull1046 function IsInLocalUnitList(s: tbtString): Boolean;
1047 {$ENDIF}
1048
NewProcnull1049 function NewProc(const OriginalName, Name: tbtString): TPSInternalProcedure;
1050
AddUsedFunctionnull1051 function AddUsedFunction(var Proc: TPSInternalProcedure): Cardinal;
1052
AddUsedFunction2null1053 function AddUsedFunction2(var Proc: TPSExternalProcedure): Cardinal;
1054
1055
CheckCompatProcnull1056 function CheckCompatProc(P: TPSType; ProcNo: Cardinal): Boolean;
1057
1058
1059 procedure ParserError(Parser: TObject; Kind: TPSParserErrorKind);
1060
ReadTypeAddProcedurenull1061 function ReadTypeAddProcedure(const Name: tbtString; FParser: TPSPascalParser): TPSType;
1062
VarIsDuplicatenull1063 function VarIsDuplicate(Proc: TPSInternalProcedure; const VarNames, s: tbtString): Boolean;
1064
IsProcDuplicLabelnull1065 function IsProcDuplicLabel(Proc: TPSInternalProcedure; const s: tbtString): Boolean;
1066
1067 procedure CheckForUnusedVars(Func: TPSInternalProcedure);
ProcIsDuplicnull1068 function ProcIsDuplic(Decl: TPSParametersDecl; const FunctionName, FunctionParamNames: tbtString; const s: tbtString; Func: TPSInternalProcedure): Boolean;
1069 public
GetConstantnull1070 function GetConstant(const Name: tbtString): TPSConstant;
1071
UseExternalProcnull1072 function UseExternalProc(const Name: tbtString): TPSParametersDecl;
1073
FindProcnull1074 function FindProc(const aName: tbtString): Cardinal;
1075
GetTypeCountnull1076 function GetTypeCount: Longint;
1077
GetTypenull1078 function GetType(I: Longint): TPSType;
1079
GetVarCountnull1080 function GetVarCount: Longint;
1081
GetVarnull1082 function GetVar(I: Longint): TPSVar;
1083
GetProcCountnull1084 function GetProcCount: Longint;
1085
GetProcnull1086 function GetProc(I: Longint): TPSProcedure;
1087
GetConstCountnull1088 function GetConstCount: Longint;
1089
GetConstnull1090 function GetConst(I: Longint): TPSConstant;
1091
GetRegProcCountnull1092 function GetRegProcCount: Longint;
1093
GetRegProcnull1094 function GetRegProc(I: Longint): TPSRegProc;
1095
AddAttributeTypenull1096 function AddAttributeType: TPSAttributeType;
FindAttributeTypenull1097 function FindAttributeType(const Name: tbtString): TPSAttributeType;
1098
1099 procedure AddToFreeList(Obj: TObject);
1100
1101 property ID: Pointer read FID write FID;
1102
MakeErrornull1103 function MakeError(const Module: tbtString; E: TPSPascalCompilerErrorType; const
1104 Param: tbtString): TPSPascalCompilerMessage;
1105
MakeWarningnull1106 function MakeWarning(const Module: tbtString; E: TPSPascalCompilerWarningType;
1107 const Param: tbtString): TPSPascalCompilerMessage;
1108
MakeHintnull1109 function MakeHint(const Module: tbtString; E: TPSPascalCompilerHintType;
1110 const Param: tbtString): TPSPascalCompilerMessage;
1111
1112 {$IFNDEF PS_NOINTERFACES}
1113
AddInterfacenull1114 function AddInterface(InheritedFrom: TPSInterface; Guid: TGuid; const Name: tbtString): TPSInterface;
1115
FindInterfacenull1116 function FindInterface(const Name: tbtString): TPSInterface;
1117
1118 {$ENDIF}
AddClassnull1119 function AddClass(InheritsFrom: TPSCompileTimeClass; aClass: TClass): TPSCompileTimeClass;
1120
AddClassNnull1121 function AddClassN(InheritsFrom: TPSCompileTimeClass; const aClass: tbtString): TPSCompileTimeClass;
1122
1123
FindClassnull1124 function FindClass(const aClass: tbtString): TPSCompileTimeClass;
1125
AddFunctionnull1126 function AddFunction(const Header: tbtString): TPSRegProc;
1127
AddDelphiFunctionnull1128 function AddDelphiFunction(const Decl: tbtString): TPSRegProc;
1129
AddTypenull1130 function AddType(const Name: tbtString; const BaseType: TPSBaseType): TPSType;
1131
AddTypeSnull1132 function AddTypeS(const Name, Decl: tbtString): TPSType;
1133
AddTypeCopynull1134 function AddTypeCopy(const Name: tbtString; TypeNo: TPSType): TPSType;
1135
AddTypeCopyNnull1136 function AddTypeCopyN(const Name, FType: tbtString): TPSType;
1137
AddConstantnull1138 function AddConstant(const Name: tbtString; FType: TPSType): TPSConstant;
1139
AddConstantNnull1140 function AddConstantN(const Name, FType: tbtString): TPSConstant;
1141
AddVariablenull1142 function AddVariable(const Name: tbtString; FType: TPSType): TPSVar;
1143
AddVariableNnull1144 function AddVariableN(const Name, FType: tbtString): TPSVar;
1145
AddUsedVariablenull1146 function AddUsedVariable(const Name: tbtString; FType: TPSType): TPSVar;
1147
AddUsedVariableNnull1148 function AddUsedVariableN(const Name, FType: tbtString): TPSVar;
1149
AddUsedPtrVariablenull1150 function AddUsedPtrVariable(const Name: tbtString; FType: TPSType): TPSVar;
1151
AddUsedPtrVariableNnull1152 function AddUsedPtrVariableN(const Name, FType: tbtString): TPSVar;
1153
FindTypenull1154 function FindType(const Name: tbtString): TPSType;
1155
MakeDeclnull1156 function MakeDecl(decl: TPSParametersDecl): tbtString;
1157
Compilenull1158 function Compile(const s: tbtString): Boolean;
1159
GetOutputnull1160 function GetOutput(var s: tbtString): Boolean;
1161
GetDebugOutputnull1162 function GetDebugOutput(var s: tbtString): Boolean;
1163
1164 procedure Clear;
1165
1166 constructor Create;
1167
1168 destructor Destroy; override;
1169
1170 property MsgCount: Longint read GetMsgCount;
1171
1172 property Msg[l: Longint]: TPSPascalCompilerMessage read GetMsg;
1173
1174 property OnTranslateLineInfo: TPSOnTranslateLineInfoProc read FOnTranslateLineInfo write FOnTranslateLineInfo;
1175
1176 property OnUses: TPSOnUses read FOnUses write FOnUses;
1177
1178 property OnExportCheck: TPSOnExportCheck read FOnExportCheck write FOnExportCheck;
1179
1180 property OnWriteLine: TPSOnWriteLineEvent read FOnWriteLine write FOnWriteLine;
1181
1182 property OnExternalProc: TPSOnExternalProc read FOnExternalProc write FOnExternalProc;
1183
1184 property OnUseVariable: TPSOnUseVariable read FOnUseVariable write FOnUseVariable;
1185
1186 property OnUseRegProc: TPSOnUseRegProc read FOnUseRegProc write FOnUseRegProc;
1187
1188 property OnBeforeOutput: TPSOnNotify read FOnBeforeOutput write FOnBeforeOutput;
1189
1190 property OnBeforeCleanup: TPSOnNotify read FOnBeforeCleanup write FOnBeforeCleanup;
1191
readnull1192 property OnFunctionStart: TPSOnFunction read FOnFunctionStart write FOnFunctionStart;
1193
readnull1194 property OnFunctionEnd: TPSOnFunction read FOnFunctionEnd write FOnFunctionEnd;
1195
1196 property IsUnit: Boolean read FIsUnit;
1197
1198 property AllowNoBegin: Boolean read FAllowNoBegin write FAllowNoBegin;
1199
1200 property AllowUnit: Boolean read FAllowUnit write FAllowUnit;
1201
1202 property AllowNoEnd: Boolean read FAllowNoEnd write FAllowNoEnd;
1203
1204 property AllowDuplicateRegister : Boolean read FAllowDuplicateRegister write FAllowDuplicateRegister;
1205
1206 property BooleanShortCircuit: Boolean read FBooleanShortCircuit write FBooleanShortCircuit;
1207
1208 property UTF8Decode: Boolean read FUtf8Decode write FUtf8Decode;
1209
1210 property AttributesOpenTokenID: TPSPasToken read FAttributesOpenTokenID write FAttributesOpenTokenID;
1211
1212 property AttributesCloseTokenID: TPSPasToken read FAttributesCloseTokenID write FAttributesCloseTokenID;
1213
1214 {$PUSH}
1215 {$WARNINGS OFF}
1216 property UnitName: tbtString read FUnitName;
1217 {$POP}
1218 end;
1219 TIFPSPascalCompiler = TPSPascalCompiler;
1220
1221 TPSValue = class(TObject)
1222 private
1223 FPos, FRow, FCol: Cardinal;
1224 public
1225
1226 property Pos: Cardinal read FPos write FPos;
1227
1228 property Row: Cardinal read FRow write FRow;
1229
1230 property Col: Cardinal read FCol write FCol;
1231
1232 procedure SetParserPos(P: TPSPascalParser);
1233
1234 end;
1235
1236 TPSParameter = class(TObject)
1237 private
1238 FValue: TPSValue;
1239 FTempVar: TPSValue;
1240 FParamMode: TPSParameterMode;
1241 FExpectedType: TPSType;
1242 public
1243
1244 property Val: TPSValue read FValue write FValue;
1245
1246 property ExpectedType: TPSType read FExpectedType write FExpectedType;
1247
1248 property TempVar: TPSValue read FTempVar write FTempVar;
1249
1250 property ParamMode: TPSParameterMode read FParamMode write FParamMode;
1251
1252 destructor Destroy; override;
1253 end;
1254
1255 TPSParameters = class(TObject)
1256 private
1257 FItems: TPSList;
GetCountnull1258 function GetCount: Cardinal;
GetItemnull1259 function GetItem(I: Longint): TPSParameter;
1260 public
1261
1262 constructor Create;
1263
1264 destructor Destroy; override;
1265
1266 property Count: Cardinal read GetCount;
1267
1268 property Item[I: Longint]: TPSParameter read GetItem; default;
1269
1270 procedure Delete(I: Cardinal);
1271
Addnull1272 function Add: TPSParameter;
1273 end;
1274
1275 TPSSubItem = class(TObject)
1276 private
1277 FType: TPSType;
1278 public
1279
1280 property aType: TPSType read FType write FType;
1281 end;
1282
1283 TPSSubNumber = class(TPSSubItem)
1284 private
1285 FSubNo: Cardinal;
1286 public
1287
1288 property SubNo: Cardinal read FSubNo write FSubNo;
1289 end;
1290
1291 TPSSubValue = class(TPSSubItem)
1292 private
1293 FSubNo: TPSValue;
1294 public
1295
1296 property SubNo: TPSValue read FSubNo write FSubNo;
1297
1298 destructor Destroy; override;
1299 end;
1300
1301 TPSValueVar = class(TPSValue)
1302 private
1303 FRecItems: TPSList;
GetRecCountnull1304 function GetRecCount: Cardinal;
GetRecItemnull1305 function GetRecItem(I: Cardinal): TPSSubItem;
1306 public
1307 constructor Create;
1308 destructor Destroy; override;
1309
RecAddnull1310 function RecAdd(Val: TPSSubItem): Cardinal;
1311
1312 procedure RecDelete(I: Cardinal);
1313
1314 property RecItem[I: Cardinal]: TPSSubItem read GetRecItem;
1315
1316 property RecCount: Cardinal read GetRecCount;
1317 end;
1318
1319 TPSValueGlobalVar = class(TPSValueVar)
1320 private
1321 FAddress: Cardinal;
1322 public
1323
1324 property GlobalVarNo: Cardinal read FAddress write FAddress;
1325 end;
1326
1327
1328 TPSValueLocalVar = class(TPSValueVar)
1329 private
1330 FLocalVarNo: Longint;
1331 public
1332
1333 property LocalVarNo: Longint read FLocalVarNo write FLocalVarNo;
1334 end;
1335
1336 TPSValueParamVar = class(TPSValueVar)
1337 private
1338 FParamNo: Longint;
1339 public
1340
1341 property ParamNo: Longint read FParamNo write FParamNo;
1342 end;
1343
1344 TPSValueAllocatedStackVar = class(TPSValueLocalVar)
1345 private
1346 FProc: TPSInternalProcedure;
1347 public
1348
1349 property Proc: TPSInternalProcedure read FProc write FProc;
1350 destructor Destroy; override;
1351 end;
1352
1353 TPSValueData = class(TPSValue)
1354 private
1355 FData: PIfRVariant;
1356 public
1357
1358 property Data: PIfRVariant read FData write FData;
1359 destructor Destroy; override;
1360 end;
1361
1362 TPSValueReplace = class(TPSValue)
1363 private
1364 FPreWriteAllocated: Boolean;
1365 FFreeOldValue: Boolean;
1366 FFreeNewValue: Boolean;
1367 FOldValue: TPSValue;
1368 FNewValue: TPSValue;
1369 FReplaceTimes: Longint;
1370 public
1371
1372 property OldValue: TPSValue read FOldValue write FOldValue;
1373
1374 property NewValue: TPSValue read FNewValue write FNewValue;
1375 {Should it free the old value when destroyed?}
1376 property FreeOldValue: Boolean read FFreeOldValue write FFreeOldValue;
1377 property FreeNewValue: Boolean read FFreeNewValue write FFreeNewValue;
1378 property PreWriteAllocated: Boolean read FPreWriteAllocated write FPreWriteAllocated;
1379
1380 property ReplaceTimes: Longint read FReplaceTimes write FReplaceTimes;
1381
1382 constructor Create;
1383 destructor Destroy; override;
1384 end;
1385
1386
1387 TPSUnValueOp = class(TPSValue)
1388 private
1389 FVal1: TPSValue;
1390 FOperator: TPSUnOperatorType;
1391 FType: TPSType;
1392 public
1393
1394 property Val1: TPSValue read FVal1 write FVal1;
1395 {The operator}
1396 property Operator: TPSUnOperatorType read FOperator write FOperator;
1397
1398 property aType: TPSType read FType write FType;
1399 destructor Destroy; override;
1400 end;
1401
1402 TPSBinValueOp = class(TPSValue)
1403 private
1404 FVal1,
1405 FVal2: TPSValue;
1406 FOperator: TPSBinOperatorType;
1407 FType: TPSType;
1408 public
1409
1410 property Val1: TPSValue read FVal1 write FVal1;
1411
1412 property Val2: TPSValue read FVal2 write FVal2;
1413 {The operator for this value}
1414 property Operator: TPSBinOperatorType read FOperator write FOperator;
1415
1416 property aType: TPSType read FType write FType;
1417
1418 destructor Destroy; override;
1419 end;
1420
1421 TPSValueNil = class(TPSValue)
1422 end;
1423
1424 TPSValueProcPtr = class(TPSValue)
1425 private
1426 FProcNo: Cardinal;
1427 public
1428
1429 property ProcPtr: Cardinal read FProcNo write FProcNo;
1430 end;
1431
1432 TPSValueProc = class(TPSValue)
1433 private
1434 FSelfPtr: TPSValue;
1435 FParameters: TPSParameters;
1436 FResultType: TPSType;
1437 public
1438 property ResultType: TPSType read FResultType write FResultType;
1439
1440 property SelfPtr: TPSValue read FSelfPtr write FSelfPtr;
1441
1442 property Parameters: TPSParameters read FParameters write FParameters;
1443 destructor Destroy; override;
1444 end;
1445
1446 TPSValueProcNo = class(TPSValueProc)
1447 private
1448 FProcNo: Cardinal;
1449 public
1450
1451 property ProcNo: Cardinal read FProcNo write FProcNo;
1452 end;
1453
1454 TPSValueProcVal = class(TPSValueProc)
1455 private
1456 FProcNo: TPSValue;
1457 public
1458
1459 property ProcNo: TPSValue read FProcNo write FProcNo;
1460
1461 destructor Destroy; override;
1462 end;
1463
1464 TPSValueArray = class(TPSValue)
1465 private
1466 FItems: TPSList;
GetCountnull1467 function GetCount: Cardinal;
GetItemnull1468 function GetItem(I: Cardinal): TPSValue;
1469 public
Addnull1470 function Add(Item: TPSValue): Cardinal;
1471 procedure Delete(I: Cardinal);
1472 property Item[I: Cardinal]: TPSValue read GetItem;
1473 property Count: Cardinal read GetCount;
1474
1475 constructor Create;
1476 destructor Destroy; override;
1477 end;
1478
1479 TPSDelphiClassItem = class;
1480
1481 TPSPropType = (iptRW, iptR, iptW);
1482
1483 TPSCompileTimeClass = class
1484 private
1485 FInheritsFrom: TPSCompileTimeClass;
1486 FClass: TClass;
1487 FClassName: tbtString;
1488 FClassNameHash: Longint;
1489 FClassItems: TPSList;
1490 FDefaultProperty: Cardinal;
1491 FIsAbstract: Boolean;
1492 FCastProc,
1493 FNilProc: Cardinal;
1494 FType: TPSType;
1495
1496 FOwner: TPSPascalCompiler;
GetCountnull1497 function GetCount: Longint;
GetItemnull1498 function GetItem(i: Longint): TPSDelphiClassItem;
1499 public
1500
1501 property aType: TPSType read FType;
1502
1503 property Items[i: Longint]: TPSDelphiClassItem read GetItem;
1504
1505 property Count: Longint read GetCount;
1506
1507 property IsAbstract: Boolean read FIsAbstract write FIsAbstract;
1508
1509
1510 property ClassInheritsFrom: TPSCompileTimeClass read FInheritsFrom write FInheritsFrom;
1511
RegisterMethodnull1512 function RegisterMethod(const Decl: tbtString): Boolean;
1513
1514 procedure RegisterProperty(const PropertyName, PropertyType: tbtString; PropAC: TPSPropType);
1515
1516 procedure RegisterPublishedProperties;
1517
RegisterPublishedPropertynull1518 function RegisterPublishedProperty(const Name: tbtString): Boolean;
1519
1520 procedure SetDefaultPropery(const Name: tbtString);
1521
1522 constructor Create(ClassName: tbtString; aOwner: TPSPascalCompiler; aType: TPSType);
1523
CreateCnull1524 class function CreateC(FClass: TClass; aOwner: TPSPascalCompiler; aType: TPSType): TPSCompileTimeClass;
1525
1526
1527 destructor Destroy; override;
1528
1529
IsCompatibleWithnull1530 function IsCompatibleWith(aType: TPSType): Boolean;
1531
SetNilnull1532 function SetNil(var ProcNo: Cardinal): Boolean;
1533
CastToTypenull1534 function CastToType(IntoType: TPSType; var ProcNo: Cardinal): Boolean;
1535
1536
Property_Findnull1537 function Property_Find(const Name: tbtString; var Index: TPSDelphiClassItem): Boolean;
1538
Property_Getnull1539 function Property_Get(Index: TPSDelphiClassItem; var ProcNo: Cardinal): Boolean;
1540
Property_Setnull1541 function Property_Set(Index: TPSDelphiClassItem; var ProcNo: Cardinal): Boolean;
1542
Property_GetHeadernull1543 function Property_GetHeader(Index: TPSDelphiClassItem; Dest: TPSParametersDecl): Boolean;
1544
1545
Func_Findnull1546 function Func_Find(const Name: tbtString; var Index: TPSDelphiClassItem): Boolean;
1547
Func_Callnull1548 function Func_Call(Index: TPSDelphiClassItem; var ProcNo: Cardinal): Boolean;
1549
1550
ClassFunc_Findnull1551 function ClassFunc_Find(const Name: tbtString; var Index: IPointer): Boolean;
1552
ClassFunc_Callnull1553 function ClassFunc_Call(Index: IPointer; var ProcNo: Cardinal): Boolean;
1554 end;
1555
1556 TPSDelphiClassItem = class(TObject)
1557 private
1558 FOwner: TPSCompileTimeClass;
1559 FOrgName: tbtString;
1560 FName: tbtString;
1561 FNameHash: Longint;
1562 FDecl: TPSParametersDecl;
1563 procedure SetName(const s: tbtString);
1564 public
1565
1566 constructor Create(Owner: TPSCompileTimeClass);
1567
1568 destructor Destroy; override;
1569
1570 property Decl: TPSParametersDecl read FDecl;
1571
1572 property Name: tbtString read FName;
1573
1574 property OrgName: tbtString read FOrgName write SetName;
1575
1576 property NameHash: Longint read FNameHash;
1577
1578 property Owner: TPSCompileTimeClass read FOwner;
1579 end;
1580
1581 TPSDelphiClassItemMethod = class(TPSDelphiClassItem)
1582 private
1583 FMethodNo: Cardinal;
1584 public
1585
1586 property MethodNo: Cardinal read FMethodNo write FMethodNo;
1587 end;
1588
1589 TPSDelphiClassItemProperty = class(TPSDelphiClassItem)
1590 private
1591 FReadProcNo: Cardinal;
1592 FWriteProcNo: Cardinal;
1593 FAccessType: TPSPropType;
1594 public
1595
1596 property AccessType: TPSPropType read FAccessType write FAccessType;
1597
1598 property ReadProcNo: Cardinal read FReadProcNo write FReadProcNo;
1599
1600 property WriteProcNo: Cardinal read FWriteProcNo write FWriteProcNo;
1601 end;
1602
1603
1604 TPSDelphiClassItemConstructor = class(TPSDelphiClassItemMethod)
1605 end;
1606
1607 {$IFNDEF PS_NOINTERFACES}
1608
1609 TPSInterfaceMethod = class;
1610
1611 TPSInterface = class(TObject)
1612 private
1613 FOwner: TPSPascalCompiler;
1614 FType: TPSType;
1615 FInheritedFrom: TPSInterface;
1616 FGuid: TGuid;
1617 FCastProc,
1618 FNilProc: Cardinal;
1619 FItems: TPSList;
1620 FName: tbtString;
1621 FNameHash: Longint;
1622 procedure SetInheritedFrom(p: TPSInterface);
1623 public
1624
1625 constructor Create(Owner: TPSPascalCompiler; InheritedFrom: TPSInterface; Guid: TGuid; const Name: tbtString; aType: TPSType);
1626
1627 destructor Destroy; override;
1628
1629 property aType: TPSType read FType;
1630
1631 property InheritedFrom: TPSInterface read FInheritedFrom write SetInheritedFrom;
1632
1633 property Guid: TGuid read FGuid write FGuid;
1634
1635 property Name: tbtString read FName write FName;
1636
1637 property NameHash: Longint read FNameHash;
1638
1639
RegisterMethodnull1640 function RegisterMethod(const Declaration: tbtString; const cc: TPSCallingConvention): Boolean;
1641
RegisterMethodExnull1642 function RegisterMethodEx(const Declaration: tbtString; const cc: TPSCallingConvention; const CustomParser: TPSPascalParser): Boolean;
1643
1644 procedure RegisterDummyMethod;
1645
IsCompatibleWithnull1646 function IsCompatibleWith(aType: TPSType): Boolean;
1647
SetNilnull1648 function SetNil(var ProcNo: Cardinal): Boolean;
1649
CastToTypenull1650 function CastToType(IntoType: TPSType; var ProcNo: Cardinal): Boolean;
1651
Func_Findnull1652 function Func_Find(const Name: tbtString; var Index: TPSInterfaceMethod): Boolean;
1653
Func_Callnull1654 function Func_Call(Index: TPSInterfaceMethod; var ProcNo: Cardinal): Boolean;
1655 end;
1656
1657
1658 TPSInterfaceMethod = class(TObject)
1659 private
1660 FName: tbtString;
1661 FDecl: TPSParametersDecl;
1662 FNameHash: Longint;
1663 FCC: TPSCallingConvention;
1664 FScriptProcNo: Cardinal;
1665 FOrgName: tbtString;
1666 FOwner: TPSInterface;
1667 FOffsetCache: Cardinal;
GetAbsoluteProcOffsetnull1668 function GetAbsoluteProcOffset: Cardinal;
1669 public
1670
1671 property AbsoluteProcOffset: Cardinal read GetAbsoluteProcOffset;
1672
1673 property ScriptProcNo: Cardinal read FScriptProcNo;
1674
1675 property OrgName: tbtString read FOrgName;
1676
1677 property Name: tbtString read FName;
1678
1679 property NameHash: Longint read FNameHash;
1680
1681 property Decl: TPSParametersDecl read FDecl;
1682
1683 property CC: TPSCallingConvention read FCC;
1684
1685
1686 constructor Create(Owner: TPSInterface);
1687
1688 destructor Destroy; override;
1689 end;
1690 {$ENDIF}
1691
1692
1693 TPSExternalClass = class(TObject)
1694 protected
1695
1696 SE: TPSPascalCompiler;
1697
1698 FTypeNo: TPSType;
1699 public
1700
SelfTypenull1701 function SelfType: TPSType; virtual;
1702
1703 constructor Create(Se: TPSPascalCompiler; TypeNo: TPSType);
1704
ClassFunc_Findnull1705 function ClassFunc_Find(const Name: tbtString; var Index: Cardinal): Boolean; virtual;
1706
ClassFunc_Callnull1707 function ClassFunc_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
1708
Func_Findnull1709 function Func_Find(const Name: tbtString; var Index: Cardinal): Boolean; virtual;
1710
Func_Callnull1711 function Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
1712
IsCompatibleWithnull1713 function IsCompatibleWith(Cl: TPSExternalClass): Boolean; virtual;
1714
SetNilnull1715 function SetNil(var ProcNo: Cardinal): Boolean; virtual;
1716
CastToTypenull1717 function CastToType(IntoType: TPSType; var ProcNo: Cardinal): Boolean; virtual;
1718
CompareClassnull1719 function CompareClass(OtherTypeNo: TPSType; var ProcNo: Cardinal): Boolean; virtual;
1720 end;
1721
1722
ExportChecknull1723 function ExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure;
1724 Types: array of TPSBaseType; Modes: array of TPSParameterMode): Boolean;
1725
1726
1727 procedure SetVarExportName(P: TPSVar; const ExpName: tbtString);
1728
AddImportedClassVariablenull1729 function AddImportedClassVariable(Sender: TPSPascalCompiler; const VarName, VarType: tbtString): Boolean;
1730
1731 const
1732 {Invalid value, this is returned by most functions of pascal script that return a cardinal, when they fail}
1733 InvalidVal = Cardinal(-1);
1734
1735 type
1736 TIFPSCompileTimeClass = TPSCompileTimeClass;
1737 TIFPSInternalProcedure = TPSInternalProcedure;
1738 TIFPSPascalCompilerError = TPSPascalCompilerError;
1739
1740 TPMFuncType = (mftProc
1741 , mftConstructor
1742 );
1743
1744
PS_mi2snull1745 function PS_mi2s(i: Cardinal): tbtString;
1746
ParseMethodnull1747 function ParseMethod(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType): Boolean;
ParseMethodExnull1748 function ParseMethodEx(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType; CustomParser: TPSPascalParser): Boolean;
1749
DeclToBitsnull1750 function DeclToBits(const Decl: TPSParametersDecl): tbtString;
1751
NewVariantnull1752 function NewVariant(FType: TPSType): PIfRVariant;
GetStringnull1753 function GetString(Src: PIfRVariant; var s: Boolean): tbtString;
1754 procedure DisposeVariant(p: PIfRVariant);
1755
1756 implementation
1757
1758 uses {$IFDEF DELPHI5}ComObj, {$ENDIF}{$IFDEF PS_FPC_HAS_COM}ComObj, {$ENDIF}Classes, typInfo;
1759
1760 {$IFDEF DELPHI3UP}
1761 resourceString
1762 {$ELSE}
1763 const
1764 {$ENDIF}
1765
1766 RPS_OnUseEventOnly = 'This function can only be called from within the OnUses event';
1767 RPS_UnableToRegisterFunction = 'Unable to register function %s';
1768 RPS_UnableToRegisterConst = 'Unable to register constant %s';
1769 RPS_InvalidTypeForVar = 'Invalid type for variable %s';
1770 RPS_InvalidType = 'Invalid Type';
1771 RPS_UnableToRegisterType = 'Unable to register type %s';
1772 RPS_UnknownInterface = 'Unknown interface: %s';
1773 RPS_ConstantValueMismatch = 'Constant Value Type Mismatch';
1774 RPS_ConstantValueNotAssigned = 'Constant Value is not assigned';
1775
1776 RPS_Error = 'Error';
1777 RPS_UnknownIdentifier = 'Unknown identifier ''%s''';
1778 RPS_IdentifierExpected = 'Identifier expected';
1779 RPS_CommentError = 'Comment error';
1780 RPS_StringError = 'String error';
1781 RPS_CharError = 'Char error';
1782 RPS_SyntaxError = 'Syntax error';
1783 RPS_EOF = 'Unexpected end of file';
1784 RPS_SemiColonExpected = 'Semicolon ('';'') expected';
1785 RPS_BeginExpected = '''BEGIN'' expected';
1786 RPS_PeriodExpected = 'period (''.'') expected';
1787 RPS_DuplicateIdent = 'Duplicate identifier ''%s''';
1788 RPS_ColonExpected = 'colon ('':'') expected';
1789 RPS_UnknownType = 'Unknown type ''%s''';
1790 RPS_CloseRoundExpected = 'Closing parenthesis expected';
1791 RPS_TypeMismatch = 'Type mismatch';
1792 RPS_InternalError = 'Internal error (%s)';
1793 RPS_AssignmentExpected = 'Assignment expected';
1794 RPS_ThenExpected = '''THEN'' expected';
1795 RPS_DoExpected = '''DO'' expected';
1796 RPS_NoResult = 'No result';
1797 RPS_OpenRoundExpected = 'opening parenthesis (''('')expected';
1798 RPS_CommaExpected = 'comma ('','') expected';
1799 RPS_ToExpected = '''TO'' expected';
1800 RPS_IsExpected = 'is (''='') expected';
1801 RPS_OfExpected = '''OF'' expected';
1802 RPS_CloseBlockExpected = 'Closing square bracket ('']'') expected';
1803 RPS_VariableExpected = 'Variable Expected';
1804 RPS_StringExpected = 'String Expected';
1805 RPS_EndExpected = '''END'' expected';
1806 RPS_UnSetLabel = 'Label ''%s'' not set';
1807 RPS_NotInLoop = 'Not in a loop';
1808 RPS_InvalidJump = 'Invalid jump';
1809 RPS_OpenBlockExpected = 'Opening square brackets (''['') expected';
1810 RPS_WriteOnlyProperty = 'Write-only property';
1811 RPS_ReadOnlyProperty = 'Read-only property';
1812 RPS_ClassTypeExpected = 'Class type expected';
1813 RPS_DivideByZero = 'Divide by Zero';
1814 RPS_MathError = 'Math Error';
1815 RPS_UnsatisfiedForward = 'Unsatisfied Forward %s';
1816 RPS_ForwardParameterMismatch = 'Forward Parameter Mismatch';
1817 RPS_InvalidNumberOfParameter = 'Invalid number of parameters';
1818 RPS_UnknownError = 'Unknown error';
1819 {$IFDEF PS_USESSUPPORT}
1820 RPS_NotAllowed = '%s is not allowed at this position';
1821 RPS_UnitNotFound = 'Unit ''%s'' not found or contains errors';
1822 RPS_CrossReference = 'Cross-Reference error of ''%s''';
1823 {$ENDIF}
1824 RPS_UnClosedAttributes = 'Attributes not closed';
1825
1826 RPS_Hint = 'Hint';
1827 RPS_VariableNotUsed = 'Variable ''%s'' never used';
1828 RPS_FunctionNotUsed = 'Function ''%s'' never used';
1829 RPS_UnknownHint = 'Unknown hint';
1830
1831
1832 RPS_Warning = 'Warning';
1833 RPS_CalculationAlwaysEvaluatesTo = 'Calculation always evaluates to %s';
1834 RPS_IsNotNeeded = '%s is not needed';
1835 RPS_AbstractClass = 'Abstract Class Construction';
1836 RPS_UnknownWarning = 'Unknown warning';
1837
1838 {$IFDEF DEBUG }
1839 RPS_UnableToRegister = 'Unable to register %s';
1840 {$ENDIF}
1841
1842 RPS_NotArrayProperty = 'Not an array property : ''%s''';
1843 RPS_NotProperty = 'Not a property : ''%s''';
1844 RPS_UnknownProperty = 'Unknown Property : ''%s''';
1845
DeclToBitsnull1846 function DeclToBits(const Decl: TPSParametersDecl): tbtString;
1847 var
1848 i: longint;
1849 begin
1850 Result := '';
1851 if Decl.Result = nil then
1852 begin
1853 Result := Result + #0;
1854 end else
1855 Result := Result + #1;
1856 for i := 0 to Decl.ParamCount -1 do
1857 begin
1858 if Decl.Params[i].Mode <> pmIn then
1859 Result := Result + #1
1860 else
1861 Result := Result + #0;
1862 end;
1863 end;
1864
1865
1866 procedure BlockWriteByte(BlockInfo: TPSBlockInfo; b: Byte);
1867 begin
1868 BlockInfo.Proc.Data := BlockInfo.Proc.Data + tbtChar(b);
1869 end;
1870
1871 procedure BlockWriteData(BlockInfo: TPSBlockInfo; const Data; Len: Longint);
1872 begin
1873 SetLength(BlockInfo.Proc.FData, Length(BlockInfo.Proc.FData) + Len);
1874 Move(Data, BlockInfo.Proc.FData[Length(BlockInfo.Proc.FData) - Len + 1], Len);
1875 end;
1876
1877 procedure BlockWriteLong(BlockInfo: TPSBlockInfo; l: Cardinal);
1878 begin
1879 BlockWriteData(BlockInfo, l, 4);
1880 end;
1881
1882 procedure BlockWriteVariant(BlockInfo: TPSBlockInfo; p: PIfRVariant);
1883 var
1884 du8: tbtu8;
1885 du16: tbtu16;
1886 begin
1887 BlockWriteLong(BlockInfo, p^.FType.FinalTypeNo);
1888 case p.FType.BaseType of
1889 btType: BlockWriteData(BlockInfo, p^.ttype.FinalTypeno, 4);
1890 {$IFNDEF PS_NOWIDESTRING}
1891 btWideString:
1892 begin
1893 BlockWriteLong(BlockInfo, Length(tbtWideString(p^.twidestring)));
1894 BlockWriteData(BlockInfo, tbtwidestring(p^.twidestring)[1], 2*Length(tbtWideString(p^.twidestring)));
1895 end;
1896 btUnicodeString:
1897 begin
1898 BlockWriteLong(BlockInfo, Length(tbtUnicodeString(p^.twidestring)));
1899 BlockWriteData(BlockInfo, tbtUnicodeString(p^.twidestring)[1], 2*Length(tbtUnicodeString(p^.twidestring)));
1900 end;
1901 btWideChar: BlockWriteData(BlockInfo, p^.twidechar, 2);
1902 {$ENDIF}
1903 btSingle: BlockWriteData(BlockInfo, p^.tsingle, sizeof(tbtSingle));
1904 btDouble: BlockWriteData(BlockInfo, p^.tdouble, sizeof(tbtDouble));
1905 btExtended: BlockWriteData(BlockInfo, p^.textended, sizeof(tbtExtended));
1906 btCurrency: BlockWriteData(BlockInfo, p^.tcurrency, sizeof(tbtCurrency));
1907 btChar: BlockWriteData(BlockInfo, p^.tchar, 1);
1908 btSet:
1909 begin
1910 BlockWriteData(BlockInfo, tbtString(p^.tstring)[1], Length(tbtString(p^.tstring)));
1911 end;
1912 btString:
1913 begin
1914 BlockWriteLong(BlockInfo, Length(tbtString(p^.tstring)));
1915 BlockWriteData(BlockInfo, tbtString(p^.tstring)[1], Length(tbtString(p^.tstring)));
1916 end;
1917 btenum:
1918 begin
1919 if TPSEnumType(p^.FType).HighValue <=256 then
1920 begin
1921 du8 := tbtu8(p^.tu32);
1922 BlockWriteData(BlockInfo, du8, 1)
1923 end
1924 else if TPSEnumType(p^.FType).HighValue <=65536 then
1925 begin
1926 du16 := tbtu16(p^.tu32);
1927 BlockWriteData(BlockInfo, du16, 2)
1928 end;
1929 end;
1930
1931 bts8,btu8: BlockWriteData(BlockInfo, p^.tu8, 1);
1932 bts16,btu16: BlockWriteData(BlockInfo, p^.tu16, 2);
1933 bts32,btu32: BlockWriteData(BlockInfo, p^.tu32, 4);
1934 {$IFNDEF PS_NOINT64}
1935 bts64: BlockWriteData(BlockInfo, p^.ts64, 8);
1936 {$ENDIF}
1937 btProcPtr: BlockWriteData(BlockInfo, p^.tu32, 4);
1938 {$IFDEF DEBUG}
1939 {$IFNDEF FPC}
1940 else
1941 asm int 3; end;
1942 {$ENDIF}
1943 {$ENDIF}
1944 end;
1945 end;
1946
1947
1948
ExportChecknull1949 function ExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; Types: array of TPSBaseType; Modes: array of TPSParameterMode): Boolean;
1950 var
1951 i: Longint;
1952 ttype: TPSType;
1953 begin
1954 if High(Types) <> High(Modes)+1 then
1955 begin
1956 Result := False;
1957 exit;
1958 end;
1959 if High(Types) <> Proc.Decl.ParamCount then
1960 begin
1961 Result := False;
1962 exit;
1963 end;
1964 TType := Proc.Decl.Result;
1965 if TType = nil then
1966 begin
1967 if Types[0] <> btReturnAddress then
1968 begin
1969 Result := False;
1970 exit;
1971 end;
1972 end else
1973 begin
1974 if TType.BaseType <> Types[0] then
1975 begin
1976 Result := False;
1977 exit;
1978 end;
1979 end;
1980 for i := 0 to High(Modes) do
1981 begin
1982 TType := Proc.Decl.Params[i].aType;
1983 if Modes[i] <> Proc.Decl.Params[i].Mode then
1984 begin
1985 Result := False;
1986 exit;
1987 end;
1988 if TType.BaseType <> Types[i+1] then
1989 begin
1990 Result := False;
1991 exit;
1992 end;
1993 end;
1994 Result := True;
1995 end;
1996
1997 procedure SetVarExportName(P: TPSVar; const ExpName: tbtString);
1998 begin
1999 if p <> nil then
2000 p.exportname := ExpName;
2001 end;
2002
FindAndAddTypenull2003 function FindAndAddType(Owner: TPSPascalCompiler; const Name, Decl: tbtString): TPSType;
2004 var
2005 tt: TPSType;
2006 begin
2007 Result := Owner.FindType(Name);
2008 if Result = nil then
2009 begin
2010 tt := Owner.AddTypeS(Name, Decl);
2011 Result := tt;
2012 end;
2013 end;
2014
ParseMethodnull2015 function ParseMethod(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType): Boolean;
2016 begin
2017 Result := ParseMethodEx(Owner, FClassName, Decl, OrgName, DestDecl, Func, nil);
2018 end;
2019
ParseMethodExnull2020 function ParseMethodEx(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType; CustomParser: TPSPascalParser): Boolean;
2021 var
2022 Parser: TPSPascalParser;
2023 FuncType: Byte;
2024 VNames: tbtString;
2025 modifier: TPSParameterMode;
2026 VCType: TPSType;
2027 ERow, EPos, ECol: Integer;
2028
2029 begin
2030 if CustomParser = nil then begin
2031 Parser := TPSPascalParser.Create;
2032 Parser.SetText(Decl);
2033 end else
2034 Parser := CustomParser;
thennull2035 if Parser.CurrTokenId = CSTII_Function then
2036 FuncType:= 0
2037 else if Parser.CurrTokenId = CSTII_Procedure then
2038 FuncType := 1
2039 else if (Parser.CurrTokenId = CSTII_Constructor) and (FClassName <> '') then
2040 FuncType := 2
2041 else
2042 begin
2043 if Parser <> CustomParser then
2044 Parser.Free;
2045 Result := False;
2046 exit;
2047 end;
2048 Parser.Next;
2049 if Parser.CurrTokenId <> CSTI_Identifier then
2050 begin
2051 if Parser <> CustomParser then
2052 Parser.Free
2053 else
2054 Owner.MakeError('', ecIdentifierExpected, '');
2055 Result := False;
2056 exit;
2057 end; {if}
2058 OrgName := Parser.OriginalToken;
2059 Parser.Next;
2060 if Parser.CurrTokenId = CSTI_OpenRound then
2061 begin
2062 Parser.Next;
2063 if Parser.CurrTokenId <> CSTI_CloseRound then
2064 begin
2065 while True do
2066 begin
2067 if Parser.CurrTokenId = CSTII_Const then
2068 begin
2069 modifier := pmIn;
2070 Parser.Next;
2071 end
2072 else
2073 if Parser.CurrTokenId = CSTII_Var then
2074 begin
2075 modifier := pmInOut;
2076 Parser.Next;
2077 end
2078 else
2079 if Parser.CurrTokenId = CSTII_Out then
2080 begin
2081 modifier := pmOut;
2082 Parser.Next;
2083 end
2084 else
2085 modifier := pmIn;
2086 if Parser.CurrTokenId <> CSTI_Identifier then
2087 begin
2088 if Parser <> CustomParser then
2089 Parser.Free
2090 else
2091 Owner.MakeError('', ecIdentifierExpected, '');
2092 Result := False;
2093 exit;
2094 end;
2095 EPos:=Parser.CurrTokenPos;
2096 ERow:=Parser.Row;
2097 ECol:=Parser.Col;
2098
2099 VNames := Parser.OriginalToken + '|';
2100 Parser.Next;
2101 while Parser.CurrTokenId = CSTI_Comma do
2102 begin
2103 Parser.Next;
2104 if Parser.CurrTokenId <> CSTI_Identifier then
2105 begin
2106 if Parser <> CustomParser then
2107 Parser.Free
2108 else
2109 Owner.MakeError('', ecIdentifierExpected, '');
2110 Result := False;
2111 exit;
2112 end;
2113 VNames := VNames + Parser.OriginalToken + '|';
2114 Parser.Next;
2115 end;
2116 if Parser.CurrTokenId <> CSTI_Colon then
2117 begin
2118 if Parser <> CustomParser then
2119 Parser.Free
2120 else
2121 Owner.MakeError('', ecColonExpected, '');
2122 Result := False;
2123 exit;
2124 end;
2125 Parser.Next;
2126 if Parser.CurrTokenID = CSTII_Array then
2127 begin
2128 Parser.nExt;
2129 if Parser.CurrTokenId <> CSTII_Of then
2130 begin
2131 if Parser <> CustomParser then
2132 Parser.Free
2133 else
2134 Owner.MakeError('', ecOfExpected, '');
2135 Result := False;
2136 exit;
2137 end;
2138 Parser.Next;
2139 if Parser.CurrTokenId = CSTII_Const then
2140 begin
2141 VCType := FindAndAddType(Owner, '!OPENARRAYOFCONST', 'array of ___Pointer')
2142 end
2143 else begin
2144 VCType := Owner.GetTypeCopyLink(Owner.FindType(Parser.GetToken));
2145 if VCType = nil then
2146 begin
2147 if Parser <> CustomParser then
2148 Parser.Free
2149 else
2150 Owner.MakeError('', ecUnknownType, Parser.GetToken);
2151 Result := False;
2152 exit;
2153 end;
2154 case VCType.BaseType of
2155 btU8: VCType := FindAndAddType(Owner, '!OPENARRAYOFU8', 'array of Byte');
2156 btS8: VCType := FindAndAddType(Owner, '!OPENARRAYOFS8', 'array of ShortInt');
2157 btU16: VCType := FindAndAddType(Owner, '!OPENARRAYOFU16', 'array of SmallInt');
2158 btS16: VCType := FindAndAddType(Owner, '!OPENARRAYOFS16', 'array of Word');
2159 btU32: VCType := FindAndAddType(Owner, '!OPENARRAYOFU32', 'array of Cardinal');
2160 btS32: VCType := FindAndAddType(Owner, '!OPENARRAYOFS32', 'array of LongInt');
2161 btSingle: VCType := FindAndAddType(Owner, '!OPENARRAYOFSINGLE', 'array of Single');
2162 btDouble: VCType := FindAndAddType(Owner, '!OPENARRAYOFDOUBLE', 'array of Double');
2163 btExtended: VCType := FindAndAddType(Owner, '!OPENARRAYOFEXTENDED', 'array of Extended');
2164 btString: VCType := FindAndAddType(Owner, '!OPENARRAYOFSTRING', 'array of string');
2165 btPChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFPCHAR', {$IFDEF PS_PANSICHAR}'array of PAnsiChar'{$ELSE}'array of PChar'{$ENDIF});
2166 btNotificationVariant, btVariant: VCType := FindAndAddType(Owner, '!OPENARRAYOFVARIANT', 'array of Variant');
2167 {$IFNDEF PS_NOINT64}btS64: VCType := FindAndAddType(Owner, '!OPENARRAYOFS64', 'array of Int64');{$ENDIF}
2168 btChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFCHAR', 'array of Char');
2169 {$IFNDEF PS_NOWIDESTRING}
2170 btWideString: VCType := FindAndAddType(Owner, '!OPENARRAYOFWIDESTRING', 'array of WideString');
2171 btUnicodeString: VCType := FindAndAddType(Owner, '!OPENARRAYOFUNICODESTRING', 'array of UnicodeString');
2172 btWideChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFWIDECHAR', 'array of WideChar');
2173 {$ENDIF}
2174 btClass: VCType := FindAndAddType(Owner, '!OPENARRAYOFTOBJECT', 'array of TObject');
2175 btRecord: VCType := FindAndAddType(Owner, '!OPENARRAYOFRECORD_'+FastUpperCase(Parser.OriginalToken), 'array of ' +FastUpperCase(Parser.OriginalToken));
2176 btEnum: VCType := FindAndAddType(Owner, '!OPENARRAYOFENUM_' + FastUpperCase(Parser.OriginalToken), 'array of ' + FastUpperCase(Parser.OriginalToken));
2177 else
2178 begin
2179 if Parser <> CustomParser then
2180 Parser.Free;
2181 Result := False;
2182 exit;
2183 end;
2184 end;
2185 end;
2186 end else if Parser.CurrTokenID = CSTII_Const then
2187 VCType := nil // any type
2188 else begin
2189 VCType := Owner.FindType(Parser.GetToken);
2190 if VCType = nil then
2191 begin
2192 if Parser <> CustomParser then
2193 Parser.Free
2194 else
2195 Owner.MakeError('', ecUnknownType, Parser.GetToken);
2196 Result := False;
2197 exit;
2198 end;
2199 end;
2200 while Pos(tbtchar('|'), VNames) > 0 do
2201 begin
2202 with DestDecl.AddParam do
2203 begin
2204 {$IFDEF PS_USESSUPPORT}
2205 DeclareUnit:=Owner.fModule;
2206 {$ENDIF}
2207 DeclarePos := EPos;
2208 DeclareRow := ERow;
2209 DeclareCol := ECol;
2210 Mode := modifier;
2211 OrgName := copy(VNames, 1, Pos(tbtchar('|'), VNames) - 1);
2212 aType := VCType;
2213 end;
2214 Delete(VNames, 1, Pos(tbtchar('|'), VNames));
2215 end;
2216 Parser.Next;
2217 if Parser.CurrTokenId = CSTI_CloseRound then
2218 break;
2219 if Parser.CurrTokenId <> CSTI_Semicolon then
2220 begin
2221 if Parser <> CustomParser then
2222 Parser.Free
2223 else
2224 Owner.MakeError('', ecSemiColonExpected, '');
2225 Result := False;
2226 exit;
2227 end;
2228 Parser.Next;
2229 end; {while}
2230 end; {if}
2231 Parser.Next;
2232 end; {if}
2233 if FuncType = 0 then
2234 begin
2235 if Parser.CurrTokenId <> CSTI_Colon then
2236 begin
2237 if Parser <> CustomParser then
2238 Parser.Free
2239 else
2240 Owner.MakeError('', ecColonExpected, '');
2241 Result := False;
2242 exit;
2243 end;
2244
2245 Parser.Next;
2246 VCType := Owner.FindType(Parser.GetToken);
2247 if VCType = nil then
2248 begin
2249 if Parser <> CustomParser then
2250 Parser.Free
2251 else
2252 Owner.MakeError('', ecUnknownType, Parser.GetToken);
2253 Result := False;
2254 exit;
2255 end;
2256 Parser.Next;
2257 end
2258 else if FuncType = 2 then {constructor}
2259 begin
2260 VCType := Owner.FindType(FClassName)
2261 end else
2262 VCType := nil;
2263 DestDecl.Result := VCType;
2264 if Parser <> CustomParser then
2265 Parser.Free;
2266 if FuncType = 2 then
2267 Func := mftConstructor
2268 else
2269 Func := mftProc;
2270 Result := True;
2271 end;
2272
2273
2274
TPSPascalCompiler.FindProcnull2275 function TPSPascalCompiler.FindProc(const aName: tbtString): Cardinal;
2276 var
2277 l, h: Longint;
2278 x: TPSProcedure;
2279 xr: TPSRegProc;
2280 name: tbtString;
2281
2282 begin
2283 name := FastUpperCase(aName);
2284 h := MakeHash(Name);
2285 if FProcs = nil then
2286 begin
2287 result := InvalidVal;
2288 Exit;
2289 end;
2290
2291 for l := FProcs.Count - 1 downto 0 do
2292 begin
2293 x := FProcs.Data^[l];
2294 if x.ClassType = TPSInternalProcedure then
2295 begin
2296 if (TPSInternalProcedure(x).NameHash = h) and
2297 (TPSInternalProcedure(x).Name = Name) then
2298 begin
2299 Result := l;
2300 exit;
2301 end;
2302 end
2303 else
2304 begin
2305 if (TPSExternalProcedure(x).RegProc.NameHash = h) and
2306 (TPSExternalProcedure(x).RegProc.Name = Name)then
2307 begin
2308 Result := l;
2309 exit;
2310 end;
2311 end;
2312 end;
2313 for l := FRegProcs.Count - 1 downto 0 do
2314 begin
2315 xr := FRegProcs[l];
2316 if (xr.NameHash = h) and (xr.Name = Name) then
2317 begin
2318 x := TPSExternalProcedure.Create;
2319 TPSExternalProcedure(x).RegProc := xr;
2320 FProcs.Add(x);
2321 if @FOnUseRegProc <> nil then
2322 FOnUseRegProc(Self, FParser.CurrTokenPos, Name);
2323 Result := FProcs.Count - 1;
2324 exit;
2325 end;
2326 end;
2327 Result := InvalidVal;
2328 end; {findfunc}
2329
UseExternalProcnull2330 function TPSPascalCompiler.UseExternalProc(const Name: tbtString): TPSParametersDecl;
2331 var
2332 ProcNo: cardinal;
2333 proc: TPSProcedure;
2334 begin
2335 ProcNo := FindProc(FastUppercase(Name));
2336 if ProcNo = InvalidVal then Result := nil
2337 else
2338 begin
2339 proc := TPSProcedure(FProcs[ProcNo]);
2340 if Proc is TPSExternalProcedure then
2341 begin
2342 Result := TPSExternalProcedure(Proc).RegProc.Decl;
2343 end else result := nil;
2344 end;
2345 end;
2346
2347
2348
TPSPascalCompiler.FindBaseTypenull2349 function TPSPascalCompiler.FindBaseType(BaseType: TPSBaseType): TPSType;
2350 var
2351 l: Longint;
2352 x: TPSType;
2353 begin
2354 for l := 0 to FTypes.Count -1 do
2355 begin
2356 X := FTypes[l];
2357 if (x.BaseType = BaseType) and (x.ClassType = TPSType) then
2358 begin
2359 Result := at2ut(x);
2360 exit;
2361 end;
2362 end;
2363 X := TPSType.Create;
2364 x.Name := '';
2365 x.BaseType := BaseType;
2366 {$IFDEF PS_USESSUPPORT}
2367 x.DeclareUnit:=fModule;
2368 {$ENDIF}
2369 x.DeclarePos := InvalidVal;
2370 x.DeclareCol := 0;
2371 x.DeclareRow := 0;
2372 FTypes.Add(x);
2373 Result := at2ut(x);
2374 end;
2375
MakeDeclnull2376 function TPSPascalCompiler.MakeDecl(decl: TPSParametersDecl): tbtString;
2377 var
2378 i: Longint;
2379 begin
2380 if Decl.Result = nil then result := '0' else
2381 result := Decl.Result.Name;
2382
2383 for i := 0 to decl.ParamCount -1 do
2384 begin
2385 if decl.GetParam(i).Mode = pmIn then
2386 Result := Result + ' @'
2387 else
2388 Result := Result + ' !';
2389 Result := Result + decl.GetParam(i).aType.Name;
2390 end;
2391 end;
2392
2393
2394 { TPSPascalCompiler }
2395
2396 const
2397 BtTypeCopy = 255;
2398
2399
2400 type
2401 TFuncType = (ftProc, ftFunc);
2402
PS_mi2snull2403 function PS_mi2s(i: Cardinal): tbtString;
2404 begin
2405 SetLength(Result, 4);
2406 Cardinal((@Result[1])^) := i;
2407 end;
2408
2409
2410
2411
TPSPascalCompiler.AddTypenull2412 function TPSPascalCompiler.AddType(const Name: tbtString; const BaseType: TPSBaseType): TPSType;
2413 begin
2414 if FProcs = nil then
2415 begin
2416 raise EPSCompilerException.Create(RPS_OnUseEventOnly);
2417 end;
2418
2419 if not(AllowDuplicateRegister) and IsDuplicate(FastUpperCase(Name),[dcTypes, dcProcs, dcVars]) then
2420 Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Name]);
2421
2422 case BaseType of
2423 btProcPtr: Result := TPSProceduralType.Create;
2424 BtTypeCopy: Result := TPSTypeLink.Create;
2425 btRecord: Result := TPSRecordType.Create;
2426 btArray: Result := TPSArrayType.Create;
2427 btStaticArray: Result := TPSStaticArrayType.Create;
2428 btEnum: Result := TPSEnumType.Create;
2429 btClass: Result := TPSClassType.Create;
2430 btExtClass: REsult := TPSUndefinedClassType.Create;
2431 btNotificationVariant, btVariant: Result := TPSVariantType.Create;
2432 {$IFNDEF PS_NOINTERFACES}
2433 btInterface: Result := TPSInterfaceType.Create;
2434 {$ENDIF}
2435 else
2436 Result := TPSType.Create;
2437 end;
2438 Result.Name := FastUppercase(Name);
2439 Result.OriginalName := Name;
2440 Result.BaseType := BaseType;
2441 {$IFDEF PS_USESSUPPORT}
2442 Result.DeclareUnit:=fModule;
2443 {$ENDIF}
2444 Result.DeclarePos := InvalidVal;
2445 Result.DeclareCol := 0;
2446 Result.DeclareRow := 0;
2447 FTypes.Add(Result);
2448 end;
2449
2450
TPSPascalCompiler.AddFunctionnull2451 function TPSPascalCompiler.AddFunction(const Header: tbtString): TPSRegProc;
2452 var
2453 Parser: TPSPascalParser;
2454 i: Integer;
Booleannull2455 IsFunction: Boolean;
2456 VNames, Name: tbtString;
2457 Decl: TPSParametersDecl;
2458 modifier: TPSParameterMode;
2459 VCType: TPSType;
2460 x: TPSRegProc;
2461 begin
2462 if FProcs = nil then
2463 raise EPSCompilerException.Create(RPS_OnUseEventOnly);
2464
2465 Parser := TPSPascalParser.Create;
2466 Parser.SetText(Header);
2467 Decl := TPSParametersDecl.Create;
2468 {$IFNDEF DELPHI_TOKYO_UP}
2469 x := nil;
2470 {$ENDIF}
2471 try
thennull2472 if Parser.CurrTokenId = CSTII_Function then
2473 IsFunction := True
2474 else if Parser.CurrTokenId = CSTII_Procedure then
2475 IsFunction := False
2476 else
2477 Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, ['']);
2478 Parser.Next;
2479 if Parser.CurrTokenId <> CSTI_Identifier then
2480 Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, ['']);
2481 Name := Parser.OriginalToken;
2482 Parser.Next;
2483 if Parser.CurrTokenId = CSTI_OpenRound then
2484 begin
2485 Parser.Next;
2486 if Parser.CurrTokenId <> CSTI_CloseRound then
2487 begin
2488 while True do
2489 begin
2490 if Parser.CurrTokenId = CSTII_Out then
2491 begin
2492 Modifier := pmOut;
2493 Parser.Next;
2494 end else
2495 if Parser.CurrTokenId = CSTII_Const then
2496 begin
2497 Modifier := pmIn;
2498 Parser.Next;
2499 end else
2500 if Parser.CurrTokenId = CSTII_Var then
2501 begin
2502 modifier := pmInOut;
2503 Parser.Next;
2504 end
2505 else
2506 modifier := pmIn;
2507 if Parser.CurrTokenId <> CSTI_Identifier then
2508 raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
2509 VNames := Parser.OriginalToken + '|';
2510 Parser.Next;
2511 while Parser.CurrTokenId = CSTI_Comma do
2512 begin
2513 Parser.Next;
2514 if Parser.CurrTokenId <> CSTI_Identifier then
2515 Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
2516 VNames := VNames + Parser.OriginalToken + '|';
2517 Parser.Next;
2518 end;
2519 if Parser.CurrTokenId <> CSTI_Colon then
2520 begin
2521 Parser.Free;
2522 Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
2523 end;
2524 Parser.Next;
2525 VCType := FindType(Parser.GetToken);
2526 if VCType = nil then
2527 Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
2528 while Pos(tbtchar('|'), VNames) > 0 do
2529 begin
2530 with Decl.AddParam do
2531 begin
2532 Mode := modifier;
2533 OrgName := copy(VNames, 1, Pos(tbtchar('|'), VNames) - 1);
2534 aType := VCType;
2535 end;
2536 Delete(VNames, 1, Pos(tbtchar('|'), VNames));
2537 end;
2538 Parser.Next;
2539 if Parser.CurrTokenId = CSTI_CloseRound then
2540 break;
2541 if Parser.CurrTokenId <> CSTI_Semicolon then
2542 Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
2543 Parser.Next;
2544 end; {while}
2545 end; {if}
2546 Parser.Next;
2547 end; {if}
thennull2548 if IsFunction then
2549 begin
2550 if Parser.CurrTokenId <> CSTI_Colon then
2551 Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
2552
2553 Parser.Next;
2554 VCType := FindType(Parser.GetToken);
2555 if VCType = nil then
2556 Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
2557 end
2558 else
2559 VCType := nil;
2560 Decl.Result := VCType;
2561 X := TPSRegProc.Create;
2562 x.OrgName := Name;
2563 x.Name := FastUpperCase(Name);
2564 x.ExportName := True;
2565 x.Decl.Assign(decl);
2566 if Decl.Result = nil then
2567 begin
2568 x.ImportDecl := x.ImportDecl + #0;
2569 end else
2570 x.ImportDecl := x.ImportDecl + #1;
2571 for i := 0 to Decl.ParamCount -1 do
2572 begin
2573 if Decl.Params[i].Mode <> pmIn then
2574 x.ImportDecl := x.ImportDecl + #1
2575 else
2576 x.ImportDecl := x.ImportDecl + #0;
2577 end;
2578
2579 FRegProcs.Add(x);
2580 finally
2581 Decl.Free;
2582 Parser.Free;
2583 end;
2584 Result := x;
2585 end;
2586
MakeHintnull2587 function TPSPascalCompiler.MakeHint(const Module: tbtString; E: TPSPascalCompilerHintType; const Param: tbtString): TPSPascalCompilerMessage;
2588 var
2589 n: TPSPascalCompilerHint;
2590 begin
2591 N := TPSPascalCompilerHint.Create;
2592 n.FHint := e;
2593 n.SetParserPos(FParser);
2594 n.FModuleName := Module;
2595 n.FParam := Param;
2596 FMessages.Add(n);
2597 Result := n;
2598 end;
2599
TPSPascalCompiler.MakeErrornull2600 function TPSPascalCompiler.MakeError(const Module: tbtString; E:
2601 TPSPascalCompilerErrorType; const Param: tbtString): TPSPascalCompilerMessage;
2602 var
2603 n: TPSPascalCompilerError;
2604 begin
2605 N := TPSPascalCompilerError.Create;
2606 n.FError := e;
2607 n.SetParserPos(FParser);
2608 {$IFNDEF PS_USESSUPPORT}
2609 n.FModuleName := Module;
2610 {$ELSE}
2611 if Module <> '' then
2612 n.FModuleName := Module
2613 else
2614 n.FModuleName := fModule;
2615 {$ENDIF}
2616 n.FParam := Param;
2617 FMessages.Add(n);
2618 Result := n;
2619 end;
2620
MakeWarningnull2621 function TPSPascalCompiler.MakeWarning(const Module: tbtString; E:
2622 TPSPascalCompilerWarningType; const Param: tbtString): TPSPascalCompilerMessage;
2623 var
2624 n: TPSPascalCompilerWarning;
2625 begin
2626 N := TPSPascalCompilerWarning.Create;
2627 n.FWarning := e;
2628 n.SetParserPos(FParser);
2629 n.FModuleName := Module;
2630 n.FParam := Param;
2631 FMessages.Add(n);
2632 Result := n;
2633 end;
2634
2635 procedure TPSPascalCompiler.Clear;
2636 var
2637 l: Longint;
2638 begin
2639 FDebugOutput := '';
2640 FOutput := '';
2641 for l := 0 to FMessages.Count - 1 do
2642 TPSPascalCompilerMessage(FMessages[l]).Free;
2643 FMessages.Clear;
2644 for L := FAutoFreeList.Count -1 downto 0 do
2645 begin
2646 TObject(FAutoFreeList[l]).Free;
2647 end;
2648 FAutoFreeList.Clear;
2649 end;
2650
2651 procedure CopyVariantContents(Src, Dest: PIfRVariant);
2652 begin
2653 case src.FType.BaseType of
2654 btu8, bts8: dest^.tu8 := src^.tu8;
2655 btu16, bts16: dest^.tu16 := src^.tu16;
2656 btenum, btu32, bts32: dest^.tu32 := src^.tu32;
2657 btsingle: Dest^.tsingle := src^.tsingle;
2658 btdouble: Dest^.tdouble := src^.tdouble;
2659 btextended: Dest^.textended := src^.textended;
2660 btCurrency: Dest^.tcurrency := Src^.tcurrency;
2661 btchar: Dest^.tchar := src^.tchar;
2662 {$IFNDEF PS_NOINT64}bts64: dest^.ts64 := src^.ts64;{$ENDIF}
2663 btset, btstring: tbtstring(dest^.tstring) := tbtstring(src^.tstring);
2664 {$IFNDEF PS_NOWIDESTRING}
2665 btunicodestring: tbtunicodestring(dest^.tunistring) := tbtunicodestring(src^.tunistring);
2666 btwidestring: tbtwidestring(dest^.twidestring) := tbtwidestring(src^.twidestring);
2667 btwidechar: Dest^.twidechar := src^.twidechar;
2668 {$ENDIF}
2669 end;
2670 end;
2671
DuplicateVariantnull2672 function DuplicateVariant(Src: PIfRVariant): PIfRVariant;
2673 begin
2674 New(Result);
2675 FillChar(Result^, SizeOf(TIfRVariant), 0);
2676 CopyVariantContents(Src, Result);
2677 end;
2678
2679
2680 procedure InitializeVariant(Vari: PIfRVariant; FType: TPSType);
2681 begin
2682 FillChar(vari^, SizeOf(TIfRVariant), 0);
2683 if FType.BaseType = btSet then
2684 begin
2685 SetLength(tbtstring(vari^.tstring), TPSSetType(FType).ByteSize);
2686 fillchar(tbtstring(vari^.tstring)[1], length(tbtstring(vari^.tstring)), 0);
2687 end;
2688 vari^.FType := FType;
2689 end;
2690
NewVariantnull2691 function NewVariant(FType: TPSType): PIfRVariant;
2692 begin
2693 New(Result);
2694 InitializeVariant(Result, FType);
2695 end;
2696
2697 procedure FinalizeA(var s: tbtString); overload; begin s := ''; end;
2698 {$IFNDEF PS_NOWIDESTRING}
2699 procedure FinalizeW(var s: tbtwidestring); overload; begin s := ''; end;
2700 procedure FinalizeU(var s: tbtunicodestring); overload; begin s := ''; end;
2701 {$ENDIF}
2702 procedure FinalizeVariant(var p: TIfRVariant);
2703 begin
2704 if (p.FType.BaseType = btString) or (p.FType.basetype = btSet) then
2705 finalizeA(tbtstring(p.tstring))
2706 {$IFNDEF PS_NOWIDESTRING}
2707 else if p.FType.BaseType = btWideString then
2708 finalizeW(tbtWideString(p.twidestring)) // tbtwidestring
2709 else if p.FType.BaseType = btUnicodeString then
2710 finalizeU(tbtUnicodeString(p.tunistring)); // tbtwidestring
2711 {$ENDIF}
2712 end;
2713
2714 procedure DisposeVariant(p: PIfRVariant);
2715 begin
2716 if p <> nil then
2717 begin
2718 FinalizeVariant(p^);
2719 Dispose(p);
2720 end;
2721 end;
2722
2723
2724
GetTypeCopyLinknull2725 function TPSPascalCompiler.GetTypeCopyLink(p: TPSType): TPSType;
2726 begin
2727 if p = nil then
2728 Result := nil
2729 else
2730 if p.BaseType = BtTypeCopy then
2731 begin
2732 Result := TPSTypeLink(p).LinkTypeNo;
2733 end else Result := p;
2734 end;
2735
IsIntTypenull2736 function IsIntType(b: TPSBaseType): Boolean;
2737 begin
2738 case b of
2739 btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF PS_NOINT64}, btS64{$ENDIF}: Result := True;
2740 else
2741 Result := False;
2742 end;
2743 end;
2744
IsRealTypenull2745 function IsRealType(b: TPSBaseType): Boolean;
2746 begin
2747 case b of
2748 btSingle, btDouble, btCurrency, btExtended: Result := True;
2749 else
2750 Result := False;
2751 end;
2752 end;
2753
IsIntRealTypenull2754 function IsIntRealType(b: TPSBaseType): Boolean;
2755 begin
2756 case b of
2757 btSingle, btDouble, btCurrency, btExtended, btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF PS_NOINT64}, btS64{$ENDIF}:
2758 Result := True;
2759 else
2760 Result := False;
2761 end;
2762
2763 end;
2764
DiffRecnull2765 function DiffRec(p1, p2: TPSSubItem): Boolean;
2766 begin
2767 if p1.ClassType = p2.ClassType then
2768 begin
2769 if P1.ClassType = TPSSubNumber then
2770 Result := TPSSubNumber(p1).SubNo <> TPSSubNumber(p2).SubNo
2771 else if P1.ClassType = TPSSubValue then
2772 Result := TPSSubValue(p1).SubNo <> TPSSubValue(p2).SubNo
2773 else
2774 Result := False;
2775 end else Result := True;
2776 end;
2777
SameRegnull2778 function SameReg(x1, x2: TPSValue): Boolean;
2779 var
2780 I: Longint;
2781 begin
2782 if (x1.ClassType = x2.ClassType) and (X1 is TPSValueVar) then
2783 begin
2784 if
2785 ((x1.ClassType = TPSValueGlobalVar) and (TPSValueGlobalVar(x1).GlobalVarNo = TPSValueGlobalVar(x2).GlobalVarNo)) or
2786 ((x1.ClassType = TPSValueLocalVar) and (TPSValueLocalVar(x1).LocalVarNo = TPSValueLocalVar(x2).LocalVarNo)) or
2787 ((x1.ClassType = TPSValueParamVar) and (TPSValueParamVar(x1).ParamNo = TPSValueParamVar(x2).ParamNo)) or
2788 ((x1.ClassType = TPSValueAllocatedStackVar) and (TPSValueAllocatedStackVar(x1).LocalVarNo = TPSValueAllocatedStackVar(x2).LocalVarNo)) then
2789 begin
2790 if TPSValueVar(x1).GetRecCount <> TPSValueVar(x2).GetRecCount then
2791 begin
2792 Result := False;
2793 exit;
2794 end;
2795 for i := 0 to TPSValueVar(x1).GetRecCount -1 do
2796 begin
2797 if DiffRec(TPSValueVar(x1).RecItem[i], TPSValueVar(x2).RecItem[i]) then
2798 begin
2799 Result := False;
2800 exit;
2801 end;
2802 end;
2803 Result := True;
2804 end else Result := False;
2805 end
2806 else
2807 Result := False;
2808 end;
2809
GetUIntnull2810 function GetUInt(Src: PIfRVariant; var s: Boolean): Cardinal;
2811 begin
2812 case Src.FType.BaseType of
2813 btU8: Result := Src^.tu8;
2814 btS8: Result := Src^.ts8;
2815 btU16: Result := Src^.tu16;
2816 btS16: Result := Src^.ts16;
2817 btU32: Result := Src^.tu32;
2818 btS32: Result := Src^.ts32;
2819 {$IFNDEF PS_NOINT64}
2820 bts64: Result := src^.ts64;
2821 {$ENDIF}
2822 btChar: Result := ord(Src^.tchar);
2823 {$IFNDEF PS_NOWIDESTRING}
2824 btWideChar: Result := ord(tbtwidechar(src^.twidechar));
2825 {$ENDIF}
2826 btEnum: Result := src^.tu32;
2827 else
2828 begin
2829 s := False;
2830 Result := 0;
2831 end;
2832 end;
2833 end;
2834
GetIntnull2835 function GetInt(Src: PIfRVariant; var s: Boolean): Longint;
2836 begin
2837 case Src.FType.BaseType of
2838 btU8: Result := Src^.tu8;
2839 btS8: Result := Src^.ts8;
2840 btU16: Result := Src^.tu16;
2841 btS16: Result := Src^.ts16;
2842 btU32: Result := Src^.tu32;
2843 btS32: Result := Src^.ts32;
2844 {$IFNDEF PS_NOINT64}
2845 bts64: Result := src^.ts64;
2846 {$ENDIF}
2847 btChar: Result := ord(Src^.tchar);
2848 {$IFNDEF PS_NOWIDESTRING}
2849 btWideChar: Result := ord(tbtwidechar(src^.twidechar));
2850 {$ENDIF}
2851 btEnum: Result := src^.tu32;
2852 else
2853 begin
2854 s := False;
2855 Result := 0;
2856 end;
2857 end;
2858 end;
2859 {$IFNDEF PS_NOINT64}
GetInt64null2860 function GetInt64(Src: PIfRVariant; var s: Boolean): Int64;
2861 begin
2862 case Src.FType.BaseType of
2863 btU8: Result := Src^.tu8;
2864 btS8: Result := Src^.ts8;
2865 btU16: Result := Src^.tu16;
2866 btS16: Result := Src^.ts16;
2867 btU32: Result := Src^.tu32;
2868 btS32: Result := Src^.ts32;
2869 bts64: Result := src^.ts64;
2870 btChar: Result := ord(Src^.tchar);
2871 {$IFNDEF PS_NOWIDESTRING}
2872 btWideChar: Result := ord(tbtwidechar(src^.twidechar));
2873 {$ENDIF}
2874 btEnum: Result := src^.tu32;
2875 else
2876 begin
2877 s := False;
2878 Result := 0;
2879 end;
2880 end;
2881 end;
2882 {$ENDIF}
2883
GetRealnull2884 function GetReal(Src: PIfRVariant; var s: Boolean): Extended;
2885 begin
2886 case Src.FType.BaseType of
2887 btU8: Result := Src^.tu8;
2888 btS8: Result := Src^.ts8;
2889 btU16: Result := Src^.tu16;
2890 btS16: Result := Src^.ts16;
2891 btU32: Result := Src^.tu32;
2892 btS32: Result := Src^.ts32;
2893 {$IFNDEF PS_NOINT64}
2894 bts64: Result := src^.ts64;
2895 {$ENDIF}
2896 btChar: Result := ord(Src^.tchar);
2897 {$IFNDEF PS_NOWIDESTRING}
2898 btWideChar: Result := ord(tbtwidechar(src^.twidechar));
2899 {$ENDIF}
2900 btSingle: Result := Src^.tsingle;
2901 btDouble: Result := Src^.tdouble;
2902 btCurrency: Result := SRc^.tcurrency;
2903 btExtended: Result := Src^.textended;
2904 else
2905 begin
2906 s := False;
2907 Result := 0;
2908 end;
2909 end;
2910 end;
2911
GetStringnull2912 function GetString(Src: PIfRVariant; var s: Boolean): tbtString;
2913 begin
2914 case Src.FType.BaseType of
2915 btChar: Result := Src^.tchar;
2916 btString: Result := tbtstring(src^.tstring);
2917 {$IFNDEF PS_NOWIDESTRING}
2918 btWideChar: Result := tbtstring(src^.twidechar);
2919 btWideString: Result := tbtstring(tbtWideString(src^.twidestring));
2920 btUnicodeString: Result := tbtstring(tbtUnicodeString(src^.tunistring));
2921 {$ENDIF}
2922 else
2923 begin
2924 s := False;
2925 Result := '';
2926 end;
2927 end;
2928 end;
2929
2930 {$IFNDEF PS_NOWIDESTRING}
GetWideStringnull2931 function TPSPascalCompiler.GetWideString(Src: PIfRVariant; var s: Boolean): tbtwidestring;
2932 begin
2933 case Src.FType.BaseType of
2934 btChar: Result := tbtWidestring(Src^.tchar);
2935 btString: Result := tbtWidestring(tbtstring(src^.tstring));
2936 btWideChar: Result := src^.twidechar;
2937 btWideString: Result := tbtWideString(src^.twidestring);
2938 btUnicodeString: result := tbtUnicodeString(src^.tunistring);
2939 else
2940 begin
2941 s := False;
2942 Result := '';
2943 end;
2944 end;
2945 end;
TPSPascalCompiler.GetUnicodeStringnull2946 function TPSPascalCompiler.GetUnicodeString(Src: PIfRVariant; var s: Boolean): tbtunicodestring;
2947 begin
2948 case Src.FType.BaseType of
2949 btChar: Result := tbtunicodestring(Src^.tchar);
2950 btString: Result := tbtunicodestring(tbtstring(src^.tstring));
2951 btWideChar: Result := src^.twidechar;
2952 btWideString: Result := tbtWideString(src^.twidestring);
2953 btUnicodeString: result := tbtUnicodeString(src^.tunistring);
2954 else
2955 begin
2956 s := False;
2957 Result := '';
2958 end;
2959 end;
2960 end;
2961 {$ENDIF}
2962
abnull2963 function ab(b: Longint): Longint;
2964 begin
2965 ab := Longint(b = 0);
2966 end;
2967
2968 procedure Set_Union(Dest, Src: PByteArray; ByteSize: Integer);
2969 var
2970 i: Longint;
2971 begin
2972 for i := ByteSize -1 downto 0 do
2973 Dest^[i] := Dest^[i] or Src^[i];
2974 end;
2975
2976 procedure Set_Diff(Dest, Src: PByteArray; ByteSize: Integer);
2977 var
2978 i: Longint;
2979 begin
2980 for i := ByteSize -1 downto 0 do
2981 Dest^[i] := Dest^[i] and not Src^[i];
2982 end;
2983
2984 procedure Set_Intersect(Dest, Src: PByteArray; ByteSize: Integer);
2985 var
2986 i: Longint;
2987 begin
2988 for i := ByteSize -1 downto 0 do
2989 Dest^[i] := Dest^[i] and Src^[i];
2990 end;
2991
2992 procedure Set_Subset(Dest, Src: PByteArray; ByteSize: Integer; var Val: Boolean);
2993 var
2994 i: Integer;
2995 begin
2996 for i := ByteSize -1 downto 0 do
2997 begin
2998 if not (Src^[i] and Dest^[i] = Dest^[i]) then
2999 begin
3000 Val := False;
3001 exit;
3002 end;
3003 end;
3004 Val := True;
3005 end;
3006
3007 procedure Set_Equal(Dest, Src: PByteArray; ByteSize: Integer; var Val: Boolean);
3008 var
3009 i: Longint;
3010 begin
3011 for i := ByteSize -1 downto 0 do
3012 begin
3013 if Dest^[i] <> Src^[i] then
3014 begin
3015 Val := False;
3016 exit;
3017 end;
3018 end;
3019 val := True;
3020 end;
3021
3022 procedure Set_membership(Item: Longint; Src: PByteArray; var Val: Boolean);
3023 begin
3024 Val := (Src^[Item shr 3] and (1 shl (Item and 7))) <> 0;
3025 end;
3026
3027 procedure Set_MakeMember(Item: Longint; Src: PByteArray);
3028 begin
3029 Src^[Item shr 3] := Src^[Item shr 3] or (1 shl (Item and 7));
3030 end;
3031
3032 procedure ConvertToBoolean(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIFRVariant; b: Boolean);
3033 begin
3034 FinalizeVariant(var1^);
3035 if FUseUsedTypes then
3036 Var1^.FType := se.at2ut(se.FDefaultBoolType)
3037 else
3038 Var1^.FType := Se.FDefaultBoolType;
3039 var1^.tu32 := Ord(b);
3040 end;
3041
3042 procedure ConvertToString(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIFRVariant; const s: tbtString);
3043 var
3044 atype: TPSType;
3045 begin
3046 FinalizeVariant(var1^);
3047 atype := se.FindBaseType(btString);
3048 if FUseUsedTypes then
3049 InitializeVariant(var1, se.at2ut(atype))
3050 else
3051 InitializeVariant(var1, atype);
3052 tbtstring(var1^.tstring) := s;
3053 end;
3054 {$IFNDEF PS_NOWIDESTRING}
3055 procedure ConvertToUnicodeString(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIFRVariant; const s: tbtunicodestring);
3056 var
3057 atype: TPSType;
3058 begin
3059 FinalizeVariant(var1^);
3060 atype := se.FindBaseType(btUnicodeString);
3061 if FUseUsedTypes then
3062 InitializeVariant(var1, se.at2ut(atype))
3063 else
3064 InitializeVariant(var1, atype);
3065 tbtunicodestring(var1^.tunistring) := s;
3066 end;
3067 {$ENDIF}
3068 procedure ConvertToFloat(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIfRVariant; NewType: TPSType);
3069 var
3070 vartemp: PIfRVariant;
3071 b: Boolean;
3072 begin
3073 New(vartemp);
3074 b := false;
3075 if FUseUsedTypes then
3076 NewType := se.at2ut(NewType);
3077 InitializeVariant(vartemp, var1.FType);
3078 CopyVariantContents(var1, vartemp);
3079 FinalizeVariant(var1^);
3080 InitializeVariant(var1, newtype);
3081 case var1.ftype.basetype of
3082 btSingle:
3083 begin
3084 if (vartemp.ftype.BaseType = btu8) or (vartemp.ftype.BaseType = btu16) or (vartemp.ftype.BaseType = btu32) then
3085 var1^.tsingle := GetUInt(vartemp, b)
3086 else
3087 var1^.tsingle := GetInt(vartemp, b)
3088 end;
3089 btDouble:
3090 begin
3091 if (vartemp.ftype.BaseType = btu8) or (vartemp.ftype.BaseType = btu16) or (vartemp.ftype.BaseType = btu32) then
3092 var1^.tdouble := GetUInt(vartemp, b)
3093 else
3094 var1^.tdouble := GetInt(vartemp, b)
3095 end;
3096 btExtended:
3097 begin
3098 if (vartemp.ftype.BaseType = btu8) or (vartemp.ftype.BaseType = btu16) or (vartemp.ftype.BaseType = btu32) then
3099 var1^.textended:= GetUInt(vartemp, b)
3100 else
3101 var1^.textended:= GetInt(vartemp, b)
3102 end;
3103 btCurrency:
3104 begin
3105 if (vartemp.ftype.BaseType = btu8) or (vartemp.ftype.BaseType = btu16) or (vartemp.ftype.BaseType = btu32) then
3106 var1^.tcurrency:= GetUInt(vartemp, b)
3107 else
3108 var1^.tcurrency:= GetInt(vartemp, b)
3109 end;
3110 end;
3111 DisposeVariant(vartemp);
3112 end;
3113
3114
IsCompatibleTypenull3115 function TPSPascalCompiler.IsCompatibleType(p1, p2: TPSType; Cast: Boolean): Boolean;
3116 begin
3117 if
3118 ((p1.BaseType = btProcPtr) and (p2 = p1)) or
3119 (p1.BaseType = btPointer) or
3120 (p2.BaseType = btPointer) or
3121 ((p1.BaseType = btNotificationVariant) or (p1.BaseType = btVariant)) or
3122 ((p2.BaseType = btNotificationVariant) or (p2.BaseType = btVariant)) or
3123 (IsIntType(p1.BaseType) and IsIntType(p2.BaseType)) or
3124 (IsRealType(p1.BaseType) and IsIntRealType(p2.BaseType)) or
3125 (((p1.basetype = btPchar) or (p1.BaseType = btString)) and ((p2.BaseType = btString) or (p2.BaseType = btPchar))) or
3126 (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btChar)) or
3127 (((p1.BaseType = btArray) or (p1.BaseType = btStaticArray)) and (
3128 (p2.BaseType = btArray) or (p2.BaseType = btStaticArray)) and IsCompatibleType(TPSArrayType(p1).ArrayTypeNo, TPSArrayType(p2).ArrayTypeNo, False)) or
3129 ((p1.BaseType = btChar) and (p2.BaseType = btChar)) or
3130 ((p1.BaseType = btSet) and (p2.BaseType = btSet)) or
3131 {$IFNDEF PS_NOWIDESTRING}
3132 ((p1.BaseType = btChar) and (p2.BaseType = btWideChar)) or
3133 ((p1.BaseType = btWideChar) and (p2.BaseType = btChar)) or
3134 ((p1.BaseType = btWideChar) and (p2.BaseType = btWideChar)) or
3135 ((p1.BaseType = btWidestring) and (p2.BaseType = btChar)) or
3136 ((p1.BaseType = btWidestring) and (p2.BaseType = btWideChar)) or
3137 ((p1.BaseType = btWidestring) and ((p2.BaseType = btString) or (p2.BaseType = btPchar) or (p2.BaseType = btUnicodeString))) or
3138 ((p1.BaseType = btWidestring) and ((p2.BaseType = btWidestring))) or
3139 ((p1.BaseType = btUnicodeString) and (p2.BaseType = btChar)) or
3140 ((p1.BaseType = btUnicodeString) and (p2.BaseType = btWideChar)) or
3141 ((p1.BaseType = btUnicodeString) and ((p2.BaseType = btString) or (p2.BaseType = btPchar) or (p2.BaseType = btUnicodeString))) or
3142 ((p1.BaseType = btUnicodeString) and (p2.BaseType = btWidestring)) or
3143 (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btWideString)or (p2.BaseType = btUnicodeString)) or
3144 (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btWidechar)) or
3145 (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btchar)) or
3146 {$ENDIF}
3147 ((p1.BaseType = btRecord) and (p2.BaseType = btrecord) and (not IsVarInCompatible(p1, p2))) or
3148 ((p1.BaseType = btEnum) and (p2.BaseType = btEnum)) or
3149 (Cast and IsIntType(P1.BaseType) and (p2.baseType = btEnum)) or
3150 (Cast and (p1.baseType = btEnum) and IsIntType(P2.BaseType))
3151 then
3152 Result := True
3153 // nx change start - allow casting class -> integer and vice versa
3154 else if p1.BaseType = btclass then
3155 Result := TPSClassType(p1).cl.IsCompatibleWith(p2) or (p2.BaseType in [btU32, btS32])
3156 else if (p1.BaseType in [btU32, btS32]) then
3157 Result := (p2.BaseType = btClass)
3158 // nx change end
3159 {$IFNDEF PS_NOINTERFACES}
3160 else if p1.BaseType = btInterface then
3161 Result := TPSInterfaceType(p1).Intf.IsCompatibleWith(p2)
3162 {$ENDIF}
3163 else if ((p1.BaseType = btExtClass) and (p2.BaseType = btExtClass)) then
3164 begin
3165 Result := TPSUndefinedClassType(p1).ExtClass.IsCompatibleWith(TPSUndefinedClassType(p2).ExtClass);
3166 end
3167 else
3168 Result := False;
3169 end;
3170
3171
PreCalcnull3172 function TPSPascalCompiler.PreCalc(FUseUsedTypes: Boolean; Var1Mod: Byte; var1: PIFRVariant; Var2Mod: Byte; Var2: PIfRVariant; Cmd: TPSBinOperatorType; Pos, Row, Col: Cardinal): Boolean;
3173 { var1=dest, var2=src }
3174 var
3175 b: Boolean;
3176
3177 begin
3178 Result := True;
3179 try
3180 if (IsRealType(var2.FType.BaseType) and IsIntType(var1.FType.BaseType)) then
3181 ConvertToFloat(Self, FUseUsedTypes, var1, var2^.FType);
3182 case Cmd of
3183 otAdd:
3184 begin { + }
3185 case var1.FType.BaseType of
3186 btU8: var1^.tu8 := var1^.tu8 + GetUint(Var2, Result);
3187 btS8: var1^.ts8 := var1^.ts8 + GetInt(Var2, Result);
3188 btU16: var1^.tu16 := var1^.tu16 + GetUint(Var2, Result);
3189 btS16: var1^.ts16 := var1^.ts16 + Getint(Var2, Result);
3190 btEnum, btU32: var1^.tu32 := var1^.tu32 + GetUint(Var2, Result);
3191 btS32: var1^.ts32 := var1^.ts32 + Getint(Var2, Result);
3192 {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 + GetInt64(Var2, Result); {$ENDIF}
3193 btSingle: var1^.tsingle := var1^.tsingle + GetReal( Var2, Result);
3194 btDouble: var1^.tdouble := var1^.tdouble + GetReal( Var2, Result);
3195 btExtended: var1^.textended := var1^.textended + GetReal( Var2, Result);
3196 btCurrency: var1^.tcurrency := var1^.tcurrency + GetReal( Var2, Result);
3197 btSet:
3198 begin
3199 if (var1.FType = var2.FType) then
3200 begin
3201 Set_Union(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize);
3202 end else Result := False;
3203 end;
3204 btChar:
3205 begin
3206 ConvertToString(Self, FUseUsedTypes, var1, getstring(Var1, b)+getstring(Var2, b));
3207 end;
3208 btString: tbtstring(var1^.tstring) := tbtstring(var1^.tstring) + GetString(Var2, Result);
3209 {$IFNDEF PS_NOWIDESTRING}
3210 btwideString: tbtwidestring(var1^.twidestring) := tbtwidestring(var1^.twidestring) + GetWideString(Var2, Result);
3211 btUnicodeString: tbtunicodestring(var1^.tunistring) := tbtunicodestring(var1^.tunistring) + GetUnicodeString(Var2, Result);
3212 btWidechar:
3213 begin
3214 ConvertToUnicodeString(Self, FUseUsedTypes, var1, GetUnicodeString(Var1, b)+GetUnicodeString(Var2, b));
3215 end;
3216 {$ENDIF}
3217 else Result := False;
3218 end;
3219 end;
3220 otSub:
3221 begin { - }
3222 case Var1.FType.BaseType of
3223 btU8: var1^.tu8 := var1^.tu8 - GetUint(Var2, Result);
3224 btS8: var1^.ts8 := var1^.ts8 - Getint(Var2, Result);
3225 btU16: var1^.tu16 := var1^.tu16 - GetUint(Var2, Result);
3226 btS16: var1^.ts16 := var1^.ts16 - Getint(Var2, Result);
3227 btEnum, btU32: var1^.tu32 := var1^.tu32 - GetUint(Var2, Result);
3228 btS32: var1^.ts32 := var1^.ts32 - Getint(Var2, Result);
3229 {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 - GetInt64(Var2, Result); {$ENDIF}
3230 btSingle: var1^.tsingle := var1^.tsingle - GetReal( Var2, Result);
3231 btDouble: var1^.tdouble := var1^.tdouble - GetReal(Var2, Result);
3232 btExtended: var1^.textended := var1^.textended - GetReal(Var2, Result);
3233 btCurrency: var1^.tcurrency := var1^.tcurrency - GetReal( Var2, Result);
3234 btSet:
3235 begin
3236 if (var1.FType = var2.FType) then
3237 begin
3238 Set_Diff(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize);
3239 end else Result := False;
3240 end;
3241 else Result := False;
3242 end;
3243 end;
3244 otMul:
3245 begin { * }
3246 case Var1.FType.BaseType of
3247 btU8: var1^.tu8 := var1^.tu8 * GetUint(Var2, Result);
3248 btS8: var1^.ts8 := var1^.ts8 * Getint(Var2, Result);
3249 btU16: var1^.tu16 := var1^.tu16 * GetUint(Var2, Result);
3250 btS16: var1^.ts16 := var1^.ts16 * Getint(Var2, Result);
3251 btU32: var1^.tu32 := var1^.tu32 * GetUint(Var2, Result);
3252 btS32: var1^.ts32 := var1^.ts32 * Getint(Var2, Result);
3253 {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 * GetInt64(Var2, Result); {$ENDIF}
3254 btSingle: var1^.tsingle := var1^.tsingle * GetReal(Var2, Result);
3255 btDouble: var1^.tdouble := var1^.tdouble * GetReal(Var2, Result);
3256 btExtended: var1^.textended := var1^.textended * GetReal( Var2, Result);
3257 btCurrency: var1^.tcurrency := var1^.tcurrency * GetReal( Var2, Result);
3258 btSet:
3259 begin
3260 if (var1.FType = var2.FType) then
3261 begin
3262 Set_Intersect(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize);
3263 end else Result := False;
3264 end;
3265 else Result := False;
3266 end;
3267 end;
3268 {$IFDEF PS_DELPHIDIV}
3269 otDiv:
3270 begin { / }
3271 if IsIntType(var1.FType.BaseType) then
3272 ConvertToFloat(self, FUseUsedTypes, var1, Self.FindType('EXTENDED'));
3273 case Var1.FType.BaseType of
3274 btSingle: var1^.tsingle := var1^.tsingle / GetReal( Var2, Result);
3275 btDouble: var1^.tdouble := var1^.tdouble / GetReal( Var2, Result);
3276 btExtended: var1^.textended := var1^.textended / GetReal( Var2, Result);
3277 btCurrency: var1^.tcurrency := var1^.tcurrency / GetReal( Var2, Result);
3278 else Result := False;
3279 end;
3280 end;
3281 otIntDiv:
3282 begin { / }
3283 case Var1.FType.BaseType of
3284 btU8: var1^.tu8 := var1^.tu8 div GetUint(Var2, Result);
3285 btS8: var1^.ts8 := var1^.ts8 div Getint(Var2, Result);
3286 btU16: var1^.tu16 := var1^.tu16 div GetUint(Var2, Result);
3287 btS16: var1^.ts16 := var1^.ts16 div Getint(Var2, Result);
3288 btU32: var1^.tu32 := var1^.tu32 div GetUint(Var2, Result);
3289 btS32: var1^.ts32 := var1^.ts32 div Getint(Var2, Result);
3290 {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 div GetInt64(Var2, Result); {$ENDIF}
3291 else Result := False;
3292 end;
3293 end;
3294 {$ELSE}
3295 otDiv, otIntDiv:
3296 begin { / }
3297 case Var1.FType.BaseType of
3298 btU8: var1^.tu8 := var1^.tu8 div GetUint(Var2, Result);
3299 btS8: var1^.ts8 := var1^.ts8 div Getint(Var2, Result);
3300 btU16: var1^.tu16 := var1^.tu16 div GetUint(Var2, Result);
3301 btS16: var1^.ts16 := var1^.ts16 div Getint(Var2, Result);
3302 btU32: var1^.tu32 := var1^.tu32 div GetUint(Var2, Result);
3303 btS32: var1^.ts32 := var1^.ts32 div Getint(Var2, Result);
3304 {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 div GetInt64(Var2, Result); {$ENDIF}
3305 btSingle: var1^.tsingle := var1^.tsingle / GetReal( Var2, Result);
3306 btDouble: var1^.tdouble := var1^.tdouble / GetReal( Var2, Result);
3307 btExtended: var1^.textended := var1^.textended / GetReal( Var2, Result);
3308 btCurrency: var1^.tcurrency := var1^.tcurrency / GetReal( Var2, Result);
3309 else Result := False;
3310 end;
3311 end;
3312 {$ENDIF}
3313 otMod:
3314 begin { MOD }
3315 case Var1.FType.BaseType of
3316 btU8: var1^.tu8 := var1^.tu8 mod GetUint(Var2, Result);
3317 btS8: var1^.ts8 := var1^.ts8 mod Getint(Var2, Result);
3318 btU16: var1^.tu16 := var1^.tu16 mod GetUint(Var2, Result);
3319 btS16: var1^.ts16 := var1^.ts16 mod Getint(Var2, Result);
3320 btU32: var1^.tu32 := var1^.tu32 mod GetUint(Var2, Result);
3321 btS32: var1^.ts32 := var1^.ts32 mod Getint(Var2, Result);
3322 {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 mod GetInt64(Var2, Result); {$ENDIF}
3323 else Result := False;
3324 end;
3325 end;
3326 otshl:
3327 begin { SHL }
3328 case Var1.FType.BaseType of
3329 btU8: var1^.tu8 := var1^.tu8 shl GetUint(Var2, Result);
3330 btS8: var1^.ts8 := var1^.ts8 shl Getint(Var2, Result);
3331 btU16: var1^.tu16 := var1^.tu16 shl GetUint(Var2, Result);
3332 btS16: var1^.ts16 := var1^.ts16 shl Getint(Var2, Result);
3333 btU32: var1^.tu32 := var1^.tu32 shl GetUint(Var2, Result);
3334 btS32: var1^.ts32 := var1^.ts32 shl Getint(Var2, Result);
3335 {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 shl GetInt64(Var2, Result); {$ENDIF}
3336 else Result := False;
3337 end;
3338 end;
3339 otshr:
3340 begin { SHR }
3341 case Var1.FType.BaseType of
3342 btU8: var1^.tu8 := var1^.tu8 shr GetUint(Var2, Result);
3343 btS8: var1^.ts8 := var1^.ts8 shr Getint(Var2, Result);
3344 btU16: var1^.tu16 := var1^.tu16 shr GetUint(Var2, Result);
3345 btS16: var1^.ts16 := var1^.ts16 shr Getint(Var2, Result);
3346 btU32: var1^.tu32 := var1^.tu32 shr GetUint(Var2, Result);
3347 btS32: var1^.ts32 := var1^.ts32 shr Getint(Var2, Result);
3348 {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 shr GetInt64( Var2, Result); {$ENDIF}
3349 else Result := False;
3350 end;
3351 end;
3352 otAnd:
3353 begin { AND }
3354 case Var1.FType.BaseType of
3355 btU8: var1^.tu8 := var1^.tu8 and GetUint(Var2, Result);
3356 btS8: var1^.ts8 := var1^.ts8 and Getint(Var2, Result);
3357 btU16: var1^.tu16 := var1^.tu16 and GetUint(Var2, Result);
3358 btS16: var1^.ts16 := var1^.ts16 and Getint(Var2, Result);
3359 btU32: var1^.tu32 := var1^.tu32 and GetUint(Var2, Result);
3360 btS32: var1^.ts32 := var1^.ts32 and Getint(Var2, Result);
3361 btEnum: var1^.ts32 := var1^.ts32 and Getint(Var2, Result);
3362 {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 and GetInt64(Var2, Result); {$ENDIF}
3363 else Result := False;
3364 end;
3365 end;
3366 otor:
3367 begin { OR }
3368 case Var1.FType.BaseType of
3369 btU8: var1^.tu8 := var1^.tu8 or GetUint(Var2, Result);
3370 btS8: var1^.ts8 := var1^.ts8 or Getint(Var2, Result);
3371 btU16: var1^.tu16 := var1^.tu16 or GetUint(Var2, Result);
3372 btS16: var1^.ts16 := var1^.ts16 or Getint(Var2, Result);
3373 btU32: var1^.tu32 := var1^.tu32 or GetUint(Var2, Result);
3374 btS32: var1^.ts32 := var1^.ts32 or Getint(Var2, Result);
3375 {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 or GetInt64(Var2, Result); {$ENDIF}
3376 btEnum: var1^.ts32 := var1^.ts32 or Getint(Var2, Result);
3377 else Result := False;
3378 end;
3379 end;
3380 otxor:
3381 begin { XOR }
3382 case Var1.FType.BaseType of
3383 btU8: var1^.tu8 := var1^.tu8 xor GetUint(Var2, Result);
3384 btS8: var1^.ts8 := var1^.ts8 xor Getint(Var2, Result);
3385 btU16: var1^.tu16 := var1^.tu16 xor GetUint(Var2, Result);
3386 btS16: var1^.ts16 := var1^.ts16 xor Getint(Var2, Result);
3387 btU32: var1^.tu32 := var1^.tu32 xor GetUint(Var2, Result);
3388 btS32: var1^.ts32 := var1^.ts32 xor Getint(Var2, Result);
3389 {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 xor GetInt64(Var2, Result); {$ENDIF}
3390 btEnum: var1^.ts32 := var1^.ts32 xor Getint(Var2, Result);
3391 else Result := False;
3392 end;
3393 end;
3394 otGreaterEqual:
3395 begin { >= }
3396 case Var1.FType.BaseType of
3397 btU8: b := var1^.tu8 >= GetUint(Var2, Result);
3398 btS8: b := var1^.ts8 >= Getint(Var2, Result);
3399 btU16: b := var1^.tu16 >= GetUint(Var2, Result);
3400 btS16: b := var1^.ts16 >= Getint(Var2, Result);
3401 btU32: b := var1^.tu32 >= GetUint(Var2, Result);
3402 btS32: b := var1^.ts32 >= Getint(Var2, Result);
3403 {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 >= GetInt64(Var2, Result); {$ENDIF}
3404 btSingle: b := var1^.tsingle >= GetReal( Var2, Result);
3405 btDouble: b := var1^.tdouble >= GetReal( Var2, Result);
3406 btExtended: b := var1^.textended >= GetReal( Var2, Result);
3407 btCurrency: b := var1^.tcurrency >= GetReal( Var2, Result);
3408 btSet:
3409 begin
3410 if (var1.FType = var2.FType) then
3411 begin
3412 Set_Subset(var2.tstring, var1.tstring, TPSSetType(var1.FType).ByteSize, b);
3413 end else Result := False;
3414 end;
3415 else
3416 Result := False;
3417 end;
3418 ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
3419 end;
3420 otLessEqual:
3421 begin { <= }
3422 case Var1.FType.BaseType of
3423 btU8: b := var1^.tu8 <= GetUint(Var2, Result);
3424 btS8: b := var1^.ts8 <= Getint(Var2, Result);
3425 btU16: b := var1^.tu16 <= GetUint(Var2, Result);
3426 btS16: b := var1^.ts16 <= Getint(Var2, Result);
3427 btU32: b := var1^.tu32 <= GetUint(Var2, Result);
3428 btS32: b := var1^.ts32 <= Getint(Var2, Result);
3429 {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 <= GetInt64(Var2, Result); {$ENDIF}
3430 btSingle: b := var1^.tsingle <= GetReal( Var2, Result);
3431 btDouble: b := var1^.tdouble <= GetReal( Var2, Result);
3432 btExtended: b := var1^.textended <= GetReal( Var2, Result);
3433 btCurrency: b := var1^.tcurrency <= GetReal( Var2, Result);
3434 btSet:
3435 begin
3436 if (var1.FType = var2.FType) then
3437 begin
3438 Set_Subset(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize, b);
3439 end else Result := False;
3440 end;
3441 else
3442 Result := False;
3443 end;
3444 ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
3445 end;
3446 otGreater:
3447 begin { > }
3448 case Var1.FType.BaseType of
3449 btU8: b := var1^.tu8 > GetUint(Var2, Result);
3450 btS8: b := var1^.ts8 > Getint(Var2, Result);
3451 btU16: b := var1^.tu16 > GetUint(Var2, Result);
3452 btS16: b := var1^.ts16 > Getint(Var2, Result);
3453 btU32: b := var1^.tu32 > GetUint(Var2, Result);
3454 btS32: b := var1^.ts32 > Getint(Var2, Result);
3455 {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 > GetInt64(Var2, Result); {$ENDIF}
3456 btSingle: b := var1^.tsingle > GetReal( Var2, Result);
3457 btDouble: b := var1^.tdouble > GetReal( Var2, Result);
3458 btExtended: b := var1^.textended > GetReal( Var2, Result);
3459 btCurrency: b := var1^.tcurrency > GetReal( Var2, Result);
3460 else
3461 Result := False;
3462 end;
3463 ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
3464 end;
3465 otLess:
3466 begin { < }
3467 case Var1.FType.BaseType of
3468 btU8: b := var1^.tu8 < GetUint(Var2, Result);
3469 btS8: b := var1^.ts8 < Getint(Var2, Result);
3470 btU16: b := var1^.tu16 < GetUint(Var2, Result);
3471 btS16: b := var1^.ts16 < Getint(Var2, Result);
3472 btU32: b := var1^.tu32 < GetUint(Var2, Result);
3473 btS32: b := var1^.ts32 < Getint(Var2, Result);
3474 {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 < GetInt64(Var2, Result); {$ENDIF}
3475 btSingle: b := var1^.tsingle < GetReal( Var2, Result);
3476 btDouble: b := var1^.tdouble < GetReal( Var2, Result);
3477 btExtended: b := var1^.textended < GetReal( Var2, Result);
3478 btCurrency: b := var1^.tcurrency < GetReal( Var2, Result);
3479 else
3480 Result := False;
3481 end;
3482 ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
3483 end;
3484 otNotEqual:
3485 begin { <> }
3486 case Var1.FType.BaseType of
3487 btU8: b := var1^.tu8 <> GetUint(Var2, Result);
3488 btS8: b := var1^.ts8 <> Getint(Var2, Result);
3489 btU16: b := var1^.tu16 <> GetUint(Var2, Result);
3490 btS16: b := var1^.ts16 <> Getint(Var2, Result);
3491 btU32: b := var1^.tu32 <> GetUint(Var2, Result);
3492 {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 <> GetInt64(Var2, Result); {$ENDIF}
3493 btS32: b := var1^.ts32 <> Getint(Var2, Result);
3494 btSingle: b := var1^.tsingle <> GetReal( Var2, Result);
3495 btDouble: b := var1^.tdouble <> GetReal( Var2, Result);
3496 btExtended: b := var1^.textended <> GetReal( Var2, Result);
3497 btCurrency: b := var1^.tcurrency <> GetReal( Var2, Result);
3498 btEnum: b := var1^.ts32 <> Getint(Var2, Result);
3499 btString: b := tbtstring(var1^.tstring) <> GetString(var2, Result);
3500 btChar: b := var1^.tchar <> GetString(var2, Result);
3501 {$IFNDEF PS_NOWIDESTRING}
3502 btWideString: b := tbtWideString(var1^.twidestring) <> GetWideString(var2, Result);
3503 btUnicodeString: b := tbtUnicodeString(var1^.tunistring) <> GetUnicodeString(var2, Result);
3504 btWideChar: b := var1^.twidechar <> GetUnicodeString(var2, Result);
3505 {$ENDIF}
3506 btSet:
3507 begin
3508 if (var1.FType = var2.FType) then
3509 begin
3510 Set_Equal(var1.tstring, var2.tstring, TPSSetType(var1.FType).GetByteSize, b);
3511 b := not b;
3512 end else Result := False;
3513 end;
3514 else
3515 Result := False;
3516 end;
3517 ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
3518 end;
3519 otEqual:
3520 begin { = }
3521 case Var1.FType.BaseType of
3522 btU8: b := var1^.tu8 = GetUint(Var2, Result);
3523 btS8: b := var1^.ts8 = Getint(Var2, Result);
3524 btU16: b := var1^.tu16 = GetUint(Var2, Result);
3525 btS16: b := var1^.ts16 = Getint(Var2, Result);
3526 btU32: b := var1^.tu32 = GetUint(Var2, Result);
3527 btS32: b := var1^.ts32 = Getint(Var2, Result);
3528 {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 = GetInt64(Var2, Result); {$ENDIF}
3529 btSingle: b := var1^.tsingle = GetReal( Var2, Result);
3530 btDouble: b := var1^.tdouble = GetReal( Var2, Result);
3531 btExtended: b := var1^.textended = GetReal( Var2, Result);
3532 btCurrency: b := var1^.tcurrency = GetReal( Var2, Result);
3533 btEnum: b := var1^.ts32 = Getint(Var2, Result);
3534 btString: b := tbtstring(var1^.tstring) = GetString(var2, Result);
3535 btChar: b := var1^.tchar = GetString(var2, Result);
3536 {$IFNDEF PS_NOWIDESTRING}
3537 btWideString: b := tbtWideString(var1^.twidestring) = GetWideString(var2, Result);
3538 btUnicodeString: b := tbtUnicodeString(var1^.twidestring) = GetUnicodeString(var2, Result);
3539 btWideChar: b := var1^.twidechar = GetUnicodeString(var2, Result);
3540 {$ENDIF}
3541 btSet:
3542 begin
3543 if (var1.FType = var2.FType) then
3544 begin
3545 Set_Equal(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize, b);
3546 end else Result := False;
3547 end;
3548 else
3549 Result := False;
3550 end;
3551 ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
3552 end;
3553 otIn:
3554 begin
3555 if (var2.Ftype.BaseType = btset) and (TPSSetType(var2).SetType = Var1.FType) then
3556 begin
3557 Set_membership(GetUint(var1, result), var2.tstring, b);
3558 end else Result := False;
3559 end;
3560 else
3561 Result := False;
3562 end;
3563 except
3564 on E: EDivByZero do
3565 begin
3566 Result := False;
3567 MakeError('', ecDivideByZero, '');
3568 Exit;
3569 end;
3570 on E: EZeroDivide do
3571 begin
3572 Result := False;
3573 MakeError('', ecDivideByZero, '');
3574 Exit;
3575 end;
3576 on E: EMathError do
3577 begin
3578 Result := False;
3579 MakeError('', ecMathError, tbtstring(e.Message));
3580 Exit;
3581 end;
3582 on E: Exception do
3583 begin
3584 Result := False;
3585 MakeError('', ecInternalError, tbtstring(E.Message));
3586 Exit;
3587 end;
3588 end;
3589 if not Result then
3590 begin
3591 with MakeError('', ecTypeMismatch, '') do
3592 begin
3593 FPosition := Pos;
3594 FRow := Row;
3595 FCol := Col;
3596 end;
3597 end;
3598 end;
3599
IsDuplicatenull3600 function TPSPascalCompiler.IsDuplicate(const s: tbtString; const check: TPSDuplicCheck): Boolean;
3601 var
3602 h, l: Longint;
3603 x: TPSProcedure;
3604 begin
3605 if (s = 'RESULT') then
3606 begin
3607 Result := True;
3608 exit;
3609 end;
3610 h := MakeHash(s);
3611 if dcTypes in Check then
3612 for l := FTypes.Count - 1 downto 0 do
3613 begin
3614 if (TPSType(FTypes.Data[l]).NameHash = h) and
3615 (TPSType(FTypes.Data[l]).Name = s) then
3616 begin
3617 Result := True;
3618 exit;
3619 end;
3620 end;
3621
3622 if dcProcs in Check then
3623 for l := FProcs.Count - 1 downto 0 do
3624 begin
3625 x := FProcs.Data[l];
3626 if x.ClassType = TPSInternalProcedure then
3627 begin
3628 if (h = TPSInternalProcedure(x).NameHash) and (s = TPSInternalProcedure(x).Name) then
3629 begin
3630 Result := True;
3631 exit;
3632 end;
3633 end
3634 else
3635 begin
3636 if (TPSExternalProcedure(x).RegProc.NameHash = h) and
3637 (TPSExternalProcedure(x).RegProc.Name = s) then
3638 begin
3639 Result := True;
3640 exit;
3641 end;
3642 end;
3643 end;
3644 if dcVars in Check then
3645 for l := FVars.Count - 1 downto 0 do
3646 begin
3647 if (TPSVar(FVars.Data[l]).NameHash = h) and
3648 (TPSVar(FVars.Data[l]).Name = s) then
3649 begin
3650 Result := True;
3651 exit;
3652 end;
3653 end;
3654 if dcConsts in Check then
3655 for l := FConstants.Count -1 downto 0 do
3656 begin
3657 if (TPSConstant(FConstants.Data[l]).NameHash = h) and
3658 (TPSConstant(FConstants.Data[l]).Name = s) then
3659 begin
3660 Result := TRue;
3661 exit;
3662 end;
3663 end;
3664 Result := False;
3665 end;
3666
3667 procedure ClearRecSubVals(RecSubVals: TPSList);
3668 var
3669 I: Longint;
3670 begin
3671 for I := 0 to RecSubVals.Count - 1 do
3672 TPSRecordFieldTypeDef(RecSubVals[I]).Free;
3673 RecSubVals.Free;
3674 end;
3675
TPSPascalCompiler.ReadTypeAddProcedurenull3676 function TPSPascalCompiler.ReadTypeAddProcedure(const Name: tbtString; FParser: TPSPascalParser): TPSType;
3677 var
Booleannull3678 IsFunction: Boolean;
3679 VNames: tbtString;
3680 modifier: TPSParameterMode;
3681 Decl: TPSParametersDecl;
3682 VCType: TPSType;
3683 begin
thennull3684 if FParser.CurrTokenId = CSTII_Function then
3685 IsFunction := True
3686 else
3687 IsFunction := False;
3688 Decl := TPSParametersDecl.Create;
3689 try
3690 FParser.Next;
3691 if FParser.CurrTokenId = CSTI_OpenRound then
3692 begin
3693 FParser.Next;
3694 if FParser.CurrTokenId <> CSTI_CloseRound then
3695 begin
3696 while True do
3697 begin
3698 if FParser.CurrTokenId = CSTII_Const then
3699 begin
3700 Modifier := pmIn;
3701 FParser.Next;
3702 end else
3703 if FParser.CurrTokenId = CSTII_Out then
3704 begin
3705 Modifier := pmOut;
3706 FParser.Next;
3707 end else
3708 if FParser.CurrTokenId = CSTII_Var then
3709 begin
3710 modifier := pmInOut;
3711 FParser.Next;
3712 end
3713 else
3714 modifier := pmIn;
3715 if FParser.CurrTokenId <> CSTI_Identifier then
3716 begin
3717 Result := nil;
3718 if FParser = Self.FParser then
3719 MakeError('', ecIdentifierExpected, '');
3720 exit;
3721 end;
3722 VNames := FParser.OriginalToken + '|';
3723 FParser.Next;
3724 while FParser.CurrTokenId = CSTI_Comma do
3725 begin
3726 FParser.Next;
3727 if FParser.CurrTokenId <> CSTI_Identifier then
3728 begin
3729 Result := nil;
3730 if FParser = Self.FParser then
3731 MakeError('', ecIdentifierExpected, '');
3732 exit;
3733 end;
3734 VNames := VNames + FParser.GetToken + '|';
3735 FParser.Next;
3736 end;
3737 if FParser.CurrTokenId <> CSTI_Colon then
3738 begin
3739 Result := nil;
3740 if FParser = Self.FParser then
3741 MakeError('', ecColonExpected, '');
3742 exit;
3743 end;
3744 FParser.Next;
3745 if FParser.CurrTokenId <> CSTI_Identifier then
3746 begin
3747 Result := nil;
3748 if FParser = self.FParser then
3749 MakeError('', ecIdentifierExpected, '');
3750 exit;
3751 end;
3752 VCType := FindType(FParser.GetToken);
3753 if VCType = nil then
3754 begin
3755 if FParser = self.FParser then
3756 MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
3757 Result := nil;
3758 exit;
3759 end;
3760 while Pos(tbtchar('|'), VNames) > 0 do
3761 begin
3762 with Decl.AddParam do
3763 begin
3764 Mode := modifier;
3765 OrgName := copy(VNames, 1, Pos(tbtchar('|'), VNames) - 1);
3766 FType := VCType;
3767 end;
3768 Delete(VNames, 1, Pos(tbtchar('|'), VNames));
3769 end;
3770 FParser.Next;
3771 if FParser.CurrTokenId = CSTI_CloseRound then
3772 break;
3773 if FParser.CurrTokenId <> CSTI_Semicolon then
3774 begin
3775 if FParser = Self.FParser then
3776 MakeError('', ecSemicolonExpected, '');
3777 Result := nil;
3778 exit;
3779 end;
3780 FParser.Next;
3781 end; {while}
3782 end; {if}
3783 FParser.Next;
3784 end; {if}
thennull3785 if IsFunction then
3786 begin
3787 if FParser.CurrTokenId <> CSTI_Colon then
3788 begin
3789 if FParser = Self.FParser then
3790 MakeError('', ecColonExpected, '');
3791 Result := nil;
3792 exit;
3793 end;
3794 FParser.Next;
3795 if FParser.CurrTokenId <> CSTI_Identifier then
3796 begin
3797 Result := nil;
3798 if FParser = Self.FParser then
3799 MakeError('', ecIdentifierExpected, '');
3800 exit;
3801 end;
3802 VCType := self.FindType(FParser.GetToken);
3803 if VCType = nil then
3804 begin
3805 if FParser = self.FParser then
3806 MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
3807 Result := nil;
3808 exit;
3809 end;
3810 FParser.Next;
3811 end
3812 else
3813 VCType := nil;
3814 Decl.Result := VcType;
3815 VCType := TPSProceduralType.Create;
3816 VCType.Name := FastUppercase(Name);
3817 VCType.OriginalName := Name;
3818 VCType.BaseType := btProcPtr;
3819 {$IFDEF PS_USESSUPPORT}
3820 VCType.DeclareUnit:=fModule;
3821 {$ENDIF}
3822 VCType.DeclarePos := FParser.CurrTokenPos;
3823 VCType.DeclareRow := FParser.Row;
3824 VCType.DeclareCol := FParser.Col;
3825 TPSProceduralType(VCType).ProcDef.Assign(Decl);
3826 FTypes.Add(VCType);
3827 Result := VCType;
3828 finally
3829 Decl.Free;
3830 end;
3831 end; {ReadTypeAddProcedure}
3832
3833
ReadTypenull3834 function TPSPascalCompiler.ReadType(const Name: tbtString; FParser: TPSPascalParser): TPSType; // InvalidVal = Invalid
3835 var
3836 TypeNo: TPSType;
3837 h, l: Longint;
3838 FieldName,fieldorgname,s: tbtString;
3839 RecSubVals: TPSList;
3840 FArrayStart, FArrayLength: Longint;
3841 rvv: PIFPSRecordFieldTypeDef;
3842 p, p2: TPSType;
3843 tempf: PIfRVariant;
3844 {$IFNDEF PS_NOINTERFACES}
3845 InheritedFrom: tbtString;
3846 Guid: TGUID;
3847 Intf: TPSInterface;
3848 {$ENDIF}
3849 begin
ornull3850 if (FParser.CurrTokenID = CSTII_Function) or (FParser.CurrTokenID = CSTII_Procedure) then
3851 begin
3852 Result := ReadTypeAddProcedure(Name, FParser);
3853 Exit;
3854 end else if FParser.CurrTokenId = CSTII_Set then
3855 begin
3856 FParser.Next;
3857 if FParser.CurrTokenId <> CSTII_Of then
3858 begin
3859 MakeError('', ecOfExpected, '');
3860 Result := nil;
3861 Exit;
3862 end;
3863 FParser.Next;
3864 if FParser.CurrTokenID <> CSTI_Identifier then
3865 begin
3866 MakeError('', ecIdentifierExpected, '');
3867 Result := nil;
3868 exit;
3869 end;
3870 TypeNo := FindType(FParser.GetToken);
3871 if TypeNo = nil then
3872 begin
3873 MakeError('', ecUnknownIdentifier, '');
3874 Result := nil;
3875 exit;
3876 end;
3877 if (TypeNo.BaseType = btEnum) or (TypeNo.BaseType = btChar) or (TypeNo.BaseType = btU8) then
3878 begin
3879 FParser.Next;
3880 p2 := TPSSetType.Create;
3881 p2.Name := FastUppercase(Name);
3882 p2.OriginalName := Name;
3883 p2.BaseType := btSet;
3884 {$IFDEF PS_USESSUPPORT}
3885 p2.DeclareUnit:=fModule;
3886 {$ENDIF}
3887 p2.DeclarePos := FParser.CurrTokenPos;
3888 p2.DeclareRow := FParser.Row;
3889 p2.DeclareCol := FParser.Col;
3890 TPSSetType(p2).SetType := TypeNo;
3891 FTypes.Add(p2);
3892 Result := p2;
3893 end else
3894 begin
3895 MakeError('', ecTypeMismatch, '');
3896 Result := nil;
3897 end;
3898 exit;
3899 end else if FParser.CurrTokenId = CSTI_OpenRound then
3900 begin
3901 FParser.Next;
3902 L := 0;
3903 P2 := TPSEnumType.Create;
3904 P2.Name := FastUppercase(Name);
3905 p2.OriginalName := Name;
3906 p2.BaseType := btEnum;
3907 {$IFDEF PS_USESSUPPORT}
3908 p2.DeclareUnit:=fModule;
3909 {$ENDIF}
3910 p2.DeclarePos := FParser.CurrTokenPos;
3911 p2.DeclareRow := FParser.Row;
3912 p2.DeclareCol := FParser.Col;
3913 FTypes.Add(p2);
3914
3915 repeat
3916 if FParser.CurrTokenId <> CSTI_Identifier then
3917 begin
3918 if FParser = Self.FParser then
3919 MakeError('', ecIdentifierExpected, '');
3920 Result := nil;
3921 exit;
3922 end;
3923 s := FParser.OriginalToken;
3924 if IsDuplicate(FastUppercase(s), [dcTypes]) then
3925 begin
3926 if FParser = Self.FParser then
3927 MakeError('', ecDuplicateIdentifier, s);
3928 Result := nil;
3929 Exit;
3930 end;
3931 with AddConstant(s, p2) do
3932 begin
3933 FValue.tu32 := L;
3934 {$IFDEF PS_USESSUPPORT}
3935 DeclareUnit:=fModule;
3936 {$ENDIF}
3937 DeclarePos:=FParser.CurrTokenPos;
3938 DeclareRow:=FParser.Row;
3939 DeclareCol:=FParser.Col;
3940 end;
3941 Inc(L);
3942 FParser.Next;
3943 if FParser.CurrTokenId = CSTI_CloseRound then
3944 Break
3945 else if FParser.CurrTokenId <> CSTI_Comma then
3946 begin
3947 if FParser = Self.FParser then
3948 MakeError('', ecCloseRoundExpected, '');
3949 Result := nil;
3950 Exit;
3951 end;
3952 FParser.Next;
3953 until False;
3954 FParser.Next;
3955 TPSEnumType(p2).HighValue := L-1;
3956 Result := p2;
3957 exit;
3958 end else
3959 if FParser.CurrTokenId = CSTII_Array then
3960 begin
3961 FParser.Next;
3962 if FParser.CurrTokenID = CSTI_OpenBlock then
3963 begin
3964 FParser.Next;
3965 tempf := ReadConstant(FParser, CSTI_TwoDots);
3966 if tempf = nil then
3967 begin
3968 Result := nil;
3969 exit;
3970 end;
3971 case tempf.FType.BaseType of
3972 btU8: FArrayStart := tempf.tu8;
3973 btS8: FArrayStart := tempf.ts8;
3974 btU16: FArrayStart := tempf.tu16;
3975 btS16: FArrayStart := tempf.ts16;
3976 btU32: FArrayStart := tempf.tu32;
3977 btS32: FArrayStart := tempf.ts32;
3978 {$IFNDEF PS_NOINT64}
3979 bts64: FArrayStart := tempf.ts64;
3980 {$ENDIF}
3981 else
3982 begin
3983 DisposeVariant(tempf);
3984 MakeError('', ecTypeMismatch, '');
3985 Result := nil;
3986 exit;
3987 end;
3988 end;
3989 DisposeVariant(tempf);
3990 if FParser.CurrTokenID <> CSTI_TwoDots then
3991 begin
3992 MakeError('', ecPeriodExpected, '');
3993 Result := nil;
3994 exit;
3995 end;
3996 FParser.Next;
3997 tempf := ReadConstant(FParser, CSTI_CloseBlock);
3998 if tempf = nil then
3999 begin
4000 Result := nil;
4001 exit;
4002 end;
4003 case tempf.FType.BaseType of
4004 btU8: FArrayLength := tempf.tu8;
4005 btS8: FArrayLength := tempf.ts8;
4006 btU16: FArrayLength := tempf.tu16;
4007 btS16: FArrayLength := tempf.ts16;
4008 btU32: FArrayLength := tempf.tu32;
4009 btS32: FArrayLength := tempf.ts32;
4010 {$IFNDEF PS_NOINT64}
4011 bts64: FArrayLength := tempf.ts64;
4012 {$ENDIF}
4013 else
4014 DisposeVariant(tempf);
4015 MakeError('', ecTypeMismatch, '');
4016 Result := nil;
4017 exit;
4018 end;
4019 DisposeVariant(tempf);
4020 FArrayLength := FArrayLength - FArrayStart + 1;
4021 if (FArrayLength < 0) or (FArrayLength > MaxInt div 4) then
4022 begin
4023 MakeError('', ecTypeMismatch, '');
4024 Result := nil;
4025 exit;
4026 end;
4027 if FParser.CurrTokenID <> CSTI_CloseBlock then
4028 begin
4029 MakeError('', ecCloseBlockExpected, '');
4030 Result := nil;
4031 exit;
4032 end;
4033 FParser.Next;
4034 end else
4035 begin
4036 FArrayStart := 0;
4037 FArrayLength := -1;
4038 end;
4039 if FParser.CurrTokenId <> CSTII_Of then
4040 begin
4041 if FParser = Self.FParser then
4042 MakeError('', ecOfExpected, '');
4043 Result := nil;
4044 exit;
4045 end;
4046 FParser.Next;
4047 TypeNo := ReadType('', FParser);
4048 if TypeNo = nil then
4049 begin
4050 if FParser = Self.FParser then
4051 MakeError('', ecUnknownIdentifier, '');
4052 Result := nil;
4053 exit;
4054 end;
4055 if (Name = '') and (FArrayLength = -1) then
4056 begin
4057 if TypeNo.Used then
4058 begin
4059 for h := 0 to FTypes.Count -1 do
4060 begin
4061 p := FTypes[H];
4062 if (p.BaseType = btArray) and (TPSArrayType(p).ArrayTypeNo = TypeNo) and (Copy(p.Name, 1, 1) <> '!') then
4063 begin
4064 Result := p;
4065 exit;
4066 end;
4067 end;
4068 end;
4069 end;
4070 if FArrayLength <> -1 then
4071 begin
4072 p := TPSStaticArrayType.Create;
4073 TPSStaticArrayType(p).StartOffset := FArrayStart;
4074 TPSStaticArrayType(p).Length := FArrayLength;
4075 p.BaseType := btStaticArray;
4076 end else
4077 begin
4078 p := TPSArrayType.Create;
4079 p.BaseType := btArray;
4080 end;
4081 p.Name := FastUppercase(Name);
4082 p.OriginalName := Name;
4083 {$IFDEF PS_USESSUPPORT}
4084 p.DeclareUnit:=fModule;
4085 {$ENDIF}
4086 p.DeclarePos := FParser.CurrTokenPos;
4087 p.DeclareRow := FParser.Row;
4088 p.DeclareCol := FParser.Col;
4089 TPSArrayType(p).ArrayTypeNo := TypeNo;
4090 FTypes.Add(p);
4091 Result := p;
4092 Exit;
4093 end
4094 else if FParser.CurrTokenId = CSTII_Record then
4095 begin
4096 FParser.Next;
4097 RecSubVals := TPSList.Create;
4098 repeat
4099 repeat
4100 if FParser.CurrTokenId <> CSTI_Identifier then
4101 begin
4102 ClearRecSubVals(RecSubVals);
4103 if FParser = Self.FParser then
4104 MakeError('', ecIdentifierExpected, '');
4105 Result := nil;
4106 exit;
4107 end;
4108 FieldName := FParser.GetToken;
4109 s := S+FParser.OriginalToken+'|';
4110 FParser.Next;
4111 h := MakeHash(FieldName);
4112 for l := 0 to RecSubVals.Count - 1 do
4113 begin
4114 if (PIFPSRecordFieldTypeDef(RecSubVals[l]).FieldNameHash = h) and
4115 (PIFPSRecordFieldTypeDef(RecSubVals[l]).FieldName = FieldName) then
4116 begin
4117 if FParser = Self.FParser then
4118 MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
4119 ClearRecSubVals(RecSubVals);
4120 Result := nil;
4121 exit;
4122 end;
4123 end;
4124 if FParser.CurrTokenID = CSTI_Colon then Break else
4125 if FParser.CurrTokenID <> CSTI_Comma then
4126 begin
4127 if FParser = Self.FParser then
4128 MakeError('', ecColonExpected, '');
4129 ClearRecSubVals(RecSubVals);
4130 Result := nil;
4131 exit;
4132 end;
4133 FParser.Next;
4134 until False;
4135 FParser.Next;
4136 p := ReadType('', FParser);
4137 if p = nil then
4138 begin
4139 ClearRecSubVals(RecSubVals);
4140 Result := nil;
4141 exit;
4142 end;
4143 p := GetTypeCopyLink(p);
4144 if FParser.CurrTokenId <> CSTI_Semicolon then
4145 begin
4146 ClearRecSubVals(RecSubVals);
4147 if FParser = Self.FParser then
4148 MakeError('', ecSemicolonExpected, '');
4149 Result := nil;
4150 exit;
4151 end; {if}
4152 FParser.Next;
4153 while Pos(tbtchar('|'), s) > 0 do
4154 begin
4155 fieldorgname := copy(s, 1, Pos(tbtchar('|'), s)-1);
4156 Delete(s, 1, length(FieldOrgName)+1);
4157 rvv := TPSRecordFieldTypeDef.Create;
4158 rvv.FieldOrgName := fieldorgname;
4159 rvv.FType := p;
4160 RecSubVals.Add(rvv);
4161 end;
4162 until FParser.CurrTokenId = CSTII_End;
4163 FParser.Next; // skip CSTII_End
4164 P := TPSRecordType.Create;
4165 p.Name := FastUppercase(Name);
4166 p.OriginalName := Name;
4167 p.BaseType := btRecord;
4168 {$IFDEF PS_USESSUPPORT}
4169 p.DeclareUnit:=fModule;
4170 {$ENDIF}
4171 p.DeclarePos := FParser.CurrTokenPos;
4172 p.DeclareRow := FParser.Row;
4173 p.DeclareCol := FParser.Col;
4174 for l := 0 to RecSubVals.Count -1 do
4175 begin
4176 rvv := RecSubVals[l];
4177 with TPSRecordType(p).AddRecVal do
4178 begin
4179 FieldOrgName := rvv.FieldOrgName;
4180 FType := rvv.FType;
4181 end;
4182 rvv.Free;
4183 end;
4184 RecSubVals.Free;
4185 FTypes.Add(p);
4186 Result := p;
4187 Exit;
4188 {$IFNDEF PS_NOINTERFACES}
4189 end else if FParser.CurrTokenId = CSTII_Interface then
4190 begin
4191 FParser.Next;
4192 if FParser.CurrTokenId <> CSTI_OpenRound then
4193 begin
4194 MakeError('', ecOpenRoundExpected, '');
4195 Result := nil;
4196 Exit;
4197 end;
4198 FParser.Next;
4199 if FParser.CurrTokenID <> CSTI_Identifier then
4200 begin
4201 MakeError('', ecIdentifierExpected, '');
4202 Result := nil;
4203 exit;
4204 end;
4205 InheritedFrom := FParser.GetToken;
4206 TypeNo := FindType(InheritedFrom);
4207 if TypeNo = nil then
4208 begin
4209 MakeError('', ecUnknownType, FParser.GetToken);
4210 Result := nil;
4211 exit;
4212 end;
4213 if TypeNo.BaseType <> btInterface then
4214 begin
4215 MakeError('', ecTypeMismatch, '');
4216 Result := nil;
4217 Exit;
4218 end;
4219 FParser.Next;
4220 if FParser.CurrTokenId <> CSTI_CloseRound then
4221 begin
4222 MakeError('', ecCloseRoundExpected, '');
4223 Result := nil;
4224 Exit;
4225 end;
4226 {$IFNDEF PS_NOINTERFACEGUIDBRACKETS}
4227 FParser.Next;
4228 if FParser.CurrTokenId <> CSTI_OpenBlock then
4229 begin
4230 MakeError('', ecOpenBlockExpected, '');
4231 Result := nil;
4232 Exit;
4233 end;
4234 {$ENDIF}
4235 FParser.Next;
4236 if FParser.CurrTokenId <> CSTI_String then
4237 begin
4238 MakeError('', ecStringExpected, '');
4239 Result := nil;
4240 Exit;
4241 end;
4242 s := FParser.GetToken;
4243 try
4244 Guid := StringToGuid(String(Copy(s, 2, Length(s)-2)));
4245 except
4246 on e: Exception do
4247 begin
4248 MakeError('', ecCustomError, tbtstring(e.Message));
4249 Result := nil;
4250 Exit;
4251 end;
4252 end;
4253 {$IFNDEF PS_NOINTERFACEGUIDBRACKETS}
4254 FParser.Next;
4255 if FParser.CurrTokenId <> CSTI_CloseBlock then
4256 begin
4257 MakeError('', ecCloseBlockExpected, '');
4258 Result := nil;
4259 Exit;
4260 end;
4261 {$ENDIF}
4262 Intf := AddInterface(FindInterface(InheritedFrom), Guid, Name);
4263 FParser.Next;
4264 repeat
4265 if not Intf.RegisterMethodEx('', cdStdCall, FParser) then begin
4266 MakeError('', ecCustomError, 'Invalid method');
4267 Result := nil;
4268 Exit;
4269 end;
4270 FParser.Next;
4271 until FParser.CurrTokenId = CSTII_End;
4272 FParser.Next; // skip CSTII_End
4273 Result := Intf.FType;
4274 Exit;
4275 {$ENDIF}
4276 end else if FParser.CurrTokenId = CSTI_Identifier then
4277 begin
4278 s := FParser.GetToken;
4279 h := MakeHash(s);
4280 Typeno := nil;
4281 for l := 0 to FTypes.Count - 1 do
4282 begin
4283 p2 := FTypes[l];
4284 if (p2.NameHash = h) and (p2.Name = s) then
4285 begin
4286 FParser.Next;
4287 Typeno := GetTypeCopyLink(p2);
4288 Break;
4289 end;
4290 end;
4291 if Typeno = nil then
4292 begin
4293 Result := nil;
4294 if FParser = Self.FParser then
4295 MakeError('', ecUnknownType, FParser.OriginalToken);
4296 exit;
4297 end;
4298 if Name <> '' then
4299 begin
4300 p := TPSTypeLink.Create;
4301 p.Name := FastUppercase(Name);
4302 p.OriginalName := Name;
4303 p.BaseType := BtTypeCopy;
4304 {$IFDEF PS_USESSUPPORT}
4305 p.DeclareUnit:=fModule;
4306 {$ENDIF}
4307 p.DeclarePos := FParser.CurrTokenPos;
4308 p.DeclareRow := FParser.Row;
4309 p.DeclareCol := FParser.Col;
4310 TPSTypeLink(p).LinkTypeNo := TypeNo;
4311 FTypes.Add(p);
4312 Result := p;
4313 Exit;
4314 end else
4315 begin
4316 Result := TypeNo;
4317 exit;
4318 end;
4319 end;
4320 Result := nil;
4321 if FParser = Self.FParser then
4322 MakeError('', ecIdentifierExpected, '');
4323 Exit;
4324 end;
4325
VarIsDuplicatenull4326 function TPSPascalCompiler.VarIsDuplicate(Proc: TPSInternalProcedure; const Varnames, s: tbtString): Boolean;
4327 var
4328 h, l: Longint;
4329 x: TPSProcedure;
4330 v: tbtString;
4331 begin
4332 h := MakeHash(s);
4333 if (s = 'RESULT') then
4334 begin
4335 Result := True;
4336 exit;
4337 end;
4338
4339 for l := FProcs.Count - 1 downto 0 do
4340 begin
4341 x := FProcs.Data[l];
4342 if x.ClassType = TPSInternalProcedure then
4343 begin
4344 if (h = TPSInternalProcedure(x).NameHash) and (s = TPSInternalProcedure(x).Name) then
4345 begin
4346 Result := True;
4347 exit;
4348 end;
4349 end
4350 else
4351 begin
4352 if (TPSExternalProcedure(x).RegProc.NameHash = h) and (TPSExternalProcedure(x).RegProc.Name = s) then
4353 begin
4354 Result := True;
4355 exit;
4356 end;
4357 end;
4358 end;
4359 if proc <> nil then
4360 begin
4361 for l := proc.ProcVars.Count - 1 downto 0 do
4362 begin
4363 if (PIFPSProcVar(proc.ProcVars.Data[l]).NameHash = h) and
4364 (PIFPSProcVar(proc.ProcVars.Data[l]).Name = s) then
4365 begin
4366 Result := True;
4367 exit;
4368 end;
4369 end;
4370 for l := Proc.FDecl.ParamCount -1 downto 0 do
4371 begin
4372 if (Proc.FDecl.Params[l].Name = s) then
4373 begin
4374 Result := True;
4375 exit;
4376 end;
4377 end;
4378 end
4379 else
4380 begin
4381 for l := FVars.Count - 1 downto 0 do
4382 begin
4383 if (TPSVar(FVars.Data[l]).NameHash = h) and
4384 (TPSVar(FVars.Data[l]).Name = s) then
4385 begin
4386 Result := True;
4387 exit;
4388 end;
4389 end;
4390 end;
4391 v := VarNames;
4392 while Pos(tbtchar('|'), v) > 0 do
4393 begin
4394 if FastUppercase(copy(v, 1, Pos(tbtchar('|'), v) - 1)) = s then
4395 begin
4396 Result := True;
4397 exit;
4398 end;
4399 Delete(v, 1, Pos(tbtchar('|'), v));
4400 end;
4401 for l := FConstants.Count -1 downto 0 do
4402 begin
4403 if (TPSConstant(FConstants.Data[l]).NameHash = h) and
4404 (TPSConstant(FConstants.Data[l]).Name = s) then
4405 begin
4406 Result := True;
4407 exit;
4408 end;
4409 end;
4410 Result := False;
4411 end;
4412
4413
TPSPascalCompiler.DoVarBlocknull4414 function TPSPascalCompiler.DoVarBlock(proc: TPSInternalProcedure): Boolean;
4415 var
4416 VarName, s: tbtString;
4417 VarType: TPSType;
4418 VarNo: Cardinal;
4419 v: TPSVar;
4420 vp: PIFPSProcVar;
4421 EPos, ERow, ECol: Integer;
4422 begin
4423 Result := False;
4424 FParser.Next; // skip CSTII_Var
4425 if FParser.CurrTokenId <> CSTI_Identifier then
4426 begin
4427 MakeError('', ecIdentifierExpected, '');
4428 exit;
4429 end;
4430 repeat
4431 VarNAme := '';
4432 if VarIsDuplicate(proc, VarName, FParser.GetToken) then
4433 begin
4434 MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
4435 exit;
4436 end;
4437 VarName := FParser.OriginalToken + '|';
4438 Varno := 0;
4439 if @FOnUseVariable <> nil then
4440 begin
4441 if Proc <> nil then
4442 FOnUseVariable(Self, ivtVariable, Proc.ProcVars.Count + VarNo, FProcs.Count -1, FParser.CurrTokenPos, '')
4443 else
4444 FOnUseVariable(Self, ivtGlobal, FVars.Count + VarNo, InvalidVal, FParser.CurrTokenPos, '')
4445 end;
4446 EPos:=FParser.CurrTokenPos;
4447 ERow:=FParser.Row;
4448 ECol:=FParser.Col;
4449 FParser.Next;
4450 while FParser.CurrTokenId = CSTI_Comma do
4451 begin
4452 FParser.Next;
4453 if FParser.CurrTokenId <> CSTI_Identifier then
4454 begin
4455 MakeError('', ecIdentifierExpected, '');
4456 end;
4457 if VarIsDuplicate(proc, VarName, FParser.GetToken) then
4458 begin
4459 MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
4460 exit;
4461 end;
4462 VarName := VarName + FParser.OriginalToken + '|';
4463 Inc(varno);
4464 if @FOnUseVariable <> nil then
4465 begin
4466 if Proc <> nil then
4467 FOnUseVariable(Self, ivtVariable, Proc.ProcVars.Count + VarNo, FProcs.Count -1, FParser.CurrTokenPos, '')
4468 else
4469 FOnUseVariable(Self, ivtGlobal, FVars.Count + VarNo, InvalidVal, FParser.CurrTokenPos, '')
4470 end;
4471 FParser.Next;
4472 end;
4473 if FParser.CurrTokenId <> CSTI_Colon then
4474 begin
4475 MakeError('', ecColonExpected, '');
4476 exit;
4477 end;
4478 FParser.Next;
4479 VarType := at2ut(ReadType('', FParser));
4480 if VarType = nil then
4481 begin
4482 exit;
4483 end;
4484 while Pos(tbtchar('|'), VarName) > 0 do
4485 begin
4486 s := copy(VarName, 1, Pos(tbtchar('|'), VarName) - 1);
4487 Delete(VarName, 1, Pos(tbtchar('|'), VarName));
4488 if proc = nil then
4489 begin
4490 v := TPSVar.Create;
4491 v.OrgName := s;
4492 v.Name := FastUppercase(s);
4493 {$IFDEF PS_USESSUPPORT}
4494 v.DeclareUnit:=fModule;
4495 {$ENDIF}
4496 v.DeclarePos := EPos;
4497 v.DeclareRow := ERow;
4498 v.DeclareCol := ECol;
4499 v.FType := VarType;
4500 FVars.Add(v);
4501 end
4502 else
4503 begin
4504 vp := TPSProcVar.Create;
4505 vp.OrgName := s;
4506 vp.Name := FastUppercase(s);
4507 vp.aType := VarType;
4508 {$IFDEF PS_USESSUPPORT}
4509 vp.DeclareUnit:=fModule;
4510 {$ENDIF}
4511 vp.DeclarePos := EPos;
4512 vp.DeclareRow := ERow;
4513 vp.DeclareCol := ECol;
4514 proc.ProcVars.Add(vp);
4515 end;
4516 end;
4517 if FParser.CurrTokenId <> CSTI_Semicolon then
4518 begin
4519 MakeError('', ecSemicolonExpected, '');
4520 exit;
4521 end;
4522 FParser.Next;
4523 until FParser.CurrTokenId <> CSTI_Identifier;
4524 Result := True;
4525 end;
4526
NewProcnull4527 function TPSPascalCompiler.NewProc(const OriginalName, Name: tbtString): TPSInternalProcedure;
4528 begin
4529 Result := TPSInternalProcedure.Create;
4530 Result.OriginalName := OriginalName;
4531 Result.Name := Name;
4532 {$IFDEF PS_USESSUPPORT}
4533 Result.DeclareUnit:=fModule;
4534 {$ENDIF}
4535 Result.DeclarePos := FParser.CurrTokenPos;
4536 Result.DeclareRow := FParser.Row;
4537 Result.DeclareCol := FParser.Col;
4538 FProcs.Add(Result);
4539 end;
4540
IsProcDuplicLabelnull4541 function TPSPascalCompiler.IsProcDuplicLabel(Proc: TPSInternalProcedure; const s: tbtString): Boolean;
4542 var
4543 i: Longint;
4544 h: Longint;
4545 u: tbtString;
4546 begin
4547 h := MakeHash(s);
4548 if s = 'RESULT' then
4549 Result := True
4550 else if Proc.Name = s then
4551 Result := True
4552 else if IsDuplicate(s, [dcVars, dcConsts, dcProcs]) then
4553 Result := True
4554 else
4555 begin
4556 for i := 0 to Proc.Decl.ParamCount -1 do
4557 begin
4558 if Proc.Decl.Params[i].Name = s then
4559 begin
4560 Result := True;
4561 exit;
4562 end;
4563 end;
4564 for i := 0 to Proc.ProcVars.Count -1 do
4565 begin
4566 if (PIFPSProcVar(Proc.ProcVars[I]).NameHash = h) and (PIFPSProcVar(Proc.ProcVars[I]).Name = s) then
4567 begin
4568 Result := True;
4569 exit;
4570 end;
4571 end;
4572 for i := 0 to Proc.FLabels.Count -1 do
4573 begin
4574 u := Proc.FLabels[I];
4575 delete(u, 1, 4);
4576 if Longint((@u[1])^) = h then
4577 begin
4578 delete(u, 1, 4);
4579 if u = s then
4580 begin
4581 Result := True;
4582 exit;
4583 end;
4584 end;
4585 end;
4586 Result := False;
4587 end;
4588 end;
4589
4590
ProcessLabelnull4591 function TPSPascalCompiler.ProcessLabel(Proc: TPSInternalProcedure): Boolean;
4592 var
4593 CurrLabel: tbtString;
4594 begin
4595 FParser.Next;
4596 while true do
4597 begin
4598 if FParser.CurrTokenId <> CSTI_Identifier then
4599 begin
4600 MakeError('', ecIdentifierExpected, '');
4601 Result := False;
4602 exit;
4603 end;
4604 CurrLabel := FParser.GetToken;
4605 if IsProcDuplicLabel(Proc, CurrLabel) then
4606 begin
4607 MakeError('', ecDuplicateIdentifier, CurrLabel);
4608 Result := False;
4609 exit;
4610 end;
4611 FParser.Next;
4612 Proc.FLabels.Add(#$FF#$FF#$FF#$FF+PS_mi2s(MakeHash(CurrLabel))+CurrLabel);
4613 if FParser.CurrTokenId = CSTI_Semicolon then
4614 begin
4615 FParser.Next;
4616 Break;
4617 end;
4618 if FParser.CurrTokenId <> CSTI_Comma then
4619 begin
4620 MakeError('', ecCommaExpected, '');
4621 Result := False;
4622 exit;
4623 end;
4624 FParser.Next;
4625 end;
4626 Result := True;
4627 end;
4628
4629 procedure TPSPascalCompiler.Debug_SavePosition(ProcNo: Cardinal; Proc: TPSInternalProcedure);
4630 var
4631 Row,
4632 Col,
4633 Pos: Cardinal;
4634 s: tbtString;
4635 begin
4636 Row := FParser.Row;
4637 Col := FParser.Col;
4638 Pos := FParser.CurrTokenPos;
4639 {$IFNDEF PS_USESSUPPORT}
4640 s := '';
4641 {$ELSE}
4642 s := fModule;
4643 {$ENDIF}
4644 if @FOnTranslateLineInfo <> nil then
4645 FOnTranslateLineInfo(Self, Pos, Row, Col, S);
4646 {$IFDEF FPC}
4647 WriteDebugData(#4 + s + #1);
4648 WriteDebugData(Ps_mi2s(ProcNo));
4649 WriteDebugData(Ps_mi2s(Length(Proc.Data)));
4650 WriteDebugData(Ps_mi2s(Pos));
4651 WriteDebugData(Ps_mi2s(Row));
4652 WriteDebugData(Ps_mi2s(Col));
4653 {$ELSE}
4654 WriteDebugData(#4 + s + #1 + PS_mi2s(ProcNo) + PS_mi2s(Length(Proc.Data)) + PS_mi2s(Pos) + PS_mi2s(Row)+ PS_mi2s(Col));
4655 {$ENDIF}
4656 end;
4657
4658 procedure TPSPascalCompiler.Debug_WriteParams(ProcNo: Cardinal; Proc: TPSInternalProcedure);
4659 var
4660 I: Longint;
4661 s: tbtString;
4662 begin
4663 s := #2 + PS_mi2s(ProcNo);
4664 if Proc.Decl.Result <> nil then
4665 begin
4666 s := s + 'Result' + #1;
4667 end;
4668 for i := 0 to Proc.Decl.ParamCount -1 do
4669 s := s + Proc.Decl.Params[i].OrgName + #1;
4670 s := s + #0#3 + PS_mi2s(ProcNo);
4671 for I := 0 to Proc.ProcVars.Count - 1 do
4672 begin
4673 s := s + PIFPSProcVar(Proc.ProcVars[I]).OrgName + #1;
4674 end;
4675 s := s + #0;
4676 WriteDebugData(s);
4677 end;
4678
4679 procedure TPSPascalCompiler.CheckForUnusedVars(Func: TPSInternalProcedure);
4680 var
4681 i: Integer;
4682 p: PIFPSProcVar;
4683 begin
4684 for i := 0 to Func.ProcVars.Count -1 do
4685 begin
4686 p := Func.ProcVars[I];
4687 if not p.Used then
4688 begin
4689 with MakeHint({$IFDEF PS_USESSUPPORT}p.DeclareUnit{$ELSE}''{$ENDIF}, ehVariableNotUsed, p.Name) do
4690 begin
4691 FRow := p.DeclareRow;
4692 FCol := p.DeclareCol;
4693 FPosition := p.DeclarePos;
4694 end;
4695 end;
4696 end;
4697 if (not Func.ResultUsed) and (Func.Decl.Result <> nil) then
4698 begin
4699 with MakeHint({$IFDEF PS_USESSUPPORT}Func.DeclareUnit{$ELSE}''{$ENDIF}, ehVariableNotUsed, 'Result') do
4700 begin
4701 FRow := Func.DeclareRow;
4702 FCol := Func.DeclareCol;
4703 FPosition := Func.DeclarePos;
4704 end;
4705 end;
4706 end;
4707
TPSPascalCompiler.ProcIsDuplicnull4708 function TPSPascalCompiler.ProcIsDuplic(Decl: TPSParametersDecl; const FunctionName, FunctionParamNames: tbtString; const s: tbtString; Func: TPSInternalProcedure): Boolean;
4709 var
4710 i: Longint;
4711 u: tbtString;
4712 begin
4713 if s = 'RESULT' then
4714 Result := True
4715 else if FunctionName = s then
4716 Result := True
4717 else
4718 begin
4719 for i := 0 to Decl.ParamCount -1 do
4720 begin
4721 if Decl.Params[i].Name = s then
4722 begin
4723 Result := True;
4724 exit;
4725 end;
4726 GRFW(u);
4727 end;
4728 u := FunctionParamNames;
4729 while Pos(tbtchar('|'), u) > 0 do
4730 begin
4731 if copy(u, 1, Pos(tbtchar('|'), u) - 1) = s then
4732 begin
4733 Result := True;
4734 exit;
4735 end;
4736 Delete(u, 1, Pos(tbtchar('|'), u));
4737 end;
4738 if Func = nil then
4739 begin
4740 result := False;
4741 exit;
4742 end;
4743 for i := 0 to Func.ProcVars.Count -1 do
4744 begin
4745 if s = PIFPSProcVar(Func.ProcVars[I]).Name then
4746 begin
4747 Result := True;
4748 exit;
4749 end;
4750 end;
4751 for i := 0 to Func.FLabels.Count -1 do
4752 begin
4753 u := Func.FLabels[I];
4754 delete(u, 1, 4);
4755 if u = s then
4756 begin
4757 Result := True;
4758 exit;
4759 end;
4760 end;
4761 Result := False;
4762 end;
4763 end;
4764 procedure WriteProcVars(Func:TPSInternalProcedure; t: TPSList);
4765 var
4766 l: Longint;
4767 v: PIFPSProcVar;
4768 begin
4769 for l := 0 to t.Count - 1 do
4770 begin
4771 v := t[l];
4772 Func.Data := Func.Data + chr(cm_pt)+ PS_mi2s(v.AType.FinalTypeNo);
4773 end;
4774 end;
4775
4776
ApplyAttribsToFunctionnull4777 function TPSPascalCompiler.ApplyAttribsToFunction(func: TPSProcedure): boolean;
4778 var
4779 i: Longint;
4780 begin
4781 for i := 0 to Func.Attributes.Count -1 do
4782 begin
4783 if @Func.Attributes.Items[i].AType.OnApplyAttributeToProc <> nil then
4784 begin
4785 if not Func.Attributes.Items[i].AType.OnApplyAttributeToProc(Self, Func, Func.Attributes.Items[i]) then
4786 begin
4787 Result := false;
4788 exit;
4789 end;
4790 end;
4791 end;
4792 result := true;
4793 end;
4794
4795
ProcessFunctionnull4796 function TPSPascalCompiler.ProcessFunction(AlwaysForward: Boolean; Att: TPSAttributes): Boolean;
4797 var
4798 FunctionType: TFuncType;
4799 OriginalName, FunctionName: tbtString;
4800 FunctionParamNames: tbtString;
4801 FunctionTempType: TPSType;
4802 ParamNo: Cardinal;
4803 FunctionDecl: TPSParametersDecl;
4804 modifier: TPSParameterMode;
4805 Func: TPSInternalProcedure;
4806 F2: TPSProcedure;
4807 EPos, ECol, ERow: Cardinal;
4808 E2Pos, E2Col, E2Row: Cardinal;
4809 pp: TPSRegProc;
4810 pp2: TPSExternalProcedure;
4811 FuncNo, I: Longint;
4812 Block: TPSBlockInfo;
4813 begin
4814 if att = nil then
4815 begin
4816 Att := TPSAttributes.Create;
4817 if not ReadAttributes(Att) then
4818 begin
4819 att.free;
4820 Result := false;
4821 exit;
4822 end;
4823 end;
4824
4825 if FParser.CurrTokenId = CSTII_Procedure then
4826 FunctionType := ftProc
4827 else
4828 FunctionType := ftFunc;
4829 Func := nil;
4830 EPos := FParser.CurrTokenPos;
4831 ERow := FParser.Row;
4832 ECol := FParser.Col;
4833 FParser.Next;
4834 Result := False;
4835 if FParser.CurrTokenId <> CSTI_Identifier then
4836 begin
4837 MakeError('', ecIdentifierExpected, '');
4838 att.free;
4839 exit;
4840 end;
4841 if assigned(FOnFunctionStart) then
4842 {$IFDEF PS_USESSUPPORT}
4843 FOnFunctionStart(fModule + '.' + FParser.OriginalToken, EPos, ERow, ECol);
4844 {$ELSE}
4845 FOnFunctionStart(FParser.OriginalToken, EPos, ERow, ECol);
4846 {$ENDIF}
4847 EPos := FParser.CurrTokenPos;
4848 ERow := FParser.Row;
4849 ECol := FParser.Col;
4850 OriginalName := FParser.OriginalToken;
4851 FunctionName := FParser.GetToken;
4852 FuncNo := -1;
4853 for i := 0 to FProcs.Count -1 do
4854 begin
4855 f2 := FProcs[I];
4856 if (f2.ClassType = TPSInternalProcedure) and (TPSInternalProcedure(f2).Name = FunctionName) and (TPSInternalProcedure(f2).Forwarded) then
4857 begin
4858 Func := FProcs[I];
4859 FuncNo := i;
4860 Break;
4861 end;
4862 end;
4863 if (Func = nil) and IsDuplicate(FunctionName, [dcTypes, dcProcs, dcVars, dcConsts]) then
4864 begin
4865 att.free;
4866 MakeError('', ecDuplicateIdentifier, FunctionName);
4867 exit;
4868 end;
4869 FParser.Next;
4870 FunctionDecl := TPSParametersDecl.Create;
4871 try
4872 if FParser.CurrTokenId = CSTI_OpenRound then
4873 begin
4874 FParser.Next;
4875 if FParser.CurrTokenId = CSTI_CloseRound then
4876 begin
4877 FParser.Next;
4878 end
4879 else
4880 begin
4881 if FunctionType = ftFunc then
4882 ParamNo := 1
4883 else
4884 ParamNo := 0;
4885 while True do
4886 begin
4887 if FParser.CurrTokenId = CSTII_Const then
4888 begin
4889 modifier := pmIn;
4890 FParser.Next;
4891 end
4892 else
4893 if FParser.CurrTokenId = CSTII_Out then
4894 begin
4895 modifier := pmOut;
4896 FParser.Next;
4897 end
4898 else
4899 if FParser.CurrTokenId = CSTII_Var then
4900 begin
4901 modifier := pmInOut;
4902 FParser.Next;
4903 end
4904 else
4905 modifier := pmIn;
4906 if FParser.CurrTokenId <> CSTI_Identifier then
4907 begin
4908 MakeError('', ecIdentifierExpected, '');
4909 exit;
4910 end;
4911 E2Pos := FParser.CurrTokenPos;
4912 E2Row := FParser.Row;
4913 E2Col := FParser.Col;
4914 FunctionParamNames := '';
4915 if ProcIsDuplic(FunctionDecl, FunctionName, FunctionParamNames, FParser.GetToken, Func) then
4916 begin
4917 MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
4918 exit;
4919 end;
4920 FunctionParamNames := FParser.OriginalToken + '|';
4921 if @FOnUseVariable <> nil then
4922 begin
4923 FOnUseVariable(Self, ivtParam, ParamNo, FProcs.Count, FParser.CurrTokenPos, '');
4924 end;
4925 inc(ParamNo);
4926 FParser.Next;
4927 while FParser.CurrTokenId = CSTI_Comma do
4928 begin
4929 FParser.Next;
4930 if FParser.CurrTokenId <> CSTI_Identifier then
4931 begin
4932 MakeError('', ecIdentifierExpected, '');
4933 exit;
4934 end;
4935 if ProcIsDuplic(FunctionDecl, FunctionName, FunctionParamNames, FParser.GetToken, Func) then
4936 begin
4937 MakeError('', ecDuplicateIdentifier, '');
4938 exit;
4939 end;
4940 if @FOnUseVariable <> nil then
4941 begin
4942 FOnUseVariable(Self, ivtParam, ParamNo, FProcs.Count, FParser.CurrTokenPos, '');
4943 end;
4944 inc(ParamNo);
4945 FunctionParamNames := FunctionParamNames + FParser.OriginalToken +
4946 '|';
4947 FParser.Next;
4948 end;
4949 if FParser.CurrTokenId <> CSTI_Colon then
4950 begin
4951 MakeError('', ecColonExpected, '');
4952 exit;
4953 end;
4954 FParser.Next;
4955 FunctionTempType := at2ut(ReadType('', FParser));
4956 if FunctionTempType = nil then
4957 begin
4958 exit;
4959 end;
4960 while Pos(tbtchar('|'), FunctionParamNames) > 0 do
4961 begin
4962 with FunctionDecl.AddParam do
4963 begin
4964 OrgName := copy(FunctionParamNames, 1, Pos(tbtchar('|'), FunctionParamNames) - 1);
4965 Mode := modifier;
4966 aType := FunctionTempType;
4967 {$IFDEF PS_USESSUPPORT}
4968 DeclareUnit:=fModule;
4969 {$ENDIF}
4970 DeclarePos:=E2Pos;
4971 DeclareRow:=E2Row;
4972 DeclareCol:=E2Col;
4973 end;
4974 Delete(FunctionParamNames, 1, Pos(tbtchar('|'), FunctionParamNames));
4975 end;
4976 if FParser.CurrTokenId = CSTI_CloseRound then
4977 break;
4978 if FParser.CurrTokenId <> CSTI_Semicolon then
4979 begin
4980 MakeError('', ecSemicolonExpected, '');
4981 exit;
4982 end;
4983 FParser.Next;
4984 end;
4985 FParser.Next;
4986 end;
4987 end;
4988 if FunctionType = ftFunc then
4989 begin
4990 if FParser.CurrTokenId <> CSTI_Colon then
4991 begin
4992 MakeError('', ecColonExpected, '');
4993 exit;
4994 end;
4995 FParser.Next;
4996 FunctionTempType := at2ut(ReadType('', FParser));
4997 if FunctionTempType = nil then
4998 exit;
4999 FunctionDecl.Result := FunctionTempType;
5000 end;
5001 if FParser.CurrTokenId <> CSTI_Semicolon then
5002 begin
5003 MakeError('', ecSemicolonExpected, '');
5004 exit;
5005 end;
5006 FParser.Next;
5007 if (Func = nil) and (FParser.CurrTokenID = CSTII_External) then
5008 begin
5009 FParser.Next;
5010 if FParser.CurrTokenID <> CSTI_String then
5011 begin
5012 MakeError('', ecStringExpected, '');
5013 exit;
5014 end;
5015 FunctionParamNames := FParser.GetToken;
5016 FunctionParamNames := copy(FunctionParamNames, 2, length(FunctionParamNames) - 2);
5017 FParser.Next;
5018 if FParser.CurrTokenID <> CSTI_Semicolon then
5019 begin
5020 MakeError('', ecSemicolonExpected, '');
5021 exit;
5022 end;
5023 FParser.Next;
5024 if @FOnExternalProc = nil then
5025 begin
5026 MakeError('', ecSemicolonExpected, '');
5027 exit;
5028 end;
5029 pp := FOnExternalProc(Self, FunctionDecl, OriginalName, FunctionParamNames);
5030 if pp = nil then
5031 begin
5032 MakeError('', ecCustomError, '');
5033 exit;
5034 end;
5035 pp2 := TPSExternalProcedure.Create;
5036 pp2.Attributes.Assign(att, true);
5037 pp2.RegProc := pp;
5038 FProcs.Add(pp2);
5039 FRegProcs.Add(pp);
p2null5040 Result := ApplyAttribsToFunction(pp2);
5041 Exit;
5042 end else if (FParser.CurrTokenID = CSTII_Forward) or AlwaysForward then
5043 begin
5044 if Func <> nil then
5045 begin
5046 MakeError('', ecBeginExpected, '');
5047 exit;
5048 end;
5049 if not AlwaysForward then
5050 begin
5051 FParser.Next;
5052 if FParser.CurrTokenID <> CSTI_Semicolon then
5053 begin
5054 MakeError('', ecSemicolonExpected, '');
5055 Exit;
5056 end;
5057 FParser.Next;
5058 end;
5059 Func := NewProc(OriginalName, FunctionName);
5060 Func.Attributes.Assign(Att, True);
5061 Func.Forwarded := True;
5062 {$IFDEF PS_USESSUPPORT}
5063 Func.FDeclareUnit := fModule;
5064 {$ENDIF}
5065 Func.FDeclarePos := EPos;
5066 Func.FDeclareRow := ERow;
5067 Func.FDeclarePos := ECol;
5068 Func.Decl.Assign(FunctionDecl);
uncnull5069 Result := ApplyAttribsToFunction(Func);
5070 exit;
5071 end;
5072 if (Func = nil) then
5073 begin
5074 Func := NewProc(OriginalName, FunctionName);
5075 Func.Attributes.Assign(att, True);
5076 Func.Decl.Assign(FunctionDecl);
5077 {$IFDEF PS_USESSUPPORT}
5078 Func.FDeclareUnit := fModule;
5079 {$ENDIF}
5080 Func.FDeclarePos := EPos;
5081 Func.FDeclareRow := ERow;
5082 Func.FDeclareCol := ECol;
5083 FuncNo := FProcs.Count -1;
uncnull5084 if not ApplyAttribsToFunction(Func) then
5085 begin
5086 result := false;
5087 exit;
5088 end;
5089 end else begin
5090 if not FunctionDecl.Same(Func.Decl) then
5091 begin
5092 MakeError('', ecForwardParameterMismatch, '');
5093 Result := false;
5094 exit;
5095 end;
5096 Func.Forwarded := False;
5097 end;
5098 if FParser.CurrTokenID = CSTII_Export then
5099 begin
5100 FParser.Next;
5101 if FParser.CurrTokenID <> CSTI_Semicolon then
5102 begin
5103 MakeError('', ecSemicolonExpected, '');
5104 exit;
5105 end;
5106 FParser.Next;
5107 end;
5108 while FParser.CurrTokenId <> CSTII_Begin do
5109 begin
5110 if FParser.CurrTokenId = CSTII_Var then
5111 begin
5112 if not DoVarBlock(Func) then
5113 exit;
5114 end else if FParser.CurrTokenId = CSTII_Label then
5115 begin
5116 if not ProcessLabel(Func) then
5117 Exit;
5118 end else
5119 begin
5120 MakeError('', ecBeginExpected, '');
5121 exit;
5122 end;
5123 end;
5124 Debug_WriteParams(FuncNo, Func);
5125 WriteProcVars(Func, Func.ProcVars);
5126 Block := TPSBlockInfo.Create(FGlobalBlock);
5127 Block.SubType := tProcBegin;
5128 Block.ProcNo := FuncNo;
5129 Block.Proc := Func;
5130 if not ProcessSub(Block) then
5131 begin
5132 Block.Free;
5133 exit;
5134 end;
5135 Block.Free;
5136 CheckForUnusedVars(Func);
5137 Result := ProcessLabelForwards(Func);
5138 if assigned(FOnFunctionEnd) then
5139 {$IFDEF PS_USESSUPPORT}
5140 OnFunctionEnd(fModule + '.' + OriginalName, FParser.CurrTokenPos, FParser.Row, FParser.Col);
5141 {$ELSE}
5142 OnFunctionEnd(OriginalName, FParser.CurrTokenPos, FParser.Row, FParser.Col);
5143 {$ENDIF}
5144 finally
5145 FunctionDecl.Free;
5146 att.Free;
5147 end;
5148 end;
5149
GetParamTypenull5150 function GetParamType(BlockInfo: TPSBlockInfo; I: Longint): TPSType;
5151 begin
5152 if BlockInfo.Proc.Decl.Result <> nil then dec(i);
5153 if i = -1 then
5154 Result := BlockInfo.Proc.Decl.Result
5155 else
5156 begin
5157 Result := BlockInfo.Proc.Decl.Params[i].aType;
5158 end;
5159 end;
5160
GetTypeNonull5161 function TPSPascalCompiler.GetTypeNo(BlockInfo: TPSBlockInfo; p: TPSValue): TPSType;
5162 begin
5163 if p.ClassType = TPSUnValueOp then
5164 Result := TPSUnValueOp(p).aType
5165 else if p.ClassType = TPSBinValueOp then
5166 Result := TPSBinValueOp(p).aType
5167 else if p.ClassType = TPSValueArray then
5168 Result := at2ut(FindType('TVariantArray'))
5169 else if p.ClassType = TPSValueData then
5170 Result := TPSValueData(p).Data.FType
5171 else if p is TPSValueProc then
5172 Result := TPSValueProc(p).ResultType
5173 else if (p is TPSValueVar) and (TPSValueVar(p).RecCount > 0) then
5174 Result := TPSValueVar(p).RecItem[TPSValueVar(p).RecCount - 1].aType
5175 else if p.ClassType = TPSValueGlobalVar then
5176 Result := TPSVar(FVars[TPSValueGlobalVar(p).GlobalVarNo]).FType
5177 else if p.ClassType = TPSValueParamVar then
5178 Result := GetParamType(BlockInfo, TPSValueParamVar(p).ParamNo)
5179 else if p is TPSValueLocalVar then
5180 Result := TPSProcVar(BlockInfo.Proc.ProcVars[TPSValueLocalVar(p).LocalVarNo]).AType
5181 else if p.classtype = TPSValueReplace then
5182 Result := GetTypeNo(BlockInfo, TPSValueReplace(p).NewValue)
5183 else
5184 Result := nil;
5185 end;
5186
IsVarInCompatiblenull5187 function TPSPascalCompiler.IsVarInCompatible(ft1, ft2: TPSType): Boolean;
5188 begin
5189 ft1 := GetTypeCopyLink(ft1);
5190 ft2 := GetTypeCopyLink(ft2);
5191 Result := (ft1 <> ft2) and (ft2 <> nil);
5192 end;
5193
ValidateParametersnull5194 function TPSPascalCompiler.ValidateParameters(BlockInfo: TPSBlockInfo; Params: TPSParameters; ParamTypes: TPSParametersDecl): boolean;
5195 var
5196 i, c: Longint;
5197 pType: TPSType;
5198
5199 begin
5200 UseProc(ParamTypes);
5201 c := 0;
5202 for i := 0 to ParamTypes.ParamCount -1 do
5203 begin
5204 while (c < Longint(Params.Count)) and (Params[c].Val = nil) do
5205 Inc(c);
5206 if c >= Longint(Params.Count) then
5207 begin
5208 MakeError('', ecInvalidnumberOfParameters, '');
5209 Result := False;
5210 exit;
5211 end;
5212 Params[c].ExpectedType := ParamTypes.Params[i].aType;
5213 Params[c].ParamMode := ParamTypes.Params[i].Mode;
5214 if ParamTypes.Params[i].Mode <> pmIn then
5215 begin
5216 if not (Params[c].Val is TPSValueVar) then
5217 begin
5218 with MakeError('', ecVariableExpected, '') do
5219 begin
5220 Row := Params[c].Val.Row;
5221 Col := Params[c].Val.Col;
5222 Pos := Params[c].Val.Pos;
5223 end;
5224 result := false;
5225 exit;
5226 end;
5227 PType := Params[c].ExpectedType;
5228 if (PType = nil) or ((PType.BaseType = btArray) and (TPSArrayType(PType).ArrayTypeNo = nil) and (GetTypeNo(BlockInfo, Params[c].Val).BaseType = btArray)) or
5229 (PType = FAnyString) then
5230 begin
5231 Params[c].ExpectedType := GetTypeNo(BlockInfo, Params[c].Val);
5232 if PType <> nil then
5233 if (Params[c].ExpectedType = nil) or not (Params[c].ExpectedType.BaseType in [btString,
5234 {$IFNDEF PS_NOWIDESTRING}btWideString, btUnicodeString, btWideChar,{$ENDIF}
5235 btChar]) then begin
5236 MakeError('', ecTypeMismatch, '');
5237 Result := False;
5238 exit;
5239 end;
5240 if Params[c].ExpectedType.BaseType = btChar then
5241 Params[c].ExpectedType := FindBaseType(btString) else
5242 {$IFNDEF PS_NOWIDESTRING}
5243 if Params[c].ExpectedType.BaseType = btWideChar then
5244 Params[c].ExpectedType := FindBaseType(btUnicodeString);
5245 {$ENDIF}
5246 end else if (PType.BaseType = btArray) and (GetTypeNo(BlockInfo, Params[c].Val).BaseType = btArray) then
5247 begin
5248 if TPSArrayType(GetTypeNo(BlockInfo, Params[c].Val)).ArrayTypeNo <> TPSArrayType(PType).ArrayTypeNo then
5249 begin
5250 MakeError('', ecTypeMismatch, '');
5251 Result := False;
5252 exit;
5253 end;
5254 end else if IsVarInCompatible(PType, GetTypeNo(BlockInfo, Params[c].Val)) then
5255 begin
5256 MakeError('', ecTypeMismatch, '');
5257 Result := False;
5258 exit;
5259 end;
5260 end;
5261 Inc(c);
5262 end;
5263 for i := c to Params.Count -1 do
5264 begin
5265 if Params[i].Val <> nil then
5266 begin
5267 MakeError('', ecInvalidnumberOfParameters, '');
5268 Result := False;
5269 exit;
5270 end;
5271 end;
5272 Result := true;
5273 end;
5274
DoTypeBlocknull5275 function TPSPascalCompiler.DoTypeBlock(FParser: TPSPascalParser): Boolean;
5276 var
5277 VOrg,VName: tbtString;
5278 Attr: TPSAttributes;
5279 FType: TPSType;
5280 i: Longint;
5281 begin
5282 Result := False;
5283 FParser.Next;
5284 repeat
5285 Attr := TPSAttributes.Create;
5286 if not ReadAttributes(Attr) then
5287 begin
5288 Attr.Free;
5289 exit;
5290 end;
5291 if (FParser.CurrTokenID = CSTII_Procedure) or (FParser.CurrTokenID = CSTII_Function) then
5292 begin
5293 Result := ProcessFunction(false, Attr);
5294 exit;
5295 end;
5296 if FParser.CurrTokenId <> CSTI_Identifier then
5297 begin
5298 MakeError('', ecIdentifierExpected, '');
5299 Attr.Free;
5300 exit;
5301 end;
5302
5303 VName := FParser.GetToken;
5304 VOrg := FParser.OriginalToken;
5305 if IsDuplicate(VName, [dcTypes, dcProcs, dcVars]) then
5306 begin
5307 MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
5308 Attr.Free;
5309 exit;
5310 end;
5311
5312 FParser.Next;
5313 if FParser.CurrTokenId <> CSTI_Equal then
5314 begin
5315 MakeError('', ecIsExpected, '');
5316 Attr.Free;
5317 exit;
5318 end;
5319 FParser.Next;
5320 FType := ReadType(VOrg, FParser);
5321 if Ftype = nil then
5322 begin
5323 Attr.Free;
5324 Exit;
5325 end;
5326 FType.Attributes.Assign(Attr, True);
5327 for i := 0 to FType.Attributes.Count -1 do
5328 begin
5329 if (@FType.Attributes[i].FAttribType.OnApplyAttributeToType <> nil) and
5330 not FType.Attributes[i].FAttribType.OnApplyAttributeToType(Self, FType, FType.Attributes[i]) then begin
5331 Attr.Free;
5332 Exit;
5333 end;
5334 end;
5335 Attr.Free;
5336 if FParser.CurrTokenID <> CSTI_Semicolon then
5337 begin
5338 MakeError('', ecSemicolonExpected, '');
5339 Exit;
5340 end;
5341 FParser.Next;
5342 until (FParser.CurrTokenId <> CSTI_Identifier) and (FParser.CurrTokenID <> FAttributesOpenTokenID);
5343 Result := True;
5344 end;
5345
5346 procedure TPSPascalCompiler.Debug_WriteLine(BlockInfo: TPSBlockInfo);
5347 var
5348 b: Boolean;
5349 begin
5350 if @FOnWriteLine <> nil then begin
5351 {$IFNDEF PS_USESSUPPORT}
5352 b := FOnWriteLine(Self, FParser.CurrTokenPos);
5353 {$ELSE}
5354 b := FOnWriteLine(Self, FModule, FParser.CurrTokenPos);
5355 {$ENDIF}
5356 end else
5357 b := true;
5358 if b then Debug_SavePosition(BlockInfo.ProcNo, BlockInfo.Proc);
5359 end;
5360
5361
TPSPascalCompiler.ReadRealnull5362 function TPSPascalCompiler.ReadReal(const s: tbtString): PIfRVariant;
5363 var
5364 C: Integer;
5365 begin
5366 New(Result);
5367 InitializeVariant(Result, FindBaseType(btExtended));
5368 Val(string(s), Result^.textended, C);
5369 end;
5370
ReadStringnull5371 function TPSPascalCompiler.ReadString: PIfRVariant;
5372 {$IFNDEF PS_NOWIDESTRING}var wchar: Boolean;{$ENDIF}
5373
ParseStringnull5374 function ParseString({$IFNDEF PS_NOWIDESTRING}var res: tbtunicodestring{$ELSE}var res: tbtString{$ENDIF}): Boolean;
5375 var
5376 temp3: {$IFNDEF PS_NOWIDESTRING}tbtunicodestring{$ELSE}tbtString{$ENDIF};
5377
ChrToStrnull5378 function ChrToStr(s: tbtString): {$IFNDEF PS_NOWIDESTRING}widechar{$ELSE}tbtchar{$ENDIF};
5379 var
5380 w: Longint;
5381 begin
5382 Delete(s, 1, 1); {First char : #}
5383 w := StrToInt(s);
5384 Result := {$IFNDEF PS_NOWIDESTRING}widechar{$ELSE}tbtchar{$ENDIF}(w);
5385 {$IFNDEF PS_NOWIDESTRING}if w > $FF then wchar := true;{$ENDIF}
5386 end;
5387
PStringnull5388 function PString(s: tbtString): tbtString;
5389 var
5390 i: Longint;
5391 begin
5392 s := copy(s, 2, Length(s) - 2);
5393 i := length(s);
5394 while i > 0 do
5395 begin
5396 if (i < length(s)) and (s[i] = #39) and (s[i + 1] = #39) then
5397 begin
5398 Delete(s, i, 1);
5399 dec(i);
5400 end;
5401 dec(i);
5402 end;
5403 PString := s;
5404 end;
5405 var
5406 lastwasstring: Boolean;
5407 begin
5408 temp3 := '';
5409 while (FParser.CurrTokenId = CSTI_String) or (FParser.CurrTokenId = CSTI_Char) do
5410 begin
5411 lastwasstring := FParser.CurrTokenId = CSTI_String;
5412 if FParser.CurrTokenId = CSTI_String then
5413 begin
5414 if UTF8Decode then
5415 begin
5416 temp3 := temp3 + {$IFNDEF PS_NOWIDESTRING}{$IFDEF DELPHI6UP}System.{$IFDEF DELPHI2009UP}UTF8ToWidestring{$ELSE}UTF8Decode{$ENDIF}{$ENDIF}{$ENDIF}(PString(FParser.GetToken));
5417 {$IFNDEF PS_NOWIDESTRING}wchar:=true;{$ENDIF}
5418 end else
5419 temp3 := temp3 + {$IFNDEF PS_NOWIDESTRING}tbtUnicodestring{$ENDIF}(PString(FParser.GetToken));
5420
5421 FParser.Next;
5422 if FParser.CurrTokenId = CSTI_String then
5423 temp3 := temp3 + #39;
5424 end {if}
5425 else
5426 begin
5427 temp3 := temp3 + ChrToStr(FParser.GetToken);
5428 FParser.Next;
5429 end; {else if}
5430 if lastwasstring and (FParser.CurrTokenId = CSTI_String) then
5431 begin
5432 MakeError('', ecSyntaxError, '');
5433 result := false;
5434 exit;
5435 end;
5436 end; {while}
5437 res := temp3;
5438 result := true;
5439 end;
5440 var
5441 {$IFNDEF PS_NOWIDESTRING}
5442 w: tbtunicodestring;
5443 {$ENDIF}
5444 s: tbtString;
5445 begin
5446 {$IFNDEF PS_NOWIDESTRING}wchar:=false;{$ENDIF}
5447 if not ParseString({$IFDEF PS_NOWIDESTRING} s {$ELSE} w {$ENDIF}) then
5448 begin
5449 result := nil;
5450 exit;
5451 end;
5452 {$IFNDEF PS_NOWIDESTRING}
5453 if wchar then
5454 begin
5455 New(Result);
5456 if Length(w) = 1 then
5457 begin
5458 InitializeVariant(Result, at2ut(FindBaseType(btwidechar)));
5459 Result^.twidechar := w[1];
5460 end else begin
5461 InitializeVariant(Result, at2ut(FindBaseType(btUnicodeString)));
5462 tbtunicodestring(Result^.tunistring) := w;
5463 end;
5464 end else begin
5465 s := tbtstring(w);
5466 {$ENDIF}
5467 New(Result);
5468 if Length(s) = 1 then
5469 begin
5470 InitializeVariant(Result, at2ut(FindBaseType(btchar)));
5471 Result^.tchar := s[1];
5472 end else begin
5473 InitializeVariant(Result, at2ut(FindBaseType(btstring)));
5474 tbtstring(Result^.tstring) := s;
5475 end;
5476 {$IFNDEF PS_NOWIDESTRING}
5477 end;
5478 {$ENDIF}
5479 end;
5480
5481
TPSPascalCompiler.ReadIntegernull5482 function TPSPascalCompiler.ReadInteger(const s: tbtString): PIfRVariant;
5483 var
5484 R: {$IFNDEF PS_NOINT64}Int64;{$ELSE}Longint;{$ENDIF}
5485 begin
5486 New(Result);
5487 {$IFNDEF PS_NOINT64}
5488 r := StrToInt64Def(string(s), 0);
5489 if (r >= Low(Integer)) and (r <= High(Integer)) then
5490 begin
5491 InitializeVariant(Result, at2ut(FindBaseType(bts32)));
5492 Result^.ts32 := r;
5493 end else if (r <= $FFFFFFFF) then
5494 begin
5495 InitializeVariant(Result, at2ut(FindBaseType(btu32)));
5496 Result^.tu32 := r;
5497 end else
5498 begin
5499 InitializeVariant(Result, at2ut(FindBaseType(bts64)));
5500 Result^.ts64 := r;
5501 end;
5502 {$ELSE}
5503 r := StrToIntDef(s, 0);
5504 InitializeVariant(Result, at2ut(FindBaseType(bts32)));
5505 Result^.ts32 := r;
5506 {$ENDIF}
5507 end;
5508
TPSPascalCompiler.ProcessSubnull5509 function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
5510
AllocStackReg2null5511 function AllocStackReg2(MType: TPSType): TPSValue;
5512 var
5513 x: TPSProcVar;
5514 begin
5515 {$IFDEF DEBUG}
5516 if (mtype = nil) or (not mtype.Used) then asm int 3; end;
5517 {$ENDIF}
5518 x := TPSProcVar.Create;
5519 {$IFDEF PS_USESSUPPORT}
5520 x.DeclareUnit:=fModule;
5521 {$ENDIF}
5522 x.DeclarePos := FParser.CurrTokenPos;
5523 x.DeclareRow := FParser.Row;
5524 x.DeclareCol := FParser.Col;
5525 x.Name := '';
5526 x.AType := MType;
5527 x.Use;
5528 BlockInfo.Proc.ProcVars.Add(x);
5529 Result := TPSValueAllocatedStackVar.Create;
5530 Result.SetParserPos(FParser);
5531 TPSValueAllocatedStackVar(Result).Proc := BlockInfo.Proc;
5532 with TPSValueAllocatedStackVar(Result) do
5533 begin
5534 LocalVarNo := proc.ProcVars.Count -1;
5535 end;
5536 end;
5537
AllocStackRegnull5538 function AllocStackReg(MType: TPSType): TPSValue;
5539 begin
5540 Result := AllocStackReg2(MType);
5541 BlockWriteByte(BlockInfo, Cm_Pt);
5542 BlockWriteLong(BlockInfo, MType.FinalTypeNo);
5543 end;
5544
AllocPointernull5545 function AllocPointer(MDestType: TPSType): TPSValue;
5546 begin
5547 Result := AllocStackReg(at2ut(FindBaseType(btPointer)));
5548 TPSProcVar(BlockInfo.Proc.ProcVars[TPSValueAllocatedStackVar(Result).LocalVarNo]).AType := MDestType;
5549 end;
5550
5551 function WriteCalculation(InData, OutReg: TPSValue): Boolean; forward;
5552 function PreWriteOutRec(var X: TPSValue; FArrType: TPSType): Boolean; forward;
5553 function WriteOutRec(x: TPSValue; AllowData: Boolean): Boolean; forward;
5554 procedure AfterWriteOutRec(var x: TPSValue); forward;
5555
CheckCompatTypenull5556 function CheckCompatType(V1, v2: TPSValue): Boolean;
5557 var
5558 p1, P2: TPSType;
5559 begin
5560 p1 := GetTypeNo(BlockInfo, V1);
5561 P2 := GetTypeNo(BlockInfo, v2);
5562 if (p1 = nil) or (p2 = nil) then
5563 begin
5564 if ((p1 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p1.ClassType = TPSInterfaceType) or {$ENDIF}(p1.BaseType = btProcPtr)) and (v2.ClassType = TPSValueNil)) or
5565 ((p2 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p2.ClassType = TPSInterfaceType) or {$ENDIF}(p2.BaseType = btProcPtr)) and (v1.ClassType = TPSValueNil)) then
5566 begin
5567 Result := True;
5568 exit;
5569 end else
5570 if ((p1 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p1.ClassType = TPSInterfaceType) or {$ENDIF}(p1.ClassType = TPSClassType)) and (v2.ClassType = TPSValueNil)) or
5571 ((p2 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p2.ClassType = TPSInterfaceType) or {$ENDIF}(p2.ClassType = TPSClassType)) and (v1.ClassType = TPSValueNil)) then
5572 begin
5573 Result := True;
5574 exit;
5575 end else
5576 if ((p1 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p1.ClassType = TPSInterfaceType) or {$ENDIF}(p1.ClassType = TPSUndefinedClassType)) and (v2.ClassType = TPSValueNil)) or
5577 ((p2 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p2.ClassType = TPSInterfaceType) or {$ENDIF}(p2.ClassType = TPSUndefinedClassType)) and (v1.ClassType = TPSValueNil)) then
5578 begin
5579 Result := True;
5580 exit;
5581 end else
5582 if (v1.ClassType = TPSValueProcPtr) and (p2 <> nil) and (p2.BaseType = btProcPtr) then
5583 begin
5584 Result := CheckCompatProc(p2, TPSValueProcPtr(v1).ProcPtr);
5585 exit;
5586 end else if (v2.ClassType = TPSValueProcPtr) and (p1 <> nil) and (p1.BaseType = btProcPtr) then
5587 begin
5588 Result := CheckCompatProc(p1, TPSValueProcPtr(v2).ProcPtr);
5589 exit;
5590 end;
5591 Result := False;
5592 end else
5593 if (p1 <> nil) and (p1.BaseType = btSet) and (v2 is TPSValueArray) then
5594 begin
5595 Result := True;
5596 end else
5597 Result := IsCompatibleType(p1, p2, False);
5598 end;
5599
5600 function _ProcessFunction(ProcCall: TPSValueProc; ResultRegister: TPSValue): Boolean; forward;
ProcessFunction2null5601 function ProcessFunction2(ProcNo: Cardinal; Par: TPSParameters; ResultReg: TPSValue): Boolean;
5602 var
5603 Temp: TPSValueProcNo;
5604 i: Integer;
5605 begin
5606 Temp := TPSValueProcNo.Create;
5607 Temp.Parameters := Par;
5608 Temp.ProcNo := ProcNo;
5609 if TObject(FProcs[ProcNo]).ClassType = TPSInternalProcedure then
5610 Temp.ResultType := TPSInternalProcedure(FProcs[ProcNo]).Decl.Result
5611 else
5612 Temp.ResultType := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl.Result;
5613 if (Temp.ResultType <> nil) and (Temp.ResultType = FAnyString) then begin // workaround to make the result type match
5614 for i := 0 to Par.Count -1 do begin
5615 if Par[i].ExpectedType.BaseType in [btString{$IFNDEF PS_NOWIDESTRING}, btWideString{$ENDIF}] then
5616 Temp.ResultType := Par[i].ExpectedType;
5617 end;
5618 end;
empnull5619 Result := _ProcessFunction(Temp, ResultReg);
5620 Temp.Parameters := nil;
5621 Temp.Free;
5622 end;
5623
MakeNilnull5624 function MakeNil(NilPos, NilRow, nilCol: Cardinal;ivar: TPSValue): Boolean;
5625 var
5626 Procno: Cardinal;
5627 PF: TPSType;
5628 Par: TPSParameters;
5629 begin
5630 Pf := GetTypeNo(BlockInfo, IVar);
5631 if not (Ivar is TPSValueVar) then
5632 begin
5633 with MakeError('', ecTypeMismatch, '') do
5634 begin
5635 FPosition := nilPos;
5636 FRow := NilRow;
5637 FCol := nilCol;
5638 end;
5639 Result := False;
5640 exit;
5641 end;
5642 if (pf.BaseType = btProcPtr) then
5643 begin
5644 Result := True;
5645 end else
5646 if (pf.BaseType = btString) or (pf.BaseType = btPChar) then
5647 begin
5648 if not PreWriteOutRec(iVar, nil) then
5649 begin
5650 Result := false;
5651 exit;
5652 end;
5653 BlockWriteByte(BlockInfo, CM_A);
5654 WriteOutRec(ivar, False);
5655 BlockWriteByte(BlockInfo, 1);
5656 BlockWriteLong(BlockInfo, GetTypeNo(BlockInfo, IVar).FinalTypeNo);
5657 BlockWriteLong(BlockInfo, 0); //empty tbtString
5658 AfterWriteOutRec(ivar);
5659 Result := True;
5660 end else if (pf.BaseType = btClass) {$IFNDEF PS_NOINTERFACES}or (pf.BaseType = btInterface){$ENDIF} then
5661 begin
5662 {$IFNDEF PS_NOINTERFACES}
5663 if (pf.BaseType = btClass) then
5664 begin
5665 {$ENDIF}
5666 if not TPSClassType(pf).Cl.SetNil(ProcNo) then
5667 begin
5668 with MakeError('', ecTypeMismatch, '') do
5669 begin
5670 FPosition := nilPos;
5671 FRow := NilRow;
5672 FCol := nilCol;
5673 end;
5674 Result := False;
5675 exit;
5676 end;
5677 {$IFNDEF PS_NOINTERFACES}
5678 end else
5679 begin
5680 if not TPSInterfaceType(pf).Intf.SetNil(ProcNo) then
5681 begin
5682 with MakeError('', ecTypeMismatch, '') do
5683 begin
5684 FPosition := nilPos;
5685 FRow := NilRow;
5686 FCol := nilCol;
5687 end;
5688 Result := False;
5689 exit;
5690 end;
5691 end;
5692 {$ENDIF}
5693 Par := TPSParameters.Create;
5694 with par.Add do
5695 begin
5696 Val := IVar;
5697 ExpectedType := GetTypeNo(BlockInfo, ivar);
5698 {$IFDEF DEBUG}
5699 if not ExpectedType.Used then asm int 3; end;
5700 {$ENDIF}
5701 ParamMode := pmInOut;
5702 end;
5703 Result := ProcessFunction2(ProcNo, Par, nil);
5704
5705 Par[0].Val := nil; // don't free IVAR
5706
5707 Par.Free;
5708 end else if pf.BaseType = btExtClass then
5709 begin
5710 if not TPSUndefinedClassType(pf).ExtClass.SetNil(ProcNo) then
5711 begin
5712 with MakeError('', ecTypeMismatch, '') do
5713 begin
5714 FPosition := nilPos;
5715 FRow := NilRow;
5716 FCol := nilCol;
5717 end;
5718 Result := False;
5719 exit;
5720 end;
5721 Par := TPSParameters.Create;
5722 with par.Add do
5723 begin
5724 Val := IVar;
5725 ExpectedType := GetTypeNo(BlockInfo, ivar);
5726 ParamMode := pmInOut;
5727 end;
5728 Result := ProcessFunction2(ProcNo, Par, nil);
5729
5730 Par[0].Val := nil; // don't free IVAR
5731
5732 Par.Free;
5733 end else begin
5734 with MakeError('', ecTypeMismatch, '') do
5735 begin
5736 FPosition := nilPos;
5737 FRow := NilRow;
5738 FCol := nilCol;
5739 end;
5740 Result := False;
5741 end;
5742 end;
DoBinCalcnull5743 function DoBinCalc(BVal: TPSBinValueOp; Output: TPSValue): Boolean;
5744 var
5745 tmpp, tmpc: TPSValue;
5746 jend, jover: Cardinal;
5747 procno: Cardinal;
5748
5749 begin
5750 if BVal.Operator >= otGreaterEqual then
5751 begin
5752 if BVal.FVal1.ClassType = TPSValueNil then
5753 begin
5754 tmpp := AllocStackReg(GetTypeNo(BlockInfo, BVal.FVal2));
5755 if not MakeNil(BVal.FVal1.Pos, BVal.FVal1.Row, BVal.FVal1.Col, tmpp) then
5756 begin
5757 tmpp.Free;
5758 Result := False;
5759 exit;
5760 end;
5761 tmpc := TPSValueReplace.Create;
5762 with TPSValueReplace(tmpc) do
5763 begin
5764 OldValue := BVal.FVal1;
5765 NewValue := tmpp;
5766 end;
5767 BVal.FVal1 := tmpc;
5768 end;
5769 if BVal.FVal2.ClassType = TPSValueNil then
5770 begin
5771 tmpp := AllocStackReg(GetTypeNo(BlockInfo, BVal.FVal1));
5772 if not MakeNil(BVal.FVal2.Pos, BVal.FVal2.Row, BVal.FVal2.Col, tmpp) then
5773 begin
5774 tmpp.Free;;
5775 Result := False;
5776 exit;
5777 end;
5778 tmpc := TPSValueReplace.Create;
5779 with TPSValueReplace(tmpc) do
5780 begin
5781 OldValue := BVal.FVal2;
5782 NewValue := tmpp;
5783 end;
5784 BVal.FVal2 := tmpc;
5785 end;
5786 if GetTypeNo(BlockInfo, BVal.FVal1).BaseType = btExtClass then
5787 begin
5788 if not TPSUndefinedClassType(GetTypeNo(BlockInfo, BVal.FVal1)).ExtClass.CompareClass(GetTypeNo(BlockInfo, Bval.FVal2), ProcNo) then
5789 begin
5790 Result := False;
5791 exit;
5792 end;
5793 tmpp := TPSValueProcNo.Create;
5794 with TPSValueProcNo(tmpp) do
5795 begin
5796 ResultType := at2ut(FDefaultBoolType);
5797 Parameters := TPSParameters.Create;
5798 ProcNo := procno;
5799 Pos := BVal.Pos;
5800 Col := BVal.Col;
5801 Row := BVal.Row;
5802 with parameters.Add do
5803 begin
5804 Val := BVal.FVal1;
5805 ExpectedType := GetTypeNo(BlockInfo, Val);
5806 end;
5807 with parameters.Add do
5808 begin
5809 Val := BVal.FVal2;
5810 ExpectedType := GetTypeNo(BlockInfo, Val);
5811 end;
5812 end;
5813 if Bval.Operator = otNotEqual then
5814 begin
5815 tmpc := TPSUnValueOp.Create;
5816 TPSUnValueOp(tmpc).Operator := otNot;
5817 TPSUnValueOp(tmpc).Val1 := tmpp;
5818 TPSUnValueOp(tmpc).aType := GetTypeNo(BlockInfo, tmpp);
5819 end else tmpc := tmpp;
5820 Result := WriteCalculation(tmpc, Output);
5821 with TPSValueProcNo(tmpp) do
5822 begin
5823 Parameters[0].Val := nil;
5824 Parameters[1].Val := nil;
5825 end;
5826 tmpc.Free;
5827 if BVal.Val1.ClassType = TPSValueReplace then
5828 begin
5829 tmpp := TPSValueReplace(BVal.Val1).OldValue;
5830 BVal.Val1.Free;
5831 BVal.Val1 := tmpp;
5832 end;
5833 if BVal.Val2.ClassType = TPSValueReplace then
5834 begin
5835 tmpp := TPSValueReplace(BVal.Val2).OldValue;
5836 BVal.Val2.Free;
5837 BVal.Val2 := tmpp;
5838 end;
5839 exit;
5840 end;
5841 if not (PreWriteOutRec(Output, nil) and PreWriteOutRec(BVal.FVal1, GetTypeNo(BlockInfo, BVal.FVal2)) and PreWriteOutRec(BVal.FVal2, GetTypeNo(BlockInfo, BVal.FVal1))) then
5842 begin
5843 Result := False;
5844 exit;
5845 end;
5846 BlockWriteByte(BlockInfo, CM_CO);
5847 case BVal.Operator of
5848 otGreaterEqual: BlockWriteByte(BlockInfo, 0);
5849 otLessEqual: BlockWriteByte(BlockInfo, 1);
5850 otGreater: BlockWriteByte(BlockInfo, 2);
5851 otLess: BlockWriteByte(BlockInfo, 3);
5852 otEqual: BlockWriteByte(BlockInfo, 5);
5853 otNotEqual: BlockWriteByte(BlockInfo, 4);
5854 otIn: BlockWriteByte(BlockInfo, 6);
5855 otIs: BlockWriteByte(BlockInfo, 7);
5856 end;
5857
5858 if not (WriteOutRec(Output, False) and writeOutRec(BVal.FVal1, True) and writeOutRec(BVal.FVal2, True)) then
5859 begin
5860 Result := False;
5861 exit;
5862 end;
5863 AfterWriteOutrec(BVal.FVal1);
5864 AfterWriteOutrec(BVal.FVal2);
5865 AfterWriteOutrec(Output);
5866 if BVal.Val1.ClassType = TPSValueReplace then
5867 begin
5868 tmpp := TPSValueReplace(BVal.Val1).OldValue;
5869 BVal.Val1.Free;
5870 BVal.Val1 := tmpp;
5871 end;
5872 if BVal.Val2.ClassType = TPSValueReplace then
5873 begin
5874 tmpp := TPSValueReplace(BVal.Val2).OldValue;
5875 BVal.Val2.Free;
5876 BVal.Val2 := tmpp;
5877 end;
5878 end else begin
5879 if (BVal.aType <> nil) and (BVal.aType <> GetTypeNo(BlockInfo, Output)) then begin
5880 tmpp := AllocStackReg(BVal.aType);
5881 PreWriteOutrec(tmpp, nil);
5882 DoBinCalc(BVal, tmpp);
5883 afterwriteoutrec(tmpp);
5884 result := WriteCalculation(tmpp, output);
5885 tmpp.Free;
5886 exit;
5887 end;
5888
5889 if not PreWriteOutRec(Output, nil) then
5890 begin
5891 Result := False;
5892 exit;
5893 end;
5894 if not SameReg(Output, BVal.Val1) then
5895 begin
5896 if not WriteCalculation(BVal.FVal1, Output) then
5897 begin
5898 Result := False;
5899 exit;
5900 end;
5901 end;
5902 if (FBooleanShortCircuit) and (IsBoolean(BVal.aType)) then
5903 begin
5904 if BVal.Operator = otAnd then
5905 begin
5906 BlockWriteByte(BlockInfo, Cm_CNG);
5907 jover := Length(BlockInfo.Proc.FData);
5908 BlockWriteLong(BlockInfo, 0);
5909 WriteOutRec(Output, True);
5910 jend := Length(BlockInfo.Proc.FData);
5911 end else if BVal.Operator = otOr then
5912 begin
5913 BlockWriteByte(BlockInfo, Cm_CG);
5914 jover := Length(BlockInfo.Proc.FData);
5915 BlockWriteLong(BlockInfo, 0);
5916 WriteOutRec(Output, True);
5917 jend := Length(BlockInfo.Proc.FData);
5918 end else
5919 begin
5920 jover := 0;
5921 jend := 0;
5922 end;
5923 end else
5924 begin
5925 jover := 0;
5926 jend := 0;
5927 end;
5928 if not PreWriteOutrec(BVal.FVal2, GetTypeNo(BlockInfo, Output)) then
5929 begin
5930 Result := False;
5931 exit;
5932 end;
5933 BlockWriteByte(BlockInfo, Cm_CA);
5934 if BVAL.Operator = otIntDiv then
5935 BlockWriteByte(BlockInfo, Ord(otDiv))
5936 else
5937 BlockWriteByte(BlockInfo, Ord(BVal.Operator));
5938 if not (WriteOutRec(Output, False) and WriteOutRec(BVal.FVal2, True)) then
5939 begin
5940 Result := False;
5941 exit;
5942 end;
5943 AfterWriteOutRec(BVal.FVal2);
5944 if FBooleanShortCircuit and (IsBoolean(BVal.aType)) and (JOver <> JEnd) then
5945 begin
5946 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
5947 unaligned(Cardinal((@BlockInfo.Proc.FData[jover+1])^)) := Cardinal(Length(BlockInfo.Proc.FData)) - jend;
5948 {$else}
5949 Cardinal((@BlockInfo.Proc.FData[jover+1])^) := Cardinal(Length(BlockInfo.Proc.FData)) - jend;
5950 {$endif}
5951 end;
5952 AfterWriteOutRec(Output);
5953 end;
5954 Result := True;
5955 end;
5956
DoUnCalcnull5957 function DoUnCalc(Val: TPSUnValueOp; Output: TPSValue): Boolean;
5958 var
5959 Tmp: TPSValue;
5960 begin
5961 if not PreWriteOutRec(Output, nil) then
5962 begin
5963 Result := False;
5964 exit;
5965 end;
5966 case Val.Operator of
5967 otNot:
5968 begin
5969 if not SameReg(Val.FVal1, Output) then
5970 begin
5971 if not WriteCalculation(Val.FVal1, Output) then
5972 begin
5973 Result := False;
5974 exit;
5975 end;
5976 end;
5977 if IsBoolean(GetTypeNo(BlockInfo, Val)) then
5978 BlockWriteByte(BlockInfo, cm_bn)
5979 else
5980 BlockWriteByte(BlockInfo, cm_in);
5981 if not WriteOutRec(Output, True) then
5982 begin
5983 Result := False;
5984 exit;
5985 end;
5986 end;
5987 otMinus:
5988 begin
5989 if not SameReg(Val.FVal1, Output) then
5990 begin
5991 if not WriteCalculation(Val.FVal1, Output) then
5992 begin
5993 Result := False;
5994 exit;
5995 end;
5996 end;
5997 BlockWriteByte(BlockInfo, cm_vm);
5998 if not WriteOutRec(Output, True) then
5999 begin
6000 Result := False;
6001 exit;
6002 end;
6003 end;
6004 otCast:
6005 begin
6006 if ((Val.aType.BaseType = btChar) and (Val.aType.BaseType <> btU8)) {$IFNDEF PS_NOWIDESTRING}or
6007 ((Val.aType.BaseType = btWideChar) and (Val.aType.BaseType <> btU16)){$ENDIF} then
6008 begin
6009 Tmp := AllocStackReg(Val.aType);
6010 end else
6011 Tmp := Output;
6012 if not (PreWriteOutRec(Val.FVal1, GetTypeNo(BlockInfo, Tmp)) and PreWriteOutRec(Tmp, GetTypeNo(BlockInfo, Tmp))) then
6013 begin
6014 Result := False;
6015 if tmp <> Output then Tmp.Free;
6016 exit;
6017 end;
6018 BlockWriteByte(BlockInfo, CM_A);
6019 if not (WriteOutRec(Tmp, False) and WriteOutRec(Val.FVal1, True)) then
6020 begin
6021 Result := false;
6022 if tmp <> Output then Tmp.Free;
6023 exit;
6024 end;
6025 AfterWriteOutRec(val.Fval1);
6026 if Tmp <> Output then
6027 begin
6028 if not WriteCalculation(Tmp, Output) then
6029 begin
6030 Result := false;
6031 Tmp.Free;
6032 exit;
6033 end;
6034 end;
6035 AfterWriteOutRec(Tmp);
6036 if Tmp <> Output then
6037 Tmp.Free;
6038 end;
6039 {else donothing}
6040 end;
6041 AfterWriteOutRec(Output);
6042 Result := True;
6043 end;
6044
6045
GetAddressnull6046 function GetAddress(Val: TPSValue): Cardinal;
6047 begin
6048 if Val.ClassType = TPSValueGlobalVar then
6049 Result := TPSValueGlobalVar(val).GlobalVarNo
6050 else if Val.ClassType = TPSValueLocalVar then
6051 Result := PSAddrStackStart + TPSValueLocalVar(val).LocalVarNo + 1
6052 else if Val.ClassType = TPSValueParamVar then
6053 Result := PSAddrStackStart - TPSValueParamVar(val).ParamNo -1
6054 else if Val.ClassType = TPSValueAllocatedStackVar then
6055 Result := PSAddrStackStart + TPSValueAllocatedStackVar(val).LocalVarNo + 1
6056 else
6057 Result := InvalidVal;
6058 end;
6059
6060
PreWriteOutRecnull6061 function PreWriteOutRec(var X: TPSValue; FArrType: TPSType): Boolean;
6062 var
6063 rr: TPSSubItem;
6064 tmpp,
6065 tmpc: TPSValue;
6066 i: Longint;
MakeSetnull6067 function MakeSet(SetType: TPSSetType; arr: TPSValueArray): Boolean;
6068 var
6069 c, i: Longint;
6070 dataval: TPSValueData;
6071 mType: TPSType;
6072 begin
6073 Result := True;
6074 dataval := TPSValueData.Create;
6075 dataval.Data := NewVariant(FarrType);
6076 for i := 0 to arr.count -1 do
6077 begin
6078 mType := GetTypeNo(BlockInfo, arr.Item[i]);
6079 if (mType <> SetType.SetType) and not (IsIntType(mType.FBaseType) and IsIntType(SetType.SetType.BaseType)) then
6080 begin
6081 with MakeError('', ecTypeMismatch, '') do
6082 begin
6083 FCol := arr.item[i].Col;
6084 FRow := arr.item[i].Row;
6085 FPosition := arr.item[i].Pos;
6086 end;
6087 DataVal.Free;
6088 Result := False;
6089 exit;
6090 end;
6091 if arr.Item[i] is TPSValueData then
6092 begin
6093 c := GetInt(TPSValueData(arr.Item[i]).Data, Result);
6094 if not Result then
6095 begin
6096 dataval.Free;
6097 exit;
6098 end;
6099 if (c < Low(Byte)) or (c > High(Byte)) then
6100 begin
6101 with MakeError('', ecTypeMismatch, '') do
6102 begin
6103 FCol := arr.item[i].Col;
6104 FRow := arr.item[i].Row;
6105 FPosition := arr.item[i].Pos;
6106 end;
6107 DataVal.Free;
6108 Result := False;
6109 exit;
6110 end;
6111 Set_MakeMember(c, dataval.Data.tstring);
6112 end else
6113 begin
6114 DataVal.Free;
6115 MakeError('', ecTypeMismatch, '');
6116 Result := False;
6117 exit;
6118 end;
6119 end;
6120 tmpc := TPSValueReplace.Create;
6121 with TPSValueReplace(tmpc) do
6122 begin
6123 OldValue := x;
6124 NewValue := dataval;
6125 PreWriteAllocated := True;
6126 end;
6127 x := tmpc;
6128 end;
6129 begin
6130 Result := True;
6131 if x.ClassType = TPSValueReplace then
6132 begin
6133 if TPSValueReplace(x).PreWriteAllocated then
6134 begin
6135 inc(TPSValueReplace(x).FReplaceTimes);
6136 end;
6137 end else
6138 if x.ClassType = TPSValueProcPtr then
6139 begin
6140 if FArrType = nil then
6141 begin
6142 MakeError('', ecTypeMismatch, '');
6143 Result := False;
6144 Exit;
6145 end;
6146 tmpp := TPSValueData.Create;
6147 TPSValueData(tmpp).Data := NewVariant(FArrType);
6148 TPSValueData(tmpp).Data.tu32 := TPSValueProcPtr(x).ProcPtr;
6149 tmpc := TPSValueReplace.Create;
6150 with TPSValueReplace(tmpc) do
6151 begin
6152 PreWriteAllocated := True;
6153 OldValue := x;
6154 NewValue := tmpp;
6155 end;
6156 x := tmpc;
6157 end else
6158 if x.ClassType = TPSValueNil then
6159 begin
6160 if FArrType = nil then
6161 begin
6162 MakeError('', ecTypeMismatch, '');
6163 Result := False;
6164 Exit;
6165 end;
6166 tmpp := AllocStackReg(FArrType);
6167 if not MakeNil(x.Pos, x.Row, x.Col, tmpp) then
6168 begin
6169 tmpp.Free;
6170 Result := False;
6171 exit;
6172 end;
6173 tmpc := TPSValueReplace.Create;
6174 with TPSValueReplace(tmpc) do
6175 begin
6176 PreWriteAllocated := True;
6177 OldValue := x;
6178 NewValue := tmpp;
6179 end;
6180 x := tmpc;
6181 end else
6182 if x.ClassType = TPSValueArray then
6183 begin
6184 if FArrType = nil then
6185 begin
6186 MakeError('', ecTypeMismatch, '');
6187 Result := False;
6188 Exit;
6189 end;
6190 if TPSType(FArrType).BaseType = btSet then
6191 begin
6192 Result := MakeSet(TPSSetType(FArrType), TPSValueArray(x));
6193 exit;
6194 end;
6195 if TPSType(FarrType).BaseType = btVariant then
6196 FArrType := at2ut(FindAndAddType(self, '!OPENARRAYOFVARIANT', 'array of Variant'));
6197 if TPSType(FarrType).BaseType <> btArray then
6198 FArrType := at2ut(FindAndAddType(self, '!OPENARRAYOFVARIANT', 'array of Variant'));
6199
6200 tmpp := AllocStackReg(FArrType);
6201 tmpc := AllocStackReg(FindBaseType(bts32));
6202 BlockWriteByte(BlockInfo, CM_A);
6203 WriteOutrec(tmpc, False);
6204 BlockWriteByte(BlockInfo, 1);
6205 BlockWriteLong(BlockInfo, FindBaseType(bts32).FinalTypeNo);
6206 BlockWriteLong(BlockInfo, TPSValueArray(x).Count);
6207 BlockWriteByte(BlockInfo, CM_PV);
6208 WriteOutrec(tmpp, False);
6209 BlockWriteByte(BlockInfo, CM_C);
6210 BlockWriteLong(BlockInfo, FindProc('SetArrayLength'));
6211 BlockWriteByte(BlockInfo, CM_PO);
6212 tmpc.Free;
6213 rr := TPSSubNumber.Create;
6214 rr.aType := TPSArrayType(FArrType).ArrayTypeNo;
6215 TPSValueVar(tmpp).RecAdd(rr);
6216 for i := 0 to TPSValueArray(x).Count -1 do
6217 begin
6218 TPSSubNumber(rr).SubNo := i;
6219 tmpc := TPSValueArray(x).Item[i];
6220 if not PreWriteOutRec(tmpc, GetTypeNo(BlockInfo, tmpc)) then
6221 begin
6222 tmpp.Free;
6223 Result := false;
6224 exit;
6225 end;
6226 if TPSArrayType(FArrType).ArrayTypeNo.BaseType = btPointer then
6227 BlockWriteByte(BlockInfo, cm_spc)
6228 else
6229 BlockWriteByte(BlockInfo, cm_a);
6230 if not (WriteOutrec(tmpp, False) and WriteOutRec(tmpc, True)) then
6231 begin
6232 Tmpp.Free;
6233 Result := false;
6234 exit;
6235 end;
6236 AfterWriteOutRec(tmpc);
6237 end;
6238 TPSValueVar(tmpp).RecDelete(0);
6239 tmpc := TPSValueReplace.Create;
6240 with TPSValueReplace(tmpc) do
6241 begin
6242 PreWriteAllocated := True;
6243 OldValue := x;
6244 NewValue := tmpp;
6245 end;
6246 x := tmpc;
6247 end else if (x.ClassType = TPSUnValueOp) then
6248 begin
6249 tmpp := AllocStackReg(GetTypeNo(BlockInfo, x));
6250 if not DoUnCalc(TPSUnValueOp(x), tmpp) then
6251 begin
6252 Result := False;
6253 exit;
6254 end;
6255 tmpc := TPSValueReplace.Create;
6256 with TPSValueReplace(tmpc) do
6257 begin
6258 PreWriteAllocated := True;
6259 OldValue := x;
6260 NewValue := tmpp;
6261 end;
6262 x := tmpc;
6263 end else if (x.ClassType = TPSBinValueOp) then
6264 begin
6265 tmpp := AllocStackReg(GetTypeNo(BlockInfo, x));
6266 if not DoBinCalc(TPSBinValueOp(x), tmpp) then
6267 begin
6268 tmpp.Free;
6269 Result := False;
6270 exit;
6271 end;
6272 tmpc := TPSValueReplace.Create;
6273 with TPSValueReplace(tmpc) do
6274 begin
6275 PreWriteAllocated := True;
6276 OldValue := x;
6277 NewValue := tmpp;
6278 end;
6279 x := tmpc;
6280 end else if x is TPSValueProc then
6281 begin
6282 tmpp := AllocStackReg(TPSValueProc(x).ResultType);
6283 if not WriteCalculation(x, tmpp) then
6284 begin
6285 tmpp.Free;
6286 Result := False;
6287 exit;
6288 end;
6289 tmpc := TPSValueReplace.Create;
6290 with TPSValueReplace(tmpc) do
6291 begin
6292 PreWriteAllocated := True;
6293 OldValue := x;
6294 NewValue := tmpp;
6295 end;
6296 x := tmpc;
6297 end else if (x is TPSValueVar) and (TPSValueVar(x).RecCount <> 0) then
6298 begin
6299 if TPSValueVar(x).RecCount = 1 then
6300 begin
6301 rr := TPSValueVar(x).RecItem[0];
6302 if rr.ClassType <> TPSSubValue then
6303 exit; // there is no need pre-calculate anything
6304 if (TPSSubValue(rr).SubNo is TPSValueVar) and (TPSValueVar(TPSSubValue(rr).SubNo).RecCount = 0) then
6305 exit;
6306 end; //if
6307 tmpp := AllocPointer(GetTypeNo(BlockInfo, x));
6308 BlockWriteByte(BlockInfo, cm_sp);
6309 WriteOutRec(tmpp, True);
6310 BlockWriteByte(BlockInfo, 0);
6311 BlockWriteLong(BlockInfo, GetAddress(x));
6312 for i := 0 to TPSValueVar(x).RecCount - 1 do
6313 begin
6314 rr := TPSValueVar(x).RecItem[I];
6315 if rr.ClassType = TPSSubNumber then
6316 begin
6317 BlockWriteByte(BlockInfo, cm_sp);
6318 WriteOutRec(tmpp, false);
6319 BlockWriteByte(BlockInfo, 2);
6320 BlockWriteLong(BlockInfo, GetAddress(tmpp));
6321 BlockWriteLong(BlockInfo, TPSSubNumber(rr).SubNo);
6322 end else begin // if rr.classtype = TPSSubValue then begin
6323 tmpc := AllocStackReg(FindBaseType(btU32));
6324 if not WriteCalculation(TPSSubValue(rr).SubNo, tmpc) then
6325 begin
6326 tmpc.Free;
6327 tmpp.Free;
6328 Result := False;
6329 exit;
6330 end; //if
6331 BlockWriteByte(BlockInfo, cm_sp);
6332 WriteOutRec(tmpp, false);
6333 BlockWriteByte(BlockInfo, 3);
6334 BlockWriteLong(BlockInfo, GetAddress(tmpp));
6335 BlockWriteLong(BlockInfo, GetAddress(tmpc));
6336 tmpc.Free;
6337 end;
6338 end; // for
6339 tmpc := TPSValueReplace.Create;
6340 with TPSValueReplace(tmpc) do
6341 begin
6342 OldValue := x;
6343 NewValue := tmpp;
6344 PreWriteAllocated := True;
6345 end;
6346 x := tmpc;
6347 end;
6348
6349 end;
6350
6351 procedure AfterWriteOutRec(var x: TPSValue);
6352 var
6353 tmp: TPSValue;
6354 begin
6355 if (x.ClassType = TPSValueReplace) and (TPSValueReplace(x).PreWriteAllocated) then
6356 begin
6357 Dec(TPSValueReplace(x).FReplaceTimes);
6358 if TPSValueReplace(x).ReplaceTimes = 0 then
6359 begin
6360 tmp := TPSValueReplace(x).OldValue;
6361 x.Free;
6362 x := tmp;
6363 end;
6364 end;
6365 end; //afterwriteoutrec
6366
WriteOutRecnull6367 function WriteOutRec(x: TPSValue; AllowData: Boolean): Boolean;
6368 var
6369 rr: TPSSubItem;
6370 begin
6371 Result := True;
6372 if x.ClassType = TPSValueReplace then
6373 Result := WriteOutRec(TPSValueReplace(x).NewValue, AllowData)
6374 else if x is TPSValueVar then
6375 begin
6376 if TPSValueVar(x).RecCount = 0 then
6377 begin
6378 BlockWriteByte(BlockInfo, 0);
6379 BlockWriteLong(BlockInfo, GetAddress(x));
6380 end
6381 else
6382 begin
6383 rr := TPSValueVar(x).RecItem[0];
6384 if rr.ClassType = TPSSubNumber then
6385 begin
6386 BlockWriteByte(BlockInfo, 2);
6387 BlockWriteLong(BlockInfo, GetAddress(x));
6388 BlockWriteLong(BlockInfo, TPSSubNumber(rr).SubNo);
6389 end
6390 else
6391 begin
6392 BlockWriteByte(BlockInfo, 3);
6393 BlockWriteLong(BlockInfo, GetAddress(x));
6394 BlockWriteLong(BlockInfo, GetAddress(TPSSubValue(rr).SubNo));
6395 end;
6396 end;
6397 end else if x.ClassType = TPSValueData then
6398 begin
6399 if AllowData then
6400 begin
6401 BlockWriteByte(BlockInfo, 1);
6402 BlockWriteVariant(BlockInfo, TPSValueData(x).Data)
6403 end
6404 else
6405 begin
6406 Result := False;
6407 exit;
6408 end;
6409 end else
6410 Result := False;
6411 end;
6412
6413 function ReadParameters(IsProperty: Boolean; Dest: TPSParameters): Boolean; forward;
6414 {$IFNDEF PS_NOIDISPATCH}
6415 function ReadIDispatchParameters(const ProcName: tbtString; aVariantType: TPSVariantType; FSelf: TPSValue): TPSValue; forward;
6416 {$ENDIF}
6417 function ReadProcParameters(ProcNo: Cardinal; FSelf: TPSValue): TPSValue; forward;
6418 function ReadVarParameters(ProcNoVar: TPSValue): TPSValue; forward;
6419
6420 function calc(endOn: TPSPasToken): TPSValue; forward;
6421 procedure CheckNotificationVariant(var Val: TPSValue);
6422 var
6423 aType: TPSType;
6424 Call: TPSValueProcNo;
6425 tmp: TPSValue;
6426 begin
6427 if not (Val is TPSValueGlobalVar) then exit;
6428 aType := GetTypeNo(BlockInfo, Val);
6429 if (AType = nil) or (AType.BaseType <> btNotificationVariant) then exit;
6430 if FParser.CurrTokenId = CSTI_Assignment then
6431 begin
6432 Call := TPSValueProcNo.Create;
6433 Call.ResultType := nil;
6434 Call.SetParserPos(FParser);
6435 Call.ProcNo := FindProc('!NOTIFICATIONVARIANTSET');;
6436 Call.SetParserPos(FParser);
6437 Call.Parameters := TPSParameters.Create;
6438 Tmp := TPSValueData.Create;
6439 TPSVAlueData(tmp).Data := NewVariant(at2ut(FindBaseType(btString)));
6440 tbtString(TPSValueData(tmp).Data.tstring) := TPSVar(FVars[TPSValueGlobalVar(Val).GlobalVarNo]).OrgName;
6441 with call.Parameters.Add do
6442 begin
6443 Val := tmp;
6444 ExpectedType := TPSValueData(tmp).Data.FType;
6445 end;
6446 FParser.Next;
6447 tmp := Calc(CSTI_SemiColon);
6448 if tmp = nil then
6449 begin
6450 Val.Free;
6451 Val := nil;
6452 exit;
6453 end;
6454 with Call.Parameters.Add do
6455 begin
6456 Val := tmp;
6457 ExpectedType := at2ut(FindBaseType(btVariant));
6458 end;
6459 Val.Free;
6460 Val := Call;
6461 end else begin
6462 Call := TPSValueProcNo.Create;
6463 Call.ResultType := AT2UT(FindBaseType(btVariant));
6464 Call.SetParserPos(FParser);
6465 Call.ProcNo := FindProc('!NOTIFICATIONVARIANTGET');
6466 Call.SetParserPos(FParser);
6467 Call.Parameters := TPSParameters.Create;
6468 Tmp := TPSValueData.Create;
6469 TPSVAlueData(tmp).Data := NewVariant(at2ut(FindBaseType(btString)));
6470 tbtString(TPSValueData(tmp).Data.tstring) := TPSVar(FVars[TPSValueGlobalVar(Val).GlobalVarNo]).OrgName;
6471 with call.Parameters.Add do
6472 begin
6473 Val := tmp;
6474 ExpectedType := TPSValueData(tmp).Data.FType;
6475 end;
6476 Val.Free;
6477 Val := Call;
6478 end;
6479 end;
6480
6481 procedure CheckProcCall(var x: TPSValue);
6482 var
6483 aType: TPSType;
6484 begin
6485 if FParser.CurrTokenId in [CSTI_Dereference, CSTI_OpenRound] then
6486 begin
6487 aType := GetTypeNo(BlockInfo, x);
6488 if (aType = nil) or (aType.BaseType <> btProcPtr) then
6489 begin
6490 MakeError('', ecTypeMismatch, '');
6491 x.Free;
6492 x := nil;
6493 Exit;
6494 end;
6495 if FParser.CurrTokenId = CSTI_Dereference then
6496 FParser.Next;
6497 x := ReadVarParameters(x);
6498 end;
6499 end;
6500
6501 procedure CheckFurther(var x: TPSValue; ImplicitPeriod: Boolean);
6502 var
6503 t: Cardinal;
6504 rr: TPSSubItem;
6505 L: Longint;
6506 u: TPSType;
6507 Param: TPSParameter;
6508 tmp, tmpn: TPSValue;
6509 tmp3: TPSValueProcNo;
6510 tmp2: Boolean;
6511
FindSubRnull6512 function FindSubR(const n: tbtString; FType: TPSType): Cardinal;
6513 var
6514 h, I: Longint;
6515 rvv: PIFPSRecordFieldTypeDef;
6516 begin
6517 h := MakeHash(n);
6518 for I := 0 to TPSRecordType(FType).RecValCount - 1 do
6519 begin
6520 rvv := TPSRecordType(FType).RecVal(I);
6521 if (rvv.FieldNameHash = h) and (rvv.FieldName = n) then
6522 begin
6523 Result := I;
6524 exit;
6525 end;
6526 end;
6527 Result := InvalidVal;
6528 end;
6529
6530 begin
6531 (* if not (x is TPSValueVar) then
6532 Exit;*)
6533 u := GetTypeNo(BlockInfo, x);
6534 if u = nil then exit;
6535 while True do
6536 begin
6537 if (u.BaseType = btClass) {$IFNDEF PS_NOINTERFACES}or (u.BaseType = btInterface){$ENDIF}
6538 {$IFNDEF PS_NOIDISPATCH}or ((u.BaseType = btNotificationVariant)){$ENDIF} or (u.BaseType = btExtClass) then exit;
6539 if FParser.CurrTokenId = CSTI_OpenBlock then
6540 begin
6541 if (u.BaseType = btString) {$IFNDEF PS_NOWIDESTRING} or
6542 (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) {$ENDIF}
6543 {$IFDEF PS_HAVEVARIANT}or (u.BaseType = btVariant){$ENDIF} then
6544 begin
6545 FParser.Next;
6546 tmp := Calc(CSTI_CloseBlock);
6547 if tmp = nil then
6548 begin
6549 x.Free;
6550 x := nil;
6551 exit;
6552 end;
6553 if not IsIntType(GetTypeNo(BlockInfo, tmp).BaseType) then
6554 begin
6555 MakeError('', ecTypeMismatch, '');
6556 tmp.Free;
6557 x.Free;
6558 x := nil;
6559 exit;
6560 end;
6561 FParser.Next;
6562 if FParser.CurrTokenId = CSTI_Assignment then
6563 begin
6564 if not (x is TPSValueVar) then begin
6565 MakeError('', ecVariableExpected, '');
6566 tmp.Free;
6567 x.Free;
6568 x := nil;
6569 exit;
6570 end;
6571 {$IFDEF PS_HAVEVARIANT}if (u.BaseType = btVariant) then
6572 l := FindProc('VarArraySet') else
6573 {$ENDIF}
6574 {$IFNDEF PS_NOWIDESTRING}
6575 if (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) then
6576 l := FindProc('WStrSet')
6577 else
6578 {$ENDIF}
6579 l := FindProc('StrSet');
6580 if l = -1 then
6581 begin
6582 MakeError('', ecUnknownIdentifier, 'StrSet');
6583 tmp.Free;
6584 x.Free;
6585 x := nil;
6586 exit;
6587 end;
6588 tmp3 := TPSValueProcNo.Create;
6589 tmp3.ResultType := nil;
6590 tmp3.SetParserPos(FParser);
6591 tmp3.ProcNo := L;
6592 tmp3.SetParserPos(FParser);
6593 tmp3.Parameters := TPSParameters.Create;
6594 param := tmp3.Parameters.Add;
6595 with tmp3.Parameters.Add do
6596 begin
6597 Val := tmp;
6598 ExpectedType := GetTypeNo(BlockInfo, tmp);
6599 {$IFDEF DEBUG}
6600 if not ExpectedType.Used then asm int 3; end;
6601 {$ENDIF}
6602 end;
6603 with tmp3.Parameters.Add do
6604 begin
6605 Val := x;
6606 ExpectedType := GetTypeNo(BlockInfo, x);
6607 {$IFDEF DEBUG}
6608 if not ExpectedType.Used then asm int 3; end;
6609 {$ENDIF}
6610 ParamMode := pmInOut;
6611 end;
6612 x := tmp3;
6613 FParser.Next;
6614 tmp := Calc(CSTI_SemiColon);
6615 if tmp = nil then
6616 begin
6617 x.Free;
6618 x := nil;
6619 exit;
6620 end;
6621 {$IFDEF PS_HAVEVARIANT}if (u.BaseType <> btVariant) then {$ENDIF}
6622 begin
6623 if (GetTypeNo(BlockInfo, Tmp).BaseType <> btChar)
6624 {$IFNDEF PS_NOWIDESTRING} and (GetTypeno(BlockInfo, Tmp).BaseType <> btWideChar) {$ENDIF} then
6625 begin
6626 x.Free;
6627 x := nil;
6628 Tmp.Free;
6629 MakeError('', ecTypeMismatch, '');
6630 exit;
6631
6632 end;
6633 end;
6634 param.Val := tmp;
6635 {$IFDEF PS_HAVEVARIANT}
6636 if u.BaseType = btVariant then
6637 Param.ExpectedType := u else{$ENDIF}
6638 Param.ExpectedType := GetTypeNo(BlockInfo, tmp);
6639 {$IFDEF DEBUG}
6640 if not Param.ExpectedType.Used then asm int 3; end;
6641 {$ENDIF}
6642 end else begin
6643 {$IFDEF PS_HAVEVARIANT}if (u.BaseType = btVariant) then
6644 l := FindProc('VarArrayGet') else
6645 {$ENDIF}
6646 {$IFNDEF PS_NOWIDESTRING}
6647 if (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) then
6648 l := FindProc('WStrGet')
6649 else
6650 {$ENDIF}
6651 l := FindProc('StrGet');
6652 if l = -1 then
6653 begin
6654 MakeError('', ecUnknownIdentifier, 'StrGet');
6655 tmp.Free;
6656 x.Free;
6657 x := nil;
6658 exit;
6659 end;
6660 tmp3 := TPSValueProcNo.Create;
6661 {$IFDEF PS_HAVEVARIANT}if (u.BaseType = btVariant) then
6662 tmp3.ResultType := FindBaseType(btVariant) else
6663 {$ENDIF}
6664 {$IFNDEF PS_NOWIDESTRING}
6665 if (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) then
6666 tmp3.ResultType := FindBaseType(btWideChar)
6667 else
6668 {$ENDIF}
6669 tmp3.ResultType := FindBaseType(btChar);
6670 tmp3.ProcNo := L;
6671 tmp3.SetParserPos(FParser);
6672 tmp3.Parameters := TPSParameters.Create;
6673 with tmp3.Parameters.Add do
6674 begin
6675 Val := x;
6676 ExpectedType := GetTypeNo(BlockInfo, x);
6677 {$IFDEF DEBUG}
6678 if not ExpectedType.Used then asm int 3; end;
6679 {$ENDIF}
6680
6681 if x is TPSValueVar then
6682 ParamMode := pmInOut
6683 else
6684 parammode := pmIn;
6685 end;
6686 with tmp3.Parameters.Add do
6687 begin
6688 Val := tmp;
6689 ExpectedType := GetTypeNo(BlockInfo, tmp);
6690 {$IFDEF DEBUG}
6691 if not ExpectedType.Used then asm int 3; end;
6692 {$ENDIF}
6693 end;
6694 x := tmp3;
6695 end;
6696 Break;
6697 end else if ((u.BaseType = btArray) or (u.BaseType = btStaticArray)) and (x is TPSValueVar) then
6698 begin
6699 FParser.Next;
6700 tmp := calc(CSTI_CloseBlock);
6701 if tmp = nil then
6702 begin
6703 x.Free;
6704 x := nil;
6705 exit;
6706 end;
6707 if not IsIntType(GetTypeNo(BlockInfo, tmp).BaseType) then
6708 begin
6709 MakeError('', ecTypeMismatch, '');
6710 tmp.Free;
6711 x.Free;
6712 x := nil;
6713 exit;
6714 end;
6715 if (tmp.ClassType = TPSValueData) then
6716 begin
6717 rr := TPSSubNumber.Create;
6718 TPSValueVar(x).RecAdd(rr);
6719 if (u.BaseType = btStaticArray) then
6720 TPSSubNumber(rr).SubNo := Cardinal(GetInt(TPSValueData(tmp).Data, tmp2) - TPSStaticArrayType(u).StartOffset)
6721 else
6722 TPSSubNumber(rr).SubNo := GetUInt(TPSValueData(tmp).Data, tmp2);
6723 tmp.Free;
6724 rr.aType := TPSArrayType(u).ArrayTypeNo;
6725 u := rr.aType;
6726 end
6727 else
6728 begin
6729 if (u.BaseType = btStaticArray) then
6730 begin
6731 tmpn := TPSBinValueOp.Create;
6732 TPSBinValueOp(tmpn).Operator := otSub;
6733 TPSBinValueOp(tmpn).Val1 := tmp;
6734 tmp := TPSValueData.Create;
6735 TPSValueData(tmp).Data := NewVariant(FindBaseType(btS32));
6736 TPSValueData(tmp).Data.ts32 := TPSStaticArrayType(u).StartOffset;
6737 TPSBinValueOp(tmpn).Val2 := tmp;
6738 TPSBinValueOp(tmpn).aType := FindBaseType(btS32);
6739 tmp := tmpn;
6740 end;
6741 rr := TPSSubValue.Create;
6742 TPSValueVar(x).recAdd(rr);
6743 TPSSubValue(rr).SubNo := tmp;
6744 rr.aType := TPSArrayType(u).ArrayTypeNo;
6745 u := rr.aType;
6746 end;
6747 if FParser.CurrTokenId <> CSTI_CloseBlock then
6748 begin
6749 MakeError('', ecCloseBlockExpected, '');
6750 x.Free;
6751 x := nil;
6752 exit;
6753 end;
6754 Fparser.Next;
6755 end else begin
6756 MakeError('', ecSemicolonExpected, '');
6757 x.Free;
6758 x := nil;
6759 exit;
6760 end;
6761 end
6762 else if ((FParser.CurrTokenId = CSTI_Period) or (ImplicitPeriod))
6763 {$IFDEF PS_HAVEVARIANT}and not (u.BaseType = btVariant){$ENDIF}
6764 then
6765 begin
6766 if not ImplicitPeriod then
6767 FParser.Next;
6768 if u.BaseType = btRecord then
6769 begin
6770 t := FindSubR(FParser.GetToken, u);
6771 if t = InvalidVal then
6772 begin
6773 if ImplicitPeriod then exit;
6774 MakeError('', ecUnknownIdentifier, FParser.GetToken);
6775 x.Free;
6776 x := nil;
6777 exit;
6778 end;
6779 if (x is TPSValueProcNo) then
6780 begin
6781 ImplicitPeriod := False;
6782 FParser.Next;
6783
6784 tmp := AllocStackReg(u);
6785 WriteCalculation(x,tmp);
6786 TPSVar(BlockInfo.Proc.FProcVars[TPSValueAllocatedStackVar(tmp).LocalVarNo]).Use;
6787
6788 rr := TPSSubNumber.Create;
6789 TPSValueVar(tmp).RecAdd(rr);
6790 TPSSubNumber(rr).SubNo := t;
6791 rr.aType := TPSRecordType(u).RecVal(t).FType;
6792 u := rr.aType;
6793
6794 tmpn := TPSValueReplace.Create;
6795 with TPSValueReplace(tmpn) do
6796 begin
6797 FreeOldValue := true;
6798 FreeNewValue := true;
6799 OldValue := tmp;
6800 NewValue := AllocStackReg(u);
6801 PreWriteAllocated := true;
6802 end;
6803
6804 if not WriteCalculation(tmp,TPSValueReplace(tmpn).NewValue) then
6805 begin
6806 {MakeError('',ecInternalError,'');}
6807 x.Free;
6808 x := nil;
6809 exit;
6810 end;
6811 x.Free;
6812 x := tmpn;
6813 end else
6814 begin
6815 if not (x is TPSValueVar) then begin
6816 MakeError('', ecVariableExpected, FParser.GetToken);
6817 x.Free;
6818 x := nil;
6819 exit;
6820 end;
6821 ImplicitPeriod := False;
6822 FParser.Next;
6823 rr := TPSSubNumber.Create;
6824 TPSValueVar(x).RecAdd(rr);
6825 TPSSubNumber(rr).SubNo := t;
6826 rr.aType := TPSRecordType(u).RecVal(t).FType;
6827 u := rr.aType;
6828 end;
6829 end
6830 {$IFDEF PS_HAVEVARIANT}
6831 else if (u.BaseType = btVariant) then break else
6832 {$ELSE}
6833 ;
6834 {$ENDIF}
6835
6836 begin
6837 x.Free;
6838 MakeError('', ecSemicolonExpected, '');
6839 x := nil;
6840 exit;
6841 end;
6842 end
6843 else
6844 break;
6845 end;
6846 end;
6847
6848
6849
6850 procedure CheckClassArrayProperty(var P: TPSValue; const VarType: TPSVariableType; VarNo: Cardinal);
6851 var
6852 Tempp: TPSValue;
6853 aType: TPSClassType;
6854 procno: Cardinal;
6855 Idx: TPSDelphiClassItem;
6856 Decl: TPSParametersDecl;
6857 begin
6858 if p = nil then exit;
6859 if (GetTypeNo(BlockInfo, p) = nil) or (GetTypeNo(BlockInfo, p).BaseType <> btClass) then exit;
6860 aType := TPSClassType(GetTypeNo(BlockInfo, p));
6861 if FParser.CurrTokenID = CSTI_OpenBlock then
6862 begin
6863 if not TPSClassType(aType).Cl.Property_Find('', Idx) then
6864 begin
6865 MakeError('', ecPeriodExpected, '');
6866 p.Free;
6867 p := nil;
6868 exit;
6869 end;
6870 if VarNo <> InvalidVal then
6871 begin
6872 if @FOnUseVariable <> nil then
6873 FOnUseVariable(Self, VarType, VarNo, BlockInfo.ProcNo, FParser.CurrTokenPos, '[Default]');
6874 end;
6875 Decl := TPSParametersDecl.Create;
6876 TPSClassType(aType).Cl.Property_GetHeader(Idx, Decl);
6877 tempp := p;
6878 P := TPSValueProcNo.Create;
6879 with TPSValueProcNo(P) do
6880 begin
6881 Parameters := TPSParameters.Create;
6882 Parameters.Add;
6883 end;
6884 if not (ReadParameters(True, TPSValueProc(P).Parameters) and
6885 ValidateParameters(BlockInfo, TPSValueProc(P).Parameters, Decl)) then
6886 begin
6887 tempp.Free;
6888 Decl.Free;
6889 p.Free;
6890 p := nil;
6891 exit;
6892 end;
6893 with TPSValueProcNo(p).Parameters[0] do
6894 begin
6895 Val := tempp;
6896 ExpectedType := GetTypeNo(BlockInfo, tempp);
6897 end;
6898 if FParser.CurrTokenId = CSTI_Assignment then
6899 begin
6900 FParser.Next;
6901 TempP := Calc(CSTI_SemiColon);
6902 if TempP = nil then
6903 begin
6904 Decl.Free;
6905 P.Free;
6906 p := nil;
6907 exit;
6908 end;
6909 with TPSValueProc(p).Parameters.Add do
6910 begin
6911 Val := Tempp;
6912 ExpectedType := at2ut(Decl.Result);
6913 end;
6914 if not TPSClassType(aType).Cl.Property_Set(Idx, procno) then
6915 begin
6916 Decl.Free;
6917 MakeError('', ecReadOnlyProperty, '');
6918 p.Free;
6919 p := nil;
6920 exit;
6921 end;
6922 TPSValueProcNo(p).ProcNo := procno;
6923 TPSValueProcNo(p).ResultType := nil;
6924 end
6925 else
6926 begin
6927 if not TPSClassType(aType).Cl.Property_Get(Idx, procno) then
6928 begin
6929 Decl.Free;
6930 MakeError('', ecWriteOnlyProperty, '');
6931 p.Free;
6932 p := nil;
6933 exit;
6934 end;
6935 TPSValueProcNo(p).ProcNo := procno;
6936 TPSValueProcNo(p).ResultType := TPSExternalProcedure(FProcs[procno]).RegProc.Decl.Result;
6937 end; // if FParser.CurrTokenId = CSTI_Assign
6938 Decl.Free;
6939 end;
6940 end;
6941
6942 procedure CheckExtClass(var P: TPSValue; const VarType: TPSVariableType; VarNo: Cardinal; ImplicitPeriod: Boolean);
6943 var
6944 Temp, Idx: Cardinal;
6945 FType: TPSType;
6946 s: tbtString;
6947
6948 begin
6949 FType := GetTypeNo(BlockInfo, p);
6950 if FType = nil then Exit;
6951 if FType.BaseType <> btExtClass then Exit;
6952 while (FParser.CurrTokenID = CSTI_Period) or (ImplicitPeriod) do
6953 begin
6954 if not ImplicitPeriod then
6955 FParser.Next;
6956 if FParser.CurrTokenID <> CSTI_Identifier then
6957 begin
6958 if ImplicitPeriod then exit;
6959 MakeError('', ecIdentifierExpected, '');
6960 p.Free;
6961 P := nil;
6962 Exit;
6963 end;
6964 s := FParser.GetToken;
6965 if TPSUndefinedClassType(FType).ExtClass.Func_Find(s, Idx) then
6966 begin
6967 FParser.Next;
6968 TPSUndefinedClassType(FType).ExtClass.Func_Call(Idx, Temp);
6969 P := ReadProcParameters(Temp, P);
6970 if p = nil then
6971 begin
6972 Exit;
6973 end;
6974 end else
6975 begin
6976 if ImplicitPeriod then exit;
6977 MakeError('', ecUnknownIdentifier, s);
6978 p.Free;
6979 P := nil;
6980 Exit;
6981 end;
6982 ImplicitPeriod := False;
6983 FType := GetTypeNo(BlockInfo, p);
6984 if (FType = nil) or (FType.BaseType <> btExtClass) then Exit;
6985 end; {while}
6986 end;
6987
6988 procedure CheckClass(var P: TPSValue; const VarType: TPSVariableType; VarNo: Cardinal; ImplicitPeriod: Boolean);
6989 var
6990 Procno: Cardinal;
6991 Idx: TPSDelphiClassItem;
6992 FType: TPSType;
6993 TempP: TPSValue;
6994 Decl: TPSParametersDecl;
6995 s: tbtString;
6996
6997 pinfo, pinfonew: tbtString;
6998 ppos: Cardinal;
6999
7000 begin
7001 FType := GetTypeNo(BlockInfo, p);
7002 if FType = nil then exit;
7003 pinfo := '';
7004 if (FType.BaseType <> btClass) then Exit;
7005 while (FParser.CurrTokenID = CSTI_Period) or (ImplicitPeriod) do
7006 begin
7007 if not ImplicitPeriod then
7008 FParser.Next;
7009 if FParser.CurrTokenID <> CSTI_Identifier then
7010 begin
7011 if ImplicitPeriod then exit;
7012 MakeError('', ecIdentifierExpected, '');
7013 p.Free;
7014 P := nil;
7015 Exit;
7016 end;
7017 s := FParser.GetToken;
7018 if TPSClassType(FType).Cl.Func_Find(s, Idx) then
7019 begin
7020 FParser.Next;
7021 VarNo := InvalidVal;
7022 TPSClassType(FType).cl.Func_Call(Idx, Procno);
7023 P := ReadProcParameters(Procno, P);
7024 if p = nil then
7025 begin
7026 Exit;
7027 end;
7028 end else if TPSClassType(FType).cl.Property_Find(s, Idx) then
7029 begin
7030 ppos := FParser.CurrTokenPos;
7031 pinfonew := FParser.OriginalToken;
7032 FParser.Next;
7033 if VarNo <> InvalidVal then
7034 begin
7035 if pinfo = '' then
7036 pinfo := pinfonew
7037 else
7038 pinfo := pinfo + '.' + pinfonew;
7039 if @FOnUseVariable <> nil then
7040 FOnUseVariable(Self, VarType, VarNo, BlockInfo.ProcNo, ppos, pinfo);
7041 end;
7042 Decl := TPSParametersDecl.Create;
7043 TPSClassType(FType).cl.Property_GetHeader(Idx, Decl);
7044 TempP := P;
7045 p := TPSValueProcNo.Create;
7046 with TPSValueProcNo(p) do
7047 begin
7048 Parameters := TPSParameters.Create;
7049 Parameters.Add;
7050 Pos := FParser.CurrTokenPos;
7051 row := FParser.Row;
7052 Col := FParser.Col;
7053 end;
7054 if Decl.ParamCount <> 0 then
7055 begin
7056 if not (ReadParameters(True, TPSValueProc(P).Parameters) and
7057 ValidateParameters(BlockInfo, TPSValueProc(P).Parameters, Decl)) then
7058 begin
7059 Tempp.Free;
7060 Decl.Free;
7061 p.Free;
7062 P := nil;
7063 exit;
7064 end;
7065 end; // if
7066 with TPSValueProcNo(p).Parameters[0] do
7067 begin
7068 Val := TempP;
7069 ExpectedType := at2ut(GetTypeNo(BlockInfo, TempP));
7070 end;
7071 if FParser.CurrTokenId = CSTI_Assignment then
7072 begin
7073 FParser.Next;
7074 TempP := Calc(CSTI_SemiColon);
7075 if TempP = nil then
7076 begin
7077 Decl.Free;
7078 P.Free;
7079 p := nil;
7080 exit;
7081 end;
7082 with TPSValueProc(p).Parameters.Add do
7083 begin
7084 Val := Tempp;
7085 ExpectedType := at2ut(Decl.Result);
7086 {$IFDEF DEBUG}
7087 if not ExpectedType.Used then asm int 3; end;
7088 {$ENDIF}
7089 end;
7090
7091 if not TPSClassType(FType).cl.Property_Set(Idx, Procno) then
7092 begin
7093 MakeError('', ecReadOnlyProperty, '');
7094 Decl.Free;
7095 p.Free;
7096 p := nil;
7097 exit;
7098 end;
7099 TPSValueProcNo(p).ProcNo := Procno;
7100 TPSValueProcNo(p).ResultType := nil;
7101 Decl.Free;
7102 Exit;
7103 end else begin
7104 if not TPSClassType(FType).cl.Property_Get(Idx, Procno) then
7105 begin
7106 MakeError('', ecWriteOnlyProperty, '');
7107 Decl.Free;
7108 p.Free;
7109 p := nil;
7110 exit;
7111 end;
7112 TPSValueProcNo(p).ProcNo := ProcNo;
7113 TPSValueProcNo(p).ResultType := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl.Result;
7114 end; // if FParser.CurrTokenId = CSTI_Assign
7115 Decl.Free;
7116 end else
7117 begin
7118 if ImplicitPeriod then exit;
7119 MakeError('', ecUnknownIdentifier, s);
7120 p.Free;
7121 P := nil;
7122 Exit;
7123 end;
7124 ImplicitPeriod := False;
7125 FType := GetTypeNo(BlockInfo, p);
7126 if (FType = nil) or (FType.BaseType <> btClass) then Exit;
7127 end; {while}
7128 end;
7129 {$IFNDEF PS_NOIDISPATCH}
7130 procedure CheckIntf(var P: TPSValue; const VarType: TPSVariableType; VarNo: Cardinal; ImplicitPeriod: Boolean);
7131 var
7132 Procno: Cardinal;
7133 Idx: TPSInterfaceMethod;
7134 FType: TPSType;
7135 s: tbtString;
7136
7137 CheckArrayProperty,HasArrayProperty:boolean;
7138 begin
7139 FType := GetTypeNo(BlockInfo, p);
7140 if FType = nil then exit;
7141 if (FType.BaseType <> btInterface) and (Ftype.BaseType <> BtVariant) and (FType.BaseType = btNotificationVariant) then Exit;
7142
7143 CheckArrayProperty:=(FParser.CurrTokenID=CSTI_OpenBlock) and
7144 (Ftype.BaseType = BtVariant);
7145 while (FParser.CurrTokenID = CSTI_Period)
7146 or (ImplicitPeriod) do begin
7147
7148 HasArrayProperty:=CheckArrayProperty;
7149 if CheckArrayProperty then begin
7150 CheckArrayProperty:=false;
7151 end else begin
7152 if not ImplicitPeriod then
7153 FParser.Next;
7154 end;
7155 if FParser.CurrTokenID <> CSTI_Identifier then
7156 begin
7157 if ImplicitPeriod then exit;
7158 if not HasArrayProperty then begin
7159 MakeError('', ecIdentifierExpected, '');
7160 p.Free;
7161 P := nil;
7162 Exit;
7163 end;
7164 end;
7165 if (FType.BaseType = btVariant) or (FType.BaseType = btNotificationVariant) then
7166 begin
7167 if HasArrayProperty then begin
7168 s:='';
7169 end else begin
7170 s := FParser.OriginalToken;
7171 FParser.Next;
7172 end;
7173 ImplicitPeriod := False;
7174 FType := GetTypeNo(BlockInfo, p);
7175 p := ReadIDispatchParameters(s, TPSVariantType(FType), p);
7176 if (FType = nil) or (FType.BaseType <> btInterface) then Exit;
7177 end else
7178 begin
7179 s := FParser.GetToken;
7180 if (FType is TPSInterfaceType) and (TPSInterfaceType(FType).Intf.Func_Find(s, Idx)) then
7181 begin
7182 FParser.Next;
7183 TPSInterfaceType(FType).Intf.Func_Call(Idx, Procno);
7184 P := ReadProcParameters(Procno, P);
7185 if p = nil then
7186 begin
7187 Exit;
7188 end;
7189 end else
7190 begin
7191 if ImplicitPeriod then exit;
7192 MakeError('', ecUnknownIdentifier, s);
7193 p.Free;
7194 P := nil;
7195 Exit;
7196 end;
7197 ImplicitPeriod := False;
7198 FType := GetTypeNo(BlockInfo, p);
7199 if (FType = nil) or ((FType.BaseType <> btInterface) and (Ftype.BaseType <> btVariant) and (Ftype.BaseType <> btNotificationVariant)) then Exit;
7200 end;
7201 end; {while}
7202 end;
7203 {$ENDIF}
ExtCheckClassTypenull7204 function ExtCheckClassType(FType: TPSType; const ParserPos: Cardinal): TPSValue;
7205 var
7206 FType2: TPSType;
7207 ProcNo, Idx: Cardinal;
7208 Temp, ResV: TPSValue;
7209 begin
7210 if FParser.CurrTokenID = CSTI_OpenRound then
7211 begin
7212 FParser.Next;
7213 Temp := Calc(CSTI_CloseRound);
7214 if Temp = nil then
7215 begin
7216 Result := nil;
7217 exit;
7218 end;
7219 if FParser.CurrTokenID <> CSTI_CloseRound then
7220 begin
7221 temp.Free;
7222 MakeError('', ecCloseRoundExpected, '');
7223 Result := nil;
7224 exit;
7225 end;
7226 FType2 := GetTypeNo(BlockInfo, Temp);
7227 if (FType.basetype = BtClass) and (ftype2.BaseType = btClass) and (ftype <> ftype2) then
7228 begin
7229 if not TPSUndefinedClassType(FType2).ExtClass.CastToType(AT2UT(FType), ProcNo) then
7230 begin
7231 temp.Free;
7232 MakeError('', ecTypeMismatch, '');
7233 Result := nil;
7234 exit;
7235 end;
7236 Result := TPSValueProcNo.Create;
7237 TPSValueProcNo(Result).Parameters := TPSParameters.Create;
7238 TPSValueProcNo(Result).ResultType := at2ut(FType);
7239 TPSValueProcNo(Result).ProcNo := ProcNo;
7240 with TPSValueProcNo(Result).Parameters.Add do
7241 begin
7242 Val := Temp;
7243 ExpectedType := GetTypeNo(BlockInfo, temp);
7244 end;
7245 with TPSValueProcNo(Result).Parameters.Add do
7246 begin
7247 ExpectedType := at2ut(FindBaseType(btu32));
7248 Val := TPSValueData.Create;
7249 with TPSValueData(val) do
7250 begin
7251 SetParserPos(FParser);
7252 Data := NewVariant(ExpectedType);
7253 Data.tu32 := at2ut(FType).FinalTypeNo;
7254 end;
7255 end;
7256 FParser.Next;
7257 Exit;
7258 end;
7259 if not IsCompatibleType(FType, FType2, True) then
7260 begin
7261 temp.Free;
7262 MakeError('', ecTypeMismatch, '');
7263 Result := nil;
7264 exit;
7265 end;
7266 FParser.Next;
7267 Result := TPSUnValueOp.Create;
7268 with TPSUnValueOp(Result) do
7269 begin
7270 Operator := otCast;
7271 Val1 := Temp;
7272 SetParserPos(FParser);
7273 aType := AT2UT(FType);
7274 end;
7275 exit;
7276 end;
7277 if FParser.CurrTokenId <> CSTI_Period then
7278 begin
7279 Result := nil;
7280 MakeError('', ecPeriodExpected, '');
7281 Exit;
7282 end;
7283 if FType.BaseType <> btExtClass then
7284 begin
7285 Result := nil;
7286 MakeError('', ecClassTypeExpected, '');
7287 Exit;
7288 end;
7289 FParser.Next;
7290 if not TPSUndefinedClassType(FType).ExtClass.ClassFunc_Find(FParser.GetToken, Idx) then
7291 begin
7292 Result := nil;
7293 MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
7294 Exit;
7295 end;
7296 FParser.Next;
7297 TPSUndefinedClassType(FType).ExtClass.ClassFunc_Call(Idx, ProcNo);
7298 Temp := TPSValueData.Create;
7299 with TPSValueData(Temp) do
7300 begin
7301 Data := NewVariant(at2ut(FindBaseType(btu32)));
7302 Data.tu32 := at2ut(FType).FinalTypeNo;
7303 end;
7304 ResV := ReadProcParameters(ProcNo, Temp);
7305 if ResV <> nil then
7306 begin
7307 TPSValueProc(Resv).ResultType := at2ut(FType);
7308 Result := Resv;
7309 end else begin
7310 Result := nil;
7311 end;
7312 end;
7313
CheckClassTypenull7314 function CheckClassType(TypeNo: TPSType; const ParserPos: Cardinal): TPSValue;
7315 var
7316 FType2: TPSType;
7317 ProcNo: Cardinal;
7318 Idx: IPointer;
7319 Temp, ResV: TPSValue;
7320 dta: PIfRVariant;
7321 begin
7322 if typeno.BaseType = btExtClass then
7323 begin
7324 Result := ExtCheckClassType(TypeNo, PArserPos);
7325 exit;
7326 end;
7327 if FParser.CurrTokenID = CSTI_OpenRound then
7328 begin
7329 FParser.Next;
7330 Temp := Calc(CSTI_CloseRound);
7331 if Temp = nil then
7332 begin
7333 Result := nil;
7334 exit;
7335 end;
7336 if FParser.CurrTokenID <> CSTI_CloseRound then
7337 begin
7338 temp.Free;
7339 MakeError('', ecCloseRoundExpected, '');
7340 Result := nil;
7341 exit;
7342 end;
7343 FType2 := GetTypeNo(BlockInfo, Temp);
7344 if ((typeno.BaseType = btClass){$IFNDEF PS_NOINTERFACES} or (TypeNo.basetype = btInterface){$ENDIF}) and
7345 (ftype2<>nil) and
7346 ((ftype2.BaseType = btClass){$IFNDEF PS_NOINTERFACES} or (ftype2.BaseType = btInterface){$ENDIF}) and (TypeNo <> ftype2) then
7347 begin
7348 {$IFNDEF PS_NOINTERFACES}
7349 if FType2.basetype = btClass then
7350 begin
7351 {$ENDIF}
7352 if not TPSClassType(FType2).Cl.CastToType(AT2UT(TypeNo), ProcNo) then
7353 begin
7354 temp.Free;
7355 MakeError('', ecTypeMismatch, '');
7356 Result := nil;
7357 exit;
7358 end;
7359 {$IFNDEF PS_NOINTERFACES}
7360 end else begin
7361 if not TPSInterfaceType(FType2).Intf.CastToType(AT2UT(TypeNo), ProcNo) then
7362 begin
7363 temp.Free;
7364 MakeError('', ecTypeMismatch, '');
7365 Result := nil;
7366 exit;
7367 end;
7368 end;
7369 {$ENDIF}
7370 Result := TPSValueProcNo.Create;
7371 TPSValueProcNo(Result).Parameters := TPSParameters.Create;
7372 TPSValueProcNo(Result).ResultType := at2ut(TypeNo);
7373 TPSValueProcNo(Result).ProcNo := ProcNo;
7374 with TPSValueProcNo(Result).Parameters.Add do
7375 begin
7376 Val := Temp;
7377 ExpectedType := GetTypeNo(BlockInfo, temp);
7378 {$IFDEF DEBUG}
7379 if not ExpectedType.Used then asm int 3; end;
7380 {$ENDIF}
7381 end;
7382 with TPSValueProcNo(Result).Parameters.Add do
7383 begin
7384 ExpectedType := at2ut(FindBaseType(btu32));
7385 {$IFDEF DEBUG}
7386 if not ExpectedType.Used then asm int 3; end;
7387 {$ENDIF}
7388 Val := TPSValueData.Create;
7389 with TPSValueData(val) do
7390 begin
7391 SetParserPos(FParser);
7392 Data := NewVariant(ExpectedType);
7393 Data.tu32 := at2ut(TypeNo).FinalTypeNo;
7394 end;
7395 end;
7396 FParser.Next;
7397 Exit;
7398 end;
7399 if (FType2=nil) or not IsCompatibleType(TypeNo, FType2, True) then
7400 begin
7401 temp.Free;
7402 MakeError('', ecTypeMismatch, '');
7403 Result := nil;
7404 exit;
7405 end;
7406 FParser.Next;
7407 Result := TPSUnValueOp.Create;
7408 with TPSUnValueOp(Result) do
7409 begin
7410 Operator := otCast;
7411 Val1 := Temp;
7412 SetParserPos(FParser);
7413 aType := AT2UT(TypeNo);
7414 end;
7415
7416 exit;
7417 end else
7418 if FParser.CurrTokenId <> CSTI_Period then
7419 begin
7420 Result := TPSValueData.Create;
7421 Result.SetParserPos(FParser);
7422 New(dta);
7423 TPSValueData(Result).Data := dta;
7424 InitializeVariant(dta, at2ut(FindBaseType(btType)));
7425 dta.ttype := at2ut(TypeNo);
7426 Exit;
7427 end;
7428 if TypeNo.BaseType <> btClass then
7429 begin
7430 Result := nil;
7431 MakeError('', ecClassTypeExpected, '');
7432 Exit;
7433 end;
7434 FParser.Next;
7435 if not TPSClassType(TypeNo).Cl.ClassFunc_Find(FParser.GetToken, Idx) then
7436 begin
7437 Result := nil;
7438 MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
7439 Exit;
7440 end;
7441 FParser.Next;
7442 TPSClassType(TypeNo).Cl.ClassFunc_Call(Idx, ProcNo);
7443 Temp := TPSValueData.Create;
7444 with TPSValueData(Temp) do
7445 begin
7446 Data := NewVariant(at2ut(FindBaseType(btu32)));
7447 Data.tu32 := at2ut(TypeNo).FinalTypeNo;
7448 end;
7449 ResV := ReadProcParameters(ProcNo, Temp);
7450 if ResV <> nil then
7451 begin
7452 TPSValueProc(Resv).ResultType := at2ut(TypeNo);
7453 Result := Resv;
7454 end else begin
7455 Result := nil;
7456 end;
7457 end;
7458
GetIdentifiernull7459 function GetIdentifier(const FType: Byte): TPSValue;
7460 {
7461 FType:
7462 0 = Anything
7463 1 = Only variables
7464 2 = Not constants
7465 }
7466
7467
7468 var
7469 vt: TPSVariableType;
7470 vno: Cardinal;
7471 TWith, Temp: TPSValue;
7472 l, h: Longint;
7473 s, u: tbtString;
7474 t: TPSConstant;
7475 Temp1: TPSType;
7476 temp2: CArdinal;
7477 bi: TPSBlockInfo;
7478 lOldRecCount: Integer;
7479
7480 begin
7481 s := FParser.GetToken;
7482
7483 if FType <> 1 then
7484 begin
7485 bi := BlockInfo;
7486 while bi <> nil do
7487 begin
7488 for l := bi.WithList.Count -1 downto 0 do
7489 begin
7490 TWith := TPSValueAllocatedStackVar.Create;
7491 TPSValueAllocatedStackVar(TWith).LocalVarNo := TPSValueAllocatedStackVar(TPSValueReplace(bi.WithList[l]).NewValue).LocalVarNo;
7492 Temp := TWith;
7493 VNo := TPSValueAllocatedStackVar(Temp).LocalVarNo;
7494 lOldRecCount := TPSValueVar(TWith).GetRecCount;
7495 vt := ivtVariable;
7496 if Temp = TWith then CheckFurther(TWith, True);
7497 if Temp = TWith then CheckClass(TWith, vt, vno, True);
7498 if Temp = TWith then CheckExtClass(TWith, vt, vno, True);
7499 if (Temp <> TWith) or (Cardinal(lOldRecCount) <> TPSValueVar(TWith).GetRecCount) then
7500 begin
7501 repeat
7502 Temp := TWith;
7503 if TWith <> nil then CheckFurther(TWith, False);
7504 if TWith <> nil then CheckClass(TWith, vt, vno, False);
7505 if TWith <> nil then CheckExtClass(TWith, vt, vno, False);
7506 {$IFNDEF PS_NOIDISPATCH}if TWith <> nil then CheckIntf(TWith, vt, vno, False);{$ENDIF}
7507 if TWith <> nil then CheckProcCall(TWith);
7508 if TWith <> nil then CheckClassArrayProperty(TWith, vt, vno);
7509 vno := InvalidVal;
7510 until (TWith = nil) or (Temp = TWith);
7511 Result := TWith;
7512 Exit;
7513 end;
7514 TWith.Free;
7515 end;
7516 bi := bi.FOwner;
7517 end;
7518 end;
7519
7520 if s = 'RESULT' then
7521 begin
7522 if BlockInfo.proc.Decl.Result = nil then
7523 begin
7524 Result := nil;
7525 MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
7526 end
7527 else
7528 begin
7529 BlockInfo.Proc.ResultUse;
7530 Result := TPSValueParamVar.Create;
7531 with TPSValueParamVar(Result) do
7532 begin
7533 SetParserPos(FParser);
7534 ParamNo := 0;
7535 end;
7536 vno := 0;
7537 vt := ivtParam;
7538 if @FOnUseVariable <> nil then
7539 FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, '');
7540 FParser.Next;
7541 repeat
7542 Temp := Result;
7543 if Result <> nil then CheckFurther(Result, False);
7544 if Result <> nil then CheckClass(Result, vt, vno, False);
7545 if Result <> nil then CheckExtClass(Result, vt, vno, False);
7546 {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
7547 if Result <> nil then CheckProcCall(Result);
7548 if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
7549 vno := InvalidVal;
7550 until (Result = nil) or (Temp = Result);
7551 end;
7552 exit;
7553 end;
7554 if BlockInfo.Proc.Decl.Result = nil then
7555 l := 0
7556 else
7557 l := 1;
7558 for h := 0 to BlockInfo.proc.Decl.ParamCount -1 do
7559 begin
7560 if BlockInfo.proc.Decl.Params[h].Name = s then
7561 begin
7562 Result := TPSValueParamVar.Create;
7563 with TPSValueParamVar(Result) do
7564 begin
7565 SetParserPos(FParser);
7566 ParamNo := l;
7567 end;
7568 vt := ivtParam;
7569 vno := L;
7570 if @FOnUseVariable <> nil then
7571 FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, '');
7572 FParser.Next;
7573 repeat
7574 Temp := Result;
7575 if Result <> nil then CheckFurther(Result, False);
7576 if Result <> nil then CheckClass(Result, vt, vno, False);
7577 if Result <> nil then CheckExtClass(Result, vt, vno, False);
7578 {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
7579 if Result <> nil then CheckProcCall(Result);
7580 if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
7581 vno := InvalidVal;
7582 until (Result = nil) or (Temp = Result);
7583 exit;
7584 end;
7585 Inc(l);
7586 GRFW(u);
7587 end;
7588
7589 h := MakeHash(s);
7590
7591 for l := 0 to BlockInfo.Proc.ProcVars.Count - 1 do
7592 begin
7593 if (PIFPSProcVar(BlockInfo.Proc.ProcVars[l]).NameHash = h) and
7594 (PIFPSProcVar(BlockInfo.Proc.ProcVars[l]).Name = s) then
7595 begin
7596 PIFPSProcVar(BlockInfo.Proc.ProcVars[l]).Use;
7597 vno := l;
7598 vt := ivtVariable;
7599 if @FOnUseVariable <> nil then
7600 FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, '');
7601 Result := TPSValueLocalVar.Create;
7602 with TPSValueLocalVar(Result) do
7603 begin
7604 LocalVarNo := l;
7605 SetParserPos(FParser);
7606 end;
7607 FParser.Next;
7608 repeat
7609 Temp := Result;
7610 if Result <> nil then CheckFurther(Result, False);
7611 if Result <> nil then CheckClass(Result, vt, vno, False);
7612 if Result <> nil then CheckExtClass(Result, vt, vno, False);
7613 {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
7614 if Result <> nil then CheckProcCall(Result);
7615 if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
7616 vno := InvalidVal;
7617 until (Result = nil) or (Temp = Result);
7618
7619 exit;
7620 end;
7621 end;
7622
7623 for l := 0 to FVars.Count - 1 do
7624 begin
7625 if (TPSVar(FVars[l]).NameHash = h) and
7626 (TPSVar(FVars[l]).Name = s) {$IFDEF PS_USESSUPPORT} and
7627 (IsInLocalUnitList(TPSVar(FVars[l]).FDeclareUnit)){$ENDIF} then
7628 begin
7629 TPSVar(FVars[l]).Use;
7630 Result := TPSValueGlobalVar.Create;
7631 with TPSValueGlobalVar(Result) do
7632 begin
7633 SetParserPos(FParser);
7634 GlobalVarNo := l;
7635
7636 end;
7637 vt := ivtGlobal;
7638 vno := l;
7639 if @FOnUseVariable <> nil then
7640 FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, '');
7641 FParser.Next;
7642 repeat
7643 Temp := Result;
7644 if Result <> nil then CheckNotificationVariant(Result);
7645 if Result <> nil then CheckFurther(Result, False);
7646 if Result <> nil then CheckClass(Result, vt, vno, False);
7647 if Result <> nil then CheckExtClass(Result, vt, vno, False);
7648 {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
7649 if Result <> nil then CheckProcCall(Result);
7650 if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
7651 vno := InvalidVal;
7652 until (Result = nil) or (Temp = Result);
7653 exit;
7654 end;
7655 end;
7656 Temp1 := FindType(FParser.GetToken);
7657 if Temp1 <> nil then
7658 begin
7659 l := FParser.CurrTokenPos;
7660 if FType = 1 then
7661 begin
7662 Result := nil;
7663 MakeError('', ecVariableExpected, FParser.OriginalToken);
7664 exit;
7665 end;
7666 vt := ivtGlobal;
7667 vno := InvalidVal;
7668 FParser.Next;
7669 Result := CheckClassType(Temp1, l);
7670 repeat
7671 Temp := Result;
7672 if Result <> nil then CheckFurther(Result, False);
7673 if Result <> nil then CheckClass(Result, vt, vno, False);
7674 if Result <> nil then CheckExtClass(Result, vt, vno, False);
7675 {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
7676 if Result <> nil then CheckProcCall(Result);
7677 if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
7678 vno := InvalidVal;
7679 until (Result = nil) or (Temp = Result);
7680
7681 exit;
7682 end;
7683 Temp2 := FindProc(FParser.GetToken);
7684 if Temp2 <> InvalidVal then
7685 begin
7686 if FType = 1 then
7687 begin
7688 Result := nil;
7689 MakeError('', ecVariableExpected, FParser.OriginalToken);
7690 exit;
7691 end;
7692 FParser.Next;
7693 Result := ReadProcParameters(Temp2, nil);
7694 if Result = nil then
7695 exit;
7696 Result.SetParserPos(FParser);
7697 vt := ivtGlobal;
7698 vno := InvalidVal;
7699 repeat
7700 Temp := Result;
7701 if Result <> nil then CheckFurther(Result, False);
7702 if Result <> nil then CheckClass(Result, vt, vno, False);
7703 if Result <> nil then CheckExtClass(Result, vt, vno, False);
7704 {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
7705 if Result <> nil then CheckProcCall(Result);
7706 if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
7707 vno := InvalidVal;
7708 until (Result = nil) or (Temp = Result);
7709 exit;
7710 end;
7711 for l := 0 to FConstants.Count -1 do
7712 begin
7713 t := TPSConstant(FConstants[l]);
7714 if (t.NameHash = h) and (t.Name = s) {$IFDEF PS_USESSUPPORT} and
7715 (IsInLocalUnitList(t.FDeclareUnit)) {$ENDIF} then
7716 begin
7717 if FType <> 0 then
7718 begin
7719 Result := nil;
7720 MakeError('', ecVariableExpected, FParser.OriginalToken);
7721 exit;
7722 end;
7723 fparser.next;
7724 Result := TPSValueData.Create;
7725 with TPSValueData(Result) do
7726 begin
7727 SetParserPos(FParser);
7728 Data := NewVariant(at2ut(t.Value.FType));
7729 CopyVariantContents(t.Value, Data);
7730 end;
7731 vt := ivtGlobal;
7732 vno := InvalidVal;
7733 repeat
7734 Temp := Result;
7735 if Result <> nil then CheckFurther(Result, False);
7736 if Result <> nil then CheckClass(Result, vt, vno, False);
7737 if Result <> nil then CheckExtClass(Result, vt, vno, False);
7738 {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
7739 if Result <> nil then CheckProcCall(Result);
7740 if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
7741 vno := InvalidVal;
7742 until (Result = nil) or (Temp = Result);
7743 exit;
7744 end;
7745 end;
7746 Result := nil;
7747 MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
7748 end;
7749
calcnull7750 function calc(endOn: TPSPasToken): TPSValue;
7751 function TryEvalConst(var P: TPSValue): Boolean; forward;
7752
7753
7754 function ReadExpression: TPSValue; forward;
7755 function ReadTerm: TPSValue; forward;
ReadFactornull7756 function ReadFactor: TPSValue;
7757 var
7758 NewVar: TPSValue;
7759 NewVarU: TPSUnValueOp;
7760 Proc: TPSProcedure;
7761 function ReadArray: Boolean;
7762 var
7763 tmp: TPSValue;
7764 begin
7765 FParser.Next;
7766 NewVar := TPSValueArray.Create;
7767 NewVar.SetParserPos(FParser);
7768 if FParser.CurrTokenID <> CSTI_CloseBlock then
7769 begin
7770 while True do
7771 begin
7772 tmp := nil;
7773 Tmp := ReadExpression();
7774 if Tmp = nil then
7775 begin
7776 Result := False;
7777 NewVar.Free;
7778 exit;
7779 end;
7780 if not TryEvalConst(tmp) then
7781 begin
7782 tmp.Free;
7783 NewVar.Free;
7784 Result := False;
7785 exit;
7786 end;
7787 TPSValueArray(NewVar).Add(tmp);
7788 if FParser.CurrTokenID = CSTI_CloseBlock then Break;
7789 if FParser.CurrTokenID <> CSTI_Comma then
7790 begin
7791 MakeError('', ecCloseBlockExpected, '');
7792 NewVar.Free;
7793 Result := False;
7794 exit;
7795 end;
7796 FParser.Next;
7797 end;
7798 end;
7799 FParser.Next;
7800 Result := True;
7801 end;
7802
CallAssignednull7803 function CallAssigned(P: TPSValue): TPSValue;
7804 var
7805 temp: TPSValueProcNo;
7806 begin
7807 temp := TPSValueProcNo.Create;
7808 temp.ProcNo := FindProc('!ASSIGNED');
7809 temp.ResultType := at2ut(FDefaultBoolType);
7810 temp.Parameters := TPSParameters.Create;
7811 with Temp.Parameters.Add do
7812 begin
7813 Val := p;
7814 ExpectedType := GetTypeNo(BlockInfo, p);
7815 {$IFDEF DEBUG}
7816 if not ExpectedType.Used then asm int 3; end;
7817 {$ENDIF}
7818 FParamMode := pmIn;
7819 end;
7820 Result := Temp;
7821 end;
7822
CallSuccnull7823 function CallSucc(P: TPSValue): TPSValue;
7824 var
7825 temp: TPSBinValueOp;
7826 begin
7827 temp := TPSBinValueOp.Create;
7828 temp.SetParserPos(FParser);
7829 temp.FOperator := otAdd;
7830 temp.FVal2 := TPSValueData.Create;
7831 TPSValueData(Temp.FVal2).Data := NewVariant(FindBaseType(bts32));
7832 TPSValueData(Temp.FVal2).Data.ts32 := 1;
7833 temp.FVal1 := p;
7834 Temp.FType := GetTypeNo(BlockInfo, P);
7835 result := temp;
7836 end;
7837
CallPrednull7838 function CallPred(P: TPSValue): TPSValue;
7839 var
7840 temp: TPSBinValueOp;
7841 begin
7842 temp := TPSBinValueOp.Create;
7843 temp.SetParserPos(FParser);
7844 temp.FOperator := otSub;
7845 temp.FVal2 := TPSValueData.Create;
7846 TPSValueData(Temp.FVal2).Data := NewVariant(FindBaseType(bts32));
7847 TPSValueData(Temp.FVal2).Data.ts32 := 1;
7848 temp.FVal1 := p;
7849 Temp.FType := GetTypeNo(BlockInfo, P);
7850 result := temp;
7851 end;
7852
7853 begin
7854 case fParser.CurrTokenID of
7855 CSTI_OpenBlock:
7856 begin
7857 if not ReadArray then
7858 begin
7859 Result := nil;
7860 exit;
7861 end;
7862 end;
7863 CSTII_Not:
7864 begin
7865 FParser.Next;
7866 NewVar := ReadFactor;
7867 if NewVar = nil then
7868 begin
7869 Result := nil;
7870 exit;
7871 end;
7872 NewVarU := TPSUnValueOp.Create;
7873 NewVarU.SetParserPos(FParser);
7874 NewVarU.aType := GetTypeNo(BlockInfo, NewVar);
7875 NewVarU.Operator := otNot;
7876 NewVarU.Val1 := NewVar;
7877 NewVar := NewVarU;
7878 end;
7879 CSTI_Plus:
7880 begin
7881 FParser.Next;
7882 NewVar := ReadTerm;
7883 if NewVar = nil then
7884 begin
7885 Result := nil;
7886 exit;
7887 end;
7888 end;
7889 CSTI_Minus:
7890 begin
7891 FParser.Next;
7892 NewVar := ReadTerm;
7893 if NewVar = nil then
7894 begin
7895 Result := nil;
7896 exit;
7897 end;
7898 NewVarU := TPSUnValueOp.Create;
7899 NewVarU.SetParserPos(FParser);
7900 NewVarU.aType := GetTypeNo(BlockInfo, NewVar);
7901 NewVarU.Operator := otMinus;
7902 NewVarU.Val1 := NewVar;
7903 NewVar := NewVarU;
7904 end;
7905 CSTII_Nil:
7906 begin
7907 FParser.Next;
7908 NewVar := TPSValueNil.Create;
7909 NewVar.SetParserPos(FParser);
7910 end;
7911 CSTI_AddressOf:
7912 begin
7913 FParser.Next;
7914 if FParser.CurrTokenID <> CSTI_Identifier then
7915 begin
7916 MakeError('', ecIdentifierExpected, '');
7917 Result := nil;
7918 exit;
7919 end;
7920 NewVar := TPSValueProcPtr.Create;
7921 NewVar.SetParserPos(FParser);
7922 TPSValueProcPtr(NewVar).ProcPtr := FindProc(FParser.GetToken);
7923 if TPSValueProcPtr(NewVar).ProcPtr = InvalidVal then
7924 begin
7925 MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
7926 NewVar.Free;
7927 Result := nil;
7928 exit;
7929 end;
7930 Proc := FProcs[TPSValueProcPtr(NewVar).ProcPtr];
7931 if Proc.ClassType <> TPSInternalProcedure then
7932 begin
7933 MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
7934 NewVar.Free;
7935 Result := nil;
7936 exit;
7937 end;
7938 FParser.Next;
7939 end;
7940 CSTI_OpenRound:
7941 begin
7942 FParser.Next;
7943 NewVar := ReadExpression();
7944 if NewVar = nil then
7945 begin
7946 Result := nil;
7947 exit;
7948 end;
7949 if FParser.CurrTokenId <> CSTI_CloseRound then
7950 begin
7951 NewVar.Free;
7952 Result := nil;
7953 MakeError('', ecCloseRoundExpected, '');
7954 exit;
7955 end;
7956 FParser.Next;
7957 end;
7958 CSTI_Char, CSTI_String:
7959 begin
7960 NewVar := TPSValueData.Create;
7961 NewVar.SetParserPos(FParser);
7962 TPSValueData(NewVar).Data := ReadString;
7963 if TPSValueData(NewVar).Data = nil then
7964 begin
7965 NewVar.Free;
7966 Result := nil;
7967 exit;
7968 end;
7969 end;
7970 CSTI_HexInt, CSTI_Integer:
7971 begin
7972 NewVar := TPSValueData.Create;
7973 NewVar.SetParserPos(FParser);
7974 TPSValueData(NewVar).Data := ReadInteger(FParser.GetToken);
7975 FParser.Next;
7976 end;
7977 CSTI_Real:
7978 begin
7979 NewVar := TPSValueData.Create;
7980 NewVar.SetParserPos(FParser);
7981 TPSValueData(NewVar).Data := ReadReal(FParser.GetToken);
7982 FParser.Next;
7983 end;
7984 CSTII_Ord:
7985 begin
7986 FParser.Next;
7987 if fParser.Currtokenid <> CSTI_OpenRound then
7988 begin
7989 Result := nil;
7990 MakeError('', ecOpenRoundExpected, '');
7991 exit;
7992 end;
7993 FParser.Next;
7994 NewVar := ReadExpression();
7995 if NewVar = nil then
7996 begin
7997 Result := nil;
7998 exit;
7999 end;
8000 if FParser.CurrTokenId <> CSTI_CloseRound then
8001 begin
8002 NewVar.Free;
8003 Result := nil;
8004 MakeError('', ecCloseRoundExpected, '');
8005 exit;
8006 end;
8007 if not ((GetTypeNo(BlockInfo, NewVar).BaseType = btChar) or
8008 {$IFNDEF PS_NOWIDESTRING} (GetTypeNo(BlockInfo, NewVar).BaseType = btWideChar) or{$ENDIF}
8009 (GetTypeNo(BlockInfo, NewVar).BaseType = btEnum) or (IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType))) then
8010 begin
8011 NewVar.Free;
8012 Result := nil;
8013 MakeError('', ecTypeMismatch, '');
8014 exit;
8015 end;
8016 NewVarU := TPSUnValueOp.Create;
8017 NewVarU.SetParserPos(FParser);
8018 NewVarU.Operator := otCast;
8019 NewVarU.FType := at2ut(FindBaseType(btu32));
8020 NewVarU.Val1 := NewVar;
8021 NewVar := NewVarU;
8022 FParser.Next;
8023 end;
8024 CSTII_Chr:
8025 begin
8026 FParser.Next;
8027 if fParser.Currtokenid <> CSTI_OpenRound then
8028 begin
8029 Result := nil;
8030 MakeError('', ecOpenRoundExpected, '');
8031 exit;
8032 end;
8033 FParser.Next;
8034 NewVar := ReadExpression();
8035 if NewVar = nil then
8036 begin
8037 Result := nil;
8038 exit;
8039 end;
8040 if FParser.CurrTokenId <> CSTI_CloseRound then
8041 begin
8042 NewVar.Free;
8043 Result := nil;
8044 MakeError('', ecCloseRoundExpected, '');
8045 exit;
8046 end;
8047 if not (IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType)) then
8048 begin
8049 NewVar.Free;
8050 Result := nil;
8051 MakeError('', ecTypeMismatch, '');
8052 exit;
8053 end;
8054 NewVarU := TPSUnValueOp.Create;
8055 NewVarU.SetParserPos(FParser);
8056 NewVarU.Operator := otCast;
8057 NewVarU.FType := at2ut(FindBaseType(btChar));
8058 NewVarU.Val1 := NewVar;
8059 NewVar := NewVarU;
8060 FParser.Next;
8061 end;
8062 CSTI_Identifier:
8063 begin
8064 if FParser.GetToken = 'SUCC' then
8065 begin
8066 FParser.Next;
8067 if FParser.CurrTokenID <> CSTI_OpenRound then
8068 begin
8069 Result := nil;
8070 MakeError('', ecOpenRoundExpected, '');
8071 exit;
8072 end;
8073 FParser.Next;
8074 NewVar := ReadExpression;
8075 if NewVar = nil then
8076 begin
8077 result := nil;
8078 exit;
8079 end;
8080 if (GetTypeNo(BlockInfo, NewVar) = nil) or (not IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType) and
8081 (GetTypeNo(BlockInfo, NewVar).BaseType <> btEnum)) then
8082 begin
8083 NewVar.Free;
8084 Result := nil;
8085 MakeError('', ecTypeMismatch, '');
8086 exit;
8087 end;
8088 if FParser.CurrTokenID <> CSTI_CloseRound then
8089 begin
8090 NewVar.Free;
8091 Result := nil;
8092 MakeError('', eccloseRoundExpected, '');
8093 exit;
8094 end;
8095 NewVar := CallSucc(NewVar);
8096 FParser.Next;
8097 end else
8098 if FParser.GetToken = 'PRED' then
8099 begin
8100 FParser.Next;
8101 if FParser.CurrTokenID <> CSTI_OpenRound then
8102 begin
8103 Result := nil;
8104 MakeError('', ecOpenRoundExpected, '');
8105 exit;
8106 end;
8107 FParser.Next;
8108 NewVar := ReadExpression;
8109 if NewVar = nil then
8110 begin
8111 result := nil;
8112 exit;
8113 end;
8114 if (GetTypeNo(BlockInfo, NewVar) = nil) or (not IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType) and
8115 (GetTypeNo(BlockInfo, NewVar).BaseType <> btEnum)) then
8116 begin
8117 NewVar.Free;
8118 Result := nil;
8119 MakeError('', ecTypeMismatch, '');
8120 exit;
8121 end;
8122 if FParser.CurrTokenID <> CSTI_CloseRound then
8123 begin
8124 NewVar.Free;
8125 Result := nil;
8126 MakeError('', eccloseRoundExpected, '');
8127 exit;
8128 end;
8129 NewVar := CallPred(NewVar);
8130 FParser.Next;
8131 end else
8132 if FParser.GetToken = 'ASSIGNED' then
8133 begin
8134 FParser.Next;
8135 if FParser.CurrTokenID <> CSTI_OpenRound then
8136 begin
8137 Result := nil;
8138 MakeError('', ecOpenRoundExpected, '');
8139 exit;
8140 end;
8141 FParser.Next;
8142 NewVar := GetIdentifier(0);
8143 if NewVar = nil then
8144 begin
8145 result := nil;
8146 exit;
8147 end;
8148 if (GetTypeNo(BlockInfo, NewVar) = nil) or
8149 ((GetTypeNo(BlockInfo, NewVar).BaseType <> btClass) and
8150 (GetTypeNo(BlockInfo, NewVar).BaseType <> btInterface) and
8151 (GetTypeNo(BlockInfo, NewVar).BaseType <> btPChar) and
8152 (GetTypeNo(BlockInfo, NewVar).BaseType <> btString)) then
8153 begin
8154 NewVar.Free;
8155 Result := nil;
8156 MakeError('', ecTypeMismatch, '');
8157 exit;
8158 end;
8159 if FParser.CurrTokenID <> CSTI_CloseRound then
8160 begin
8161 NewVar.Free;
8162 Result := nil;
8163 MakeError('', eccloseRoundExpected, '');
8164 exit;
8165 end;
8166 NewVar := CallAssigned(NewVar);
8167 FParser.Next;
8168 end else
8169 begin
8170 NewVar := GetIdentifier(0);
8171 if NewVar = nil then
8172 begin
8173 Result := nil;
8174 exit;
8175 end;
8176 end;
8177 end;
8178 else
8179 begin
8180 MakeError('', ecSyntaxError, '');
8181 Result := nil;
8182 exit;
8183 end;
8184 end; {case}
8185 Result := NewVar;
8186 end; // ReadFactor
8187
GetResultTypenull8188 function GetResultType(p1, P2: TPSValue; Cmd: TPSBinOperatorType): TPSType;
8189 var
8190 pp, t1, t2: PIFPSType;
8191 begin
8192 t1 := GetTypeNo(BlockInfo, p1);
8193 t2 := GetTypeNo(BlockInfo, P2);
8194 if (t1 = nil) or (t2 = nil) then
8195 begin
8196 if ((p1.ClassType = TPSValueNil) or (p2.ClassType = TPSValueNil)) and ((t1 <> nil) or (t2 <> nil)) then
8197 begin
8198 if p1.ClassType = TPSValueNil then
8199 pp := t2
8200 else
8201 pp := t1;
8202 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
8203 Result := AT2UT(FDefaultBoolType)
8204 else
8205 Result := nil;
8206 exit;
8207 end;
8208 Result := nil;
8209 exit;
8210 end;
8211 case Cmd of
8212 otAdd: {plus}
8213 begin
8214 if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
8215 ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
8216 (t2.BaseType = btString) or
8217 {$IFNDEF PS_NOWIDESTRING}
8218 (t2.BaseType = btwideString) or
8219 (t2.BaseType = btUnicodestring) or
8220 (t2.BaseType = btwidechar) or
8221 {$ENDIF}
8222 (t2.BaseType = btPchar) or
8223 (t2.BaseType = btChar) or
8224 (isIntRealType(t2.BaseType))) then
8225 Result := t1
8226 else
8227 if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and (
8228 ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
8229 (t1.BaseType = btString) or
8230 {$IFNDEF PS_NOWIDESTRING}
8231 (t1.BaseType = btUnicodestring) or
8232 (t1.BaseType = btwideString) or
8233 (t1.BaseType = btwidechar) or
8234 {$ENDIF}
8235 (t1.BaseType = btPchar) or
8236 (t1.BaseType = btChar) or
8237 (isIntRealType(t1.BaseType))) then
8238 Result := t2
8239 else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) then
8240 Result := t1
8241 else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
8242 Result := t1
8243 else if IsIntRealType(t1.BaseType) and
8244 IsIntRealType(t2.BaseType) then
8245 begin
8246 if IsRealType(t1.BaseType) then
8247 Result := t1
8248 else
8249 Result := t2;
8250 end
8251 else if (t1.basetype = btSet) and (t2.Name = 'TVARIANTARRAY') then
8252 Result := t1
8253 else if (t2.basetype = btSet) and (t1.Name = 'TVARIANTARRAY') then
8254 Result := t2
8255 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
8256 Result := at2ut(FindBaseType(btString))
8257 {$IFNDEF PS_NOWIDESTRING}
8258 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
8259 ((t2.BaseType = btString) or (t2.BaseType = btChar) or (t2.BaseType = btPchar) or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar) or (t2.BaseType = btUnicodeString)) then
8260 Result := at2ut(FindBaseType(btUnicodeString))
8261 {$ENDIF}
8262 else
8263 Result := nil;
8264 end;
8265
8266 otSub, otMul, otIntDiv, otDiv: { - * / }
8267 begin
8268 if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
8269 ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
8270 (isIntRealType(t2.BaseType))) then
8271 begin
8272 Result := t1;
8273 {$IFDEF PS_DELPHIDIV}
8274 if Cmd = otDiv then
8275 result := FindBaseType(btExtended);
8276 {$ENDIF}
8277 end
8278 else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) and ((cmd = otSub) or (cmd = otMul)) then
8279 Result := t1
8280 else if (t1.basetype = btSet) and (t2.Name = 'TVARIANTARRAY') and ((cmd = otSub) or (cmd = otMul)) then
8281 Result := t1
8282 else if (t2.basetype = btSet) and (t1.Name = 'TVARIANTARRAY') and ((cmd = otSub) or (cmd = otMul)) then
8283 Result := t2
8284 else
8285 if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and (
8286 ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
8287 (isIntRealType(t1.BaseType))) then
8288 begin
8289 Result := t2;
8290 {$IFDEF PS_DELPHIDIV}
8291 if Cmd = otDiv then
8292 result := FindBaseType(btExtended);
8293 {$ENDIF}
8294 end
8295 else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then begin
8296 Result := t1;
8297 {$IFDEF PS_DELPHIDIV}
8298 if Cmd = otDiv then
8299 result := FindBaseType(btExtended);
8300 {$ENDIF}
8301 end else if IsIntRealType(t1.BaseType) and
8302 IsIntRealType(t2.BaseType) then
8303 begin
8304 if IsRealType(t1.BaseType) then
8305 Result := t1
8306 else
8307 Result := t2;
8308 {$IFDEF PS_DELPHIDIV}
8309 if Cmd = otIntDiv then //intdiv only works
8310 result := nil;
8311 {$ENDIF}
8312 end
8313 else
8314 Result := nil;
8315 end;
8316 otAnd, otOr, otXor: {and,or,xor}
8317 begin
8318 if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
8319 ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
8320 (isIntType(t2.BaseType))) then
8321 Result := t1
8322 else
8323 if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and (
8324 ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
8325 (isIntType(t1.BaseType))) then
8326 Result := t2
8327 else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
8328 Result := t1
8329 else if (IsBoolean(t1)) and ((t2 = t1) or ((t2.BaseType = btVariant)
8330 or (t2.BaseType = btNotificationVariant))) then
8331 begin
8332 Result := t1;
8333 if ((p1.ClassType = TPSValueData) or (p2.ClassType = TPSValueData)) then
8334 begin
8335 if cmd = otAnd then {and}
8336 begin
8337 if p1.ClassType = TPSValueData then
8338 begin
8339 if (TPSValueData(p1).FData^.tu8 <> 0) then
8340 begin
8341 with MakeWarning('', ewIsNotNeeded, '"True and"') do
8342 if p1.Pos>0 then
8343 begin
8344 FRow := p1.Row;
8345 FCol := p1.Col;
8346 FPosition := p1.Pos;
8347 end;
8348 end else
8349 begin
8350 with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'False') do
8351 begin
8352 FRow := p1.Row;
8353 FCol := p1.Col;
8354 FPosition := p1.Pos;
8355 end;
8356 end;
8357 end else begin
8358 if (TPSValueData(p2).Data.tu8 <> 0) then
8359 begin
8360 with MakeWarning('', ewIsNotNeeded, '"and True"') do
8361 if p2.Pos>0 then
8362 begin
8363 FRow := p2.Row;
8364 FCol := p2.Col;
8365 FPosition := p2.Pos;
8366 end;
8367 end
8368 else
8369 begin
8370 with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'False') do
8371 begin
8372 FRow := p2.Row;
8373 FCol := p2.Col;
8374 FPosition := p2.Pos;
8375 end;
8376 end;
8377 end;
8378 end else if cmd = otOr then {or}
8379 begin
8380 if p1.ClassType = TPSValueData then
8381 begin
8382 if (TPSValueData(p1).Data.tu8 <> 0) then
8383 begin
8384 with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'True') do
8385 begin
8386 FRow := p1.Row;
8387 FCol := p1.Col;
8388 FPosition := p1.Pos;
8389 end;
8390 end
8391 else
8392 begin
8393 with MakeWarning('', ewIsNotNeeded, '"False or"') do
8394 begin
8395 FRow := p1.Row;
8396 FCol := p1.Col;
8397 FPosition := p1.Pos;
8398 end;
8399 end
8400 end else begin
8401 if (TPSValueData(p2).Data.tu8 <> 0) then
8402 begin
8403 with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'True') do
8404 begin
8405 FRow := p2.Row;
8406 FCol := p2.Col;
8407 FPosition := p1.Pos;
8408 end;
8409 end
8410 else
8411 begin
8412 with MakeWarning('', ewIsNotNeeded, '"or False"') do
8413 begin
8414 FRow := p2.Row;
8415 FCol := p2.Col;
8416 FPosition := p2.Pos;
8417 end;
8418 end
8419 end;
8420 end;
8421 end;
8422 end else
8423 Result := nil;
8424 end;
8425 otMod, otShl, otShr: {mod,shl,shr}
8426 begin
8427 if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
8428 ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
8429 (isIntType(t2.BaseType))) then
8430 Result := t1
8431 else
8432 if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and (
8433 ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
8434 (isIntType(t1.BaseType))) then
8435 Result := t2
8436 else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
8437 Result := t1
8438 else
8439 Result := nil;
8440 end;
8441 otGreater, otLess, otGreaterEqual, otLessEqual: { >=, <=, >, <}
8442 begin
8443 if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
8444 ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
8445 (t2.BaseType = btString) or
8446 (t2.BaseType = btPchar) or
8447 (t2.BaseType = btChar) or
8448 (isIntRealType(t2.BaseType))) then
8449 Result := FDefaultBoolType
8450 else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) and ((cmd = otGreaterEqual) or (cmd = otLessEqual)) then
8451 Result := FDefaultBoolType
8452 else
8453 if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and (
8454 ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
8455 (t1.BaseType = btString) or
8456 (t1.BaseType = btPchar) or
8457 (t1.BaseType = btChar) or
8458 (isIntRealType(t1.BaseType))) then
8459 Result := FDefaultBoolType
8460 else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
8461 Result := FDefaultBoolType
8462 else if IsIntRealType(t1.BaseType) and
8463 IsIntRealType(t2.BaseType) then
8464 Result := FDefaultBoolType
8465 else if
8466 ((t1.BaseType = btString) or (t1.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar) or (t1.BaseType = btUnicodestring){$ENDIF}) and
8467 ((t2.BaseType = btString) or (t2.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar) or (t2.BaseType = btUnicodestring){$ENDIF}) then
8468 Result := FDefaultBoolType
8469 else if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) then
8470 Result := FDefaultBoolType
8471 else
8472 Result := nil;
8473 end;
8474 otEqual, otNotEqual: {=, <>}
8475 begin
8476 if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
8477 ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
8478 (t2.BaseType = btString) or
8479 (t2.BaseType = btPchar) or
8480 (t2.BaseType = btChar) or
8481 (isIntRealType(t2.BaseType))) then
8482 Result := FDefaultBoolType
8483 else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) then
8484 Result := FDefaultBoolType
8485 else
8486 if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and (
8487 ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
8488 (t1.BaseType = btString) or
8489 (t1.BaseType = btPchar) or
8490 (t1.BaseType = btChar) or
8491 (isIntRealType(t1.BaseType))) then
8492 Result := FDefaultBoolType
8493 else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
8494 Result := FDefaultBoolType
8495 else if IsIntRealType(t1.BaseType) and
8496 IsIntRealType(t2.BaseType) then
8497 Result := FDefaultBoolType
8498 else if
8499 ((t1.BaseType = btString) or (t1.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar) or (t1.BaseType = btUnicodestring){$ENDIF}) and
8500 ((t2.BaseType = btString) or (t2.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar) or (t2.BaseType = btUnicodestring){$ENDIF}) then
8501 Result := FDefaultBoolType
8502 else if (t1.basetype = btSet) and (t2.Name = 'TVARIANTARRAY') then
8503 Result := FDefaultBoolType
8504 else if (t2.basetype = btSet) and (t1.Name = 'TVARIANTARRAY') then
8505 Result := FDefaultBoolType
8506 else if (t1.BaseType = btEnum) and (t1 = t2) then
8507 Result := FDefaultBoolType
8508 else if (t1.BaseType = btClass) and (t2.BaseType = btClass) then
8509 Result := FDefaultBoolType
8510 else if (t1 = t2) then
8511 Result := FDefaultBoolType
8512 else if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) then
8513 Result := FDefaultBoolType
8514 else Result := nil;
8515 end;
8516 otIn:
8517 begin
8518 if (t2.Name = 'TVARIANTARRAY') then
8519 Result := FDefaultBoolType
8520 else
8521 if (t2.BaseType = btSet) and (TPSSetType(t2).SetType = t1) then
8522 Result := FDefaultBoolType
8523 else
8524 Result := nil;
8525 end;
8526 otIs:
8527 begin
8528 if t2.BaseType = btType then
8529 begin
8530 Result := FDefaultBoolType
8531 end else
8532 Result := nil;
8533 end;
8534 otAs:
8535 begin
8536 if t2.BaseType = btType then
8537 begin
8538 Result := at2ut(TPSValueData(p2).Data.ttype);
8539 end else
8540 Result := nil;
8541 end;
8542 else
8543 Result := nil;
8544 end;
8545 end;
8546
8547
ReadTermnull8548 function ReadTerm: TPSValue;
8549 var
8550 F1, F2: TPSValue;
8551 fType: TPSType;
8552 F: TPSBinValueOp;
8553 Token: TPSPasToken;
8554 Op: TPSBinOperatorType;
8555 begin
8556 F1 := ReadFactor;
8557 if F1 = nil then
8558 begin
8559 Result := nil;
8560 exit;
8561 end;
8562 while FParser.CurrTokenID in [CSTI_Multiply, CSTI_Divide, CSTII_Div, CSTII_Mod, CSTII_And, CSTII_Shl, CSTII_Shr, CSTII_As] do
8563 begin
8564 Token := FParser.CurrTokenID;
8565 FParser.Next;
8566 F2 := ReadFactor;
8567 if f2 = nil then
8568 begin
8569 f1.Free;
8570 Result := nil;
8571 exit;
8572 end;
8573 case Token of
8574 CSTI_Multiply: Op := otMul;
8575 CSTI_Divide: Op := otDiv;
8576 CSTII_div: Op := otIntDiv;
8577 CSTII_mod: Op := otMod;
8578 CSTII_and: Op := otAnd;
8579 CSTII_shl: Op := otShl;
8580 CSTII_shr: Op := otShr;
8581 CSTII_As: Op := otAs;
8582 else
8583 Op := otAdd;
8584 end;
8585 if (Op = otAs) and (f2 is TPSValueData) and (TPSValueData(f2).Data.FType.BaseType = btType) then begin
8586 fType := TPSValueData(f2).Data.ttype;
8587 f2.Free;
8588 f2 := TPSUnValueOp.Create;
8589 TPSUnValueOp(F2).Val1 := f1;
8590 TPSUnValueOp(F2).SetParserPos(FParser);
8591 TPSUnValueOp(f2).FType := fType;
8592 TPSUnValueOp(f2).Operator := otCast;
8593 f1 := f2;
8594 end else begin
8595 F := TPSBinValueOp.Create;
8596 f.Val1 := F1;
8597 f.Val2 := F2;
8598 f.Operator := Op;
8599 f.aType := GetResultType(F1, F2, Op);
8600 if f.aType = nil then
8601 begin
8602 MakeError('', ecTypeMismatch, '');
8603 f.Free;
8604 Result := nil;
8605 exit;
8606 end;
8607 f1 := f;
8608 end;
8609 end;
8610 Result := F1;
8611 end; // ReadTerm
8612
ReadSimpleExpressionnull8613 function ReadSimpleExpression: TPSValue;
8614 var
8615 F1, F2: TPSValue;
8616 F: TPSBinValueOp;
8617 Token: TPSPasToken;
8618 Op: TPSBinOperatorType;
8619 begin
8620 F1 := ReadTerm;
8621 if F1 = nil then
8622 begin
8623 Result := nil;
8624 exit;
8625 end;
8626 while FParser.CurrTokenID in [CSTI_Plus, CSTI_Minus, CSTII_Or, CSTII_Xor] do
8627 begin
8628 Token := FParser.CurrTokenID;
8629 FParser.Next;
8630 F2 := ReadTerm;
8631 if f2 = nil then
8632 begin
8633 f1.Free;
8634 Result := nil;
8635 exit;
8636 end;
8637 case Token of
8638 CSTI_Plus: Op := otAdd;
8639 CSTI_Minus: Op := otSub;
8640 CSTII_or: Op := otOr;
8641 CSTII_xor: Op := otXor;
8642 else
8643 Op := otAdd;
8644 end;
8645 F := TPSBinValueOp.Create;
8646 f.Val1 := F1;
8647 f.Val2 := F2;
8648 f.Operator := Op;
8649 f.aType := GetResultType(F1, F2, Op);
8650 if f.aType = nil then
8651 begin
8652 MakeError('', ecTypeMismatch, '');
8653 f.Free;
8654 Result := nil;
8655 exit;
8656 end;
8657 f1 := f;
8658 end;
8659 Result := F1;
8660 end; // ReadSimpleExpression
8661
8662
ReadExpressionnull8663 function ReadExpression: TPSValue;
8664 var
8665 F1, F2: TPSValue;
8666 F: TPSBinValueOp;
8667 Token: TPSPasToken;
8668 Op: TPSBinOperatorType;
8669 begin
8670 F1 := ReadSimpleExpression;
8671 if F1 = nil then
8672 begin
8673 Result := nil;
8674 exit;
8675 end;
8676 while FParser.CurrTokenID in [ CSTI_GreaterEqual, CSTI_LessEqual, CSTI_Greater, CSTI_Less, CSTI_Equal, CSTI_NotEqual, CSTII_in, CSTII_is] do
8677 begin
8678 Token := FParser.CurrTokenID;
8679 FParser.Next;
8680 F2 := ReadSimpleExpression;
8681 if f2 = nil then
8682 begin
8683 f1.Free;
8684 Result := nil;
8685 exit;
8686 end;
8687 case Token of
8688 CSTI_GreaterEqual: Op := otGreaterEqual;
8689 CSTI_LessEqual: Op := otLessEqual;
8690 CSTI_Greater: Op := otGreater;
8691 CSTI_Less: Op := otLess;
8692 CSTI_Equal: Op := otEqual;
8693 CSTI_NotEqual: Op := otNotEqual;
8694 CSTII_in: Op := otIn;
8695 CSTII_is: Op := otIs;
8696 else
8697 Op := otAdd;
8698 end;
8699 F := TPSBinValueOp.Create;
8700 f.Val1 := F1;
8701 f.Val2 := F2;
8702 f.Operator := Op;
8703 f.aType := GetResultType(F1, F2, Op);
8704 if f.aType = nil then
8705 begin
8706 MakeError('', ecTypeMismatch, '');
8707 f.Free;
8708 Result := nil;
8709 exit;
8710 end;
8711 f1 := f;
8712 end;
8713 Result := F1;
8714 end; // ReadExpression
8715
TryEvalConstnull8716 function TryEvalConst(var P: TPSValue): Boolean;
8717 var
8718 preplace: TPSValue;
8719 begin
8720 if p is TPSBinValueOp then
8721 begin
8722 if not (TryEvalConst(TPSBinValueOp(p).FVal1) and TryEvalConst(TPSBinValueOp(p).FVal2)) then
8723 begin
8724 Result := False;
8725 exit;
8726 end;
8727 if (TPSBinValueOp(p).FVal1.ClassType = TPSValueData) and (TPSBinValueOp(p).FVal2.ClassType = TPSValueData) then
8728 begin
8729 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
8730 begin
8731 Result := False;
8732 exit;
8733 end;
8734 preplace := TPSValueData.Create;
8735 preplace.Pos := p.Pos;
8736 preplace.Row := p.Row;
8737 preplace.Col := p.Col;
8738 TPSValueData(preplace).Data := TPSValueData(TPSBinValueOp(p).Val1).Data;
8739 TPSValueData(TPSBinValueOp(p).Val1).Data := nil;
8740 p.Free;
8741 p := preplace;
8742 end;
8743 end else if p is TPSUnValueOp then
8744 begin
8745 if not TryEvalConst(TPSUnValueOp(p).FVal1) then
8746 begin
8747 Result := False;
8748 exit;
8749 end;
8750 if TPSUnValueOp(p).FVal1.ClassType = TPSValueData then
8751 begin
8752 //
8753 case TPSUnValueOp(p).Operator of
8754 otNot:
8755 begin
8756 case TPSValueData(TPSUnValueOp(p).FVal1).Data^.FType.BaseType of
8757 btEnum:
8758 begin
8759 if IsBoolean(TPSValueData(TPSUnValueOp(p).FVal1).Data^.FType) then
8760 begin
8761 TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8 := (not TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8) and 1;
8762 end else
8763 begin
8764 MakeError('', ecTypeMismatch, '');
8765 Result := False;
8766 exit;
8767 end;
8768 end;
8769 btU8: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8770 btU16: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8771 btU32: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu32 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu32;
8772 bts8: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts8 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts8;
8773 bts16: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts16 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts16;
8774 bts32: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts32 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts32;
8775 {$IFNDEF PS_NOINT64}
8776 bts64: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8777 {$ENDIF}
8778 else
8779 begin
8780 MakeError('', ecTypeMismatch, '');
8781 Result := False;
8782 exit;
8783 end;
8784 end;
8785 preplace := TPSUnValueOp(p).Val1;
8786 TPSUnValueOp(p).Val1 := nil;
8787 p.Free;
8788 p := preplace;
8789 end;
8790 otMinus:
8791 begin
8792 case TPSValueData(TPSUnValueOp(p).FVal1).Data^.FType.BaseType of
8793 btU8: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8794 btU16: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8795 btU32: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu32 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu32;
8796 bts8: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts8 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts8;
8797 bts16: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts16 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts16;
8798 bts32: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts32 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts32;
8799 {$IFNDEF PS_NOINT64}
8800 bts64: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8801 {$ENDIF}
8802 btSingle: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tsingle := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tsingle;
8803 btDouble: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tdouble := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tdouble;
8804 btExtended: TPSValueData(TPSUnValueOp(p).FVal1).Data^.textended := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.textended;
8805 btCurrency: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tcurrency := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tcurrency;
8806 else
8807 begin
8808 MakeError('', ecTypeMismatch, '');
8809 Result := False;
8810 exit;
8811 end;
8812 end;
8813 preplace := TPSUnValueOp(p).Val1;
8814 TPSUnValueOp(p).Val1 := nil;
8815 p.Free;
8816 p := preplace;
8817 end;
8818 otCast:
8819 begin
8820 preplace := TPSValueData.Create;
8821 TPSValueData(preplace).Data := NewVariant(TPSUnValueOp(p).FType);
8822 case TPSUnValueOp(p).FType.BaseType of
8823 btU8:
8824 begin
8825 case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
8826 btchar: TPSValueData(preplace).Data.tu8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
8827 {$IFNDEF PS_NOWIDESTRING}
8828 btwidechar: TPSValueData(preplace).Data.tu8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
8829 {$ENDIF}
8830 btU8: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8831 btS8: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
8832 btU16: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8833 btS16: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
8834 btU32: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
8835 btS32: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
8836 {$IFNDEF PS_NOINT64}
8837 btS64: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8838 {$ENDIF}
8839 else
8840 begin
8841 MakeError('', ecTypeMismatch, '');
8842 preplace.Free;
8843 Result := False;
8844 exit;
8845 end;
8846 end;
8847 end;
8848 btS8:
8849 begin
8850 case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
8851 btchar: TPSValueData(preplace).Data.ts8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
8852 {$IFNDEF PS_NOWIDESTRING}
8853 btwidechar: TPSValueData(preplace).Data.ts8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
8854 {$ENDIF}
8855 btU8: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8856 btS8: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
8857 btU16: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8858 btS16: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
8859 btU32: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
8860 btS32: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
8861 {$IFNDEF PS_NOINT64}
8862 btS64: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8863 {$ENDIF}
8864 else
8865 begin
8866 MakeError('', ecTypeMismatch, '');
8867 preplace.Free;
8868 Result := False;
8869 exit;
8870 end;
8871 end;
8872 end;
8873 btU16:
8874 begin
8875 case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
8876 btchar: TPSValueData(preplace).Data.tu16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
8877 {$IFNDEF PS_NOWIDESTRING}
8878 btwidechar: TPSValueData(preplace).Data.tu16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
8879 {$ENDIF}
8880 btU8: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8881 btS8: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
8882 btU16: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8883 btS16: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
8884 btU32: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
8885 btS32: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
8886 {$IFNDEF PS_NOINT64}
8887 btS64: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8888 {$ENDIF}
8889 else
8890 begin
8891 MakeError('', ecTypeMismatch, '');
8892 preplace.Free;
8893 Result := False;
8894 exit;
8895 end;
8896 end;
8897 end;
8898 bts16:
8899 begin
8900 case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
8901 btchar: TPSValueData(preplace).Data.ts16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
8902 {$IFNDEF PS_NOWIDESTRING}
8903 btwidechar: TPSValueData(preplace).Data.ts16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
8904 {$ENDIF}
8905 btU8: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8906 btS8: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
8907 btU16: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8908 btS16: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
8909 btU32: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
8910 btS32: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
8911 {$IFNDEF PS_NOINT64}
8912 btS64: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8913 {$ENDIF}
8914 else
8915 begin
8916 MakeError('', ecTypeMismatch, '');
8917 preplace.Free;
8918 Result := False;
8919 exit;
8920 end;
8921 end;
8922 end;
8923 btU32:
8924 begin
8925 case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
8926 btchar: TPSValueData(preplace).Data.tu32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
8927 {$IFNDEF PS_NOWIDESTRING}
8928 btwidechar: TPSValueData(preplace).Data.tu32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
8929 {$ENDIF}
8930 btU8: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8931 btS8: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
8932 btU16: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8933 btS16: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
8934 btU32: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
8935 btS32: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
8936 {$IFNDEF PS_NOINT64}
8937 btS64: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8938 {$ENDIF}
8939 else
8940 begin
8941 MakeError('', ecTypeMismatch, '');
8942 preplace.Free;
8943 Result := False;
8944 exit;
8945 end;
8946 end;
8947 end;
8948 btS32:
8949 begin
8950 case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
8951 btchar: TPSValueData(preplace).Data.ts32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
8952 {$IFNDEF PS_NOWIDESTRING}
8953 btwidechar: TPSValueData(preplace).Data.ts32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
8954 {$ENDIF}
8955 btU8: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8956 btS8: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
8957 btU16: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8958 btS16: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
8959 btU32: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
8960 btS32: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
8961 {$IFNDEF PS_NOINT64}
8962 btS64: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8963 {$ENDIF}
8964 else
8965 begin
8966 MakeError('', ecTypeMismatch, '');
8967 preplace.Free;
8968 Result := False;
8969 exit;
8970 end;
8971 end;
8972 end;
8973 {$IFNDEF PS_NOINT64}
8974 btS64:
8975 begin
8976 case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
8977 btchar: TPSValueData(preplace).Data.ts64 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
8978 {$IFNDEF PS_NOWIDESTRING}
8979 btwidechar: TPSValueData(preplace).Data.ts64 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
8980 {$ENDIF}
8981 btU8: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8982 btS8: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
8983 btU16: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8984 btS16: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
8985 btU32: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
8986 btS32: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
8987 btS64: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8988 else
8989 begin
8990 MakeError('', ecTypeMismatch, '');
8991 preplace.Free;
8992 Result := False;
8993 exit;
8994 end;
8995 end;
8996 end;
8997 {$ENDIF}
8998 btChar:
8999 begin
9000 case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
9001 btchar: TPSValueData(preplace).Data.tchar := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar;
9002 btU8: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8);
9003 btS8: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8);
9004 btU16: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16);
9005 btS16: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16);
9006 btU32: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32);
9007 btS32: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32);
9008 {$IFNDEF PS_NOINT64}
9009 btS64: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64);
9010 {$ENDIF}
9011 else
9012 begin
9013 MakeError('', ecTypeMismatch, '');
9014 Result := False;
9015 preplace.Free;
9016 exit;
9017 end;
9018 end;
9019 end;
9020 else
9021 begin
9022 MakeError('', ecTypeMismatch, '');
9023 Result := False;
9024 preplace.Free;
9025 exit;
9026 end;
9027 end;
9028 p.Free;
9029 p := preplace;
9030 end;
9031 else
9032 begin
9033 MakeError('', ecTypeMismatch, '');
9034 Result := False;
9035 exit;
9036 end;
9037 end; // case
9038 end; // if
9039 end;
9040 Result := True;
9041 end;
9042
9043 var
9044 Temp, Val: TPSValue;
9045 vt: TPSVariableType;
9046
9047 begin
9048 Val := ReadExpression;
9049 if Val = nil then
9050 begin
9051 Result := nil;
9052 exit;
9053 end;
9054 vt := ivtGlobal;
9055 repeat
9056 Temp := Val;
9057 if Val <> nil then CheckFurther(Val, False);
9058 if Val <> nil then CheckClass(Val, vt, InvalidVal, False);
9059 if Val <> nil then CheckExtClass(Val, vt, InvalidVal, False);
9060 {$IFNDEF PS_NOIDISPATCH}if Val <> nil then CheckIntf(Val, vt, InvalidVal, False);{$ENDIF}
9061 if Val <> nil then CheckProcCall(Val);
9062 if Val<> nil then CheckClassArrayProperty(Val, vt, InvalidVal);
9063 until (Val = nil) or (Temp = Val);
9064
9065 if not TryEvalConst(Val) then
9066 begin
9067 Val.Free;
9068 Result := nil;
9069 exit;
9070 end;
9071 Result := Val;
9072 end;
9073
ReadParametersnull9074 function ReadParameters(IsProperty: Boolean; Dest: TPSParameters): Boolean;
9075 var
9076 sr,cr: TPSPasToken;
9077 begin
9078 if IsProperty then
9079 begin
9080 sr := CSTI_OpenBlock;
9081 cr := CSTI_CloseBlock;
9082 end else begin
9083 sr := CSTI_OpenRound;
9084 cr := CSTI_CloseRound;
9085 end;
9086 if FParser.CurrTokenId = sr then
9087 begin
9088 FParser.Next;
9089 if FParser.CurrTokenId = cr then
9090 begin
9091 FParser.Next;
9092 Result := True;
9093 exit;
9094 end;
9095 end else
9096 begin
9097 result := True;
9098 exit;
9099 end;
9100 repeat
9101 with Dest.Add do
9102 begin
9103 Val := calc(CSTI_CloseRound);
9104 if Val = nil then
9105 begin
9106 result := false;
9107 exit;
9108 end;
9109 end;
9110 if FParser.CurrTokenId = cr then
9111 begin
9112 FParser.Next;
9113 Break;
9114 end;
9115 if FParser.CurrTokenId <> CSTI_Comma then
9116 begin
9117 MakeError('', ecCommaExpected, '');
9118 Result := false;
9119 exit;
9120 end; {if}
9121 FParser.Next;
9122 until False;
9123 Result := true;
9124 end;
9125
ReadProcParametersnull9126 function ReadProcParameters(ProcNo: Cardinal; FSelf: TPSValue): TPSValue;
9127 var
9128 Decl: TPSParametersDecl;
9129 begin
9130 if TPSProcedure(FProcs[ProcNo]).ClassType = TPSInternalProcedure then
9131 Decl := TPSInternalProcedure(FProcs[ProcNo]).Decl
9132 else
9133 Decl := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl;
9134 UseProc(Decl);
9135 Result := TPSValueProcNo.Create;
9136 TPSValueProcNo(Result).ProcNo := ProcNo;
9137 TPSValueProcNo(Result).ResultType := Decl.Result;
9138 with TPSValueProcNo(Result) do
9139 begin
9140 SetParserPos(FParser);
9141 Parameters := TPSParameters.Create;
9142 if FSelf <> nil then
9143 begin
9144 Parameters.Add;
9145 end;
9146 end;
9147
9148 if not ReadParameters(False, TPSValueProc(Result).Parameters) then
9149 begin
9150 FSelf.Free;
9151 Result.Free;
9152 Result := nil;
9153 exit;
9154 end;
9155
9156 if not ValidateParameters(BlockInfo, TPSValueProc(Result).Parameters, Decl) then
9157 begin
9158 FSelf.Free;
9159 Result.Free;
9160 Result := nil;
9161 exit;
9162 end;
9163 if FSelf <> nil then
9164 begin
9165 with TPSValueProcNo(Result).Parameters[0] do
9166 begin
9167 Val := FSelf;
9168 ExpectedType := GetTypeNo(BlockInfo, FSelf);
9169 end;
9170 end;
9171 end;
9172 {$IFNDEF PS_NOIDISPATCH}
9173
ReadIDispatchParametersnull9174 function ReadIDispatchParameters(const ProcName: tbtString; aVariantType: TPSVariantType; FSelf: TPSValue): TPSValue;
9175 var
9176 Par: TPSParameters;
9177 PropSet: Boolean;
9178 i: Longint;
9179 Temp: TPSValue;
9180 begin
9181 Par := TPSParameters.Create;
9182 try
9183 if not ReadParameters(FParser.CurrTokenID = CSTI_OpenBlock, Par) then
9184 begin
9185 FSelf.Free;
9186 Result := nil;
9187 exit;
9188 end;
9189
9190 if FParser.CurrTokenID = CSTI_Assignment then
9191 begin
9192 FParser.Next;
9193 PropSet := True;
9194 Temp := calc(CSTI_SemiColon);
9195 if temp = nil then
9196 begin
9197 FSelf.Free;
9198 Result := nil;
9199 exit;
9200 end;
9201 with par.Add do
9202 begin
9203 FValue := Temp;
9204 end;
9205 end else
9206 begin
9207 PropSet := False;
9208 end;
9209
9210 Result := TPSValueProcNo.Create;
9211 TPSValueProcNo(Result).ResultType := aVariantType;
9212 with TPSValueProcNo(Result) do
9213 begin
9214 SetParserPos(FParser);
9215 Parameters := TPSParameters.Create;
9216 if FSelf <> nil then
9217 begin
9218 with Parameters.Add do
9219 begin
9220 Val := FSelf;
9221 ExpectedType := aVariantType.GetDynIvokeSelfType(Self);
9222 end;
9223 with Parameters.Add do
9224 begin
9225 Val := TPSValueData.Create;
9226 TPSValueData(Val).Data := NewVariant(FDefaultBoolType);
9227 TPSValueData(Val).Data.tu8 := Ord(PropSet);
9228 ExpectedType := FDefaultBoolType;
9229 end;
9230
9231 with Parameters.Add do
9232 begin
9233 Val := TPSValueData.Create;
9234 TPSValueData(Val).Data := NewVariant(FindBaseType(btString));
9235 tbtString(TPSValueData(Val).data.tString) := Procname;
9236 ExpectedType := FindBaseType(btString);
9237 end;
9238
9239 with Parameters.Add do
9240 begin
9241 val := TPSValueArray.Create;
9242 ExpectedType := aVariantType.GetDynInvokeParamType(Self);
9243 temp := Val;
9244 end;
9245 for i := 0 to Par.Count -1 do
9246 begin
9247 TPSValueArray(Temp).Add(par.Item[i].Val);
9248 par.Item[i].val := nil;
9249 end;
9250 end;
9251 end;
9252 TPSValueProcNo(Result).ProcNo := aVariantType.GetDynInvokeProcNo(Self, ProcName, TPSValueProcNo(Result).Parameters);
9253 finally
9254 Par.Free;
9255 end;
9256
9257 end;
9258
9259 {$ENDIF}
9260
ReadVarParametersnull9261 function ReadVarParameters(ProcNoVar: TPSValue): TPSValue;
9262 var
9263 Decl: TPSParametersDecl;
9264 begin
9265 Decl := TPSProceduralType(GetTypeNo(BlockInfo, ProcnoVar)).ProcDef;
9266 UseProc(Decl);
9267
9268 Result := TPSValueProcVal.Create;
9269
9270 with TPSValueProcVal(Result) do
9271 begin
9272 ResultType := Decl.Result;
9273 ProcNo := ProcNoVar;
9274 Parameters := TPSParameters.Create;
9275 end;
9276
9277 if not ReadParameters(False, TPSValueProc(Result).Parameters) then
9278 begin
9279 Result.Free;
9280 Result := nil;
9281 exit;
9282 end;
9283
9284 if not ValidateParameters(BlockInfo, TPSValueProc(Result).Parameters, Decl) then
9285 begin
9286 Result.Free;
9287 Result := nil;
9288 exit;
9289 end;
9290 end;
9291
9292
WriteCalculationnull9293 function WriteCalculation(InData, OutReg: TPSValue): Boolean;
9294
CheckOutregnull9295 function CheckOutreg(Where, Outreg: TPSValue; aRoot: Boolean): Boolean;
9296 var
9297 i: Longint;
9298 begin
9299 Result := False;
9300 if Outreg is TPSValueReplace
9301 then Outreg:=TPSValueReplace(Outreg).OldValue;
9302 if Where is TPSValueVar then begin
9303 if TPSValueVar(Where).GetRecCount > 0 then result := true;
9304 if SAmeReg(Where, OutReg) and not aRoot then
9305 result := true;
9306 end else
9307 if Where.ClassType = TPSUnValueOp then
9308 begin
9309 if CheckOutReg(TPSUnValueOp(Where).Val1, OutReg, aRoot) then
9310 Result := True;
9311 end else if Where.ClassType = TPSBinValueOp then
9312 begin
9313 if CheckOutreg(TPSBinValueOp(Where).Val1, OutReg, aRoot) or CheckOutreg(TPSBinValueOp(Where).Val2, OutReg, False) then
9314 Result := True;
9315 end else if Where is TPSValueVar then
9316 begin
9317 if SameReg(Where, OutReg) then
9318 Result := True;
9319 end else if Where is TPSValueProc then
9320 begin
9321 for i := 0 to TPSValueProc(Where).Parameters.Count -1 do
9322 begin
9323 if Checkoutreg(TPSValueProc(Where).Parameters[i].Val, Outreg, false) then
9324 begin
9325 Result := True;
9326 break;
9327 end;
9328 end;
9329 end;
9330 end;
9331 begin
9332 if not CheckCompatType(Outreg, InData) then
9333 begin
9334 MakeError('', ecTypeMismatch, '');
9335 Result := False;
9336 exit;
9337 end;
9338 if SameReg(OutReg, InData) then
9339 begin
9340 Result := True;
9341 exit;
9342 end;
9343 if InData is TPSValueProc then
9344 begin
PSValueProcnull9345 Result := _ProcessFunction(TPSValueProc(indata), OutReg)
9346 end else begin
9347 if not PreWriteOutRec(OutReg, nil) then
9348 begin
9349 Result := False;
9350 exit;
9351 end;
9352 if (not CheckOutReg(InData, OutReg, true)) and (InData is TPSBinValueOp) or (InData is TPSUnValueOp) then
9353 begin
9354 if InData is TPSBinValueOp then
9355 begin
9356 if not DoBinCalc(TPSBinValueOp(InData), OutReg) then
9357 begin
9358 AfterWriteOutRec(OutReg);
9359 Result := False;
9360 exit;
9361 end;
9362 end else
9363 begin
9364 if not DoUnCalc(TPSUnValueOp(InData), OutReg) then
9365 begin
9366 AfterWriteOutRec(OutReg);
9367 Result := False;
9368 exit;
9369 end;
9370 end;
9371 end else if (InData is TPSBinValueOp) and (not CheckOutReg(TPSBinValueOp(InData).Val2, OutReg, false)) then
9372 begin
9373 if not DoBinCalc(TPSBinValueOp(InData), OutReg) then
9374 begin
9375 AfterWriteOutRec(OutReg);
9376 Result := False;
9377 exit;
9378 end;
9379 end else begin
9380 if not PreWriteOutRec(InData, GetTypeNo(BlockInfo, OutReg)) then
9381 begin
9382 Result := False;
9383 exit;
9384 end;
9385 BlockWriteByte(BlockInfo, CM_A);
9386 if not (WriteOutRec(OutReg, False) and WriteOutRec(InData, True)) then
9387 begin
9388 Result := False;
9389 exit;
9390 end;
9391 AfterWriteOutRec(InData);
9392 end;
9393 AfterWriteOutRec(OutReg);
9394 Result := True;
9395 end;
9396 end; {WriteCalculation}
9397
9398
_ProcessFunctionnull9399 function _ProcessFunction(ProcCall: TPSValueProc; ResultRegister: TPSValue): Boolean;
9400 var
9401 res: TPSType;
9402 tmp: TPSParameter;
9403 lTv: TPSValue;
9404 resreg: TPSValue;
9405 l: Longint;
9406
Cleanupnull9407 function Cleanup: Boolean;
9408 var
9409 i: Longint;
9410 begin
9411 for i := 0 to ProcCall.Parameters.Count -1 do
9412 begin
9413 if ProcCall.Parameters[i].TempVar <> nil then
9414 ProcCall.Parameters[i].TempVar.Free;
9415 ProcCall.Parameters[i].TempVar := nil;
9416 end;
9417 if ProcCall is TPSValueProcVal then
9418 AfterWriteOutRec(TPSValueProcVal(ProcCall).fProcNo);
9419 if ResReg <> nil then
9420 AfterWriteOutRec(resreg);
9421 if ResReg <> nil then
9422 begin
9423 if ResReg <> ResultRegister then
9424 begin
9425 if ResultRegister <> nil then
9426 begin
9427 if not WriteCalculation(ResReg, ResultRegister) then
9428 begin
9429 Result := False;
9430 resreg.Free;
9431 exit;
9432 end;
9433 end;
9434 resreg.Free;
9435 end;
9436 end;
9437 Result := True;
9438 end;
9439
9440 begin
9441 Res := ProcCall.ResultType;
9442 if ProcCall.ResultType = FAnyString then
9443 begin
9444 for l := ProcCall.Parameters.Count - 1 downto 0 do
9445 begin
9446 Tmp := ProcCall.Parameters[l];
9447 if (Tmp.ParamMode <> pmOut) and (Tmp.ExpectedType = FAnyString) then
9448 begin
9449 Res := GetTypeNo(BlockInfo, tmp.Val);
9450 Break;
9451 end;
9452 end;
9453 end;
9454 Result := False;
9455 if (res = nil) and (ResultRegister <> nil) then
9456 begin
9457 MakeError('', ecNoResult, '');
9458 exit;
9459 end
9460 else if (res <> nil) then
9461 begin
9462 if (ResultRegister = nil) or (Res <> GetTypeNo(BlockInfo, ResultRegister)) then
9463 begin
9464 resreg := AllocStackReg(res);
9465
9466 end else resreg := ResultRegister;
9467 end
9468 else
9469 resreg := nil;
9470 if ResReg <> nil then
9471 begin
9472 if not PreWriteOutRec(resreg, nil) then
9473 begin
9474 Cleanup;
9475 exit;
9476 end;
9477 end;
9478 if Proccall is TPSValueProcVal then
9479 begin
9480 if not PreWriteOutRec(TPSValueProcVal(ProcCall).fProcNo, nil) then
9481 begin
9482 Cleanup;
9483 exit;
9484 end;
9485 end;
9486 for l := ProcCall.Parameters.Count - 1 downto 0 do
9487 begin
9488 Tmp := ProcCall.Parameters[l];
9489 if (Tmp.ParamMode <> pmIn) then
9490 begin
9491 if IsVarInCompatible(GetTypeNo(BlockInfo, tmp.Val), tmp.ExpectedType) then
9492 begin
9493 with MakeError('', ecTypeMismatch, '') do
9494 begin
9495 pos := tmp.Val.Pos;
9496 row := tmp.Val.row;
9497 col := tmp.Val.col;
9498 end;
9499 Cleanup;
9500 exit;
9501 end;
9502 if Copy(tmp.ExpectedType.Name, 1, 10) = '!OPENARRAY' then begin
9503 tmp.TempVar := AllocPointer(tmp.ExpectedType);
9504 lTv := AllocStackReg(tmp.ExpectedType);
9505 if not PreWriteOutRec(Tmp.FValue, nil) then
9506 begin
9507 cleanup;
9508 exit;
9509 end;
9510 BlockWriteByte(BlockInfo, CM_A);
9511 WriteOutRec(lTv, False);
9512 WriteOutRec(Tmp.FValue, False);
9513 AfterWriteOutRec(Tmp.FValue);
9514
9515 BlockWriteByte(BlockInfo, cm_sp);
9516 WriteOutRec(tmp.TempVar, False);
9517 WriteOutRec(lTv, False);
9518
9519 lTv.Free;
9520 // BlockWriteByte(BlockInfo, CM_PO); // pop the temp var
9521
9522 end else begin
9523 tmp.TempVar := AllocPointer(GetTypeNo(BlockInfo, Tmp.FValue));
9524 if not PreWriteOutRec(Tmp.FValue, nil) then
9525 begin
9526 cleanup;
9527 exit;
9528 end;
9529 BlockWriteByte(BlockInfo, cm_sp);
9530 WriteOutRec(tmp.TempVar, False);
9531 WriteOutRec(Tmp.FValue, False);
9532 AfterWriteOutRec(Tmp.FValue);
9533 end;
9534 end
9535 else
9536 begin
9537 if (Tmp.ExpectedType = nil) or (Tmp.ExpectedType = FAnyString) then
9538 Tmp.ExpectedType := GetTypeNo(BlockInfo, tmp.Val);
9539 if Tmp.ExpectedType.BaseType = btPChar then
9540 begin
9541 Tmp.TempVar := AllocStackReg(at2ut(FindBaseType(btstring)))
9542 end else
9543 begin
9544 Tmp.TempVar := AllocStackReg(Tmp.ExpectedType);
9545 end;
9546 if not WriteCalculation(Tmp.Val, Tmp.TempVar) then
9547 begin
9548 Cleanup;
9549 exit;
9550 end;
9551 end;
9552 end; {for}
9553 if res <> nil then
9554 begin
9555 BlockWriteByte(BlockInfo, CM_PV);
9556
9557 if not WriteOutRec(resreg, False) then
9558 begin
9559 Cleanup;
9560 MakeError('', ecInternalError, '00015');
9561 exit;
9562 end;
9563 end;
9564 if ProcCall is TPSValueProcVal then
9565 begin
9566 BlockWriteByte(BlockInfo, Cm_cv);
9567 WriteOutRec(TPSValueProcVal(ProcCall).ProcNo, True);
9568 end else begin
9569 BlockWriteByte(BlockInfo, CM_C);
9570 BlockWriteLong(BlockInfo, TPSValueProcNo(ProcCall).ProcNo);
9571 end;
9572 if res <> nil then
9573 BlockWriteByte(BlockInfo, CM_PO);
9574 if not Cleanup then
9575 begin
9576 Result := False;
9577 exit;
9578 end;
9579 Result := True;
9580 end; {ProcessVarFunction}
9581
HasInvalidJumpsnull9582 function HasInvalidJumps(StartPos, EndPos: Cardinal): Boolean;
9583 var
9584 I, J: Longint;
9585 Ok: LongBool;
9586 FLabelsInBlock: TIfStringList;
9587 s: tbtString;
9588 begin
9589 FLabelsInBlock := TIfStringList.Create;
9590 for i := 0 to BlockInfo.Proc.FLabels.Count -1 do
9591 begin
9592 s := BlockInfo.Proc.FLabels[I];
9593 if (Cardinal((@s[1])^) >= StartPos) and (Cardinal((@s[1])^) <= EndPos) then
9594 begin
9595 Delete(s, 1, 8);
9596 FLabelsInBlock.Add(s);
9597 end;
9598 end;
9599 for i := 0 to BlockInfo.Proc.FGotos.Count -1 do
9600 begin
9601 s := BlockInfo.Proc.FGotos[I];
9602 if (Cardinal((@s[1])^) >= StartPos) and (Cardinal((@s[1])^) <= EndPos) then
9603 begin
9604 Delete(s, 1, 4);
9605 s := BlockInfo.Proc.FLabels[Cardinal((@s[1])^)];
9606 Delete(s,1,8);
9607 OK := False;
9608 for J := 0 to FLabelsInBlock.Count -1 do
9609 begin
9610 if FLabelsInBlock[J] = s then
9611 begin
9612 Ok := True;
9613 Break;
9614 end;
9615 end;
9616 if not Ok then
9617 begin
9618 MakeError('', ecInvalidJump, '');
9619 Result := True;
9620 FLabelsInBlock.Free;
9621 exit;
9622 end;
9623 end else begin
9624 Delete(s, 1, 4);
9625 s := BlockInfo.Proc.FLabels[Cardinal((@s[1])^)];
9626 Delete(s,1,8);
9627 OK := True;
9628 for J := 0 to FLabelsInBlock.Count -1 do
9629 begin
9630 if FLabelsInBlock[J] = s then
9631 begin
9632 Ok := False;
9633 Break;
9634 end;
9635 end;
9636 if not Ok then
9637 begin
9638 MakeError('', ecInvalidJump, '');
9639 Result := True;
9640 FLabelsInBlock.Free;
9641 exit;
9642 end;
9643 end;
9644 end;
9645 FLabelsInBlock.Free;
9646 Result := False;
9647 end;
9648
ProcessFornull9649 function ProcessFor: Boolean;
9650 { Process a for x := y to z do }
9651 var
9652 VariableVar: TPSValue;
9653 TempBool,
9654 InitVal,
9655 finVal: TPSValue;
9656 Block: TPSBlockInfo;
9657 Backwards: Boolean;
9658 FPos, NPos, EPos, RPos: Longint;
9659 OldCO, OldBO: TPSList;
9660 I: Longint;
9661 iOldWithCount: Integer;
9662 iOldTryCount: Integer;
9663 iOldExFnlCount: Integer;
9664 lType: TPSType;
9665 begin
9666 Debug_WriteLine(BlockInfo);
9667 Result := False;
9668 FParser.Next;
9669 if FParser.CurrTokenId <> CSTI_Identifier then
9670 begin
9671 MakeError('', ecIdentifierExpected, '');
9672 exit;
9673 end;
9674 VariableVar := GetIdentifier(1);
9675 if VariableVar = nil then
9676 exit;
9677 lType := GetTypeNo(BlockInfo, VariableVar);
9678 if lType = nil then begin
9679 MakeError('', ecTypeMismatch, '');
9680 VariableVar.Free;
9681 exit;
9682 end;
9683 case lType.BaseType of
9684 btU8, btS8, btU16, btS16, btU32, btS32, {$IFNDEF PS_NOINT64} btS64, {$ENDIF} btVariant, btEnum: ;
9685 else
9686 begin
9687 MakeError('', ecTypeMismatch, '');
9688 VariableVar.Free;
9689 exit;
9690 end;
9691 end;
9692 if FParser.CurrTokenId <> CSTI_Assignment then
9693 begin
9694 MakeError('', ecAssignmentExpected, '');
9695 VariableVar.Free;
9696 exit;
9697 end;
9698 FParser.Next;
9699 InitVal := calc(CSTII_DownTo);
9700 if InitVal = nil then
9701 begin
9702 VariableVar.Free;
9703 exit;
9704 end;
9705 if FParser.CurrTokenId = CSTII_To then
9706 Backwards := False
9707 else if FParser.CurrTokenId = CSTII_DownTo then
9708 Backwards := True
9709 else
9710 begin
9711 MakeError('', ecToExpected, '');
9712 VariableVar.Free;
9713 InitVal.Free;
9714 exit;
9715 end;
9716 FParser.Next;
9717 finVal := calc(CSTII_do);
9718 if finVal = nil then
9719 begin
9720 VariableVar.Free;
9721 InitVal.Free;
9722 exit;
9723 end;
9724 lType := GetTypeNo(BlockInfo, finVal);
9725 if lType = nil then begin
9726 MakeError('', ecTypeMismatch, '');
9727 VariableVar.Free;
9728 InitVal.Free;
9729 exit;
9730 end;
9731 case lType.BaseType of
9732 btVariant, btEnum, btU8, btS8, btU16, btS16, btU32, {$IFNDEF PS_NOINT64} btS64, {$ENDIF} btS32: ;
9733 else
9734 begin
9735 MakeError('', ecTypeMismatch, '');
9736 VariableVar.Free;
9737 InitVal.Free;
9738 exit;
9739 end;
9740 end;
9741 if FParser.CurrTokenId <> CSTII_do then
9742 begin
9743 MakeError('', ecDoExpected, '');
9744 finVal.Free;
9745 InitVal.Free;
9746 VariableVar.Free;
9747 exit;
9748 end;
9749 FParser.Next;
9750 if not WriteCalculation(InitVal, VariableVar) then
9751 begin
9752 VariableVar.Free;
9753 InitVal.Free;
9754 finVal.Free;
9755 exit;
9756 end;
9757 InitVal.Free;
9758 TempBool := AllocStackReg(at2ut(FDefaultBoolType));
9759 NPos := Length(BlockInfo.Proc.Data);
9760 if not (PreWriteOutRec(VariableVar, nil) and PreWriteOutRec(finVal, nil)) then
9761 begin
9762 TempBool.Free;
9763 VariableVar.Free;
9764 finVal.Free;
9765 exit;
9766 end;
9767 BlockWriteByte(BlockInfo, CM_CO);
9768 if Backwards then
9769 begin
9770 BlockWriteByte(BlockInfo, 0); { >= }
9771 end
9772 else
9773 begin
9774 BlockWriteByte(BlockInfo, 1); { <= }
9775 end;
9776 if not (WriteOutRec(TempBool, False) and WriteOutRec(VariableVar, True) and WriteOutRec(finVal, True)) then
9777 begin
9778 TempBool.Free;
9779 VariableVar.Free;
9780 finVal.Free;
9781 exit;
9782 end;
9783 AfterWriteOutRec(finVal);
9784 AfterWriteOutRec(VariableVar);
9785 finVal.Free;
9786 BlockWriteByte(BlockInfo, Cm_CNG);
9787 EPos := Length(BlockInfo.Proc.Data);
9788 BlockWriteLong(BlockInfo, $12345678);
9789 WriteOutRec(TempBool, False);
9790 RPos := Length(BlockInfo.Proc.Data);
9791 OldCO := FContinueOffsets;
9792 FContinueOffsets := TPSList.Create;
9793 OldBO := FBreakOffsets;
9794 FBreakOffsets := TPSList.Create;
9795 Block := TPSBlockInfo.Create(BlockInfo);
9796 Block.SubType := tOneLiner;
9797
9798 iOldWithCount := FWithCount;
9799 FWithCount := 0;
9800 iOldTryCount := FTryCount;
9801 FTryCount := 0;
9802 iOldExFnlCount := FExceptFinallyCount;
9803 FExceptFinallyCount := 0;
9804
9805 if not ProcessSub(Block) then
9806 begin
9807 Block.Free;
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 Block.Free;
9822 FPos := Length(BlockInfo.Proc.Data);
9823 if not PreWriteOutRec(VariableVar, nil) then
9824 begin
9825 TempBool.Free;
9826 VariableVar.Free;
9827 FBreakOffsets.Free;
9828 FContinueOffsets.Free;
9829 FContinueOffsets := OldCO;
9830 FBreakOffsets := OldBo;
9831
9832 FWithCount := iOldWithCount;
9833 FTryCount := iOldTryCount;
9834 FExceptFinallyCount := iOldExFnlCount;
9835
9836 exit;
9837 end;
9838 if Backwards then
9839 BlockWriteByte(BlockInfo, cm_dec)
9840 else
9841 BlockWriteByte(BlockInfo, cm_inc);
9842 if not WriteOutRec(VariableVar, False) then
9843 begin
9844 TempBool.Free;
9845 VariableVar.Free;
9846 FBreakOffsets.Free;
9847 FContinueOffsets.Free;
9848 FContinueOffsets := OldCO;
9849 FBreakOffsets := OldBo;
9850
9851 FWithCount := iOldWithCount;
9852 FTryCount := iOldTryCount;
9853 FExceptFinallyCount := iOldExFnlCount;
9854
9855 exit;
9856 end;
9857 AfterWriteOutRec(VariableVar);
9858 BlockWriteByte(BlockInfo, Cm_G);
9859 BlockWriteLong(BlockInfo, Longint(NPos - Length(BlockInfo.Proc.Data) - 4));
9860 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
9861 unaligned(Longint((@BlockInfo.Proc.Data[EPos + 1])^)) := Length(BlockInfo.Proc.Data) - RPos;
9862 {$else}
9863 Longint((@BlockInfo.Proc.Data[EPos + 1])^) := Length(BlockInfo.Proc.Data) - RPos;
9864 {$endif}
9865 for i := 0 to FBreakOffsets.Count -1 do
9866 begin
9867 EPos := IPointer(FBreakOffsets[I]);
9868 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
9869 unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(EPos);
9870 {$else}
9871 Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos);
9872 {$endif}
9873 end;
9874 for i := 0 to FContinueOffsets.Count -1 do
9875 begin
9876 EPos := IPointer(FContinueOffsets[I]);
9877 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
9878 unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Longint(FPos) - Longint(EPos);
9879 {$else}
9880 Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(FPos) - Longint(EPos);
9881 {$endif}
9882 end;
9883 FBreakOffsets.Free;
9884 FContinueOffsets.Free;
9885 FContinueOffsets := OldCO;
9886 FBreakOffsets := OldBo;
9887
9888 FWithCount := iOldWithCount;
9889 FTryCount := iOldTryCount;
9890 FExceptFinallyCount := iOldExFnlCount;
9891
9892 TempBool.Free;
9893 VariableVar.Free;
9894 if HasInvalidJumps(RPos, Length(BlockInfo.Proc.Data)) then
9895 begin
9896 Result := False;
9897 exit;
9898 end;
9899 Result := True;
9900 end; {ProcessFor}
9901
ProcessWhilenull9902 function ProcessWhile: Boolean;
9903 var
9904 vin, vout: TPSValue;
9905 SPos, EPos: Cardinal;
9906 OldCo, OldBO: TPSList;
9907 I: Longint;
9908 Block: TPSBlockInfo;
9909
9910 iOldWithCount: Integer;
9911 iOldTryCount: Integer;
9912 iOldExFnlCount: Integer;
9913
9914 begin
9915 Result := False;
9916 Debug_WriteLine(BlockInfo);
9917 FParser.Next;
9918 vout := calc(CSTII_do);
9919 if vout = nil then
9920 exit;
9921 if FParser.CurrTokenId <> CSTII_do then
9922 begin
9923 vout.Free;
9924 MakeError('', ecDoExpected, '');
9925 exit;
9926 end;
9927 vin := AllocStackReg(at2ut(FDefaultBoolType));
9928 SPos := Length(BlockInfo.Proc.Data); // start position
9929 OldCo := FContinueOffsets;
9930 FContinueOffsets := TPSList.Create;
9931 OldBO := FBreakOffsets;
9932 FBreakOffsets := TPSList.Create;
9933 if not WriteCalculation(vout, vin) then
9934 begin
9935 vout.Free;
9936 vin.Free;
9937 FBreakOffsets.Free;
9938 FContinueOffsets.Free;
9939 FContinueOffsets := OldCO;
9940 FBreakOffsets := OldBo;
9941 exit;
9942 end;
9943 vout.Free;
9944 FParser.Next; // skip DO
9945 BlockWriteByte(BlockInfo, Cm_CNG); // only goto if expression is false
9946 BlockWriteLong(BlockInfo, $12345678);
9947 EPos := Length(BlockInfo.Proc.Data);
9948 if not WriteOutRec(vin, False) then
9949 begin
9950 MakeError('', ecInternalError, '00017');
9951 vin.Free;
9952 FBreakOffsets.Free;
9953 FContinueOffsets.Free;
9954 FContinueOffsets := OldCO;
9955 FBreakOffsets := OldBo;
9956 exit;
9957 end;
9958 Block := TPSBlockInfo.Create(BlockInfo);
9959 Block.SubType := tOneLiner;
9960
9961 iOldWithCount := FWithCount;
9962 FWithCount := 0;
9963 iOldTryCount := FTryCount;
9964 FTryCount := 0;
9965 iOldExFnlCount := FExceptFinallyCount;
9966 FExceptFinallyCount := 0;
9967
9968 if not ProcessSub(Block) then
9969 begin
9970 Block.Free;
9971 vin.Free;
9972 FBreakOffsets.Free;
9973 FContinueOffsets.Free;
9974 FContinueOffsets := OldCO;
9975 FBreakOffsets := OldBo;
9976
9977 FWithCount := iOldWithCount;
9978 FTryCount := iOldTryCount;
9979 FExceptFinallyCount := iOldExFnlCount;
9980
9981 exit;
9982 end;
9983 Block.Free;
9984 Debug_WriteLine(BlockInfo);
9985 BlockWriteByte(BlockInfo, Cm_G);
9986 BlockWriteLong(BlockInfo, Longint(SPos) - Length(BlockInfo.Proc.Data) - 4);
9987 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
9988 unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(EPos) - 5;
9989 {$else}
9990 Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos) - 5;
9991 {$endif}
9992 for i := 0 to FBreakOffsets.Count -1 do
9993 begin
9994 EPos := Cardinal(FBreakOffsets[I]);
9995 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
9996 unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(EPos);
9997 {$else}
9998 Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos);
9999 {$endif}
10000 end;
10001 for i := 0 to FContinueOffsets.Count -1 do
10002 begin
10003 EPos := Cardinal(FContinueOffsets[I]);
10004 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10005 unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Longint(SPos) - Longint(EPos);
10006 {$else}
10007 Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(SPos) - Longint(EPos);
10008 {$endif}
10009 end;
10010 FBreakOffsets.Free;
10011 FContinueOffsets.Free;
10012 FContinueOffsets := OldCO;
10013 FBreakOffsets := OldBo;
10014
10015 FWithCount := iOldWithCount;
10016 FTryCount := iOldTryCount;
10017 FExceptFinallyCount := iOldExFnlCount;
10018
10019 vin.Free;
10020 if HasInvalidJumps(EPos, Length(BlockInfo.Proc.Data)) then
10021 begin
10022 Result := False;
10023 exit;
10024 end;
10025 Result := True;
10026 end;
10027
ProcessRepeatnull10028 function ProcessRepeat: Boolean;
10029 var
10030 vin, vout: TPSValue;
10031 CPos, SPos, EPos: Cardinal;
10032 I: Longint;
10033 OldCo, OldBO: TPSList;
10034 Block: TPSBlockInfo;
10035
10036 iOldWithCount: Integer;
10037 iOldTryCount: Integer;
10038 iOldExFnlCount: Integer;
10039
10040 begin
10041 Result := False;
10042 Debug_WriteLine(BlockInfo);
10043 FParser.Next;
10044 OldCo := FContinueOffsets;
10045 FContinueOffsets := TPSList.Create;
10046 OldBO := FBreakOffsets;
10047 FBreakOffsets := TPSList.Create;
10048 vin := AllocStackReg(at2ut(FDefaultBoolType));
10049 SPos := Length(BlockInfo.Proc.Data);
10050 Block := TPSBlockInfo.Create(BlockInfo);
10051 Block.SubType := tRepeat;
10052
10053 iOldWithCount := FWithCount;
10054 FWithCount := 0;
10055 iOldTryCount := FTryCount;
10056 FTryCount := 0;
10057 iOldExFnlCount := FExceptFinallyCount;
10058 FExceptFinallyCount := 0;
10059
10060 if not ProcessSub(Block) then
10061 begin
10062 Block.Free;
10063 FBreakOffsets.Free;
10064 FContinueOffsets.Free;
10065 FContinueOffsets := OldCO;
10066 FBreakOffsets := OldBo;
10067
10068 FWithCount := iOldWithCount;
10069 FTryCount := iOldTryCount;
10070 FExceptFinallyCount := iOldExFnlCount;
10071
10072 vin.Free;
10073 exit;
10074 end;
10075 Block.Free;
10076 FParser.Next; //cstii_until
10077 vout := calc(CSTI_Semicolon);
10078 if vout = nil then
10079 begin
10080 FBreakOffsets.Free;
10081 FContinueOffsets.Free;
10082 FContinueOffsets := OldCO;
10083 FBreakOffsets := OldBo;
10084
10085 FWithCount := iOldWithCount;
10086 FTryCount := iOldTryCount;
10087 FExceptFinallyCount := iOldExFnlCount;
10088
10089 vin.Free;
10090 exit;
10091 end;
10092 CPos := Length(BlockInfo.Proc.Data);
10093 if not WriteCalculation(vout, vin) then
10094 begin
10095 vout.Free;
10096 vin.Free;
10097 FBreakOffsets.Free;
10098 FContinueOffsets.Free;
10099 FContinueOffsets := OldCO;
10100 FBreakOffsets := OldBo;
10101
10102 FWithCount := iOldWithCount;
10103 FTryCount := iOldTryCount;
10104 FExceptFinallyCount := iOldExFnlCount;
10105
10106 exit;
10107 end;
10108 vout.Free;
10109 BlockWriteByte(BlockInfo, Cm_CNG);
10110 BlockWriteLong(BlockInfo, $12345678);
10111 EPos := Length(BlockInfo. Proc.Data);
10112 if not WriteOutRec(vin, False) then
10113 begin
10114 MakeError('', ecInternalError, '00016');
10115 vin.Free;
10116 FBreakOffsets.Free;
10117 FContinueOffsets.Free;
10118 FContinueOffsets := OldCO;
10119 FBreakOffsets := OldBo;
10120
10121 FWithCount := iOldWithCount;
10122 FTryCount := iOldTryCount;
10123 FExceptFinallyCount := iOldExFnlCount;
10124
10125 exit;
10126 end;
10127 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10128 unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Longint(SPos) -
10129 Length(BlockInfo.Proc.Data);
10130 {$else}
10131 Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(SPos) -
10132 Length(BlockInfo.Proc.Data);
10133 {$endif}
10134 for i := 0 to FBreakOffsets.Count -1 do
10135 begin
10136 EPos := Cardinal(FBreakOffsets[I]);
10137 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10138 unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo. Proc.Data) - Longint(EPos);
10139 {$else}
10140 Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo. Proc.Data) - Longint(EPos);
10141 {$endif}
10142 end;
10143 for i := 0 to FContinueOffsets.Count -1 do
10144 begin
10145 EPos := Cardinal(FContinueOffsets[I]);
10146 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10147 unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Longint(CPos) - Longint(EPos);
10148 {$else}
10149 Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(CPos) - Longint(EPos);
10150 {$endif}
10151 end;
10152 FBreakOffsets.Free;
10153 FContinueOffsets.Free;
10154 FContinueOffsets := OldCO;
10155 FBreakOffsets := OldBo;
10156
10157 FWithCount := iOldWithCount;
10158 FTryCount := iOldTryCount;
10159 FExceptFinallyCount := iOldExFnlCount;
10160
10161 vin.Free;
10162 if HasInvalidJumps(SPos, Length(BlockInfo. Proc.Data)) then
10163 begin
10164 Result := False;
10165 exit;
10166 end;
10167 Result := True;
10168 end; {ProcessRepeat}
10169
ProcessIfnull10170 function ProcessIf: Boolean;
10171 var
10172 vout, vin: TPSValue;
10173 SPos, EPos: Cardinal;
10174 Block: TPSBlockInfo;
10175 begin
10176 Result := False;
10177 Debug_WriteLine(BlockInfo);
10178 FParser.Next;
10179 vout := calc(CSTII_Then);
10180 if vout = nil then
10181 exit;
10182 if FParser.CurrTokenId <> CSTII_Then then
10183 begin
10184 vout.Free;
10185 MakeError('', ecThenExpected, '');
10186 exit;
10187 end;
10188 vin := AllocStackReg(at2ut(FDefaultBoolType));
10189 if not WriteCalculation(vout, vin) then
10190 begin
10191 vout.Free;
10192 vin.Free;
10193 exit;
10194 end;
10195 vout.Free;
10196 BlockWriteByte(BlockInfo, cm_sf);
10197 if not WriteOutRec(vin, False) then
10198 begin
10199 MakeError('', ecInternalError, '00018');
10200 vin.Free;
10201 exit;
10202 end;
10203 BlockWriteByte(BlockInfo, 1);
10204 vin.Free;
10205 BlockWriteByte(BlockInfo, cm_fg);
10206 BlockWriteLong(BlockInfo, $12345678);
10207 SPos := Length(BlockInfo.Proc.Data);
10208 FParser.Next; // skip then
10209 Block := TPSBlockInfo.Create(BlockInfo);
10210 Block.SubType := tifOneliner;
10211 if not ProcessSub(Block) then
10212 begin
10213 Block.Free;
10214 exit;
10215 end;
10216 Block.Free;
10217 if FParser.CurrTokenId = CSTII_Else then
10218 begin
10219 BlockWriteByte(BlockInfo, Cm_G);
10220 BlockWriteLong(BlockInfo, $12345678);
10221 EPos := Length(BlockInfo.Proc.Data);
10222 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10223 unaligned(Longint((@BlockInfo.Proc.Data[SPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(SPos);
10224 {$else}
10225 Longint((@BlockInfo.Proc.Data[SPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(SPos);
10226 {$endif}
10227 FParser.Next;
10228 Block := TPSBlockInfo.Create(BlockInfo);
10229 Block.SubType := tOneLiner;
10230 if not ProcessSub(Block) then
10231 begin
10232 Block.Free;
10233 exit;
10234 end;
10235 Block.Free;
10236 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10237 unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(EPos);
10238 {$else}
10239 Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos);
10240 {$endif}
10241 end
10242 else
10243 begin
10244 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10245 unaligned(Longint((@BlockInfo.Proc.Data[SPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(SPos) + 5 - 5;
10246 {$else}
10247 Longint((@BlockInfo.Proc.Data[SPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(SPos) + 5 - 5;
10248 {$endif}
10249 end;
10250 Result := True;
10251 end; {ProcessIf}
10252
_ProcessLabelnull10253 function _ProcessLabel: Longint; {0 = failed; 1 = successful; 2 = no label}
10254 var
10255 I, H: Longint;
10256 s: tbtString;
10257 begin
10258 h := MakeHash(FParser.GetToken);
10259 for i := 0 to BlockInfo.Proc.FLabels.Count -1 do
10260 begin
10261 s := BlockInfo.Proc.FLabels[I];
10262 delete(s, 1, 4);
10263 if Longint((@s[1])^) = h then
10264 begin
10265 delete(s, 1, 4);
10266 if s = FParser.GetToken then
10267 begin
10268 s := BlockInfo.Proc.FLabels[I];
10269 Cardinal((@s[1])^) := Length(BlockInfo.Proc.Data);
10270 BlockInfo.Proc.FLabels[i] := s;
10271 FParser.Next;
10272 if fParser.CurrTokenId = CSTI_Colon then
10273 begin
10274 Result := 1;
10275 FParser.Next;
10276 exit;
10277 end else begin
10278 MakeError('', ecColonExpected, '');
10279 Result := 0;
10280 Exit;
10281 end;
10282 end;
10283 end;
10284 end;
10285 result := 2;
10286 end;
10287
ProcessIdentifiernull10288 function ProcessIdentifier: Boolean;
10289 var
10290 vin, vout: TPSValue;
10291 begin
10292 Result := False;
10293 Debug_WriteLine(BlockInfo);
10294 vin := Calc(CSTI_Assignment);//GetIdentifier(2);
10295 if vin <> nil then
10296 begin
10297 if vin is TPSValueVar then
10298 begin // assignment needed
10299 if FParser.CurrTokenId <> CSTI_Assignment then
10300 begin
10301 MakeError('', ecAssignmentExpected, '');
10302 vin.Free;
10303 exit;
10304 end;
10305 FParser.Next;
10306 vout := calc(CSTI_Semicolon);
10307 if vout = nil then
10308 begin
10309 vin.Free;
10310 exit;
10311 end;
10312 if not WriteCalculation(vout, vin) then
10313 begin
10314 vin.Free;
10315 vout.Free;
10316 exit;
10317 end;
10318 vin.Free;
10319 vout.Free;
10320 end else if vin is TPSValueProc then
10321 begin
PSValueProcnull10322 Result := _ProcessFunction(TPSValueProc(vin), nil);
10323 vin.Free;
10324 Exit;
10325 end else
10326 begin
10327 MakeError('', ecInternalError, '20');
10328 vin.Free;
10329 REsult := False;
10330 exit;
10331 end;
10332 end
10333 else
10334 begin
10335 Result := False;
10336 exit;
10337 end;
10338 Result := True;
10339 end; {ProcessIdentifier}
10340
ProcessCasenull10341 function ProcessCase: Boolean;
10342 var
10343 V1, V2, TempRec, Val, CalcItem: TPSValue;
10344 p: TPSBinValueOp;
10345 SPos, CurrP: Cardinal;
10346 I: Longint;
10347 EndReloc: TPSList;
10348 Block: TPSBlockInfo;
10349
NewRecnull10350 function NewRec(val: TPSValue): TPSValueReplace;
10351 begin
10352 Result := TPSValueReplace.Create;
10353 Result.SetParserPos(FParser);
10354 Result.FNewValue := Val;
10355 Result.FreeNewValue := False;
10356 end;
10357
Combinenull10358 function Combine(v1, v2: TPSValue; Op: TPSBinOperatorType): TPSValue;
10359 begin
10360 if V1 = nil then
10361 begin
10362 Result := v2;
10363 end else if v2 = nil then
10364 begin
10365 Result := V1;
10366 end else
10367 begin
10368 Result := TPSBinValueOp.Create;
10369 TPSBinValueOp(Result).FType := FDefaultBoolType;
10370 TPSBinValueOp(Result).Operator := Op;
10371 Result.SetParserPos(FParser);
10372 TPSBinValueOp(Result).FVal1 := V1;
10373 TPSBinValueOp(Result).FVal2 := V2;
10374 end;
10375 end;
10376
10377
10378 begin
10379 Debug_WriteLine(BlockInfo);
10380 FParser.Next;
10381 Val := calc(CSTII_of);
10382 if Val = nil then
10383 begin
10384 ProcessCase := False;
10385 exit;
10386 end; {if}
10387 if FParser.CurrTokenId <> CSTII_Of then
10388 begin
10389 MakeError('', ecOfExpected, '');
10390 val.Free;
10391 ProcessCase := False;
10392 exit;
10393 end; {if}
10394 FParser.Next;
10395 TempRec := AllocStackReg(GetTypeNo(BlockInfo, Val));
10396 if not WriteCalculation(Val, TempRec) then
10397 begin
10398 TempRec.Free;
10399 val.Free;
10400 ProcessCase := False;
10401 exit;
10402 end; {if}
10403 val.Free;
10404 EndReloc := TPSList.Create;
10405 CalcItem := AllocStackReg(at2ut(FDefaultBoolType));
10406 SPos := Length(BlockInfo.Proc.Data);
10407 repeat
10408 V1 := nil;
10409 while true do
10410 begin
10411 Val := calc(CSTI_Colon);
10412 if (Val = nil) then
10413 begin
10414 V1.Free;
10415 CalcItem.Free;
10416 TempRec.Free;
10417 EndReloc.Free;
10418 ProcessCase := False;
10419 exit;
10420 end; {if}
10421 if fParser.CurrTokenID = CSTI_TwoDots then begin
10422 FParser.Next;
10423 V2 := Calc(CSTI_colon);
10424 if V2 = nil then begin
10425 V1.Free;
10426 CalcItem.Free;
10427 TempRec.Free;
10428 EndReloc.Free;
10429 ProcessCase := False;
10430 Val.Free;
10431 exit;
10432 end;
10433 p := TPSBinValueOp.Create;
10434 p.SetParserPos(FParser);
10435 p.Operator := otGreaterEqual;
10436 p.aType := at2ut(FDefaultBoolType);
10437 p.Val2 := Val;
10438 p.Val1 := NewRec(TempRec);
10439 Val := p;
10440 p := TPSBinValueOp.Create;
10441 p.SetParserPos(FParser);
10442 p.Operator := otLessEqual;
10443 p.aType := at2ut(FDefaultBoolType);
10444 p.Val2 := V2;
10445 p.Val1 := NewRec(TempRec);
10446 P := TPSBinValueOp(Combine(Val,P, otAnd));
10447 end else begin
10448 p := TPSBinValueOp.Create;
10449 p.SetParserPos(FParser);
10450 p.Operator := otEqual;
10451 p.aType := at2ut(FDefaultBoolType);
10452 p.Val1 := Val;
10453 p.Val2 := NewRec(TempRec);
10454 end;
10455 V1 := Combine(V1, P, otOr);
10456 if FParser.CurrTokenId = CSTI_Colon then Break;
10457 if FParser.CurrTokenID <> CSTI_Comma then
10458 begin
10459 MakeError('', ecColonExpected, '');
10460 V1.Free;
10461 CalcItem.Free;
10462 TempRec.Free;
10463 EndReloc.Free;
10464 ProcessCase := False;
10465 exit;
10466 end;
10467 FParser.Next;
10468 end;
10469 FParser.Next;
10470 if not WriteCalculation(V1, CalcItem) then
10471 begin
10472 CalcItem.Free;
10473 v1.Free;
10474 EndReloc.Free;
10475 ProcessCase := False;
10476 exit;
10477 end;
10478 v1.Free;
10479 BlockWriteByte(BlockInfo, Cm_CNG);
10480 BlockWriteLong(BlockInfo, $12345678);
10481 CurrP := Length(BlockInfo.Proc.Data);
10482 WriteOutRec(CalcItem, False);
10483 Block := TPSBlockInfo.Create(BlockInfo);
10484 Block.SubType := tifOneliner;
10485 if not ProcessSub(Block) then
10486 begin
10487 Block.Free;
10488 CalcItem.Free;
10489 TempRec.Free;
10490 EndReloc.Free;
10491 ProcessCase := False;
10492 exit;
10493 end;
10494 Block.Free;
10495 BlockWriteByte(BlockInfo, Cm_G);
10496 BlockWriteLong(BlockInfo, $12345678);
10497 EndReloc.Add(Pointer(Length(BlockInfo.Proc.Data)));
10498 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10499 unaligned(Cardinal((@BlockInfo.Proc.Data[CurrP - 3])^)) := Cardinal(Length(BlockInfo.Proc.Data)) - CurrP - 5;
10500 {$else}
10501 Cardinal((@BlockInfo.Proc.Data[CurrP - 3])^) := Cardinal(Length(BlockInfo.Proc.Data)) - CurrP - 5;
10502 {$endif}
10503 if FParser.CurrTokenID = CSTI_Semicolon then FParser.Next;
10504 if FParser.CurrTokenID = CSTII_Else then
10505 begin
10506 FParser.Next;
10507 Block := TPSBlockInfo.Create(BlockInfo);
10508 Block.SubType := tOneliner;
10509 if not ProcessSub(Block) then
10510 begin
10511 Block.Free;
10512 CalcItem.Free;
10513 TempRec.Free;
10514 EndReloc.Free;
10515 ProcessCase := False;
10516 exit;
10517 end;
10518 Block.Free;
10519 if FParser.CurrTokenID = CSTI_Semicolon then FParser.Next;
10520 if FParser.CurrtokenId <> CSTII_End then
10521 begin
10522 MakeError('', ecEndExpected, '');
10523 CalcItem.Free;
10524 TempRec.Free;
10525 EndReloc.Free;
10526 ProcessCase := False;
10527 exit;
10528 end;
10529 end;
10530 until FParser.CurrTokenID = CSTII_End;
10531 FParser.Next;
10532 for i := 0 to EndReloc.Count -1 do
10533 begin
10534 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10535 unaligned(Cardinal((@BlockInfo.Proc.Data[Cardinal(EndReloc[I])- 3])^)) := Cardinal(Length(BlockInfo.Proc.Data)) - Cardinal(EndReloc[I]);
10536 {$else}
10537 Cardinal((@BlockInfo.Proc.Data[Cardinal(EndReloc[I])- 3])^) := Cardinal(Length(BlockInfo.Proc.Data)) - Cardinal(EndReloc[I]);
10538 {$endif}
10539 end;
10540 CalcItem.Free;
10541 TempRec.Free;
10542 EndReloc.Free;
10543 if FContinueOffsets <> nil then
10544 begin
10545 for i := 0 to FContinueOffsets.Count -1 do
10546 begin
10547 if Cardinal(FContinueOffsets[i]) >= SPos then
10548 begin
10549 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10550 unaligned(Byte((@BlockInfo.Proc.Data[Longint(FContinueOffsets[i]) - 4])^)) := Cm_P2G;
10551 {$else}
10552 Byte((@BlockInfo.Proc.Data[Longint(FContinueOffsets[i]) - 4])^) := Cm_P2G;
10553 {$endif}
10554 end;
10555 end;
10556 end;
10557 if FBreakOffsets <> nil then
10558 begin
10559 for i := 0 to FBreakOffsets.Count -1 do
10560 begin
10561 if Cardinal(FBreakOffsets[i]) >= SPos then
10562 begin
10563 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10564 unaligned(Byte((@BlockInfo.Proc.Data[Longint(FBreakOffsets[i]) - 4])^)) := Cm_P2G;
10565 {$else}
10566 Byte((@BlockInfo.Proc.Data[Longint(FBreakOffsets[i]) - 4])^) := Cm_P2G;
10567 {$endif}
10568 end;
10569 end;
10570 end;
10571 if HasInvalidJumps(SPos, Length(BlockInfo.Proc.Data)) then
10572 begin
10573 Result := False;
10574 exit;
10575 end;
10576 Result := True;
10577 end; {ProcessCase}
ProcessGotonull10578 function ProcessGoto: Boolean;
10579 var
10580 I, H: Longint;
10581 s: tbtString;
10582 begin
10583 Debug_WriteLine(BlockInfo);
10584 FParser.Next;
10585 h := MakeHash(FParser.GetToken);
10586 for i := 0 to BlockInfo.Proc.FLabels.Count -1 do
10587 begin
10588 s := BlockInfo.Proc.FLabels[I];
10589 delete(s, 1, 4);
10590 if Longint((@s[1])^) = h then
10591 begin
10592 delete(s, 1, 4);
10593 if s = FParser.GetToken then
10594 begin
10595 FParser.Next;
10596 BlockWriteByte(BlockInfo, Cm_G);
10597 BlockWriteLong(BlockInfo, $12345678);
10598 BlockInfo.Proc.FGotos.Add(PS_mi2s(length(BlockInfo.Proc.Data))+PS_mi2s(i));
10599 Result := True;
10600 exit;
10601 end;
10602 end;
10603 end;
10604 MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
10605 Result := False;
10606 end; {ProcessGoto}
10607
ProcessWithnull10608 function ProcessWith: Boolean;
10609 var
10610 Block: TPSBlockInfo;
10611 aVar, aReplace: TPSValue;
10612 aType: TPSType;
10613
10614 iStartOffset: Integer;
10615
10616 tmp: TPSValue;
10617 begin
10618 Debug_WriteLine(BlockInfo);
10619 Block := TPSBlockInfo.Create(BlockInfo);
10620 Block.SubType := tOneLiner;
10621
10622 FParser.Next;
10623 repeat
10624 aVar := GetIdentifier(0);
10625 if aVar = nil then
10626 begin
10627 block.Free;
10628 Result := False;
10629 exit;
10630 end;
10631 AType := GetTypeNo(BlockInfo, aVar);
10632 if (AType = nil) or ((aType.BaseType <> btRecord) and (aType.BaseType <> btClass)) then
10633 begin
10634 MakeError('', ecClassTypeExpected, '');
10635 Block.Free;
10636 Result := False;
10637 exit;
10638 end;
10639
10640 aReplace := TPSValueReplace.Create;
10641 aReplace.SetParserPos(FParser);
10642 TPSValueReplace(aReplace).FreeOldValue := True;
10643 TPSValueReplace(aReplace).FreeNewValue := True;
10644 TPSValueReplace(aReplace).OldValue := aVar;
10645
10646 //if aVar.InheritsFrom(TPSVar) then TPSVar(aVar).Use;
10647 tmp := AllocPointer(GetTypeNo(BlockInfo, aVar));
10648 TPSProcVar(BlockInfo.Proc.ProcVars[TPSValueAllocatedStackVar(tmp).LocalVarNo]).Use;
10649 PreWriteOutRec(tmp,GetTypeNo(BlockInfo, tmp));
10650 PreWriteOutRec(aVar,GetTypeNo(BlockInfo, aVar));
10651 BlockWriteByte(BlockInfo, cm_sp);
10652 WriteOutRec(tmp, false);
10653 WriteOutRec(aVar, false);
10654 TPSValueReplace(aReplace).NewValue := tmp;
10655
10656
10657
10658 Block.WithList.Add(aReplace);
10659
10660 if FParser.CurrTokenID = CSTII_do then
10661 begin
10662 FParser.Next;
10663 Break;
10664 end else
10665 if FParser.CurrTokenId <> CSTI_Comma then
10666 begin
10667 MakeError('', ecDoExpected, '');
10668 Block.Free;
10669 Result := False;
10670 exit;
10671 end;
10672 FParser.Next;
10673 until False;
10674
10675
10676 inc(FWithCount);
10677
10678 iStartOffset := Length(Block.Proc.Data);
10679
10680 if not (ProcessSub(Block) and (not HasInvalidJumps(iStartOffset,Length(BlockInfo.Proc.Data) + 1)) ) then
10681 begin
10682 dec(FWithCount);
10683 Block.Free;
10684 Result := False;
10685 exit;
10686 end;
10687 dec(FWithCount);
10688
10689 AfterWriteOutRec(aVar);
10690 AfterWriteOutRec(tmp);
10691 Block.Free;
10692 Result := True;
10693 end;
10694
ProcessTrynull10695 function ProcessTry: Boolean;
10696 var
10697 FStartOffset: Cardinal;
10698 iBlockStartOffset: Integer;
10699 Block: TPSBlockInfo;
10700 begin
10701 FParser.Next;
10702 BlockWriteByte(BlockInfo, cm_puexh);
10703 FStartOffset := Length(BlockInfo.Proc.Data) + 1;
10704 BlockWriteLong(BlockInfo, InvalidVal);
10705 BlockWriteLong(BlockInfo, InvalidVal);
10706 BlockWriteLong(BlockInfo, InvalidVal);
10707 BlockWriteLong(BlockInfo, InvalidVal);
10708 Block := TPSBlockInfo.Create(BlockInfo);
10709 Block.SubType := tTry;
10710 inc(FTryCount);
10711 if ProcessSub(Block) and (not HasInvalidJumps(FStartOffset,Length(BlockInfo.Proc.Data) + 1)) then
10712 begin
10713 dec(FTryCount);
10714 Block.Free;
10715 BlockWriteByte(BlockInfo, cm_poexh);
10716 BlockWriteByte(BlockInfo, 0);
10717 if FParser.CurrTokenID = CSTII_Except then
10718 begin
10719 FParser.Next;
10720 Cardinal((@BlockInfo.Proc.Data[FStartOffset + 4])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
10721 iBlockStartOffset := Length(BlockInfo.Proc.Data) ;
10722 Block := TPSBlockInfo.Create(BlockInfo);
10723 Block.SubType := tTryEnd;
10724 inc(FExceptFinallyCount);
10725 if ProcessSub(Block) and (not HasInvalidJumps(iBlockStartOffset,Length(BlockInfo.Proc.Data) + 1)) then
10726 begin
10727 dec(FExceptFinallyCount);
10728 Block.Free;
10729 BlockWriteByte(BlockInfo, cm_poexh);
10730 BlockWriteByte(BlockInfo, 2);
10731 if FParser.CurrTokenId = CSTII_Finally then
10732 begin
10733 Cardinal((@BlockInfo.Proc.Data[FStartOffset + 8])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
10734 iBlockStartOffset := Length(BlockInfo.Proc.Data) ;
10735 Block := TPSBlockInfo.Create(BlockInfo);
10736 Block.SubType := tTryEnd;
10737 FParser.Next;
10738 inc(FExceptFinallyCount);
10739 if ProcessSub(Block) and (not HasInvalidJumps(iBlockStartOffset,Length(BlockInfo.Proc.Data) + 1)) then
10740 begin
10741 dec(FExceptFinallyCount);
10742 Block.Free;
10743 if FParser.CurrTokenId = CSTII_End then
10744 begin
10745 BlockWriteByte(BlockInfo, cm_poexh);
10746 BlockWriteByte(BlockInfo, 3);
10747 end else begin
10748 MakeError('', ecEndExpected, '');
10749 Result := False;
10750 exit;
10751 end;
10752 end else
10753 begin
10754 Block.Free;
10755 Result := False;
10756 dec(FExceptFinallyCount);
10757 exit;
10758 end;
10759 end else if FParser.CurrTokenID <> CSTII_End then
10760 begin
10761 MakeError('', ecEndExpected, '');
10762 Result := False;
10763 exit;
10764 end;
10765 FParser.Next;
10766 end else
10767 begin
10768 Block.Free;
10769 Result := False;
10770 dec(FExceptFinallyCount);
10771 exit;
10772 end;
10773 end else if FParser.CurrTokenId = CSTII_Finally then
10774 begin
10775 FParser.Next;
10776 Cardinal((@BlockInfo.Proc.Data[FStartOffset])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
10777 iBlockStartOffset := Length(BlockInfo.Proc.Data) ;
10778 Block := TPSBlockInfo.Create(BlockInfo);
10779 Block.SubType := tTryEnd;
10780 inc(FExceptFinallyCount);
10781 if ProcessSub(Block) and (not HasInvalidJumps(iBlockStartOffset,Length(BlockInfo.Proc.Data) + 1)) then
10782 begin
10783 dec(FExceptFinallyCount);
10784 Block.Free;
10785 BlockWriteByte(BlockInfo, cm_poexh);
10786 BlockWriteByte(BlockInfo, 1);
10787 if FParser.CurrTokenId = CSTII_Except then
10788 begin
10789 Cardinal((@BlockInfo.Proc.Data[FStartOffset + 4])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
10790 iBlockStartOffset := Length(BlockInfo.Proc.Data) ;
10791 FParser.Next;
10792 Block := TPSBlockInfo.Create(BlockInfo);
10793 Block.SubType := tTryEnd;
10794 inc(FExceptFinallyCount);
10795 if ProcessSub(Block) and (not HasInvalidJumps(iBlockStartOffset,Length(BlockInfo.Proc.Data) + 1)) then
10796 begin
10797 dec(FExceptFinallyCount);
10798 Block.Free;
10799 if FParser.CurrTokenId = CSTII_End then
10800 begin
10801 BlockWriteByte(BlockInfo, cm_poexh);
10802 BlockWriteByte(BlockInfo, 2);
10803 end else begin
10804 MakeError('', ecEndExpected, '');
10805 Result := False;
10806 exit;
10807 end;
10808 end else
10809 begin
10810 Block.Free;
10811 Result := False;
10812 dec(FExceptFinallyCount);
10813 exit;
10814 end;
10815 end else if FParser.CurrTokenID <> CSTII_End then
10816 begin
10817 MakeError('', ecEndExpected, '');
10818 Result := False;
10819 exit;
10820 end;
10821 FParser.Next;
10822 end else
10823 begin
10824 Block.Free;
10825 Result := False;
10826 dec(FExceptFinallyCount);
10827 exit;
10828 end;
10829 end;
10830 end else
10831 begin
10832 Block.Free;
10833 Result := False;
10834 dec(FTryCount);
10835 exit;
10836 end;
10837 Cardinal((@BlockInfo.Proc.Data[FStartOffset + 12])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
10838 Result := True;
10839 end; {ProcessTry}
10840
10841 var
10842 i: Integer;
10843 Block: TPSBlockInfo;
10844
10845 begin
10846 ProcessSub := False;
10847 if (BlockInfo.SubType = tProcBegin) or (BlockInfo.SubType= tMainBegin) or
10848 {$IFDEF PS_USESSUPPORT}
10849 (BlockInfo.SubType = tUnitInit) or (BlockInfo.SubType= tUnitFinish) or // NvdS
10850 {$endif}
10851 (BlockInfo.SubType= tSubBegin) then
10852 begin
10853 FParser.Next; // skip CSTII_Begin
10854 end;
10855 while True do
10856 begin
10857 case FParser.CurrTokenId of
10858 CSTII_Goto:
10859 begin
10860 if not ProcessGoto then
10861 Exit;
10862 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10863 break;
10864 end;
10865 CSTII_With:
10866 begin
10867 if not ProcessWith then
10868 Exit;
10869 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10870 break;
10871 end;
10872 CSTII_Try:
10873 begin
10874 if not ProcessTry then
10875 Exit;
10876 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10877 break;
10878 end;
10879 CSTII_Finally, CSTII_Except:
10880 begin
10881 if (BlockInfo.SubType = tTry) or (BlockInfo.SubType = tTryEnd) then
10882 Break
10883 else
10884 begin
10885 MakeError('', ecEndExpected, '');
10886 Exit;
10887 end;
10888 end;
10889 CSTII_Begin:
10890 begin
10891 Block := TPSBlockInfo.Create(BlockInfo);
10892 Block.SubType := tSubBegin;
10893 if not ProcessSub(Block) then
10894 begin
10895 Block.Free;
10896 Exit;
10897 end;
10898 Block.Free;
10899
10900 FParser.Next; // skip END
10901 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10902 break;
10903 end;
10904 CSTI_Semicolon:
10905 begin
10906
10907 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10908 break
10909 else FParser.Next;
10910 end;
10911 CSTII_until:
10912 begin
10913 Debug_WriteLine(BlockInfo);
10914 if BlockInfo.SubType = tRepeat then
10915 begin
10916 break;
10917 end
10918 else
10919 begin
10920 MakeError('', ecIdentifierExpected, '');
10921 exit;
10922 end;
10923 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10924 break;
10925 end;
10926 CSTII_Else:
10927 begin
10928 if BlockInfo.SubType = tifOneliner then
10929 break
10930 else
10931 begin
10932 MakeError('', ecIdentifierExpected, '');
10933 exit;
10934 end;
10935 end;
10936 CSTII_repeat:
10937 begin
10938 if not ProcessRepeat then
10939 exit;
10940 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10941 break;
10942 end;
10943 CSTII_For:
10944 begin
10945 if not ProcessFor then
10946 exit;
10947 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10948 break;
10949 end;
10950 CSTII_While:
10951 begin
10952 if not ProcessWhile then
10953 exit;
10954 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10955 break;
10956 end;
10957 CSTII_Exit:
10958 begin
10959 Debug_WriteLine(BlockInfo);
10960 BlockWriteByte(BlockInfo, Cm_R);
10961 FParser.Next;
10962 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10963 break;
10964 end;
10965 CSTII_Case:
10966 begin
10967 if not ProcessCase then
10968 exit;
10969 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10970 break;
10971 end;
10972 CSTII_If:
10973 begin
10974 if not ProcessIf then
10975 exit;
10976 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10977 break;
10978 end;
10979 CSTI_OpenRound,
10980 CSTI_Identifier:
10981 begin
10982 case _ProcessLabel of
10983 0: Exit;
10984 1: ;
10985 else
10986 begin
10987 if FParser.GetToken = 'BREAK' then
10988 begin
10989 if FBreakOffsets = nil then
10990 begin
10991 MakeError('', ecNotInLoop, '');
10992 exit;
10993 end;
10994 for i := 0 to FExceptFinallyCount - 1 do
10995 begin
10996 BlockWriteByte(BlockInfo, cm_poexh);
10997 BlockWriteByte(BlockInfo, 1);
10998 end;
10999
11000 for i := 0 to FTryCount - 1 do
11001 begin
11002 BlockWriteByte(BlockInfo, cm_poexh);
11003 BlockWriteByte(BlockInfo, 0);
11004 BlockWriteByte(BlockInfo, cm_poexh);
11005 BlockWriteByte(BlockInfo, 1);
11006 end;
11007
11008 for i := 0 to FWithCount - 1 do
11009 BlockWriteByte(BlockInfo,cm_po);
11010 BlockWriteByte(BlockInfo, Cm_G);
11011 BlockWriteLong(BlockInfo, $12345678);
11012 FBreakOffsets.Add(Pointer(Length(BlockInfo.Proc.Data)));
11013 FParser.Next;
11014 if (BlockInfo.SubType= tifOneliner) or (BlockInfo.SubType = TOneLiner) then
11015 break;
11016 end else if FParser.GetToken = 'CONTINUE' then
11017 begin
11018 if FBreakOffsets = nil then
11019 begin
11020 MakeError('', ecNotInLoop, '');
11021 exit;
11022 end;
11023 for i := 0 to FExceptFinallyCount - 1 do
11024 begin
11025 BlockWriteByte(BlockInfo, cm_poexh);
11026 BlockWriteByte(BlockInfo, 1);
11027 end;
11028
11029 for i := 0 to FTryCount - 1 do
11030 begin
11031 BlockWriteByte(BlockInfo, cm_poexh);
11032 BlockWriteByte(BlockInfo, 0);
11033 BlockWriteByte(BlockInfo, cm_poexh);
11034 BlockWriteByte(BlockInfo, 1);
11035 end;
11036
11037 for i := 0 to FWithCount - 1 do
11038 BlockWriteByte(BlockInfo,cm_po);
11039 BlockWriteByte(BlockInfo, Cm_G);
11040 BlockWriteLong(BlockInfo, $12345678);
11041 FContinueOffsets.Add(Pointer(Length(BlockInfo.Proc.Data)));
11042 FParser.Next;
11043 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
11044 break;
11045 end else
11046 if not ProcessIdentifier then
11047 exit;
11048 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
11049 break;
11050 end;
11051 end; {case}
11052
11053 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
11054 break;
11055
11056 end;
11057 {$IFDEF PS_USESSUPPORT}
11058 CSTII_Finalization: //NvdS
11059 begin //
11060 if (BlockInfo.SubType = tUnitInit) then //
11061 begin //
11062 break; //
11063 end //
11064 else //
11065 begin //
11066 MakeError('', ecIdentifierExpected, ''); //
11067 exit; //
11068 end; //
11069 end; //nvds
11070 {$endif}
11071 CSTII_End:
11072 begin
11073 if (BlockInfo.SubType = tTryEnd) or (BlockInfo.SubType = tMainBegin) or
11074 (BlockInfo.SubType = tSubBegin) or (BlockInfo.SubType = tifOneliner) or
11075 (BlockInfo.SubType = tProcBegin) or (BlockInfo.SubType = TOneLiner)
11076 {$IFDEF PS_USESSUPPORT} or (BlockInfo.SubType = tUnitInit) or (BlockInfo.SubType = tUnitFinish) {$endif} then //nvds
11077 begin
11078 break;
11079 end
11080 else
11081 begin
11082 MakeError('', ecIdentifierExpected, '');
11083 exit;
11084 end;
11085 end;
11086 CSTI_EOF:
11087 begin
11088 MakeError('', ecUnexpectedEndOfFile, '');
11089 exit;
11090 end;
11091 else
11092 begin
11093 MakeError('', ecIdentifierExpected, '');
11094 exit;
11095 end;
11096 end;
11097 end;
11098 if (BlockInfo.SubType = tMainBegin) or (BlockInfo.SubType = tProcBegin)
11099 {$IFDEF PS_USESSUPPORT} or (BlockInfo.SubType = tUnitInit) or (BlockInfo.SubType = tUnitFinish) {$endif} then //nvds
11100 begin
11101 Debug_WriteLine(BlockInfo);
11102 BlockWriteByte(BlockInfo, Cm_R);
11103 {$IFDEF PS_USESSUPPORT}
11104 if FParser.CurrTokenId = CSTII_End then //nvds
11105 begin
11106 {$endif}
11107 FParser.Next; // skip end
11108 if ((BlockInfo.SubType = tMainBegin)
11109 {$IFDEF PS_USESSUPPORT} or (BlockInfo.SubType = tUnitInit) or (BlockInfo.SubType = tUnitFinish){$endif}) //nvds
11110 and (FParser.CurrTokenId <> CSTI_Period) then
11111 begin
11112 MakeError('', ecPeriodExpected, '');
11113 exit;
11114 end;
11115 if (BlockInfo.SubType = tProcBegin) and (FParser.CurrTokenId <> CSTI_Semicolon) then
11116 begin
11117 MakeError('', ecSemicolonExpected, '');
11118 exit;
11119 end;
11120 FParser.Next;
11121 {$IFDEF PS_USESSUPPORT}
11122 end; //nvds
11123 {$endif}
11124 end
11125 else if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
11126 begin
11127 if (FParser.CurrTokenID <> CSTII_Else) and (FParser.CurrTokenID <> CSTII_End) then
11128 if FParser.CurrTokenID <> CSTI_Semicolon then
11129 begin
11130 MakeError('', ecSemicolonExpected, '');
11131 exit;
11132 end;
11133 end;
11134
11135 ProcessSub := True;
11136 end;
11137 procedure TPSPascalCompiler.UseProc(procdecl: TPSParametersDecl);
11138 var
11139 i: Longint;
11140 begin
11141 if procdecl.Result <> nil then
11142 procdecl.Result := at2ut(procdecl.Result);
11143 for i := 0 to procdecl.ParamCount -1 do
11144 begin
11145 procdecl.Params[i].aType := at2ut(procdecl.Params[i].aType);
11146 end;
11147 end;
11148
at2utnull11149 function TPSPascalCompiler.at2ut(p: TPSType): TPSType;
11150 var
11151 i: Longint;
11152 begin
11153 p := GetTypeCopyLink(p);
11154 if p = nil then
11155 begin
11156 Result := nil;
11157 exit;
11158 end;
11159 if not p.Used then
11160 begin
11161 p.Use;
11162 case p.BaseType of
11163 btStaticArray, btArray: TPSArrayType(p).ArrayTypeNo := at2ut(TPSArrayType(p).ArrayTypeNo);
11164 btRecord:
11165 begin
11166 for i := 0 to TPSRecordType(p).RecValCount -1 do
11167 begin
11168 TPSRecordType(p).RecVal(i).aType := at2ut(TPSRecordType(p).RecVal(i).aType);
11169 end;
11170 end;
11171 btSet: TPSSetType(p).SetType := at2ut(TPSSetType(p).SetType);
11172 btProcPtr:
11173 begin
11174 UseProc(TPSProceduralType(p).ProcDef);
11175 end;
11176 end;
11177 p.FFinalTypeNo := FCurrUsedTypeNo;
11178 inc(FCurrUsedTypeNo);
11179 end;
11180 Result := p;
11181 end;
11182
TPSPascalCompiler.ProcessLabelForwardsnull11183 function TPSPascalCompiler.ProcessLabelForwards(Proc: TPSInternalProcedure): Boolean;
11184 var
11185 i: Longint;
11186 s, s2: tbtString;
11187 begin
11188 for i := 0 to Proc.FLabels.Count -1 do
11189 begin
11190 s := Proc.FLabels[I];
11191 if Longint((@s[1])^) = -1 then
11192 begin
11193 delete(s, 1, 8);
11194 MakeError('', ecUnSetLabel, s);
11195 Result := False;
11196 exit;
11197 end;
11198 end;
11199 for i := Proc.FGotos.Count -1 downto 0 do
11200 begin
11201 s := Proc.FGotos[I];
11202 s2 := Proc.FLabels[Cardinal((@s[5])^)];
11203 Cardinal((@Proc.Data[Cardinal((@s[1])^)-3])^) := Cardinal((@s2[1])^) - Cardinal((@s[1])^) ;
11204 end;
11205 Result := True;
11206 end;
11207
11208
11209 type
11210 TCompilerState = (csStart, csProgram, csUnit, csUses, csInterface, csInterfaceUses, csImplementation);
11211
TPSPascalCompiler.Compilenull11212 function TPSPascalCompiler.Compile(const s: tbtString): Boolean;
11213 var
11214 Position: TCompilerState;
11215 i: Longint;
11216 {$IFDEF PS_USESSUPPORT}
11217 OldFileName: tbtString;
11218 OldParser : TPSPascalParser;
11219 OldIsUnit : Boolean;
11220 OldUnit : TPSUnit;
11221 {$ENDIF}
11222
11223 procedure Cleanup;
11224 var
11225 I: Longint;
11226 PT: TPSType;
11227 begin
11228 {$IFDEF PS_USESSUPPORT}
11229 if fInCompile>1 then
11230 begin
11231 dec(fInCompile);
11232 exit;
11233 end;
11234 {$ENDIF}
11235
11236 if @FOnBeforeCleanup <> nil then
11237 FOnBeforeCleanup(Self); // no reason it actually read the result of this call
11238 FGlobalBlock.Free;
11239 FGlobalBlock := nil;
11240
11241 for I := 0 to FRegProcs.Count - 1 do
11242 TObject(FRegProcs[I]).Free;
11243 FRegProcs.Free;
11244 for i := 0 to FConstants.Count -1 do
11245 begin
11246 TPSConstant(FConstants[I]).Free;
11247 end;
11248 Fconstants.Free;
11249 for I := 0 to FVars.Count - 1 do
11250 begin
11251 TPSVar(FVars[I]).Free;
11252 end;
11253 FVars.Free;
11254 FVars := nil;
11255 for I := 0 to FProcs.Count - 1 do
11256 TPSProcedure(FProcs[I]).Free;
11257 FProcs.Free;
11258 FProcs := nil;
11259 //reverse free types: a custom type's attribute value type may point to a base type
11260 for I := FTypes.Count - 1 downto 0 do
11261 begin
11262 PT := FTypes[I];
11263 pt.Free;
11264 end;
11265 FTypes.Free;
11266
11267 {$IFNDEF PS_NOINTERFACES}
11268 for i := FInterfaces.Count -1 downto 0 do
11269 TPSInterface(FInterfaces[i]).Free;
11270 FInterfaces.Free;
11271 {$ENDIF}
11272
11273 for i := FClasses.Count -1 downto 0 do
11274 begin
11275 TPSCompileTimeClass(FClasses[I]).Free;
11276 end;
11277 FClasses.Free;
11278 for i := FAttributeTypes.Count -1 downto 0 do
11279 begin
11280 TPSAttributeType(FAttributeTypes[i]).Free;
11281 end;
11282 FAttributeTypes.Free;
11283 FAttributeTypes := nil;
11284
11285 {$IFDEF PS_USESSUPPORT}
11286 for I := 0 to FUnitInits.Count - 1 do //nvds
11287 begin //nvds
11288 TPSBlockInfo(FUnitInits[I]).free; //nvds
11289 end; //nvds
11290 FUnitInits.Free; //nvds
11291 FUnitInits := nil; //
11292 for I := 0 to FUnitFinits.Count - 1 do //nvds
11293 begin //nvds
11294 TPSBlockInfo(FUnitFinits[I]).free; //nvds
11295 end; //nvds
11296 FUnitFinits.Free; //
11297 FUnitFinits := nil; //
11298
11299 FreeAndNil(fUnits);
11300 FreeAndNil(FUses);
11301 fInCompile:=0;
11302 {$ENDIF}
11303 end;
11304
11305 function MakeOutput: Boolean;
11306
11307 procedure WriteByte(b: Byte);
11308 begin
11309 FOutput := FOutput + tbtChar(b);
11310 end;
11311
11312 procedure WriteData(const Data; Len: Longint);
11313 var
11314 l: Longint;
11315 begin
11316 if Len < 0 then Len := 0;
11317 l := Length(FOutput);
11318 SetLength(FOutput, l + Len);
11319 Move(Data, FOutput[l + 1], Len);
11320 end;
11321
11322 procedure WriteLong(l: Cardinal);
11323 begin
11324 WriteData(l, 4);
11325 end;
11326
11327 procedure WriteVariant(p: PIfRVariant);
11328 begin
11329 WriteLong(p^.FType.FinalTypeNo);
11330 case p.FType.BaseType of
11331 btType: WriteLong(p^.ttype.FinalTypeNo);
11332 {$IFNDEF PS_NOWIDESTRING}
11333 btWideString:
11334 begin
11335 WriteLong(Length(tbtWideString(p^.twidestring)));
11336 WriteData(tbtwidestring(p^.twidestring)[1], 2*Length(tbtWideString(p^.twidestring)));
11337 end;
11338 btUnicodeString:
11339 begin
11340 WriteLong(Length(tbtUnicodestring(p^.twidestring)));
11341 WriteData(tbtUnicodestring(p^.twidestring)[1], 2*Length(tbtUnicodestring(p^.twidestring)));
11342 end;
11343 btWideChar: WriteData(p^.twidechar, 2);
11344 {$ENDIF}
11345 btSingle: WriteData(p^.tsingle, sizeof(tbtSingle));
11346 btDouble: WriteData(p^.tsingle, sizeof(tbtDouble));
11347 btExtended: WriteData(p^.tsingle, sizeof(tbtExtended));
11348 btCurrency: WriteData(p^.tsingle, sizeof(tbtCurrency));
11349 btChar: WriteData(p^.tchar, 1);
11350 btSet:
11351 begin
11352 WriteData(tbtString(p^.tstring)[1], Length(tbtString(p^.tstring)));
11353 end;
11354 btString:
11355 begin
11356 WriteLong(Length(tbtString(p^.tstring)));
11357 WriteData(tbtString(p^.tstring)[1], Length(tbtString(p^.tstring)));
11358 end;
11359 btenum:
11360 begin
11361 if TPSEnumType(p^.FType).HighValue <=256 then
11362 WriteData( p^.tu32, 1)
11363 else if TPSEnumType(p^.FType).HighValue <=65536 then
11364 WriteData(p^.tu32, 2)
11365 else
11366 WriteData(p^.tu32, 4);
11367 end;
11368 bts8,btu8: WriteData(p^.tu8, 1);
11369 bts16,btu16: WriteData(p^.tu16, 2);
11370 bts32,btu32: WriteData(p^.tu32, 4);
11371 {$IFNDEF PS_NOINT64}
11372 bts64: WriteData(p^.ts64, 8);
11373 {$ENDIF}
11374 btProcPtr: WriteData(p^.tu32, 4);
11375 {$IFDEF DEBUG}
11376 else
11377 asm int 3; end;
11378 {$ENDIF}
11379 end;
11380 end;
11381
11382 procedure WriteAttributes(attr: TPSAttributes);
11383 var
11384 i, j: Longint;
11385 begin
11386 WriteLong(attr.Count);
11387 for i := 0 to Attr.Count -1 do
11388 begin
11389 j := Length(attr[i].FAttribType.Name);
11390 WriteLong(j);
11391 WriteData(Attr[i].FAttribType.Name[1], j);
11392 WriteLong(Attr[i].Count);
11393 for j := 0 to Attr[i].Count -1 do
11394 begin
11395 WriteVariant(Attr[i][j]);
11396 end;
11397 end;
11398 end;
11399
11400 procedure WriteTypes;
11401 var
11402 l, n: Longint;
11403 bt: TPSBaseType;
11404 x: TPSType;
11405 s: tbtString;
11406 FExportName: tbtString;
11407 Items: TPSList;
11408 procedure WriteTypeNo(TypeNo: Cardinal);
11409 begin
11410 WriteData(TypeNo, 4);
11411 end;
11412 begin
11413 Items := TPSList.Create;
11414 try
11415 for l := 0 to FCurrUsedTypeNo -1 do
11416 Items.Add(nil);
11417 for l := 0 to FTypes.Count -1 do
11418 begin
11419 x := FTypes[l];
11420 if x.Used then
11421 Items[x.FinalTypeNo] := x;
11422 end;
11423 for l := 0 to Items.Count - 1 do
11424 begin
11425 x := Items[l];
11426 if x.FExportName then
11427 FExportName := x.Name
11428 else
11429 FExportName := '';
11430 if (x.BaseType = btExtClass) and (x is TPSUndefinedClassType) then
11431 begin
11432 x := GetTypeCopyLink(TPSUndefinedClassType(x).ExtClass.SelfType);
11433 end;
11434 bt := x.BaseType;
11435 if (x.BaseType = btType) or (x.BaseType = btNotificationVariant) then
11436 begin
11437 bt := btU32;
11438 end else
11439 if (x.BaseType = btEnum) then begin
11440 if TPSEnumType(x).HighValue <= 256 then
11441 bt := btU8
11442 else if TPSEnumType(x).HighValue <= 65536 then
11443 bt := btU16
11444 else
11445 bt := btU32;
11446 end;
11447 if FExportName <> '' then
11448 begin
11449 WriteByte(bt + 128);
11450 end
11451 else
11452 WriteByte(bt);
11453 {$IFNDEF PS_NOINTERFACES} if x.BaseType = btInterface then
11454 begin
11455 WriteData(TPSInterfaceType(x).Intf.Guid, Sizeof(TGuid));
11456 end else {$ENDIF} if x.BaseType = btClass then
11457 begin
11458 WriteLong(Length(TPSClassType(X).Cl.FClassName));
11459 WriteData(TPSClassType(X).Cl.FClassName[1], Length(TPSClassType(X).Cl.FClassName));
11460 end else
11461 if (x.BaseType = btProcPtr) then
11462 begin
11463 s := DeclToBits(TPSProceduralType(x).ProcDef);
11464 WriteLong(Length(s));
11465 WriteData(s[1], Length(s));
11466 end else
11467 if (x.BaseType = btSet) then
11468 begin
11469 WriteLong(TPSSetType(x).BitSize);
11470 end else
11471 if (x.BaseType = btArray) or (x.basetype = btStaticArray) then
11472 begin
11473 WriteLong(TPSArrayType(x).ArrayTypeNo.FinalTypeNo);
11474 if (x.baseType = btstaticarray) then begin
11475 WriteLong(TPSStaticArrayType(x).Length);
11476 WriteLong(TPSStaticArrayType(x).StartOffset); //<-additional StartOffset
11477 end;
11478 end else if x.BaseType = btRecord then
11479 begin
11480 n := TPSRecordType(x).RecValCount;
11481 WriteData( n, 4);
11482 for n := 0 to TPSRecordType(x).RecValCount - 1 do
11483 WriteTypeNo(TPSRecordType(x).RecVal(n).FType.FinalTypeNo);
11484 end;
11485 if FExportName <> '' then
11486 begin
11487 WriteLong(Length(FExportName));
11488 WriteData(FExportName[1], length(FExportName));
11489 end;
11490 WriteAttributes(x.Attributes);
11491 end;
11492 finally
11493 Items.Free;
11494 end;
11495 end;
11496
11497 procedure WriteVars;
11498 var
11499 l,j : Longint;
11500 x: TPSVar;
11501 begin
11502 for l := 0 to FVars.Count - 1 do
11503 begin
11504 x := FVars[l];
11505 if x.SaveAsPointer then
11506 begin
11507 for j := FTypes.count -1 downto 0 do
11508 begin
11509 if TPSType(FTypes[j]).BaseType = btPointer then
11510 begin
11511 WriteLong(TPSType(FTypes[j]).FinalTypeNo);
11512 break;
11513 end;
11514 end;
11515 end else
11516 WriteLong(x.FType.FinalTypeNo);
11517 if x.exportname <> '' then
11518 begin
11519 WriteByte( 1);
11520 WriteLong(Length(X.ExportName));
11521 WriteData( X.ExportName[1], length(X.ExportName));
11522 end else
11523 WriteByte( 0);
11524 end;
11525 end;
11526
11527 procedure WriteProcs;
11528 var
11529 l: Longint;
11530 xp: TPSProcedure;
11531 xo: TPSInternalProcedure;
11532 xe: TPSExternalProcedure;
11533 s: tbtString;
11534 att: Byte;
11535 begin
11536 for l := 0 to FProcs.Count - 1 do
11537 begin
11538 xp := FProcs[l];
11539 if xp.Attributes.Count <> 0 then att := 4 else att := 0;
11540 if xp.ClassType = TPSInternalProcedure then
11541 begin
11542 xo := TPSInternalProcedure(xp);
11543 xo.OutputDeclPosition := Length(FOutput);
11544 WriteByte(att or 2); // exported
11545 WriteLong(0); // offset is unknown at this time
11546 WriteLong(0); // length is also unknown at this time
11547 WriteLong(Length(xo.Name));
11548 WriteData( xo.Name[1], length(xo.Name));
11549 s := MakeExportDecl(xo.Decl);
11550 WriteLong(Length(s));
11551 WriteData( s[1], length(S));
11552 end
11553 else
11554 begin
11555 xe := TPSExternalProcedure(xp);
11556 if xe.RegProc.ImportDecl <> '' then
11557 begin
11558 WriteByte( att or 3); // imported
11559 if xe.RegProc.FExportName then
11560 begin
11561 WriteByte(Length(xe.RegProc.Name));
11562 WriteData(xe.RegProc.Name[1], Length(xe.RegProc.Name) and $FF);
11563 end else begin
11564 WriteByte(0);
11565 end;
11566 WriteLong(Length(xe.RegProc.ImportDecl));
11567 WriteData(xe.RegProc.ImportDecl[1], Length(xe.RegProc.ImportDecl));
11568 end else begin
11569 WriteByte(att or 1); // imported
11570 WriteByte(Length(xe.RegProc.Name));
11571 WriteData(xe.RegProc.Name[1], Length(xe.RegProc.Name) and $FF);
11572 end;
11573 end;
11574 if xp.Attributes.Count <> 0 then
11575 WriteAttributes(xp.Attributes);
11576 end;
11577 end;
11578
11579 procedure WriteProcs2;
11580 var
11581 l: Longint;
11582 L2: Cardinal;
11583 x: TPSProcedure;
11584 begin
11585 for l := 0 to FProcs.Count - 1 do
11586 begin
11587 x := FProcs[l];
11588 if x.ClassType = TPSInternalProcedure then
11589 begin
11590 if TPSInternalProcedure(x).Data = '' then
11591 TPSInternalProcedure(x).Data := Chr(Cm_R);
11592 L2 := Length(FOutput);
11593 Move(L2, FOutput[TPSInternalProcedure(x).OutputDeclPosition + 2], 4);
11594 // write position
11595 WriteData(TPSInternalProcedure(x).Data[1], Length(TPSInternalProcedure(x).Data));
11596 L2 := Cardinal(Length(FOutput)) - L2;
11597 Move(L2, FOutput[TPSInternalProcedure(x).OutputDeclPosition + 6], 4); // write length
11598 end;
11599 end;
11600 end;
11601
11602
11603
11604 {$IFDEF PS_USESSUPPORT}
11605 function FindMainProc: Cardinal;
11606 var
11607 l: Longint;
11608 Proc : TPSInternalProcedure;
11609 ProcData : tbtString;
11610 Calls : Integer;
11611
11612 procedure WriteProc(const aData: Longint);
11613 var
11614 l: Longint;
11615 begin
11616 ProcData := ProcData + Chr(cm_c);
11617 l := Length(ProcData);
11618 SetLength(ProcData, l + 4);
11619 Move(aData, ProcData[l + 1], 4);
11620 inc(Calls);
11621 end;
11622 begin
11623 ProcData := ''; Calls := 1;
11624 for l := 0 to FUnitInits.Count-1 do
11625 if (FUnitInits[l] <> nil) and
11626 (TPSBlockInfo(FUnitInits[l]).Proc.Data<>'') then
11627 WriteProc(TPSBlockInfo(FUnitInits[l]).FProcNo);
11628
11629 WriteProc(FGlobalBlock.FProcNo);
11630
11631 for l := FUnitFinits.Count-1 downto 0 do
11632 if (FUnitFinits[l] <> nil) and
11633 (TPSBlockInfo(FUnitFinits[l]).Proc.Data<>'') then
11634 WriteProc(TPSBlockInfo(FUnitFinits[l]).FProcNo);
11635
11636 if Calls = 1 then begin
11637 Result := FGlobalBlock.FProcNo;
11638 end else
11639 begin
11640 Proc := NewProc('Master proc', '!MASTERPROC');
11641 Result := FindProc('!MASTERPROC');
11642 Proc.data := Procdata + Chr(cm_R);
11643 end;
11644 end;
11645 {$ELSE}
11646 function FindMainProc: Cardinal;
11647 var
11648 l: Longint;
11649 begin
11650 for l := 0 to FProcs.Count - 1 do
11651 begin
11652 if (TPSProcedure(FProcs[l]).ClassType = TPSInternalProcedure) and
11653 (TPSInternalProcedure(FProcs[l]).Name = PSMainProcName) then
11654 begin
11655 Result := l;
11656 exit;
11657 end;
11658 end;
11659 Result := InvalidVal;
11660 end;
11661 {$ENDIF}
11662
11663 procedure CreateDebugData;
11664 var
11665 I: Longint;
11666 p: TPSProcedure;
11667 pv: TPSVar;
11668 s: tbtString;
11669 begin
11670 s := #0;
11671 for I := 0 to FProcs.Count - 1 do
11672 begin
11673 p := FProcs[I];
11674 if p.ClassType = TPSInternalProcedure then
11675 begin
11676 if TPSInternalProcedure(p).Name = PSMainProcName then
11677 s := s + #1
11678 else
11679 s := s + TPSInternalProcedure(p).OriginalName + #1;
11680 end
11681 else
11682 begin
11683 s := s+ TPSExternalProcedure(p).RegProc.OrgName + #1;
11684 end;
11685 end;
11686 s := s + #0#1;
11687 for I := 0 to FVars.Count - 1 do
11688 begin
11689 pv := FVars[I];
11690 s := s + pv.OrgName + #1;
11691 end;
11692 s := s + #0;
11693 WriteDebugData(s);
11694 end;
11695
11696 var //nvds
11697 MainProc : Cardinal; //nvds
11698
11699 begin
11700 if @FOnBeforeOutput <> nil then
11701 begin
11702 if not FOnBeforeOutput(Self) then
11703 begin
11704 Result := false;
11705 exit;
11706 end;
11707 end;
11708 MainProc := FindMainProc; //NvdS (need it here becose FindMainProc can create a New proc.
11709 CreateDebugData;
11710 WriteLong(PSValidHeader);
11711 WriteLong(PSCurrentBuildNo);
11712 WriteLong(FCurrUsedTypeNo);
11713 WriteLong(FProcs.Count);
11714 WriteLong(FVars.Count);
11715 WriteLong(MainProc); //nvds
11716 WriteLong(0);
11717 WriteTypes;
11718 WriteProcs;
11719 WriteVars;
11720 WriteProcs2;
11721
11722 Result := true;
11723 end;
11724
11725 function CheckExports: Boolean;
11726 var
11727 i: Longint;
11728 p: TPSProcedure;
11729 begin
11730 if @FOnExportCheck = nil then
11731 begin
11732 result := true;
11733 exit;
11734 end;
11735 for i := 0 to FProcs.Count -1 do
11736 begin
11737 p := FProcs[I];
11738 if p.ClassType = TPSInternalProcedure then
11739 begin
11740 if not FOnExportCheck(Self, TPSInternalProcedure(p), MakeDecl(TPSInternalProcedure(p).Decl)) then
11741 begin
11742 Result := false;
11743 exit;
11744 end;
11745 end;
11746 end;
11747 Result := True;
11748 end;
11749 function DoConstBlock: Boolean;
11750 var
11751 COrgName: tbtString;
11752 CTemp, CValue: PIFRVariant;
11753 Cp: TPSConstant;
11754 TokenPos, TokenRow, TokenCol: Integer;
11755 begin
11756 FParser.Next;
11757 repeat
11758 if FParser.CurrTokenID <> CSTI_Identifier then
11759 begin
11760 MakeError('', ecIdentifierExpected, '');
11761 Result := False;
11762 Exit;
11763 end;
11764 TokenPos := FParser.CurrTokenPos;
11765 TokenRow := FParser.Row;
11766 TokenCol := FParser.Col;
11767 COrgName := FParser.OriginalToken;
11768 if IsDuplicate(FastUpperCase(COrgName), [dcVars, dcProcs, dcConsts]) then
11769 begin
11770 MakeError('', ecDuplicateIdentifier, COrgName);
11771 Result := False;
11772 exit;
11773 end;
11774 FParser.Next;
11775 if FParser.CurrTokenID <> CSTI_Equal then
11776 begin
11777 MakeError('', ecIsExpected, '');
11778 Result := False;
11779 Exit;
11780 end;
11781 FParser.Next;
11782 CValue := ReadConstant(FParser, CSTI_SemiColon);
11783 if CValue = nil then
11784 begin
11785 Result := False;
11786 Exit;
11787 end;
11788 if FParser.CurrTokenID <> CSTI_Semicolon then
11789 begin
11790 MakeError('', ecSemicolonExpected, '');
11791 Result := False;
11792 exit;
11793 end;
11794 cp := TPSConstant.Create;
11795 cp.Orgname := COrgName;
11796 cp.Name := FastUpperCase(COrgName);
11797 {$IFDEF PS_USESSUPPORT}
11798 cp.DeclareUnit:=fModule;
11799 {$ENDIF}
11800 cp.DeclarePos := TokenPos;
11801 cp.DeclareRow := TokenRow;
11802 cp.DeclareCol := TokenCol;
11803 New(CTemp);
11804 InitializeVariant(CTemp, CValue.FType);
11805 CopyVariantContents(cvalue, CTemp);
11806 cp.Value := CTemp;
11807 FConstants.Add(cp);
11808 DisposeVariant(CValue);
11809 FParser.Next;
11810 until FParser.CurrTokenId <> CSTI_Identifier;
11811 Result := True;
11812 end;
11813
11814 function ProcessUses: Boolean;
11815 var
11816 {$IFNDEF PS_USESSUPPORT}
11817 FUses: TIfStringList;
11818 {$ENDIF}
11819 I: Longint;
11820 s: tbtString;
11821 {$IFDEF PS_USESSUPPORT}
11822 Parse: Boolean;
11823 ParseUnit: tbtString;
11824 ParserPos: TPSPascalParser;
11825 {$ENDIF}
11826 begin
11827 FParser.Next;
11828 {$IFNDEF PS_USESSUPPORT}
11829 FUses := TIfStringList.Create;
11830 FUses.Add('System');
11831 {$ENDIF}
11832 repeat
11833 if FParser.CurrTokenID <> CSTI_Identifier then
11834 begin
11835 MakeError('', ecIdentifierExpected, '');
11836 {$IFNDEF PS_USESSUPPORT}
11837 FUses.Free;
11838 {$ENDIF}
11839 Result := False;
11840 exit;
11841 end;
11842 s := FParser.GetToken;
11843 {$IFDEF PS_USESSUPPORT}
11844 Parse:=true;
11845 {$ENDIF}
11846 for i := 0 to FUses.Count -1 do
11847 begin
11848 if FUses[I] = s then
11849 begin
11850 {$IFNDEF PS_USESSUPPORT}
11851 MakeError('', ecDuplicateIdentifier, s);
11852 FUses.Free;
11853 Result := False;
11854 exit;
11855 {$ELSE}
11856 Parse:=false;
11857 {$ENDIF}
11858 end;
11859 end;
11860 {$IFDEF PS_USESSUPPORT}
11861 if fUnits.GetUnit(S).HasUses(fModule) then
11862 begin
11863 MakeError('', ecCrossReference, s);
11864 Result := False;
11865 exit;
11866 end;
11867
11868 fUnit.AddUses(S);
11869
11870 if Parse then
11871 begin
11872 {$ENDIF}
11873 FUses.Add(s);
11874 if @FOnUses <> nil then
11875 begin
11876 try
11877 {$IFDEF PS_USESSUPPORT}
11878 OldFileName:=fModule;
11879 fModule:=FParser.OriginalToken;
11880 ParseUnit:=FParser.OriginalToken;
11881 ParserPos:=FParser;
11882 {$ENDIF}
11883 if not OnUses(Self, FParser.GetToken) then
11884 begin
11885 {$IFNDEF PS_USESSUPPORT}
11886 FUses.Free;
11887 {$ELSE}
11888 FParser:=ParserPos;
11889 fModule:=OldFileName;
11890 MakeError(OldFileName, ecUnitNotFoundOrContainsErrors, ParseUnit);
11891 {$ENDIF}
11892 Result := False;
11893 exit;
11894 end;
11895 {$IFDEF PS_USESSUPPORT}
11896 fModule:=OldFileName;
11897 {$ENDIF}
11898 except
11899 on e: Exception do
11900 begin
11901 MakeError('', ecCustomError, tbtstring(e.Message));
11902 {$IFNDEF PS_USESSUPPORT}
11903 FUses.Free;
11904 {$ENDIF}
11905 Result := False;
11906 exit;
11907 end;
11908 end;
11909 end;
11910 {$IFDEF PS_USESSUPPORT}
11911 end;
11912 {$ENDIF}
11913 FParser.Next;
11914 if FParser.CurrTokenID = CSTI_Semicolon then break
11915 else if FParser.CurrTokenId <> CSTI_Comma then
11916 begin
11917 MakeError('', ecSemicolonExpected, '');
11918 Result := False;
11919 {$IFNDEF PS_USESSUPPORT}
11920 FUses.Free;
11921 {$ENDIF}
11922 exit;
11923 end;
11924 FParser.Next;
11925 until False;
11926 {$IFNDEF PS_USESSUPPORT}
11927 FUses.Free;
11928 {$ENDIF}
11929 FParser.next;
11930 Result := True;
11931 end;
11932
11933 var
11934 Proc: TPSProcedure;
11935 {$IFDEF PS_USESSUPPORT}
11936 Block : TPSBlockInfo; //nvds
11937 {$ENDIF}
11938 begin
11939 Result := False;
11940 FWithCount := -1;
11941
11942 {$IFDEF PS_USESSUPPORT}
11943 if fInCompile=0 then
11944 begin
11945 {$ENDIF}
11946 FUnitName := '';
11947 FCurrUsedTypeNo := 0;
11948 FIsUnit := False;
11949 Clear;
11950 FParserHadError := False;
11951 FParser.SetText(s);
11952 FAttributeTypes := TPSList.Create;
11953 FProcs := TPSList.Create;
11954 FConstants := TPSList.Create;
11955 FVars := TPSList.Create;
11956 FTypes := TPSList.Create;
11957 FRegProcs := TPSList.Create;
11958 FClasses := TPSList.Create;
11959
11960 {$IFDEF PS_USESSUPPORT}
11961 FUnitInits := TPSList.Create; //nvds
11962 FUnitFinits:= TPSList.Create; //nvds
11963
11964 FUses:=TIFStringList.Create;
11965 FUnits:=TPSUnitList.Create;
11966 {$ENDIF}
11967 {$IFNDEF PS_NOINTERFACES} FInterfaces := TPSList.Create;{$ENDIF}
11968
11969 FGlobalBlock := TPSBlockInfo.Create(nil);
11970 FGlobalBlock.SubType := tMainBegin;
11971
11972 FGlobalBlock.Proc := NewProc(PSMainProcNameOrg, PSMainProcName);
11973 FGlobalBlock.ProcNo := FindProc(PSMainProcName);
11974
11975 {$IFDEF PS_USESSUPPORT}
11976 OldFileName:=fModule;
11977 fModule:='System';
11978 FUses.Add('System');
11979 {$ENDIF}
11980 {$IFNDEF PS_NOSTANDARDTYPES}
11981 DefineStandardTypes;
11982 DefineStandardProcedures;
11983 {$ENDIF}
11984 if @FOnUses <> nil then
11985 begin
11986 try
11987 if not OnUses(Self, 'SYSTEM') then
11988 begin
11989 Cleanup;
11990 exit;
11991 end;
11992 except
11993 on e: Exception do
11994 begin
11995 MakeError('', ecCustomError, tbtstring(e.Message));
11996 Cleanup;
11997 exit;
11998 end;
11999 end;
12000 end;
12001 {$IFDEF PS_USESSUPPORT}
12002 fModule:=OldFileName;
12003 OldParser:=nil;
12004 OldUnit:=nil;
12005 OldIsUnit:=false; // defaults
12006 end
12007 else
12008 begin
12009 OldParser:=FParser;
12010 OldIsUnit:=FIsUnit;
12011 OldUnit:=fUnit;
12012 FParser:=TPSPascalParser.Create;
12013 FParser.SetText(s);
12014 end;
12015
12016 fUnit:=fUnits.GetUnit(fModule);
12017
12018 inc(fInCompile);
12019 {$ENDIF}
12020
12021 Position := csStart;
12022 repeat
12023 if FParser.CurrTokenId = CSTI_EOF then
12024 begin
12025 if FParserHadError then
12026 begin
12027 Cleanup;
12028 exit;
12029 end;
12030 if FAllowNoEnd then
12031 Break
12032 else
12033 begin
12034 MakeError('', ecUnexpectedEndOfFile, '');
12035 Cleanup;
12036 exit;
12037 end;
12038 end;
12039 if (FParser.CurrTokenId = CSTII_Program) and (Position = csStart) then
12040 begin
12041 {$IFDEF PS_USESSUPPORT}
12042 if fInCompile>1 then
12043 begin
12044 MakeError('', ecNotAllowed, 'program');
12045 Cleanup;
12046 exit;
12047 end;
12048 {$ENDIF}
12049 Position := csProgram;
12050 FParser.Next;
12051 if FParser.CurrTokenId <> CSTI_Identifier then
12052 begin
12053 MakeError('', ecIdentifierExpected, '');
12054 Cleanup;
12055 exit;
12056 end;
12057 FParser.Next;
12058 if FParser.CurrTokenId <> CSTI_Semicolon then
12059 begin
12060 MakeError('', ecSemicolonExpected, '');
12061 Cleanup;
12062 exit;
12063 end;
12064 FParser.Next;
12065 end else
12066 if (Fparser.CurrTokenID = CSTII_Implementation) and ((Position = csinterface) or (position = csInterfaceUses)) then
12067 begin
12068 Position := csImplementation;
12069 FParser.Next;
12070 end else
12071 if (Fparser.CurrTokenID = CSTII_Interface) and (Position = csUnit) then
12072 begin
12073 Position := csInterface;
12074 FParser.Next;
12075 end else
12076 if (FParser.CurrTokenId = CSTII_Unit) and (Position = csStart) and (FAllowUnit) then
12077 begin
12078 Position := csUnit;
12079 FIsUnit := True;
12080 FParser.Next;
12081 if FParser.CurrTokenId <> CSTI_Identifier then
12082 begin
12083 MakeError('', ecIdentifierExpected, '');
12084 Cleanup;
12085 exit;
12086 end;
12087 if fInCompile = 1 then
12088 FUnitName := FParser.OriginalToken;
12089 FParser.Next;
12090 if FParser.CurrTokenId <> CSTI_Semicolon then
12091 begin
12092 MakeError('', ecSemicolonExpected, '');
12093 Cleanup;
12094 exit;
12095 end;
12096 FParser.Next;
12097 end
12098 else if (FParser.CurrTokenID = CSTII_Uses) and ((Position < csuses) or (Position = csInterface)) then
12099 begin
12100 if (Position = csInterface) or (Position =csInterfaceUses)
12101 then Position := csInterfaceUses
12102 else Position := csUses;
12103 if not ProcessUses then
12104 begin
12105 Cleanup;
12106 exit;
12107 end;
12108 end else if (FParser.CurrTokenId = CSTII_Procedure) or
12109 (FParser.CurrTokenId = CSTII_Function) or (FParser.CurrTokenID = FAttributesOpenTokenID) then
12110 begin
12111 if (Position = csInterface) or (position = csInterfaceUses) then
12112 begin
12113 if not ProcessFunction(True, nil) then
12114 begin
12115 Cleanup;
12116 exit;
12117 end;
12118 end else begin
12119 Position := csUses;
12120 if not ProcessFunction(False, nil) then
12121 begin
12122 Cleanup;
12123 exit;
12124 end;
12125 end;
12126 end
12127 else if (FParser.CurrTokenId = CSTII_Label) then
12128 begin
12129 if (Position = csInterface) or (Position =csInterfaceUses)
12130 then Position := csInterfaceUses
12131 else Position := csUses;
12132 if not ProcessLabel(FGlobalBlock.Proc) then
12133 begin
12134 Cleanup;
12135 exit;
12136 end;
12137 end
12138 else if (FParser.CurrTokenId = CSTII_Var) then
12139 begin
12140 if (Position = csInterface) or (Position =csInterfaceUses)
12141 then Position := csInterfaceUses
12142 else Position := csUses;
12143 if not DoVarBlock(nil) then
12144 begin
12145 Cleanup;
12146 exit;
12147 end;
12148 end
12149 else if (FParser.CurrTokenId = CSTII_Const) then
12150 begin
12151 if (Position = csInterface) or (Position =csInterfaceUses)
12152 then Position := csInterfaceUses
12153 else Position := csUses;
12154 if not DoConstBlock then
12155 begin
12156 Cleanup;
12157 exit;
12158 end;
12159 end
12160 else if (FParser.CurrTokenId = CSTII_Type) then
12161 begin
12162 if (Position = csInterface) or (Position =csInterfaceUses)
12163 then Position := csInterfaceUses
12164 else Position := csUses;
12165 if not DoTypeBlock(FParser) then
12166 begin
12167 Cleanup;
12168 exit;
12169 end;
12170 end
12171 else if (FParser.CurrTokenId = CSTII_Begin)
12172 {$IFDEF PS_USESSUPPORT}
12173 or ((FParser.CurrTokenID = CSTII_initialization) and FIsUnit) {$ENDIF} then //nvds
12174 begin
12175 {$IFDEF PS_USESSUPPORT}
12176 if FIsUnit then
12177 begin
12178 Block := TPSBlockInfo.Create(nil); //nvds
12179 Block.SubType := tUnitInit; //nvds
12180 Block.Proc := NewProc(PSMainProcNameOrg+'_'+fModule, FastUpperCase(PSMainProcName+'_'+fModule)); //nvds
12181 Block.ProcNo := FindProc(PSMainProcName+'_'+fModule); //nvds
12182 Block.Proc.DeclareUnit:= fModule;
12183 Block.Proc.DeclarePos := FParser.CurrTokenPos;
12184 Block.Proc.DeclareRow := FParser.Row;
12185 Block.Proc.DeclareCol := FParser.Col;
12186 Block.Proc.Use;
12187 FUnitInits.Add(Block);
12188 if ProcessSub(Block) then
12189 begin
12190 if (Fparser.CurrTokenId = CSTI_EOF) THEN break;
12191 end
12192 else
12193 begin
12194 Cleanup;
12195 exit;
12196 end;
12197 end
12198 else
12199 begin
12200 FGlobalBlock.Proc.DeclareUnit:= fModule;
12201 {$ENDIF}
12202 FGlobalBlock.Proc.DeclarePos := FParser.CurrTokenPos;
12203 FGlobalBlock.Proc.DeclareRow := FParser.Row;
12204 FGlobalBlock.Proc.DeclareCol := FParser.Col;
12205 if ProcessSub(FGlobalBlock) then
12206 begin
12207 break;
12208 end
12209 else
12210 begin
12211 Cleanup;
12212 exit;
12213 end;
12214 {$IFDEF PS_USESSUPPORT}
12215 end;
12216 {$ENDIF}
12217 end
12218 {$IFDEF PS_USESSUPPORT}
12219 else if ((FParser.CurrTokenID = CSTII_finalization) and FIsUnit) then //NvdS
12220 begin
12221 Block := TPSBlockInfo.Create(nil);
12222 Block.SubType := tUnitFinish;
12223 Block.Proc := NewProc('!Finish_'+fModule, '!FINISH_'+FastUppercase(fModule));
12224 Block.ProcNo := FindProc('!FINISH_'+FastUppercase(fModule));
12225 Block.Proc.DeclareUnit:= fModule;
12226
12227 Block.Proc.DeclarePos := FParser.CurrTokenPos;
12228 Block.Proc.DeclareRow := FParser.Row;
12229 Block.Proc.DeclareCol := FParser.Col;
12230 Block.Proc.use;
12231 FUnitFinits.Add(Block);
12232 if ProcessSub(Block) then
12233 begin
12234 break;
12235 end else begin
12236 Cleanup;
12237 Result := False; //Cleanup;
12238 exit;
12239 end;
12240 end
12241 {$endif}
12242 else if (Fparser.CurrTokenId = CSTII_End) and (FAllowNoBegin or FIsUnit) then
12243 begin
12244 FParser.Next;
12245 if FParser.CurrTokenID <> CSTI_Period then
12246 begin
12247 MakeError('', ecPeriodExpected, '');
12248 Cleanup;
12249 exit;
12250 end;
12251 break;
12252 end else
12253 begin
12254 MakeError('', ecBeginExpected, '');
12255 Cleanup;
12256 exit;
12257 end;
12258 until False;
12259
12260 {$IFDEF PS_USESSUPPORT}
12261 dec(fInCompile);
12262 if fInCompile=0 then
12263 begin
12264 {$ENDIF}
12265 if not ProcessLabelForwards(FGlobalBlock.Proc) then
12266 begin
12267 Cleanup;
12268 exit;
12269 end;
12270 // NVDS: Do we need to check here also do a ProcessLabelForwards() for each Initialisation/finalization block?
12271
12272 for i := 0 to FProcs.Count -1 do
12273 begin
12274 Proc := FProcs[I];
12275 if (Proc.ClassType = TPSInternalProcedure) and (TPSInternalProcedure(Proc).Forwarded) then
12276 begin
12277 with MakeError('', ecUnsatisfiedForward, TPSInternalProcedure(Proc).Name) do
12278 begin
12279 FPosition := TPSInternalProcedure(Proc).DeclarePos;
12280 FRow := TPSInternalProcedure(Proc).DeclareRow;
12281 FCol := TPSInternalProcedure(Proc).DeclareCol;
12282 end;
12283 Cleanup;
12284 Exit;
12285 end;
12286 end;
12287 if not CheckExports then
12288 begin
12289 Cleanup;
12290 exit;
12291 end;
12292 for i := 0 to FVars.Count -1 do
12293 begin
12294 if not TPSVar(FVars[I]).Used then
12295 begin
12296 with MakeHint({$IFDEF PS_USESSUPPORT}TPSVar(FVars[I]).DeclareUnit{$ELSE}''{$ENDIF}, ehVariableNotUsed, TPSVar(FVars[I]).Name) do
12297 begin
12298 FPosition := TPSVar(FVars[I]).DeclarePos;
12299 FRow := TPSVar(FVars[I]).DeclareRow;
12300 FCol := TPSVar(FVars[I]).DeclareCol;
12301 end;
12302 end;
12303 end;
12304
12305 Result := MakeOutput;
12306 Cleanup;
12307 {$IFDEF PS_USESSUPPORT}
12308 end
12309 else
12310 begin
12311 fParser.Free;
12312 fParser:=OldParser;
12313 fIsUnit:=OldIsUnit;
12314 fUnit:=OldUnit;
12315 result:=true;
12316 end;
12317 {$ENDIF}
12318 end;
12319
12320 constructor TPSPascalCompiler.Create;
12321 begin
12322 inherited Create;
12323 FParser := TPSPascalParser.Create;
12324 FParser.OnParserError := ParserError;
12325 FAutoFreeList := TPSList.Create;
12326 FOutput := '';
12327 FAllowDuplicateRegister := true;
12328 {$IFDEF PS_USESSUPPORT}
12329 FAllowUnit := true;
12330 {$ENDIF}
12331 FMessages := TPSList.Create;
12332 FAttributesOpenTokenID := CSTI_OpenBlock;
12333 FAttributesCloseTokenID := CSTI_CloseBlock;
12334 end;
12335
12336 destructor TPSPascalCompiler.Destroy;
12337 begin
12338 Clear;
12339 FAutoFreeList.Free;
12340
12341 FMessages.Free;
12342 FParser.Free;
12343 inherited Destroy;
12344 end;
12345
GetOutputnull12346 function TPSPascalCompiler.GetOutput(var s: tbtString): Boolean;
12347 begin
12348 if Length(FOutput) <> 0 then
12349 begin
12350 s := FOutput;
12351 Result := True;
12352 end
12353 else
12354 Result := False;
12355 end;
12356
GetMsgnull12357 function TPSPascalCompiler.GetMsg(l: Longint): TPSPascalCompilerMessage;
12358 begin
12359 Result := FMessages[l];
12360 end;
12361
GetMsgCountnull12362 function TPSPascalCompiler.GetMsgCount: Longint;
12363 begin
12364 Result := FMessages.Count;
12365 end;
12366
12367 procedure TPSPascalCompiler.DefineStandardTypes;
12368 var
12369 i: Longint;
12370 begin
12371 AddType('Byte', btU8);
12372 FDefaultBoolType := AddTypeS('Boolean', '(False, True)');
12373 FDefaultBoolType.ExportName := True;
12374 with TPSEnumType(AddType('LongBool', btEnum)) do
12375 begin
12376 HighValue := 2147483647; // make sure it's gonna be a 4 byte var
12377 end;
12378 with TPSEnumType(AddType('WordBool', btEnum)) do
12379 begin
12380 HighValue := 65535; // make sure it's gonna be a 2 byte var
12381 end;
12382 with TPSEnumType(AddType('ByteBool', btEnum)) do
12383 begin
12384 HighValue := 255; // make sure it's gonna be a 1 byte var
12385 end;
12386 //following 2 IFDEFs should actually be UNICODE IFDEFs...
12387 AddType({$IFDEF PS_PANSICHAR}'AnsiChar'{$ELSE}'Char'{$ENDIF}, btChar);
12388 {$IFDEF PS_PANSICHAR}
12389 AddType('Char', btWideChar);
12390 {$ENDIF}
12391 {$IFNDEF PS_NOWIDESTRING}
12392 AddType('WideChar', btWideChar);
12393 AddType('WideString', btWideString);
12394 AddType('UnicodeString', btUnicodeString);
12395 {$ENDIF}
12396 AddType('AnsiString', btString);
12397 {$IFNDEF PS_NOWIDESTRING}
12398 {$IFDEF DELPHI2009UP}
12399 AddType('string', btUnicodeString);
12400 AddType('NativeString', btUnicodeString);
12401 {$ELSE}
12402 AddType('string', btString);
12403 AddType('NativeString', btString);
12404 {$ENDIF}
12405 {$ELSE}
12406 AddType('string', btString);
12407 AddType('NativeString', btString);
12408 {$ENDIF}
12409 FAnyString := AddType('AnyString', btString);
12410 FAnyMethod := AddTypeS('AnyMethod', 'procedure');
12411 AddType('ShortInt', btS8);
12412 AddType('Word', btU16);
12413 AddType('SmallInt', btS16);
12414 AddType('LongInt', btS32);
12415 at2ut(AddType('___Pointer', btPointer));
12416 AddType('LongWord', btU32);
12417 AddTypeCopyN('Integer', 'LongInt');
12418 AddTypeCopyN('Cardinal', 'LongWord');
12419 AddType('tbtString', btString);
12420 {$IFNDEF PS_NOINT64}
12421 AddType('Int64', btS64);
12422 {$ENDIF}
12423 AddType('Single', btSingle);
12424 AddType('Double', btDouble);
12425 AddType('Extended', btExtended);
12426 AddType('Currency', btCurrency);
12427 AddType({$IFDEF PS_PANSICHAR}'PAnsiChar'{$ELSE}'PChar'{$ENDIF}, btPChar);
12428 AddType('Variant', btVariant);
12429 AddType('!NotificationVariant', btNotificationVariant);
12430 for i := FTypes.Count -1 downto 0 do AT2UT(FTypes[i]);
12431 TPSArrayType(AddType('TVariantArray', btArray)).ArrayTypeNo := FindType('Variant');
12432
donull12433 with AddFunction('function Assigned(I: LongInt): Boolean;') do
12434 begin
12435 Name := '!ASSIGNED';
12436 end;
12437
donull12438 with AddFunction('procedure _T(Name: tbtString; V: Variant);') do
12439 begin
12440 Name := '!NOTIFICATIONVARIANTSET';
12441 end;
donull12442 with AddFunction('function _T(Name: tbtString): Variant;') do
12443 begin
12444 Name := '!NOTIFICATIONVARIANTGET';
12445 end;
12446 end;
12447
12448
TPSPascalCompiler.FindTypenull12449 function TPSPascalCompiler.FindType(const Name: tbtString): TPSType;
12450 var
12451 i, n: Longint;
12452 RName: tbtString;
12453 begin
12454 if FProcs = nil then begin Result := nil; exit;end;
12455 RName := Fastuppercase(Name);
12456 n := makehash(rname);
12457 for i := FTypes.Count - 1 downto 0 do
12458 begin
12459 Result := FTypes.Data[I];
12460 if (Result.NameHash = n) and (Result.name = rname) then
12461 begin
12462 Result := GetTypeCopyLink(Result);
12463 exit;
12464 end;
12465 end;
12466 result := nil;
12467 end;
12468
TPSPascalCompiler.AddConstantnull12469 function TPSPascalCompiler.AddConstant(const Name: tbtString; FType: TPSType): TPSConstant;
12470 var
12471 pc: TPSConstant;
12472 val: PIfRVariant;
12473 begin
12474 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
12475
12476 FType := GetTypeCopyLink(FType);
12477 if FType = nil then
12478 Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterConst, [name]);
12479
12480 if not(AllowDuplicateRegister) and IsDuplicate(FastUpperCase(Name),[dcProcs, dcVars, dcConsts]) then
12481 Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Name]);
12482
12483 pc := TPSConstant.Create;
12484 pc.OrgName := name;
12485 pc.Name := FastUppercase(name);
12486 pc.DeclarePos:=InvalidVal;
12487 {$IFDEF PS_USESSUPPORT}
12488 pc.DeclareUnit:=fModule;
12489 {$ENDIF}
12490 New(Val);
12491 InitializeVariant(Val, FType);
12492 pc.Value := Val;
12493 FConstants.Add(pc);
12494 result := pc;
12495 end;
12496
TPSPascalCompiler.ReadAttributesnull12497 function TPSPascalCompiler.ReadAttributes(Dest: TPSAttributes): Boolean;
12498 var
12499 Att: TPSAttributeType;
12500 at: TPSAttribute;
12501 varp: PIfRVariant;
12502 h, i: Longint;
12503 s: tbtString;
12504 begin
12505 if FParser.CurrTokenID <> FAttributesOpenTokenID then begin Result := true; exit; end;
12506 FParser.Next;
12507 if FParser.CurrTokenID <> CSTI_Identifier then
12508 begin
12509 MakeError('', ecIdentifierExpected, '');
12510 Result := False;
12511 exit;
12512 end;
12513 s := FParser.GetToken;
12514 h := MakeHash(s);
12515 att := nil;
12516 for i := FAttributeTypes.count -1 downto 0 do
12517 begin
12518 att := FAttributeTypes[i];
12519 if (att.FNameHash = h) and (att.FName = s) then
12520 Break;
12521 att := nil;
12522 end;
12523 if att = nil then
12524 begin
12525 MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
12526 Result := False;
12527 exit;
12528 end;
12529 FParser.Next;
12530 i := 0;
12531 at := Dest.Add(att);
12532 {$IFDEF PS_USESSUPPORT}
12533 at.DeclareUnit:=fModule;
12534 {$ENDIF}
12535 at.DeclarePos := FParser.CurrTokenPos;
12536 at.DeclareRow := FParser.Row;
12537 at.DeclareCol := FParser.Col;
12538 while att.Fields[i].Hidden do
12539 begin
12540 at.AddValue(NewVariant(at2ut(att.Fields[i].FieldType)));
12541 inc(i);
12542 end;
12543 if FParser.CurrTokenId <> CSTI_OpenRound then
12544 begin
12545 MakeError('', ecOpenRoundExpected, '');
12546 Result := False;
12547 exit;
12548 end;
12549 FParser.Next;
12550 if i < Att.FieldCount then
12551 begin
12552 while i < att.FieldCount do
12553 begin
12554 varp := ReadConstant(FParser, CSTI_CloseRound);
12555 if varp = nil then
12556 begin
12557 Result := False;
12558 exit;
12559 end;
12560 at.AddValue(varp);
12561 if not IsCompatibleType(varp.FType, Att.Fields[i].FieldType, False) then
12562 begin
12563 MakeError('', ecTypeMismatch, '');
12564 Result := False;
12565 exit;
12566 end;
12567 Inc(i);
12568 while (i < Att.FieldCount) and (att.Fields[i].Hidden) do
12569 begin
12570 at.AddValue(NewVariant(at2ut(att.Fields[i].FieldType)));
12571 inc(i);
12572 end;
12573 if i >= Att.FieldCount then
12574 begin
12575 break;
12576 end else
12577 begin
12578 if FParser.CurrTokenID <> CSTI_Comma then
12579 begin
12580 MakeError('', ecCommaExpected, '');
12581 Result := False;
12582 exit;
12583 end;
12584 end;
12585 FParser.Next;
12586 end;
12587 end;
12588 if FParser.CurrTokenID <> CSTI_CloseRound then
12589 begin
12590 MakeError('', ecCloseRoundExpected, '');
12591 Result := False;
12592 exit;
12593 end;
12594 FParser.Next;
12595 if FParser.CurrTokenID <> FAttributesCloseTokenID then
12596 begin
12597 MakeError('', ecUnClosedAttributes, '');
12598 Result := False;
12599 exit;
12600 end;
12601 FParser.Next;
12602 Result := True;
12603 end;
12604
12605 type
12606 TConstOperation = class(TObject)
12607 private
12608 FDeclPosition, FDeclRow, FDeclCol: Cardinal;
12609 public
12610 property DeclPosition: Cardinal read FDeclPosition write FDeclPosition;
12611 property DeclRow: Cardinal read FDeclRow write FDeclRow;
12612 property DeclCol: Cardinal read FDeclCol write FDeclCol;
12613 procedure SetPos(Parser: TPSPascalParser);
12614 end;
12615
12616 TUnConstOperation = class(TConstOperation)
12617 private
12618 FOpType: TPSUnOperatorType;
12619 FVal1: TConstOperation;
12620 public
12621 property OpType: TPSUnOperatorType read FOpType write FOpType;
12622 property Val1: TConstOperation read FVal1 write FVal1;
12623
12624 destructor Destroy; override;
12625 end;
12626
12627 TBinConstOperation = class(TConstOperation)
12628 private
12629 FOpType: TPSBinOperatorType;
12630 FVal2: TConstOperation;
12631 FVal1: TConstOperation;
12632 public
12633 property OpType: TPSBinOperatorType read FOpType write FOpType;
12634 property Val1: TConstOperation read FVal1 write FVal1;
12635 property Val2: TConstOperation read FVal2 write FVal2;
12636
12637 destructor Destroy; override;
12638 end;
12639
12640 TConstData = class(TConstOperation)
12641 private
12642 FData: PIfRVariant;
12643 public
12644 property Data: PIfRVariant read FData write FData;
12645 destructor Destroy; override;
12646 end;
12647
12648
IsBooleannull12649 function TPSPascalCompiler.IsBoolean(aType: TPSType): Boolean;
12650 begin
12651 Result := (AType = FDefaultBoolType)
12652 or (AType.Name = 'LONGBOOL')
12653 or (AType.Name = 'WORDBOOL')
12654 or (AType.Name = 'BYTEBOOL');
12655 end;
12656
12657
TPSPascalCompiler.ReadConstantnull12658 function TPSPascalCompiler.ReadConstant(FParser: TPSPascalParser; StopOn: TPSPasToken): PIfRVariant;
12659
12660 function ReadExpression: TConstOperation; forward;
12661 function ReadTerm: TConstOperation; forward;
ReadFactornull12662 function ReadFactor: TConstOperation;
12663 var
12664 NewVar: TConstOperation;
12665 NewVarU: TUnConstOperation;
GetConstantIdentifiernull12666 function GetConstantIdentifier: PIfRVariant;
12667 var
12668 s: tbtString;
12669 sh: Longint;
12670 i: Longint;
12671 p: TPSConstant;
12672 begin
12673 s := FParser.GetToken;
12674 sh := MakeHash(s);
12675 for i := FConstants.Count -1 downto 0 do
12676 begin
12677 p := FConstants[I];
12678 if (p.NameHash = sh) and (p.Name = s) then
12679 begin
12680 New(Result);
12681 InitializeVariant(Result, p.Value.FType);
12682 CopyVariantContents(P.Value, Result);
12683 FParser.Next;
12684 exit;
12685 end;
12686 end;
12687 MakeError('', ecUnknownIdentifier, '');
12688 Result := nil;
12689 end;
12690 begin
12691 case fParser.CurrTokenID of
12692 CSTII_Not:
12693 begin
12694 FParser.Next;
12695 NewVar := ReadFactor;
12696 if NewVar = nil then
12697 begin
12698 Result := nil;
12699 exit;
12700 end;
12701 NewVarU := TUnConstOperation.Create;
12702 NewVarU.OpType := otNot;
12703 NewVarU.Val1 := NewVar;
12704 NewVar := NewVarU;
12705 end;
12706 CSTI_Minus:
12707 begin
12708 FParser.Next;
12709 NewVar := ReadTerm;
12710 if NewVar = nil then
12711 begin
12712 Result := nil;
12713 exit;
12714 end;
12715 NewVarU := TUnConstOperation.Create;
12716 NewVarU.OpType := otMinus;
12717 NewVarU.Val1 := NewVar;
12718 NewVar := NewVarU;
12719 end;
12720 CSTI_OpenRound:
12721 begin
12722 FParser.Next;
12723 NewVar := ReadExpression;
12724 if NewVar = nil then
12725 begin
12726 Result := nil;
12727 exit;
12728 end;
12729 if FParser.CurrTokenId <> CSTI_CloseRound then
12730 begin
12731 NewVar.Free;
12732 Result := nil;
12733 MakeError('', ecCloseRoundExpected, '');
12734 exit;
12735 end;
12736 FParser.Next;
12737 end;
12738 CSTI_Char, CSTI_String:
12739 begin
12740 NewVar := TConstData.Create;
12741 NewVar.SetPos(FParser);
12742 TConstData(NewVar).Data := ReadString;
12743 end;
12744 CSTI_HexInt, CSTI_Integer:
12745 begin
12746 NewVar := TConstData.Create;
12747 NewVar.SetPos(FParser);
12748 TConstData(NewVar).Data := ReadInteger(FParser.GetToken);
12749 FParser.Next;
12750 end;
12751 CSTI_Real:
12752 begin
12753 NewVar := TConstData.Create;
12754 NewVar.SetPos(FParser);
12755 TConstData(NewVar).Data := ReadReal(FParser.GetToken);
12756 FParser.Next;
12757 end;
12758 CSTI_Identifier:
12759 begin
12760 NewVar := TConstData.Create;
12761 NewVar.SetPos(FParser);
12762 TConstData(NewVar).Data := GetConstantIdentifier;
12763 if TConstData(NewVar).Data = nil then
12764 begin
12765 NewVar.Free;
12766 Result := nil;
12767 exit;
12768 end
12769 end;
12770 else
12771 begin
12772 MakeError('', ecSyntaxError, '');
12773 Result := nil;
12774 exit;
12775 end;
12776 end; {case}
12777 Result := NewVar;
12778 end; // ReadFactor
12779
ReadTermnull12780 function ReadTerm: TConstOperation;
12781 var
12782 F1, F2: TConstOperation;
12783 F: TBinConstOperation;
12784 Token: TPSPasToken;
12785 Op: TPSBinOperatorType;
12786 begin
12787 F1 := ReadFactor;
12788 if F1 = nil then
12789 begin
12790 Result := nil;
12791 exit;
12792 end;
12793 while FParser.CurrTokenID in [CSTI_Multiply, CSTI_Divide, CSTII_Div, CSTII_Mod, CSTII_And, CSTII_Shl, CSTII_Shr] do
12794 begin
12795 Token := FParser.CurrTokenID;
12796 FParser.Next;
12797 F2 := ReadFactor;
12798 if f2 = nil then
12799 begin
12800 f1.Free;
12801 Result := nil;
12802 exit;
12803 end;
12804 case Token of
12805 CSTI_Multiply: Op := otMul;
12806 CSTI_Divide: Op := otDiv;
12807 CSTII_Div: Op := otIntDiv;
12808 CSTII_mod: Op := otMod;
12809 CSTII_and: Op := otAnd;
12810 CSTII_shl: Op := otShl;
12811 CSTII_shr: Op := otShr;
12812 else
12813 Op := otAdd;
12814 end;
12815 F := TBinConstOperation.Create;
12816 f.Val1 := F1;
12817 f.Val2 := F2;
12818 f.OpType := Op;
12819 f1 := f;
12820 end;
12821 Result := F1;
12822 end; // ReadTerm
12823
ReadSimpleExpressionnull12824 function ReadSimpleExpression: TConstOperation;
12825 var
12826 F1, F2: TConstOperation;
12827 F: TBinConstOperation;
12828 Token: TPSPasToken;
12829 Op: TPSBinOperatorType;
12830 begin
12831 F1 := ReadTerm;
12832 if F1 = nil then
12833 begin
12834 Result := nil;
12835 exit;
12836 end;
12837 while FParser.CurrTokenID in [CSTI_Plus, CSTI_Minus, CSTII_Or, CSTII_Xor] do
12838 begin
12839 Token := FParser.CurrTokenID;
12840 FParser.Next;
12841 F2 := ReadTerm;
12842 if f2 = nil then
12843 begin
12844 f1.Free;
12845 Result := nil;
12846 exit;
12847 end;
12848 case Token of
12849 CSTI_Plus: Op := otAdd;
12850 CSTI_Minus: Op := otSub;
12851 CSTII_or: Op := otOr;
12852 CSTII_xor: Op := otXor;
12853 else
12854 Op := otAdd;
12855 end;
12856 F := TBinConstOperation.Create;
12857 f.Val1 := F1;
12858 f.Val2 := F2;
12859 f.OpType := Op;
12860 f1 := f;
12861 end;
12862 Result := F1;
12863 end; // ReadSimpleExpression
12864
12865
ReadExpressionnull12866 function ReadExpression: TConstOperation;
12867 var
12868 F1, F2: TConstOperation;
12869 F: TBinConstOperation;
12870 Token: TPSPasToken;
12871 Op: TPSBinOperatorType;
12872 begin
12873 F1 := ReadSimpleExpression;
12874 if F1 = nil then
12875 begin
12876 Result := nil;
12877 exit;
12878 end;
12879 while FParser.CurrTokenID in [ CSTI_GreaterEqual, CSTI_LessEqual, CSTI_Greater, CSTI_Less, CSTI_Equal, CSTI_NotEqual] do
12880 begin
12881 Token := FParser.CurrTokenID;
12882 FParser.Next;
12883 F2 := ReadSimpleExpression;
12884 if f2 = nil then
12885 begin
12886 f1.Free;
12887 Result := nil;
12888 exit;
12889 end;
12890 case Token of
12891 CSTI_GreaterEqual: Op := otGreaterEqual;
12892 CSTI_LessEqual: Op := otLessEqual;
12893 CSTI_Greater: Op := otGreater;
12894 CSTI_Less: Op := otLess;
12895 CSTI_Equal: Op := otEqual;
12896 CSTI_NotEqual: Op := otNotEqual;
12897 else
12898 Op := otAdd;
12899 end;
12900 F := TBinConstOperation.Create;
12901 f.Val1 := F1;
12902 f.Val2 := F2;
12903 f.OpType := Op;
12904 f1 := f;
12905 end;
12906 Result := F1;
12907 end; // ReadExpression
12908
12909
EvalConstnull12910 function EvalConst(P: TConstOperation): PIfRVariant;
12911 var
12912 p1, p2: PIfRVariant;
12913 begin
12914 if p is TBinConstOperation then
12915 begin
12916 p1 := EvalConst(TBinConstOperation(p).Val1);
12917 if p1 = nil then begin Result := nil; exit; end;
12918 p2 := EvalConst(TBinConstOperation(p).Val2);
12919 if p2 = nil then begin DisposeVariant(p1); Result := nil; exit; end;
12920 if not PreCalc(False, 0, p1, 0, p2, TBinConstOperation(p).OpType, p.DeclPosition, p.DeclRow, p.DeclCol) then
12921 begin
12922 DisposeVariant(p1);
12923 DisposeVariant(p2);
12924 // MakeError('', ecTypeMismatch, '');
12925 result := nil;
12926 exit;
12927 end;
12928 DisposeVariant(p2);
12929 Result := p1;
12930 end else if p is TUnConstOperation then
12931 begin
12932 with TUnConstOperation(P) do
12933 begin
12934 p1 := EvalConst(Val1);
12935 case OpType of
12936 otNot:
12937 case p1.FType.BaseType of
12938 btU8: p1.tu8 := not p1.tu8;
12939 btU16: p1.tu16 := not p1.tu16;
12940 btU32: p1.tu32 := not p1.tu32;
12941 bts8: p1.ts8 := not p1.ts8;
12942 bts16: p1.ts16 := not p1.ts16;
12943 bts32: p1.ts32 := not p1.ts32;
12944 {$IFNDEF PS_NOINT64}
12945 bts64: p1.ts64 := not p1.ts64;
12946 {$ENDIF}
12947 else
12948 begin
12949 MakeError('', ecTypeMismatch, '');
12950 DisposeVariant(p1);
12951 Result := nil;
12952 exit;
12953 end;
12954 end;
12955 otMinus:
12956 case p1.FType.BaseType of
12957 btU8: p1.tu8 := -p1.tu8;
12958 btU16: p1.tu16 := -p1.tu16;
12959 btU32: p1.tu32 := -p1.tu32;
12960 bts8: p1.ts8 := -p1.ts8;
12961 bts16: p1.ts16 := -p1.ts16;
12962 bts32: p1.ts32 := -p1.ts32;
12963 {$IFNDEF PS_NOINT64}
12964 bts64: p1.ts64 := -p1.ts64;
12965 {$ENDIF}
12966 btDouble: p1.tdouble := - p1.tDouble;
12967 btSingle: p1.tsingle := - p1.tsingle;
12968 btCurrency: p1.tcurrency := - p1.tcurrency;
12969 btExtended: p1.textended := - p1.textended;
12970 else
12971 begin
12972 MakeError('', ecTypeMismatch, '');
12973 DisposeVariant(p1);
12974 Result := nil;
12975 exit;
12976 end;
12977 end;
12978 else
12979 begin
12980 DisposeVariant(p1);
12981 Result := nil;
12982 exit;
12983 end;
12984 end;
12985 end;
12986 Result := p1;
12987 end else
12988 begin
12989 if ((p as TConstData).Data.FType.BaseType = btString)
12990 and (length(tbtstring((p as TConstData).Data.tstring)) =1) then
12991 begin
12992 New(p1);
12993 InitializeVariant(p1, FindBaseType(btChar));
12994 p1.tchar := tbtstring((p as TConstData).Data.tstring)[1];
12995 Result := p1;
12996 end else begin
12997 New(p1);
12998 InitializeVariant(p1, (p as TConstData).Data.FType);
12999 CopyVariantContents((p as TConstData).Data, p1);
13000 Result := p1;
13001 end;
13002 end;
13003 end;
13004
13005 var
13006 Val: TConstOperation;
13007 begin
13008 Val := ReadExpression;
13009 if val = nil then
13010 begin
13011 Result := nil;
13012 exit;
13013 end;
13014 Result := EvalConst(Val);
13015 Val.Free;
13016 end;
13017
13018 procedure TPSPascalCompiler.WriteDebugData(const s: tbtString);
13019 begin
13020 FDebugOutput := FDebugOutput + s;
13021 end;
13022
TPSPascalCompiler.GetDebugOutputnull13023 function TPSPascalCompiler.GetDebugOutput(var s: tbtString): Boolean;
13024 begin
13025 if Length(FDebugOutput) <> 0 then
13026 begin
13027 s := FDebugOutput;
13028 Result := True;
13029 end
13030 else
13031 Result := False;
13032 end;
13033
TPSPascalCompiler.AddUsedFunctionnull13034 function TPSPascalCompiler.AddUsedFunction(var Proc: TPSInternalProcedure): Cardinal;
13035 begin
13036 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13037 Proc := TPSInternalProcedure.Create;
13038 FProcs.Add(Proc);
13039 Result := FProcs.Count - 1;
13040 end;
13041
13042 {$IFNDEF PS_NOINTERFACES}
13043 const
13044 IUnknown_Guid: TGuid = (D1: 0; d2: 0; d3: 0; d4: ($c0,00,00,00,00,00,00,$46));
13045 IDispatch_Guid: Tguid = (D1: $20400; D2: $0; D3: $0; D4:($C0, $0, $0, $0, $0, $0, $0, $46));
13046 {$ENDIF}
13047
13048 procedure TPSPascalCompiler.DefineStandardProcedures;
13049 var
13050 p: TPSRegProc;
13051 begin
13052 { The following needs to be in synch in these 3 functions:
13053 -UPSCompiler.TPSPascalCompiler.DefineStandardProcedures
13054 -UPSRuntime.DefProc
13055 -UPSRuntime.TPSExec.RegisterStandardProcs
13056 }
13057 {$IFNDEF PS_NOINT64}
13058 AddFunction('function IntToStr(I: Int64): string;');
13059 {$ELSE}
13060 AddFunction('function IntToStr(I: Integer): string;');
13061 {$ENDIF}
13062 AddFunction('function StrToInt(S: string): LongInt;');
AddFunctionnull13063 AddFunction('function StrToIntDef(S: string; def: LongInt): LongInt;');
13064 AddFunction('function Copy(S: AnyString; iFrom, iCount: LongInt): AnyString;');
AddFunctionnull13065 AddFunction('function Pos(SubStr, S: AnyString): LongInt;');
13066 AddFunction('procedure Delete(var S: AnyString; iFrom, iCount: LongInt);');
AddFunctionnull13067 AddFunction('procedure Insert(S: AnyString; var s2: AnyString; iPos: LongInt);');
Decl.AddParam.OrgNamenull13068 AddFunction('function GetArrayLength: Integer;').Decl.AddParam.OrgName := 'Arr';
13069 p := AddFunction('procedure SetArrayLength;');
withnull13070 with P.Decl.AddParam do
13071 begin
13072 OrgName := 'arr';
13073 Mode := pmInOut;
13074 end;
13075 with P.Decl.AddParam do
13076 begin
13077 OrgName := 'count';
13078 aType := FindBaseType(btS32);
13079 end;
13080 AddFunction('function StrGet(var S: string; I: Integer): Char;');
AddFunctionnull13081 AddFunction('function StrGet2(S: string; I: Integer): Char;');
13082 AddFunction('procedure StrSet(C: Char; I: Integer; var S: string);');
13083 {$IFNDEF PS_NOWIDESTRING}
13084 AddFunction('function WStrGet(var S: AnyString; I: Integer): WideChar;');
13085 AddFunction('procedure WStrSet(C: AnyString; I: Integer; var S: AnyString);');
13086 {$ENDIF}
13087 AddDelphiFunction('function VarArrayGet(var S: Variant; I: Integer): Variant;');
13088 AddDelphiFunction('procedure VarArraySet(C: Variant; I: Integer; var S: Variant);');
AddFunctionnull13089 AddFunction('function AnsiUpperCase(S: string): string;');
13090 AddFunction('function AnsiLowerCase(S: string): string;');
AddFunctionnull13091 AddFunction('function UpperCase(S: AnyString): AnyString;');
13092 AddFunction('function LowerCase(S: AnyString): AnyString;');
AddFunctionnull13093 AddFunction('function Trim(S: AnyString): AnyString;');
Decl.AddParam.OrgNamenull13094 AddFunction('function Length: Integer;').Decl.AddParam.OrgName := 'S';
Declnull13095 with AddFunction('procedure SetLength;').Decl do
13096 begin
13097 with AddParam do
13098 begin
13099 OrgName:='s';
13100 Mode:=pmInOut;
13101 end;
13102 with AddParam do
13103 begin
13104 OrgName:='NewLength';
13105 aType:=FindBaseType(btS32); //Integer
13106 end;
13107 end;
13108 {$IFNDEF PS_NOINT64}
Decl.AddParam.OrgNamenull13109 AddFunction('function Low: Int64;').Decl.AddParam.OrgName := 'X';
Decl.AddParam.OrgNamenull13110 AddFunction('function High: Int64;').Decl.AddParam.OrgName := 'X';
13111 {$ELSE}
Decl.AddParam.OrgNamenull13112 AddFunction('function Low: Integer;').Decl.AddParam.OrgName := 'X';
Decl.AddParam.OrgNamenull13113 AddFunction('function High: Integer;').Decl.AddParam.OrgName := 'X';
13114 {$ENDIF}
Declnull13115 with AddFunction('procedure Dec;').Decl do begin
13116 with AddParam do
13117 begin
13118 OrgName:='x';
13119 Mode:=pmInOut;
13120 end;
13121 end;
Declnull13122 with AddFunction('procedure Inc;').Decl do begin
13123 with AddParam do
13124 begin
13125 OrgName:='x';
13126 Mode:=pmInOut;
13127 end;
13128 end;
Declnull13129 with AddFunction('procedure Include;').Decl do begin
13130 with AddParam do
13131 begin
13132 OrgName:='s';
13133 Mode:=pmInOut;
13134 end;
13135 with AddParam do
13136 begin
13137 OrgName:='m';
13138 Mode:=pmIn;
13139 end;
13140 end;
Declnull13141 with AddFunction('procedure Exclude;').Decl do begin
13142 with AddParam do
13143 begin
13144 OrgName:='s';
13145 Mode:=pmInOut;
13146 end;
13147 with AddParam do
13148 begin
13149 OrgName:='m';
13150 Mode:=pmIn;
13151 end;
13152 end;
13153 AddFunction('function Sin(E: Extended): Extended;');
AddFunctionnull13154 AddFunction('function Cos(E: Extended): Extended;');
13155 AddFunction('function Sqrt(E: Extended): Extended;');
AddFunctionnull13156 AddFunction('function Round(E: Extended): LongInt;');
13157 AddFunction('function Trunc(E: Extended): LongInt;');
AddFunctionnull13158 AddFunction('function Int(E: Extended): Extended;');
13159 AddFunction('function Pi: Extended;');
AddFunctionnull13160 AddFunction('function Abs(E: Extended): Extended;');
13161 AddFunction('function StrToFloat(S: string): Extended;');
AddFunctionnull13162 AddFunction('function FloatToStr(E: Extended): string;');
13163 AddFunction('function PadL(S: AnyString; I: LongInt): AnyString;');
AddFunctionnull13164 AddFunction('function PadR(S: AnyString; I: LongInt): AnyString;');
13165 AddFunction('function PadZ(S: AnyString; I: LongInt): AnyString;');
AddFunctionnull13166 AddFunction('function Replicate(C: Char; I: LongInt): string;');
13167 AddFunction('function StringOfChar(C: Char; I: LongInt): string;');
AddTypeSnull13168 AddTypeS('TVarType', 'Word');
13169 AddConstantN('varEmpty', 'Word').Value.tu16 := varempty;
13170 AddConstantN('varNull', 'Word').Value.tu16 := varnull;
13171 AddConstantN('varSmallInt', 'Word').Value.tu16 := varsmallint;
13172 AddConstantN('varInteger', 'Word').Value.tu16 := varinteger;
13173 AddConstantN('varSingle', 'Word').Value.tu16 := varsingle;
13174 AddConstantN('varDouble', 'Word').Value.tu16 := vardouble;
13175 AddConstantN('varCurrency', 'Word').Value.tu16 := varcurrency;
13176 AddConstantN('varDate', 'Word').Value.tu16 := vardate;
13177 AddConstantN('varOleStr', 'Word').Value.tu16 := varolestr;
13178 AddConstantN('varDispatch', 'Word').Value.tu16 := vardispatch;
13179 AddConstantN('varError', 'Word').Value.tu16 := varerror;
13180 AddConstantN('varBoolean', 'Word').Value.tu16 := varboolean;
13181 AddConstantN('varVariant', 'Word').Value.tu16 := varvariant;
13182 AddConstantN('varUnknown', 'Word').Value.tu16 := varunknown;
13183 {$IFDEF DELPHI6UP}
13184 AddConstantN('varShortInt', 'Word').Value.tu16 := varshortint;
13185 AddConstantN('varByte', 'Word').Value.tu16 := varbyte;
13186 AddConstantN('varWord', 'Word').Value.tu16 := varword;
13187 AddConstantN('varLongWord', 'Word').Value.tu16 := varlongword;
13188 AddConstantN('varInt64', 'Word').Value.tu16 := varint64;
13189 {$ENDIF}
13190 {$IFDEF DELPHI5UP}
13191 AddConstantN('varStrArg', 'Word').Value.tu16 := varstrarg;
13192 AddConstantN('varAny', 'Word').Value.tu16 := varany;
13193 {$ENDIF}
13194 AddConstantN('varString', 'Word').Value.tu16 := varstring;
13195 AddConstantN('varTypeMask', 'Word').Value.tu16 := vartypemask;
13196 AddConstantN('varArray', 'Word').Value.tu16 := vararray;
13197 AddConstantN('varByRef', 'Word').Value.tu16 := varByRef;
13198 {$IFDEF UNICODE}
13199 AddConstantN('varUString', 'Word').Value.tu16 := varUString;
13200 {$ENDIF}
13201 AddDelphiFunction('function Unassigned: Variant;');
AddDelphiFunctionnull13202 AddDelphiFunction('function VarIsEmpty(const V: Variant): Boolean;');
13203 {$IFDEF DELPHI7UP}
13204 AddDelphiFunction('function VarIsClear(const V: Variant): Boolean;');
13205 {$ENDIF}
13206 AddDelphiFunction('function Null: Variant;');
13207 AddDelphiFunction('function VarIsNull(const V: Variant): Boolean;');
AddDelphiFunctionnull13208 AddDelphiFunction('function VarType(const V: Variant): TVarType;');
13209 addTypeS('TIFException', '(ErNoError, erCannotImport, erInvalidType, ErInternalError, '+
13210 'erInvalidHeader, erInvalidOpcode, erInvalidOpcodeParameter, erNoMainProc, erOutOfGlobalVarsRange, '+
13211 'erOutOfProcRange, ErOutOfRange, erOutOfStackRange, ErTypeMismatch, erUnexpectedEof, '+
13212 'erVersionError, ErDivideByZero, ErMathError,erCouldNotCallProc, erOutofRecordRange, '+
13213 'erOutOfMemory, erException, erNullPointerException, erNullVariantError, erInterfaceNotSupported, erCustomError)');
13214 AddFunction('procedure RaiseLastException;');
AddFunctionnull13215 AddFunction('procedure RaiseException(Ex: TIFException; Param: string);');
13216 AddFunction('function ExceptionType: TIFException;');
AddFunctionnull13217 AddFunction('function ExceptionParam: string;');
13218 AddFunction('function ExceptionProc: Cardinal;');
AddFunctionnull13219 AddFunction('function ExceptionPos: Cardinal;');
13220 AddFunction('function ExceptionToString(er: TIFException; Param: string): string;');
13221 {$IFNDEF PS_NOINT64}
13222 AddFunction('function StrToInt64(S: string): Int64;');
13223 AddFunction('function Int64ToStr(I: Int64): string;');
AddFunctionnull13224 AddFunction('function StrToInt64Def(S: string; def: Int64): Int64;');
13225 {$ENDIF}
13226
Decl.AddParamnull13227 with AddFunction('function SizeOf: LongInt;').Decl.AddParam do
13228 begin
13229 OrgName := 'Data';
13230 end;
13231 {$IFNDEF PS_NOINTERFACES}
13232 with AddInterface(nil, IUnknown_Guid, 'IUnknown') do
13233 begin
13234 RegisterDummyMethod; // Query Interface
13235 RegisterDummyMethod; // _AddRef
13236 RegisterDummyMethod; // _Release
13237 end;
13238 with AddInterface(nil, IUnknown_Guid, 'IInterface') do
13239 begin
13240 RegisterDummyMethod; // Query Interface
13241 RegisterDummyMethod; // _AddRef
13242 RegisterDummyMethod; // _Release
13243 end;
13244
13245 {$IFNDEF PS_NOIDISPATCH}
13246 with AddInterface(FindInterface('IUnknown'), IDispatch_Guid, 'IDispatch') do
13247 begin
13248 RegisterDummyMethod; // GetTypeCount
13249 RegisterDummyMethod; // GetTypeInfo
13250 RegisterDummyMethod; // GetIdsOfName
13251 RegisterDummyMethod; // Invoke
13252 end;
13253 with TPSInterfaceType(FindType('IDispatch')) do
13254 begin
13255 ExportName := True;
13256 end;
13257 AddDelphiFunction('function IdispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: string; Par: array of Variant): Variant;');
13258 {$ENDIF}
13259 {$ENDIF}
13260 end;
13261
TPSPascalCompiler.GetTypeCountnull13262 function TPSPascalCompiler.GetTypeCount: Longint;
13263 begin
13264 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13265 Result := FTypes.Count;
13266 end;
13267
TPSPascalCompiler.GetTypenull13268 function TPSPascalCompiler.GetType(I: Longint): TPSType;
13269 begin
13270 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13271 Result := FTypes[I];
13272 end;
13273
GetVarCountnull13274 function TPSPascalCompiler.GetVarCount: Longint;
13275 begin
13276 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13277 Result := FVars.Count;
13278 end;
13279
TPSPascalCompiler.GetVarnull13280 function TPSPascalCompiler.GetVar(I: Longint): TPSVar;
13281 begin
13282 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13283 Result := FVars[i];
13284 end;
13285
GetProcCountnull13286 function TPSPascalCompiler.GetProcCount: Longint;
13287 begin
13288 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13289 Result := FProcs.Count;
13290 end;
13291
GetProcnull13292 function TPSPascalCompiler.GetProc(I: Longint): TPSProcedure;
13293 begin
13294 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13295 Result := FProcs[i];
13296 end;
13297
13298
13299
13300
TPSPascalCompiler.AddUsedFunction2null13301 function TPSPascalCompiler.AddUsedFunction2(var Proc: TPSExternalProcedure): Cardinal;
13302 begin
13303 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13304 Proc := TPSExternalProcedure.Create;
13305 FProcs.Add(Proc);
13306 Result := FProcs.Count -1;
13307 end;
13308
AddVariablenull13309 function TPSPascalCompiler.AddVariable(const Name: tbtString; FType: TPSType): TPSVar;
13310 var
13311 P: TPSVar;
13312 s:tbtString;
13313 begin
13314 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13315 if FType = nil then raise EPSCompilerException.CreateFmt(RPS_InvalidTypeForVar, [Name]);
13316 s := Fastuppercase(Name);
13317 if IsDuplicate(s,[dcVars]) then raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Name]);
13318
13319 p := TPSVar.Create;
13320 p.OrgName := Name;
13321 p.Name := s;
13322 p.FType := AT2UT(FType);
13323 p.exportname := p.Name;
13324 FVars.Add(p);
13325 Result := P;
13326 end;
13327
TPSPascalCompiler.AddAttributeTypenull13328 function TPSPascalCompiler.AddAttributeType: TPSAttributeType;
13329 begin
13330 if FAttributeTypes = nil then Raise Exception.Create(RPS_OnUseEventOnly);
13331 Result := TPSAttributeType.Create;
13332 FAttributeTypes.Add(Result);
13333 end;
13334
TPSPascalCompiler.FindAttributeTypenull13335 function TPSPascalCompiler.FindAttributeType(const Name: tbtString): TPSAttributeType;
13336 var
13337 h, i: Integer;
13338 n: tbtString;
13339 begin
13340 if FAttributeTypes = nil then Raise Exception.Create(RPS_OnUseEventOnly);
13341 n := FastUpperCase(Name);
13342 h := MakeHash(n);
13343 for i := FAttributeTypes.Count -1 downto 0 do
13344 begin
13345 result := TPSAttributeType(FAttributeTypes[i]);
13346 if (Result.NameHash = h) and (Result.Name = n) then
13347 exit;
13348 end;
13349 result := nil;
13350 end;
TPSPascalCompiler.GetConstCountnull13351 function TPSPascalCompiler.GetConstCount: Longint;
13352 begin
13353 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13354 result := FConstants.Count;
13355 end;
13356
GetConstnull13357 function TPSPascalCompiler.GetConst(I: Longint): TPSConstant;
13358 begin
13359 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13360 Result := TPSConstant(FConstants[i]);
13361 end;
13362
GetRegProcCountnull13363 function TPSPascalCompiler.GetRegProcCount: Longint;
13364 begin
13365 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13366 Result := FRegProcs.Count;
13367 end;
13368
GetRegProcnull13369 function TPSPascalCompiler.GetRegProc(I: Longint): TPSRegProc;
13370 begin
13371 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13372 Result := TPSRegProc(FRegProcs[i]);
13373 end;
13374
13375
13376 procedure TPSPascalCompiler.AddToFreeList(Obj: TObject);
13377 begin
13378 FAutoFreeList.Add(Obj);
13379 end;
13380
TPSPascalCompiler.AddConstantNnull13381 function TPSPascalCompiler.AddConstantN(const Name,
13382 FType: tbtString): TPSConstant;
13383 begin
13384 Result := AddConstant(Name, FindType(FType));
13385 end;
13386
TPSPascalCompiler.AddTypeCopynull13387 function TPSPascalCompiler.AddTypeCopy(const Name: tbtString;
13388 TypeNo: TPSType): TPSType;
13389 begin
13390 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13391 TypeNo := GetTypeCopyLink(TypeNo);
13392 if Typeno = nil then raise EPSCompilerException.Create(RPS_InvalidType);
13393 Result := AddType(Name, BtTypeCopy);
13394 TPSTypeLink(Result).LinkTypeNo := TypeNo;
13395 end;
13396
TPSPascalCompiler.AddTypeCopyNnull13397 function TPSPascalCompiler.AddTypeCopyN(const Name,
13398 FType: tbtString): TPSType;
13399 begin
13400 Result := AddTypeCopy(Name, FindType(FType));
13401 end;
13402
13403
TPSPascalCompiler.AddUsedVariablenull13404 function TPSPascalCompiler.AddUsedVariable(const Name: tbtString;
13405 FType: TPSType): TPSVar;
13406 begin
13407 Result := AddVariable(Name, FType);
13408 if Result <> nil then
13409 Result.Use;
13410 end;
13411
TPSPascalCompiler.AddUsedVariableNnull13412 function TPSPascalCompiler.AddUsedVariableN(const Name,
13413 FType: tbtString): TPSVar;
13414 begin
13415 Result := AddVariable(Name, FindType(FType));
13416 if Result <> nil then
13417 Result.Use;
13418 end;
13419
AddVariableNnull13420 function TPSPascalCompiler.AddVariableN(const Name,
13421 FType: tbtString): TPSVar;
13422 begin
13423 Result := AddVariable(Name, FindType(FType));
13424 end;
13425
TPSPascalCompiler.AddUsedPtrVariablenull13426 function TPSPascalCompiler.AddUsedPtrVariable(const Name: tbtString; FType: TPSType): TPSVar;
13427 begin
13428 Result := AddVariable(Name, FType);
13429 if Result <> nil then
13430 begin
13431 result.SaveAsPointer := True;
13432 Result.Use;
13433 end;
13434 end;
13435
AddUsedPtrVariableNnull13436 function TPSPascalCompiler.AddUsedPtrVariableN(const Name, FType: tbtString): TPSVar;
13437 begin
13438 Result := AddVariable(Name, FindType(FType));
13439 if Result <> nil then
13440 begin
13441 result.SaveAsPointer := True;
13442 Result.Use;
13443 end;
13444 end;
13445
AddTypeSnull13446 function TPSPascalCompiler.AddTypeS(const Name, Decl: tbtString): TPSType;
13447 var
13448 Parser: TPSPascalParser;
13449 begin
13450 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13451 Parser := TPSPascalParser.Create;
13452 Parser.SetText(Decl);
13453
13454 if not(AllowDuplicateRegister) and (FindType(Name)<>nil) then
13455 Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Name]);
13456
13457 Result := ReadType(Name, Parser);
13458 if Result<>nil then
13459 begin
13460 Result.ExportName := True;
13461 Result.DeclarePos:=InvalidVal;
13462 {$IFDEF PS_USESSUPPORT}
13463 Result.DeclareUnit:=fModule;
13464 {$ENDIF}
13465 Result.DeclareRow:=0;
13466 Result.DeclareCol:=0;
13467 end;
13468 Parser.Free;
13469 if result = nil then Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterType, [name]);
13470 end;
13471
13472
TPSPascalCompiler.CheckCompatProcnull13473 function TPSPascalCompiler.CheckCompatProc(P: TPSType; ProcNo: Cardinal): Boolean;
13474 var
13475 i: Longint;
13476 s1, s2: TPSParametersDecl;
13477 begin
13478 if p.BaseType <> btProcPtr then begin
13479 Result := False;
13480 Exit;
13481 end;
13482
13483 if p = FAnyMethod then begin
13484 Result := True;
13485 Exit;
13486 end;
13487
13488 S1 := TPSProceduralType(p).ProcDef;
13489
13490 if TPSProcedure(FProcs[ProcNo]).ClassType = TPSInternalProcedure then
13491 s2 := TPSInternalProcedure(FProcs[ProcNo]).Decl
13492 else
13493 s2 := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl;
13494 if (s1.Result <> s2.Result) or (s1.ParamCount <> s2.ParamCount) then
13495 begin
13496 Result := False;
13497 Exit;
13498 end;
13499 for i := 0 to s1.ParamCount -1 do
13500 begin
13501 if (s1.Params[i].Mode <> s2.Params[i].Mode) or (s1.Params[i].aType <> s2.Params[i].aType) then
13502 begin
13503 Result := False;
13504 Exit;
13505 end;
13506 end;
13507 Result := True;
13508 end;
13509
MakeExportDeclnull13510 function TPSPascalCompiler.MakeExportDecl(decl: TPSParametersDecl): tbtString;
13511 var
13512 i: Longint;
13513 begin
13514 if Decl.Result = nil then result := '-1' else
13515 result := IntToStr(Decl.Result.FinalTypeNo);
13516
13517 for i := 0 to decl.ParamCount -1 do
13518 begin
13519 if decl.GetParam(i).Mode = pmIn then
13520 Result := Result + ' @'
13521 else
13522 Result := Result + ' !';
13523 Result := Result + inttostr(decl.GetParam(i).aType.FinalTypeNo);
13524 end;
13525 end;
13526
13527
TPSPascalCompiler.IsIntBoolTypenull13528 function TPSPascalCompiler.IsIntBoolType(aType: TPSType): Boolean;
13529 begin
13530 if Isboolean(aType) then begin Result := True; exit;end;
13531
13532 case aType.BaseType of
13533 btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF PS_NOINT64}, btS64{$ENDIF}: Result := True;
13534 else
13535 Result := False;
13536 end;
13537 end;
13538
13539
13540 procedure TPSPascalCompiler.ParserError(Parser: TObject;
13541 Kind: TPSParserErrorKind);
13542 begin
13543 FParserHadError := True;
13544 case Kind of
13545 ICOMMENTERROR: MakeError('', ecCommentError, '');
13546 ISTRINGERROR: MakeError('', ecStringError, '');
13547 ICHARERROR: MakeError('', ecCharError, '');
13548 else
13549 MakeError('', ecSyntaxError, '');
13550 end;
13551 end;
13552
13553
AddDelphiFunctionnull13554 function TPSPascalCompiler.AddDelphiFunction(const Decl: tbtString): TPSRegProc;
13555 var
13556 p: TPSRegProc;
13557 pDecl: TPSParametersDecl;
13558 DOrgName: tbtString;
13559 FT: TPMFuncType;
13560 i: Longint;
13561
13562 begin
13563 pDecl := TPSParametersDecl.Create;
13564 {$IFNDEF DELPHI_TOKYO_UP}
13565 p := nil;
13566 {$ENDIF}
13567 try
13568 if not ParseMethod(Self, '', Decl, DOrgName, pDecl, FT) then
13569 Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Decl]);
13570
13571 if (FindProc(DOrgName)<>InvalidVal) and not(FAllowDuplicateRegister) then
13572 Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Decl]);
13573
13574 p := TPSRegProc.Create;
13575 P.Name := FastUppercase(DOrgName);
13576 p.OrgName := DOrgName;
13577 p.ExportName := True;
13578 p.Decl.Assign(pDecl);
13579
13580 FRegProcs.Add(p);
13581
13582 if pDecl.Result = nil then
13583 begin
13584 p.ImportDecl := p.ImportDecl + #0;
13585 end else
13586 p.ImportDecl := p.ImportDecl + #1;
13587 for i := 0 to pDecl.ParamCount -1 do
13588 begin
13589 if pDecl.Params[i].Mode <> pmIn then
13590 p.ImportDecl := p.ImportDecl + #1
13591 else
13592 p.ImportDecl := p.ImportDecl + #0;
13593 end;
13594 finally
13595 pDecl.Free;
13596 end;
13597 Result := p;
13598 end;
13599
13600 {$IFNDEF PS_NOINTERFACES}
AddInterfacenull13601 function TPSPascalCompiler.AddInterface(InheritedFrom: TPSInterface; Guid: TGuid; const Name: tbtString): TPSInterface;
13602 var
13603 f: TPSType;
13604 begin
13605 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13606 f := FindType(Name);
13607 if (f<>nil) and not(FAllowDuplicateRegister) then
13608 Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Name]);
13609
13610 if (f <> nil) and (f is TPSInterfaceType) then
13611 begin
13612 result := TPSInterfaceType(f).Intf;
13613 Result.Guid := Guid;
13614 Result.InheritedFrom := InheritedFrom;
13615 exit;
13616 end;
13617 f := AddType(Name, btInterface);
13618 Result := TPSInterface.Create(Self, InheritedFrom, GUID, FastUppercase(Name), f);
13619 FInterfaces.Add(Result);
13620 TPSInterfaceType(f).Intf := Result;
13621 end;
13622
TPSPascalCompiler.FindInterfacenull13623 function TPSPascalCompiler.FindInterface(const Name: tbtString): TPSInterface;
13624 var
13625 n: tbtString;
13626 i, nh: Longint;
13627 begin
13628 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13629 n := FastUpperCase(Name);
13630 nh := MakeHash(n);
13631 for i := FInterfaces.Count -1 downto 0 do
13632 begin
13633 Result := FInterfaces[i];
13634 if (Result.NameHash = nh) and (Result.Name = N) then
13635 exit;
13636 end;
13637 raise EPSCompilerException.CreateFmt(RPS_UnknownInterface, [Name]);
13638 end;
13639 {$ENDIF}
TPSPascalCompiler.AddClassnull13640 function TPSPascalCompiler.AddClass(InheritsFrom: TPSCompileTimeClass; aClass: TClass): TPSCompileTimeClass;
13641 var
13642 f: TPSType;
13643 begin
13644 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13645 Result := FindClass(tbtstring(aClass.ClassName));
13646 if (Result<>nil) and not(FAllowDuplicateRegister) then
13647 Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [aClass.ClassName]);
13648 if Result <> nil then
13649 begin
13650 if InheritsFrom <> nil then
13651 Result.FInheritsFrom := InheritsFrom;
13652 exit;
13653 end;
13654 f := AddType(tbtstring(aClass.ClassName), btClass);
13655 Result := TPSCompileTimeClass.CreateC(aClass, Self, f);
13656 Result.FInheritsFrom := InheritsFrom;
13657 FClasses.Add(Result);
13658 TPSClassType(f).Cl := Result;
13659 f.ExportName := True;
13660 end;
13661
TPSPascalCompiler.AddClassNnull13662 function TPSPascalCompiler.AddClassN(InheritsFrom: TPSCompileTimeClass; const aClass: tbtString): TPSCompileTimeClass;
13663 var
13664 f: TPSType;
13665 begin
13666 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13667 Result := FindClass(aClass);
13668 if (Result<>nil) and (Result.FInheritsFrom<>nil) and not(FAllowDuplicateRegister) then
13669 Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [aClass]);
13670 if Result <> nil then
13671 begin
13672 if InheritsFrom <> nil then
13673 Result.FInheritsFrom := InheritsFrom;
13674 exit;
13675 end;
13676 f := AddType(aClass, btClass);
13677 Result := TPSCompileTimeClass.Create(FastUppercase(aClass), Self, f);
13678 TPSClassType(f).Cl := Result;
13679 Result.FInheritsFrom := InheritsFrom;
13680 FClasses.Add(Result);
13681 TPSClassType(f).Cl := Result;
13682 f.ExportName := True;
13683 end;
13684
TPSPascalCompiler.FindClassnull13685 function TPSPascalCompiler.FindClass(const aClass: tbtString): TPSCompileTimeClass;
13686 var
13687 i: Longint;
13688 Cl: tbtString;
13689 H: Longint;
13690 x: TPSCompileTimeClass;
13691 begin
13692 cl := FastUpperCase(aClass);
13693 H := MakeHash(Cl);
13694 for i :=0 to FClasses.Count -1 do
13695 begin
13696 x := FClasses[I];
13697 if (X.FClassNameHash = H) and (X.FClassName = Cl) then
13698 begin
13699 Result := X;
13700 Exit;
13701 end;
13702 end;
13703 Result := nil;
13704 end;
13705
13706
13707
13708 { }
13709
TransDoubleToStrnull13710 function TransDoubleToStr(D: Double): tbtString;
13711 begin
13712 SetLength(Result, SizeOf(Double));
13713 Double((@Result[1])^) := D;
13714 end;
13715
TransSingleToStrnull13716 function TransSingleToStr(D: Single): tbtString;
13717 begin
13718 SetLength(Result, SizeOf(Single));
13719 Single((@Result[1])^) := D;
13720 end;
13721
TransExtendedToStrnull13722 function TransExtendedToStr(D: Extended): tbtString;
13723 begin
13724 SetLength(Result, SizeOf(Extended));
13725 Extended((@Result[1])^) := D;
13726 end;
13727
TransLongintToStrnull13728 function TransLongintToStr(D: Longint): tbtString;
13729 begin
13730 SetLength(Result, SizeOf(Longint));
13731 Longint((@Result[1])^) := D;
13732 end;
13733
TransCardinalToStrnull13734 function TransCardinalToStr(D: Cardinal): tbtString;
13735 begin
13736 SetLength(Result, SizeOf(Cardinal));
13737 Cardinal((@Result[1])^) := D;
13738 end;
13739
TransWordToStrnull13740 function TransWordToStr(D: Word): tbtString;
13741 begin
13742 SetLength(Result, SizeOf(Word));
13743 Word((@Result[1])^) := D;
13744 end;
13745
TransSmallIntToStrnull13746 function TransSmallIntToStr(D: SmallInt): tbtString;
13747 begin
13748 SetLength(Result, SizeOf(SmallInt));
13749 SmallInt((@Result[1])^) := D;
13750 end;
13751
TransByteToStrnull13752 function TransByteToStr(D: Byte): tbtString;
13753 begin
13754 SetLength(Result, SizeOf(Byte));
13755 Byte((@Result[1])^) := D;
13756 end;
13757
TransShortIntToStrnull13758 function TransShortIntToStr(D: ShortInt): tbtString;
13759 begin
13760 SetLength(Result, SizeOf(ShortInt));
13761 ShortInt((@Result[1])^) := D;
13762 end;
13763
GetConstantnull13764 function TPSPascalCompiler.GetConstant(const Name: tbtString): TPSConstant;
13765 var
13766 h, i: Longint;
13767 n: tbtString;
13768
13769 begin
13770 n := FastUppercase(name);
13771 h := MakeHash(n);
13772 for i := 0 to FConstants.Count -1 do
13773 begin
13774 result := TPSConstant(FConstants[i]);
13775 if (Result.NameHash = h) and (Result.Name = n) then exit;
13776 end;
13777 result := nil;
13778 end;
13779
13780 {$IFDEF PS_USESSUPPORT}
IsInLocalUnitListnull13781 function TPSPascalCompiler.IsInLocalUnitList(s: tbtstring): Boolean;
13782 begin
13783 s:=FastUpperCase(s);
13784 if (s = '') or (s=FastUpperCase(fModule)) or (s='SYSTEM') then
13785 begin
13786 result:=true;
13787 exit;
13788 end;
13789 result:=fUnit.HasUses(S);
13790 end;
13791 {$ENDIF}
13792
13793 { TPSType }
13794
13795 constructor TPSType.Create;
13796 begin
13797 inherited Create;
13798 FAttributes := TPSAttributes.Create;
13799 FFinalTypeNo := InvalidVal;
13800 end;
13801
13802 destructor TPSType.Destroy;
13803 begin
13804 FAttributes.Free;
13805 inherited Destroy;
13806 end;
13807
13808 procedure TPSType.SetName(const Value: tbtString);
13809 begin
13810 FName := Value;
13811 FNameHash := MakeHash(Value);
13812 end;
13813
13814 procedure TPSType.Use;
13815 begin
13816 FUsed := True;
13817 end;
13818
13819 { TPSRecordType }
13820
TPSRecordType.AddRecValnull13821 function TPSRecordType.AddRecVal: PIFPSRecordFieldTypeDef;
13822 begin
13823 Result := TPSRecordFieldTypeDef.Create;
13824 FRecordSubVals.Add(Result);
13825 end;
13826
13827 constructor TPSRecordType.Create;
13828 begin
13829 inherited Create;
13830 FRecordSubVals := TPSList.Create;
13831 end;
13832
13833 destructor TPSRecordType.Destroy;
13834 var
13835 i: Longint;
13836 begin
13837 for i := FRecordSubVals.Count -1 downto 0 do
13838 TPSRecordFieldTypeDef(FRecordSubVals[I]).Free;
13839 FRecordSubVals.Free;
13840 inherited Destroy;
13841 end;
13842
TPSRecordType.RecValnull13843 function TPSRecordType.RecVal(I: Longint): PIFPSRecordFieldTypeDef;
13844 begin
13845 Result := FRecordSubVals[I]
13846 end;
13847
TPSRecordType.RecValCountnull13848 function TPSRecordType.RecValCount: Longint;
13849 begin
13850 Result := FRecordSubVals.Count;
13851 end;
13852
13853
13854 { TPSRegProc }
13855
13856 constructor TPSRegProc.Create;
13857 begin
13858 inherited Create;
13859 FDecl := TPSParametersDecl.Create;
13860 end;
13861
13862 destructor TPSRegProc.Destroy;
13863 begin
13864 FDecl.Free;
13865 inherited Destroy;
13866 end;
13867
13868 procedure TPSRegProc.SetName(const Value: tbtString);
13869 begin
13870 FName := Value;
13871 FNameHash := MakeHash(FName);
13872 end;
13873
13874 { TPSRecordFieldTypeDef }
13875
13876 procedure TPSRecordFieldTypeDef.SetFieldOrgName(const Value: tbtString);
13877 begin
13878 FFieldOrgName := Value;
13879 FFieldName := FastUppercase(Value);
13880 FFieldNameHash := MakeHash(FFieldName);
13881 end;
13882
13883 { TPSProcVar }
13884
13885 procedure TPSProcVar.SetName(const Value: tbtString);
13886 begin
13887 FName := Value;
13888 FNameHash := MakeHash(FName);
13889 end;
13890
13891 procedure TPSProcVar.Use;
13892 begin
13893 FUsed := True;
13894 end;
13895
13896
13897
13898 { TPSInternalProcedure }
13899
13900 constructor TPSInternalProcedure.Create;
13901 begin
13902 inherited Create;
13903 FProcVars := TPSList.Create;
13904 FLabels := TIfStringList.Create;
13905 FGotos := TIfStringList.Create;
13906 FDecl := TPSParametersDecl.Create;
13907 end;
13908
13909 destructor TPSInternalProcedure.Destroy;
13910 var
13911 i: Longint;
13912 begin
13913 FDecl.Free;
13914 for i := FProcVars.Count -1 downto 0 do
13915 TPSProcVar(FProcVars[I]).Free;
13916 FProcVars.Free;
13917 FGotos.Free;
13918 FLabels.Free;
13919 inherited Destroy;
13920 end;
13921
13922 procedure TPSInternalProcedure.ResultUse;
13923 begin
13924 FResultUsed := True;
13925 end;
13926
13927 procedure TPSInternalProcedure.SetName(const Value: tbtString);
13928 begin
13929 FName := Value;
13930 FNameHash := MakeHash(FName);
13931 end;
13932
13933 procedure TPSInternalProcedure.Use;
13934 begin
13935 FUsed := True;
13936 end;
13937
13938 { TPSProcedure }
13939 constructor TPSProcedure.Create;
13940 begin
13941 inherited Create;
13942 FAttributes := TPSAttributes.Create;
13943 end;
13944
13945 destructor TPSProcedure.Destroy;
13946 begin
13947 FAttributes.Free;
13948 inherited Destroy;
13949 end;
13950
13951 { TPSVar }
13952
13953 procedure TPSVar.SetName(const Value: tbtString);
13954 begin
13955 FName := Value;
13956 FNameHash := MakeHash(Value);
13957 end;
13958
13959 procedure TPSVar.Use;
13960 begin
13961 FUsed := True;
13962 end;
13963
13964 { TPSConstant }
13965
13966 destructor TPSConstant.Destroy;
13967 begin
13968 DisposeVariant(Value);
13969 inherited Destroy;
13970 end;
13971
13972 procedure TPSConstant.SetChar(c: tbtChar);
13973 begin
13974 if (FValue <> nil) then
13975 begin
13976 case FValue.FType.BaseType of
13977 btChar: FValue.tchar := c;
13978 btString: tbtString(FValue.tstring) := c;
13979 {$IFNDEF PS_NOWIDESTRING}
13980 btWideString: tbtwidestring(FValue.twidestring) := tbtWidestring(c);
13981 btUnicodeString: tbtUnicodestring(FValue.twidestring) := tbtUnicodestring(c);
13982 {$ENDIF}
13983 else
13984 raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
13985 end;
13986 end else
13987 raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
13988 end;
13989
13990 procedure TPSConstant.SetExtended(const Val: Extended);
13991 begin
13992 if (FValue <> nil) then
13993 begin
13994 case FValue.FType.BaseType of
13995 btSingle: FValue.tsingle := Val;
13996 btDouble: FValue.tdouble := Val;
13997 btExtended: FValue.textended := Val;
13998 btCurrency: FValue.tcurrency := Val;
13999 else
14000 raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
14001 end;
14002 end else
14003 raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
14004 end;
14005
14006 procedure TPSConstant.SetInt(const Val: Longint);
14007 begin
14008 if (FValue <> nil) then
14009 begin
14010 case FValue.FType.BaseType of
14011 btEnum: FValue.tu32 := Val;
14012 btU32, btS32: FValue.ts32 := Val;
14013 btU16, btS16: FValue.ts16 := Val;
14014 btU8, btS8: FValue.ts8 := Val;
14015 btSingle: FValue.tsingle := Val;
14016 btDouble: FValue.tdouble := Val;
14017 btExtended: FValue.textended := Val;
14018 btCurrency: FValue.tcurrency := Val;
14019 {$IFNDEF PS_NOINT64}
14020 bts64: FValue.ts64 := Val;
14021 {$ENDIF}
14022 else
14023 raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
14024 end;
14025 end else
14026 raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
14027 end;
14028 {$IFNDEF PS_NOINT64}
14029 procedure TPSConstant.SetInt64(const Val: Int64);
14030 begin
14031 if (FValue <> nil) then
14032 begin
14033 case FValue.FType.BaseType of
14034 btEnum: FValue.tu32 := Val;
14035 btU32, btS32: FValue.ts32 := Val;
14036 btU16, btS16: FValue.ts16 := Val;
14037 btU8, btS8: FValue.ts8 := Val;
14038 btSingle: FValue.tsingle := Val;
14039 btDouble: FValue.tdouble := Val;
14040 btExtended: FValue.textended := Val;
14041 btCurrency: FValue.tcurrency := Val;
14042 bts64: FValue.ts64 := Val;
14043 else
14044 raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
14045 end;
14046 end else
14047 raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
14048 end;
14049 {$ENDIF}
14050 procedure TPSConstant.SetName(const Value: tbtString);
14051 begin
14052 FName := Value;
14053 FNameHash := MakeHash(Value);
14054 end;
14055
14056
14057 procedure TPSConstant.SetSet(const val);
14058 begin
14059 if (FValue <> nil) then
14060 begin
14061 case FValue.FType.BaseType of
14062 btSet:
14063 begin
14064 if length(tbtstring(FValue.tstring)) <> TPSSetType(FValue.FType).ByteSize then
14065 SetLength(tbtstring(FValue.tstring), TPSSetType(FValue.FType).ByteSize);
14066 Move(Val, FValue.tstring^, TPSSetType(FValue.FType).ByteSize);
14067 end;
14068 else
14069 raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
14070 end;
14071 end else
14072 raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
14073 end;
14074
14075 procedure TPSConstant.SetString(const Val: tbtString);
14076 begin
14077 if (FValue <> nil) then
14078 begin
14079 case FValue.FType.BaseType of
14080 btChar: FValue.tchar := (Val+#0)[1];
14081 btString: tbtString(FValue.tstring) := val;
14082 {$IFNDEF PS_NOWIDESTRING}
14083 btWideChar: FValue.twidechar := WideChar((Val+#0)[1]);
14084 btWideString: tbtwidestring(FValue.twidestring) := tbtwidestring(val);
14085 btUnicodeString: tbtunicodestring(FValue.tunistring) := tbtunicodestring(val);
14086 {$ENDIF}
14087 else
14088 raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
14089 end;
14090 end else
14091 raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
14092 end;
14093
14094 procedure TPSConstant.SetUInt(const Val: Cardinal);
14095 begin
14096 if (FValue <> nil) then
14097 begin
14098 case FValue.FType.BaseType of
14099 btEnum: FValue.tu32 := Val;
14100 btU32, btS32: FValue.tu32 := Val;
14101 btU16, btS16: FValue.tu16 := Val;
14102 btU8, btS8: FValue.tu8 := Val;
14103 btSingle: FValue.tsingle := Val;
14104 btDouble: FValue.tdouble := Val;
14105 btExtended: FValue.textended := Val;
14106 btCurrency: FValue.tcurrency := Val;
14107 {$IFNDEF PS_NOINT64}
14108 bts64: FValue.ts64 := Val;
14109 {$ENDIF}
14110 else
14111 raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
14112 end;
14113 end else
14114 raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
14115 end;
14116
14117 {$IFNDEF PS_NOWIDESTRING}
14118 procedure TPSConstant.SetWideChar(const val: WideChar);
14119 begin
14120 if (FValue <> nil) then
14121 begin
14122 case FValue.FType.BaseType of
14123 btString: tbtString(FValue.tstring) := tbtstring(val);
14124 btWideChar: FValue.twidechar := val;
14125 btWideString: tbtwidestring(FValue.twidestring) := val;
14126 btUnicodeString: tbtUnicodestring(FValue.tUniString) := val;
14127 else
14128 raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
14129 end;
14130 end else
14131 raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
14132 end;
14133
14134 procedure TPSConstant.SetWideString(const val: tbtwidestring);
14135 begin
14136 if (FValue <> nil) then
14137 begin
14138 case FValue.FType.BaseType of
14139 btString: tbtString(FValue.tstring) := tbtstring(val);
14140 btWideString: tbtwidestring(FValue.twidestring) := val;
14141 btUnicodeString: tbtunicodestring(FValue.tunistring) := val;
14142 else
14143 raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
14144 end;
14145 end else
14146 raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
14147 end;
14148 procedure TPSConstant.SetUnicodeString(const val: tbtunicodestring);
14149 begin
14150 if (FValue <> nil) then
14151 begin
14152 case FValue.FType.BaseType of
14153 btString: tbtString(FValue.tstring) := tbtstring(val);
14154 btWideString: tbtwidestring(FValue.twidestring) := val;
14155 btUnicodeString: tbtunicodestring(FValue.tunistring) := val;
14156 else
14157 raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
14158 end;
14159 end else
14160 raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
14161 end;
14162 {$ENDIF}
14163 { TPSPascalCompilerError }
14164
TPSPascalCompilerError.ErrorTypenull14165 function TPSPascalCompilerError.ErrorType: tbtString;
14166 begin
14167 Result := tbtstring(RPS_Error);
14168 end;
14169
TPSPascalCompilerError.ShortMessageToStringnull14170 function TPSPascalCompilerError.ShortMessageToString: tbtString;
14171 begin
14172 case Error of
14173 ecUnknownIdentifier: Result := tbtstring(Format (RPS_UnknownIdentifier, [Param]));
14174 ecIdentifierExpected: Result := tbtstring(RPS_IdentifierExpected);
14175 ecCommentError: Result := tbtstring(RPS_CommentError);
14176 ecStringError: Result := tbtstring(RPS_StringError);
14177 ecCharError: Result := tbtstring(RPS_CharError);
14178 ecSyntaxError: Result := tbtstring(RPS_SyntaxError);
14179 ecUnexpectedEndOfFile: Result := tbtstring(RPS_EOF);
14180 ecSemicolonExpected: Result := tbtstring(RPS_SemiColonExpected);
14181 ecBeginExpected: Result := tbtstring(RPS_BeginExpected);
14182 ecPeriodExpected: Result := tbtstring(RPS_PeriodExpected);
14183 ecDuplicateIdentifier: Result := tbtstring(Format (RPS_DuplicateIdent, [Param]));
14184 ecColonExpected: Result := tbtstring(RPS_ColonExpected);
14185 ecUnknownType: Result := tbtstring(Format (RPS_UnknownType, [Param]));
14186 ecCloseRoundExpected: Result := tbtstring(RPS_CloseRoundExpected);
14187 ecTypeMismatch: Result := tbtstring(RPS_TypeMismatch);
14188 ecInternalError: Result := tbtstring(Format (RPS_InternalError, [Param]));
14189 ecAssignmentExpected: Result := tbtstring(RPS_AssignmentExpected);
14190 ecThenExpected: Result := tbtstring(RPS_ThenExpected);
14191 ecDoExpected: Result := tbtstring(RPS_DoExpected);
14192 ecNoResult: Result := tbtstring(RPS_NoResult);
14193 ecOpenRoundExpected: Result := tbtstring(RPS_OpenRoundExpected);
14194 ecCommaExpected: Result := tbtstring(RPS_CommaExpected);
14195 ecToExpected: Result := tbtstring(RPS_ToExpected);
14196 ecIsExpected: Result := tbtstring(RPS_IsExpected);
14197 ecOfExpected: Result := tbtstring(RPS_OfExpected);
14198 ecCloseBlockExpected: Result := tbtstring(RPS_CloseBlockExpected);
14199 ecVariableExpected: Result := tbtstring(RPS_VariableExpected);
14200 ecStringExpected: result := tbtstring(RPS_StringExpected);
14201 ecEndExpected: Result := tbtstring(RPS_EndExpected);
14202 ecUnSetLabel: Result := tbtstring(Format (RPS_UnSetLabel, [Param]));
14203 ecNotInLoop: Result := tbtstring(RPS_NotInLoop);
14204 ecInvalidJump: Result := tbtstring(RPS_InvalidJump);
14205 ecOpenBlockExpected: Result := tbtstring(RPS_OpenBlockExpected);
14206 ecWriteOnlyProperty: Result := tbtstring(RPS_WriteOnlyProperty);
14207 ecReadOnlyProperty: Result := tbtstring(RPS_ReadOnlyProperty);
14208 ecClassTypeExpected: Result := tbtstring(RPS_ClassTypeExpected);
14209 ecCustomError: Result := Param;
14210 ecDivideByZero: Result := tbtstring(RPS_DivideByZero);
14211 ecMathError: Result := tbtstring(RPS_MathError);
14212 ecUnsatisfiedForward: Result := tbtstring(Format (RPS_UnsatisfiedForward, [Param]));
14213 ecForwardParameterMismatch: Result := tbtstring(RPS_ForwardParameterMismatch);
14214 ecInvalidnumberOfParameters: Result := tbtstring(RPS_InvalidNumberOfParameter);
14215 {$IFDEF PS_USESSUPPORT}
14216 ecNotAllowed : Result:=tbtstring(Format(RPS_NotAllowed,[Param]));
14217 ecUnitNotFoundOrContainsErrors: Result:=tbtstring(Format(RPS_UnitNotFound,[Param]));
14218 ecCrossReference: Result:=tbtstring(Format(RPS_CrossReference,[Param]));
14219 {$ENDIF}
14220 ecUnClosedAttributes: Result:=tbtstring(RPS_UnClosedAttributes);
14221 else
14222 Result := tbtstring(RPS_UnknownError);
14223 end;
14224 Result := Result;
14225 end;
14226
14227
14228 { TPSPascalCompilerHint }
14229
TPSPascalCompilerHint.ErrorTypenull14230 function TPSPascalCompilerHint.ErrorType: tbtString;
14231 begin
14232 Result := tbtstring(RPS_Hint);
14233 end;
14234
TPSPascalCompilerHint.ShortMessageToStringnull14235 function TPSPascalCompilerHint.ShortMessageToString: tbtString;
14236 begin
14237 case Hint of
14238 ehVariableNotUsed: Result := tbtstring(Format (RPS_VariableNotUsed, [Param]));
14239 ehFunctionNotUsed: Result := tbtstring(Format (RPS_FunctionNotUsed, [Param]));
14240 ehCustomHint: Result := Param;
14241 else
14242 Result := tbtstring(RPS_UnknownHint);
14243 end;
14244 end;
14245
14246 { TPSPascalCompilerWarning }
14247
ErrorTypenull14248 function TPSPascalCompilerWarning.ErrorType: tbtString;
14249 begin
14250 Result := tbtstring(RPS_Warning);
14251 end;
14252
TPSPascalCompilerWarning.ShortMessageToStringnull14253 function TPSPascalCompilerWarning.ShortMessageToString: tbtString;
14254 begin
14255 case Warning of
14256 ewCustomWarning: Result := Param;
14257 ewCalculationAlwaysEvaluatesTo: Result := tbtstring(Format (RPS_CalculationAlwaysEvaluatesTo, [Param]));
14258 ewIsNotNeeded: Result := tbtstring(Format (RPS_IsNotNeeded, [Param]));
14259 ewAbstractClass: Result := tbtstring(RPS_AbstractClass);
14260 else
14261 Result := tbtstring(RPS_UnknownWarning);
14262 end;
14263 end;
14264
14265 { TPSPascalCompilerMessage }
14266
TPSPascalCompilerMessage.MessageToStringnull14267 function TPSPascalCompilerMessage.MessageToString: tbtString;
14268 begin
14269 Result := '['+ErrorType+'] '+FModuleName+'('+IntToStr(FRow)+':'+IntToStr(FCol)+'): '+ShortMessageToString;
14270 end;
14271
14272 procedure TPSPascalCompilerMessage.SetParserPos(Parser: TPSPascalParser);
14273 begin
14274 FPosition := Parser.CurrTokenPos;
14275 FRow := Parser.Row;
14276 FCol := Parser.Col;
14277 end;
14278
14279 procedure TPSPascalCompilerMessage.SetCustomPos(Pos, Row, Col: Cardinal);
14280 begin
14281 FPosition := Pos;
14282 FRow := Row;
14283 FCol := Col;
14284 end;
14285
14286 { TUnConstOperation }
14287
14288 destructor TUnConstOperation.Destroy;
14289 begin
14290 FVal1.Free;
14291 inherited Destroy;
14292 end;
14293
14294
14295 { TBinConstOperation }
14296
14297 destructor TBinConstOperation.Destroy;
14298 begin
14299 FVal1.Free;
14300 FVal2.Free;
14301 inherited Destroy;
14302 end;
14303
14304 { TConstData }
14305
14306 destructor TConstData.Destroy;
14307 begin
14308 DisposeVariant(FData);
14309 inherited Destroy;
14310 end;
14311
14312
14313 { TConstOperation }
14314
14315 procedure TConstOperation.SetPos(Parser: TPSPascalParser);
14316 begin
14317 FDeclPosition := Parser.CurrTokenPos;
14318 FDeclRow := Parser.Row;
14319 FDeclCol := Parser.Col;
14320 end;
14321
14322 { TPSValue }
14323
14324 procedure TPSValue.SetParserPos(P: TPSPascalParser);
14325 begin
14326 FPos := P.CurrTokenPos;
14327 FRow := P.Row;
14328 FCol := P.Col;
14329 end;
14330
14331 { TPSValueData }
14332
14333 destructor TPSValueData.Destroy;
14334 begin
14335 DisposeVariant(FData);
14336 inherited Destroy;
14337 end;
14338
14339
14340 { TPSValueReplace }
14341
14342 constructor TPSValueReplace.Create;
14343 begin
14344 FFreeNewValue := True;
14345 FReplaceTimes := 1;
14346 end;
14347
14348 destructor TPSValueReplace.Destroy;
14349 begin
14350 if FFreeOldValue then
14351 FOldValue.Free;
14352 if FFreeNewValue then
14353 FNewValue.Free;
14354 inherited Destroy;
14355 end;
14356
14357
14358
14359 { TPSUnValueOp }
14360
14361 destructor TPSUnValueOp.Destroy;
14362 begin
14363 FVal1.Free;
14364 inherited Destroy;
14365 end;
14366
14367 { TPSBinValueOp }
14368
14369 destructor TPSBinValueOp.Destroy;
14370 begin
14371 FVal1.Free;
14372 FVal2.Free;
14373 inherited Destroy;
14374 end;
14375
14376
14377
14378
14379 { TPSSubValue }
14380
14381 destructor TPSSubValue.Destroy;
14382 begin
14383 FSubNo.Free;
14384 inherited Destroy;
14385 end;
14386
14387 { TPSValueVar }
14388
14389 constructor TPSValueVar.Create;
14390 begin
14391 inherited Create;
14392 FRecItems := TPSList.Create;
14393 end;
14394
14395 destructor TPSValueVar.Destroy;
14396 var
14397 i: Longint;
14398 begin
14399 for i := 0 to FRecItems.Count -1 do
14400 begin
14401 TPSSubItem(FRecItems[I]).Free;
14402 end;
14403 FRecItems.Free;
14404 inherited Destroy;
14405 end;
14406
TPSValueVar.GetRecCountnull14407 function TPSValueVar.GetRecCount: Cardinal;
14408 begin
14409 Result := FRecItems.Count;
14410 end;
14411
TPSValueVar.GetRecItemnull14412 function TPSValueVar.GetRecItem(I: Cardinal): TPSSubItem;
14413 begin
14414 Result := FRecItems[I];
14415 end;
14416
TPSValueVar.RecAddnull14417 function TPSValueVar.RecAdd(Val: TPSSubItem): Cardinal;
14418 begin
14419 Result := FRecItems.Add(Val);
14420 end;
14421
14422 procedure TPSValueVar.RecDelete(I: Cardinal);
14423 var
14424 rr :TPSSubItem;
14425 begin
14426 rr := FRecItems[i];
14427 FRecItems.Delete(I);
14428 rr.Free;
14429 end;
14430
14431 { TPSValueProc }
14432
14433 destructor TPSValueProc.Destroy;
14434 begin
14435 FSelfPtr.Free;
14436 FParameters.Free;
14437 end;
14438 { TPSParameter }
14439
14440 destructor TPSParameter.Destroy;
14441 begin
14442 FTempVar.Free;
14443 FValue.Free;
14444 inherited Destroy;
14445 end;
14446
14447
14448 { TPSParameters }
14449
Addnull14450 function TPSParameters.Add: TPSParameter;
14451 begin
14452 Result := TPSParameter.Create;
14453 FItems.Add(Result);
14454 end;
14455
14456 constructor TPSParameters.Create;
14457 begin
14458 inherited Create;
14459 FItems := TPSList.Create;
14460 end;
14461
14462 procedure TPSParameters.Delete(I: Cardinal);
14463 var
14464 p: TPSParameter;
14465 begin
14466 p := FItems[I];
14467 FItems.Delete(i);
14468 p.Free;
14469 end;
14470
14471 destructor TPSParameters.Destroy;
14472 var
14473 i: Longint;
14474 begin
14475 for i := FItems.Count -1 downto 0 do
14476 begin
14477 TPSParameter(FItems[I]).Free;
14478 end;
14479 FItems.Free;
14480 inherited Destroy;
14481 end;
14482
GetCountnull14483 function TPSParameters.GetCount: Cardinal;
14484 begin
14485 Result := FItems.Count;
14486 end;
14487
GetItemnull14488 function TPSParameters.GetItem(I: Longint): TPSParameter;
14489 begin
14490 Result := FItems[I];
14491 end;
14492
14493
14494 { TPSValueArray }
14495
Addnull14496 function TPSValueArray.Add(Item: TPSValue): Cardinal;
14497 begin
14498 Result := FItems.Add(Item);
14499 end;
14500
14501 constructor TPSValueArray.Create;
14502 begin
14503 inherited Create;
14504 FItems := TPSList.Create;
14505 end;
14506
14507 procedure TPSValueArray.Delete(I: Cardinal);
14508 begin
14509 FItems.Delete(i);
14510 end;
14511
14512 destructor TPSValueArray.Destroy;
14513 var
14514 i: Longint;
14515 begin
14516 for i := FItems.Count -1 downto 0 do
14517 TPSValue(FItems[I]).Free;
14518 FItems.Free;
14519
14520 inherited Destroy;
14521 end;
14522
TPSValueArray.GetCountnull14523 function TPSValueArray.GetCount: Cardinal;
14524 begin
14525 Result := FItems.Count;
14526 end;
14527
GetItemnull14528 function TPSValueArray.GetItem(I: Cardinal): TPSValue;
14529 begin
14530 Result := FItems[I];
14531 end;
14532
14533
14534 { TPSValueAllocatedStackVar }
14535
14536 destructor TPSValueAllocatedStackVar.Destroy;
14537 var
14538 pv: TPSProcVar;
14539 begin
14540 {$IFDEF DEBUG}
14541 if Cardinal(LocalVarNo +1) <> proc.ProcVars.Count then
14542 begin
14543 Abort;
14544 exit;
14545 end;
14546 {$ENDIF}
14547 if Proc <> nil then
14548 begin
14549 pv := Proc.ProcVars[Proc.ProcVars.Count -1];
14550 Proc.ProcVars.Delete(Proc.ProcVars.Count -1);
14551 pv.Free;
14552 Proc.Data := Proc.Data + tbtChar(CM_PO);
14553 end;
14554 inherited Destroy;
14555 end;
14556
14557
14558
14559
AddImportedClassVariablenull14560 function AddImportedClassVariable(Sender: TPSPascalCompiler; const VarName, VarType: tbtString): Boolean;
14561 var
14562 P: TPSVar;
14563 begin
14564 P := Sender.AddVariableN(VarName, VarType);
14565 if p = nil then
14566 begin
14567 Result := False;
14568 Exit;
14569 end;
14570 SetVarExportName(P, FastUppercase(VarName));
14571 p.Use;
14572 Result := True;
14573 end;
14574
14575
14576 {'class:'+CLASSNAME+'|'+FUNCNAME+'|'+chr(CallingConv)+chr(hasresult)+params
14577
14578 For property write functions there is an '@' after the funcname.
14579 }
14580
14581 const
14582 ProcHDR = 'procedure a;';
14583
14584
14585
14586 { TPSCompileTimeClass }
14587
TPSCompileTimeClass.CastToTypenull14588 function TPSCompileTimeClass.CastToType(IntoType: TPSType;
14589 var ProcNo: Cardinal): Boolean;
14590 var
14591 P: TPSExternalProcedure;
14592 begin
14593 if (IntoType <> nil) and (IntoType.BaseType <> btClass) and (IntoType.BaseType <> btInterface) then
14594 begin
14595 Result := False;
14596 exit;
14597 end;
14598 if FCastProc <> InvalidVal then
14599 begin
14600 Procno := FCastProc;
14601 Result := True;
14602 exit;
14603 end;
14604 ProcNo := FOwner. AddUsedFunction2(P);
rocHDRnull14605 P.RegProc := FOwner.AddFunction(ProcHDR);
14606 P.RegProc.Name := '';
14607
14608 with P.RegProc.Decl.AddParam do
14609 begin
14610 OrgName := 'Org';
14611 aType := Self.FType;
14612 end;
14613 with P.RegProc.Decl.AddParam do
14614 begin
14615 OrgName := 'TypeNo';
14616 aType := FOwner.at2ut(FOwner.FindBaseType(btU32));
14617 end;
14618 P.RegProc.Decl.Result := IntoType;
14619 P.RegProc.ImportDecl := 'class:+';
14620 FCastProc := ProcNo;
14621 Result := True;
14622 end;
14623
14624
ClassFunc_Callnull14625 function TPSCompileTimeClass.ClassFunc_Call(Index: IPointer;
14626 var ProcNo: Cardinal): Boolean;
14627 var
14628 C: TPSDelphiClassItemConstructor;
14629 P: TPSExternalProcedure;
14630 s: tbtString;
14631 i: Longint;
14632
14633 begin
14634 if FIsAbstract then
14635 FOwner.MakeWarning('', ewAbstractClass, '');
14636 C := Pointer(Index);
14637 if c.MethodNo = InvalidVal then
14638 begin
14639 ProcNo := FOwner.AddUsedFunction2(P);
rocHDRnull14640 P.RegProc := FOwner.AddFunction(ProcHDR);
14641 P.RegProc.Name := '';
14642 P.RegProc.Decl.Assign(c.Decl);
14643 s := 'class:' + C.Owner.FClassName + '|' + C.Name + '|'+ chr(0);
14644 if c.Decl.Result = nil then
14645 s := s + #0
14646 else
14647 s := s + #1;
14648 for i := 0 to C.Decl.ParamCount -1 do
14649 begin
14650 if c.Decl.Params[i].Mode <> pmIn then
14651 s := s + #1
14652 else
14653 s := s + #0;
14654 end;
14655 P.RegProc.ImportDecl := s;
14656 C.MethodNo := ProcNo;
14657 end else begin
14658 ProcNo := c.MethodNo;
14659 end;
14660 Result := True;
14661 end;
14662
TPSCompileTimeClass.ClassFunc_Findnull14663 function TPSCompileTimeClass.ClassFunc_Find(const Name: tbtString;
14664 var Index: IPointer): Boolean;
14665 var
14666 H: Longint;
14667 I: Longint;
14668 CurrClass: TPSCompileTimeClass;
14669 C: TPSDelphiClassItem;
14670 begin
14671 H := MakeHash(Name);
14672 CurrClass := Self;
14673 while CurrClass <> nil do
14674 begin
14675 for i := CurrClass.FClassItems.Count -1 downto 0 do
14676 begin
14677 C := CurrClass.FClassItems[I];
14678 if (c is TPSDelphiClassItemConstructor) and (C.NameHash = H) and (C.Name = Name) then
14679 begin
14680 Index := IPointer(C);
14681 Result := True;
14682 exit;
14683 end;
14684 end;
14685 CurrClass := CurrClass.FInheritsFrom;
14686 end;
14687 Result := False;
14688 end;
14689
14690
TPSCompileTimeClass.CreateCnull14691 class function TPSCompileTimeClass.CreateC(FClass: TClass; aOwner: TPSPascalCompiler; aType: TPSType): TPSCompileTimeClass;
14692 begin
14693 Result := TPSCompileTimeClass.Create(FastUpperCase(tbtstring(FClass.ClassName)), aOwner, aType);
14694 Result.FClass := FClass;
14695 end;
14696
14697 constructor TPSCompileTimeClass.Create(ClassName: tbtString; aOwner: TPSPascalCompiler; aType: TPSType);
14698 begin
14699 inherited Create;
14700 FType := aType;
14701 FCastProc := InvalidVal;
14702 FNilProc := InvalidVal;
14703
14704 FDefaultProperty := InvalidVal;
14705 FClassName := Classname;
14706 FClassNameHash := MakeHash(FClassName);
14707 FClassItems := TPSList.Create;
14708 FOwner := aOwner;
14709 end;
14710
14711 destructor TPSCompileTimeClass.Destroy;
14712 var
14713 I: Longint;
14714 begin
14715 for i := FClassItems.Count -1 downto 0 do
14716 TPSDelphiClassItem(FClassItems[I]).Free;
14717 FClassItems.Free;
14718 inherited Destroy;
14719 end;
14720
14721
TPSCompileTimeClass.Func_Callnull14722 function TPSCompileTimeClass.Func_Call(Index: TPSDelphiClassItem;
14723 var ProcNo: Cardinal): Boolean;
14724 var
14725 C: TPSDelphiClassItemMethod;
14726 P: TPSExternalProcedure;
14727 i: Longint;
14728 s: tbtString;
14729
14730 begin
14731 C := Index as TPSDelphiClassItemMethod;
14732 if c.MethodNo = InvalidVal then
14733 begin
14734 ProcNo := FOwner.AddUsedFunction2(P);
rocHDRnull14735 P.RegProc := FOwner.AddFunction(ProcHDR);
14736 P.RegProc.Name := '';
14737 p.RegProc.Decl.Assign(c.Decl);
14738 s := 'class:' + C.Owner.FClassName + '|' + C.Name + '|'+ chr(0);
14739 if c.Decl.Result = nil then
14740 s := s + #0
14741 else
14742 s := s + #1;
14743 for i := 0 to c.Decl.ParamCount -1 do
14744 begin
14745 if c.Decl.Params[i].Mode <> pmIn then
14746 s := s + #1
14747 else
14748 s := s + #0;
14749 end;
14750 P.RegProc.ImportDecl := s;
14751 C.MethodNo := ProcNo;
14752 end else begin
14753 ProcNo := c.MethodNo;
14754 end;
14755 Result := True;
14756 end;
14757
TPSCompileTimeClass.Func_Findnull14758 function TPSCompileTimeClass.Func_Find(const Name: tbtString;
14759 var Index: TPSDelphiClassItem): Boolean;
14760 var
14761 H: Longint;
14762 I: Longint;
14763 CurrClass: TPSCompileTimeClass;
14764 C: TPSDelphiClassItem;
14765 begin
14766 H := MakeHash(Name);
14767 CurrClass := Self;
14768 while CurrClass <> nil do
14769 begin
14770 for i := CurrClass.FClassItems.Count -1 downto 0 do
14771 begin
14772 C := CurrClass.FClassItems[I];
14773 if (c is TPSDelphiClassItemMethod) and (C.NameHash = H) and (C.Name = Name) then
14774 begin
14775 Index := C;
14776 Result := True;
14777 exit;
14778 end;
14779 end;
14780 CurrClass := CurrClass.FInheritsFrom;
14781 end;
14782 Result := False;
14783 end;
14784
TPSCompileTimeClass.GetCountnull14785 function TPSCompileTimeClass.GetCount: Longint;
14786 begin
14787 Result := FClassItems.Count;
14788 end;
14789
GetItemnull14790 function TPSCompileTimeClass.GetItem(i: Longint): TPSDelphiClassItem;
14791 begin
14792 Result := FClassItems[i];
14793 end;
14794
TPSCompileTimeClass.IsCompatibleWithnull14795 function TPSCompileTimeClass.IsCompatibleWith(aType: TPSType): Boolean;
14796 var
14797 Temp: TPSCompileTimeClass;
14798 begin
14799 if (atype.BaseType <> btClass) then
14800 begin
14801 Result := False;
14802 exit;
14803 end;
14804 temp := TPSClassType(aType).Cl;
14805 while Temp <> nil do
14806 begin
14807 if Temp = Self then
14808 begin
14809 Result := True;
14810 exit;
14811 end;
14812 Temp := Temp.FInheritsFrom;
14813 end;
14814 Result := False;
14815 end;
14816
TPSCompileTimeClass.Property_Findnull14817 function TPSCompileTimeClass.Property_Find(const Name: tbtString;
14818 var Index: TPSDelphiClassItem): Boolean;
14819 var
14820 H: Longint;
14821 I: Longint;
14822 CurrClass: TPSCompileTimeClass;
14823 C: TPSDelphiClassItem;
14824 begin
14825 if Name = '' then
14826 begin
14827 CurrClass := Self;
14828 while CurrClass <> nil do
14829 begin
14830 if CurrClass.FDefaultProperty <> InvalidVal then
14831 begin
14832 Index := TPSDelphiClassItem(CurrClass.FClassItems[Currclass.FDefaultProperty]);
14833 result := True;
14834 exit;
14835 end;
14836 CurrClass := CurrClass.FInheritsFrom;
14837 end;
14838 Result := False;
14839 exit;
14840 end;
14841 H := MakeHash(Name);
14842 CurrClass := Self;
14843 while CurrClass <> nil do
14844 begin
14845 for i := CurrClass.FClassItems.Count -1 downto 0 do
14846 begin
14847 C := CurrClass.FClassItems[I];
14848 if (c is TPSDelphiClassItemProperty) and (C.NameHash = H) and (C.Name = Name) then
14849 begin
14850 Index := C;
14851 Result := True;
14852 exit;
14853 end;
14854 end;
14855 CurrClass := CurrClass.FInheritsFrom;
14856 end;
14857 Result := False;
14858 end;
14859
Property_Getnull14860 function TPSCompileTimeClass.Property_Get(Index: TPSDelphiClassItem;
14861 var ProcNo: Cardinal): Boolean;
14862 var
14863 C: TPSDelphiClassItemProperty;
14864 P: TPSExternalProcedure;
14865 s: tbtString;
14866
14867 begin
14868 C := Index as TPSDelphiClassItemProperty;
14869 if c.AccessType = iptW then
14870 begin
14871 Result := False;
14872 exit;
14873 end;
14874 if c.ReadProcNo = InvalidVal then
14875 begin
14876 ProcNo := FOwner.AddUsedFunction2(P);
rocHDRnull14877 P.RegProc := FOwner.AddFunction(ProcHDR);
14878 P.RegProc.Name := '';
14879 P.RegProc.Decl.Result := C.Decl.Result;
14880 s := 'class:' + C.Owner.FClassName + '|' + C.Name + '|'+#0#0#0#0;
14881 Longint((@(s[length(s)-3]))^) := c.Decl.ParamCount +1;
14882 P.RegProc.ImportDecl := s;
14883 C.ReadProcNo := ProcNo;
14884 end else begin
14885 ProcNo := c.ReadProcNo;
14886 end;
14887 Result := True;
14888 end;
14889
Property_GetHeadernull14890 function TPSCompileTimeClass.Property_GetHeader(Index: TPSDelphiClassItem;
14891 Dest: TPSParametersDecl): Boolean;
14892 var
14893 c: TPSDelphiClassItemProperty;
14894 begin
14895 C := Index as TPSDelphiClassItemProperty;
14896 FOwner.UseProc(c.Decl);
14897 Dest.Assign(c.Decl);
14898 Result := True;
14899 end;
14900
Property_Setnull14901 function TPSCompileTimeClass.Property_Set(Index: TPSDelphiClassItem;
14902 var ProcNo: Cardinal): Boolean;
14903 var
14904 C: TPSDelphiClassItemProperty;
14905 P: TPSExternalProcedure;
14906 s: tbtString;
14907
14908 begin
14909 C := Index as TPSDelphiClassItemProperty;
14910 if c.AccessType = iptR then
14911 begin
14912 Result := False;
14913 exit;
14914 end;
14915 if c.WriteProcNo = InvalidVal then
14916 begin
14917 ProcNo := FOwner.AddUsedFunction2(P);
rocHDRnull14918 P.RegProc := FOwner.AddFunction(ProcHDR);
14919 P.RegProc.Name := '';
14920 s := 'class:' + C.Owner.FClassName + '|' + C.Name + '@|'#0#0#0#0;
14921 Longint((@(s[length(s)-3]))^) := C.Decl.ParamCount+1;
14922 P.RegProc.ImportDecl := s;
14923 C.WriteProcNo := ProcNo;
14924 end else begin
14925 ProcNo := c.WriteProcNo;
14926 end;
14927 Result := True;
14928 end;
14929
TPSCompileTimeClass.RegisterMethodnull14930 function TPSCompileTimeClass.RegisterMethod(const Decl: tbtString): Boolean;
14931 var
14932 DOrgName: tbtString;
14933 DDecl: TPSParametersDecl;
14934 FT: TPMFuncType;
14935 p: TPSDelphiClassItemMethod;
14936 begin
14937 DDecl := TPSParametersDecl.Create;
14938 try
14939 if not ParseMethod(FOwner, FClassName, Decl, DOrgName, DDecl, FT) then
14940 begin
14941 Result := False;
14942 {$IFDEF DEBUG} raise EPSCompilerException.CreateFmt(RPS_UnableToRegister, [Decl]); {$ENDIF}
14943 exit;
14944 end;
14945 if ft = mftConstructor then
14946 p := TPSDelphiClassItemConstructor.Create(Self)
14947 else
14948 p := TPSDelphiClassItemMethod.Create(self);
14949 p.OrgName := DOrgName;
14950 p.Decl.Assign(DDecl);
14951 p.MethodNo := InvalidVal;
14952 FClassItems.Add(p);
14953 Result := True;
14954 finally
14955 DDecl.Free;
14956 end;
14957 end;
14958
14959 procedure TPSCompileTimeClass.RegisterProperty(const PropertyName,
14960 PropertyType: tbtString; PropAC: TPSPropType);
14961 var
14962 FType: TPSType;
14963 Param: TPSParameterDecl;
14964 p: TPSDelphiClassItemProperty;
14965 PT: tbtString;
14966 begin
14967 pt := PropertyType;
14968 p := TPSDelphiClassItemProperty.Create(Self);
14969 p.AccessType := PropAC;
14970 p.ReadProcNo := InvalidVal;
14971 p.WriteProcNo := InvalidVal;
14972 p.OrgName := PropertyName;
14973 repeat
14974 FType := FOwner.FindType(FastUpperCase(grfw(pt)));
14975 if FType = nil then
14976 begin
14977 p.Free;
14978 Exit;
14979 end;
14980 if p.Decl.Result = nil then p.Decl.Result := FType else
14981 begin
14982 param := p.Decl.AddParam;
14983 Param.OrgName := 'param'+IntToStr(p.Decl.ParamCount);
14984 Param.aType := FType;
14985 end;
14986 until pt = '';
14987 FClassItems.Add(p);
14988 end;
14989
14990
14991 procedure TPSCompileTimeClass.RegisterPublishedProperties;
14992 var
14993 p: PPropList;
14994 i, Count: Longint;
14995 a: TPSPropType;
14996 begin
14997 if (Fclass = nil) or (Fclass.ClassInfo = nil) then exit;
14998 Count := GetTypeData(fclass.ClassInfo)^.PropCount;
14999 GetMem(p, Count * SizeOf(Pointer));
15000 GetPropInfos(fclass.ClassInfo, p);
15001 for i := Count -1 downto 0 do
15002 begin
15003 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
15004 begin
15005 if (p^[i]^.GetProc <> nil) then
15006 begin
15007 if p^[i]^.SetProc = nil then
15008 a := iptr
15009 else
15010 a := iptrw;
15011 end else
15012 begin
15013 a := iptW;
15014 if p^[i]^.SetProc = nil then continue;
15015 end;
15016 RegisterProperty(p^[i]^.Name, p^[i]^.PropType^.Name, a);
15017 end;
15018 end;
15019 FreeMem(p);
15020 end;
15021
TPSCompileTimeClass.RegisterPublishedPropertynull15022 function TPSCompileTimeClass.RegisterPublishedProperty(const Name: tbtString): Boolean;
15023 var
15024 p: PPropInfo;
15025 a: TPSPropType;
15026 begin
15027 if (Fclass = nil) or (Fclass.ClassInfo = nil) then begin Result := False; exit; end;
15028 p := GetPropInfo(fclass.ClassInfo, string(Name));
15029 if p = nil then begin Result := False; exit; end;
15030 if (p^.GetProc <> nil) then
15031 begin
15032 if p^.SetProc = nil then
15033 a := iptr
15034 else
15035 a := iptrw;
15036 end else
15037 begin
15038 a := iptW;
15039 if p^.SetProc = nil then begin result := False; exit; end;
15040 end;
15041 RegisterProperty(p^.Name, p^.PropType^.Name, a);
15042 Result := True;
15043 end;
15044
15045
15046 procedure TPSCompileTimeClass.SetDefaultPropery(const Name: tbtString);
15047 var
15048 i,h: Longint;
15049 p: TPSDelphiClassItem;
15050 s: tbtString;
15051
15052 begin
15053 s := FastUppercase(name);
15054 h := MakeHash(s);
15055 for i := FClassItems.Count -1 downto 0 do
15056 begin
15057 p := FClassItems[i];
15058 if (p.NameHash = h) and (p.Name = s) then
15059 begin
15060 if p is TPSDelphiClassItemProperty then
15061 begin
15062 if p.Decl.ParamCount = 0 then
15063 raise EPSCompilerException.CreateFmt(RPS_NotArrayProperty, [Name]);
15064 FDefaultProperty := I;
15065 exit;
15066 end else raise EPSCompilerException.CreateFmt(RPS_NotProperty, [Name]);
15067 end;
15068 end;
15069 raise EPSCompilerException.CreateFmt(RPS_UnknownProperty, [Name]);
15070 end;
15071
SetNilnull15072 function TPSCompileTimeClass.SetNil(var ProcNo: Cardinal): Boolean;
15073 var
15074 P: TPSExternalProcedure;
15075
15076 begin
15077 if FNilProc <> InvalidVal then
15078 begin
15079 Procno := FNilProc;
15080 Result := True;
15081 exit;
15082 end;
15083 ProcNo := FOwner.AddUsedFunction2(P);
rocHDRnull15084 P.RegProc := FOwner.AddFunction(ProcHDR);
15085 P.RegProc.Name := '';
15086 with P.RegProc.Decl.AddParam do
15087 begin
15088 OrgName := 'VarNo';
15089 aType := FOwner.at2ut(FType);
15090 end;
15091 P.RegProc.ImportDecl := 'class:-';
15092 FNilProc := Procno;
15093 Result := True;
15094 end;
15095
15096 { TPSSetType }
15097
GetBitSizenull15098 function TPSSetType.GetBitSize: Longint;
15099 begin
15100 case SetType.BaseType of
15101 btEnum: begin Result := TPSEnumType(setType).HighValue+1; end;
15102 btChar, btU8: Result := 256;
15103 else
15104 Result := 0;
15105 end;
15106 end;
15107
TPSSetType.GetByteSizenull15108 function TPSSetType.GetByteSize: Longint;
15109 var
15110 r: Longint;
15111 begin
15112 r := BitSize;
15113 if r mod 8 <> 0 then inc(r, 7);
15114 Result := r div 8;
15115 end;
15116
15117
15118 { TPSBlockInfo }
15119
15120 procedure TPSBlockInfo.Clear;
15121 var
15122 i: Longint;
15123 begin
15124 for i := WithList.Count -1 downto 0 do
15125 begin
15126 TPSValue(WithList[i]).Free;
15127 WithList.Delete(i);
15128 end;
15129 end;
15130
15131 constructor TPSBlockInfo.Create(Owner: TPSBlockInfo);
15132 begin
15133 inherited Create;
15134 FOwner := Owner;
15135 FWithList := TPSList.Create;
15136 if FOwner <> nil then
15137 begin
15138 FProcNo := FOwner.ProcNo;
15139 FProc := FOwner.Proc;
15140 end;
15141 end;
15142
15143 destructor TPSBlockInfo.Destroy;
15144 begin
15145 Clear;
15146 FWithList.Free;
15147 inherited Destroy;
15148 end;
15149
15150 { TPSAttributeTypeField }
15151 procedure TPSAttributeTypeField.SetFieldOrgName(const Value: tbtString);
15152 begin
15153 FFieldOrgName := Value;
15154 FFieldName := FastUpperCase(Value);
15155 FFieldNameHash := MakeHash(FFieldName);
15156 end;
15157
15158 constructor TPSAttributeTypeField.Create(AOwner: TPSAttributeType);
15159 begin
15160 inherited Create;
15161 FOwner := AOwner;
15162 end;
15163
15164 { TPSAttributeType }
15165
GetFieldnull15166 function TPSAttributeType.GetField(I: Longint): TPSAttributeTypeField;
15167 begin
15168 Result := TPSAttributeTypeField(FFields[i]);
15169 end;
15170
TPSAttributeType.GetFieldCountnull15171 function TPSAttributeType.GetFieldCount: Longint;
15172 begin
15173 Result := FFields.Count;
15174 end;
15175
15176 procedure TPSAttributeType.SetName(const s: tbtString);
15177 begin
15178 FOrgname := s;
15179 FName := FastUppercase(s);
15180 FNameHash := MakeHash(FName);
15181 end;
15182
15183 constructor TPSAttributeType.Create;
15184 begin
15185 inherited Create;
15186 FFields := TPSList.Create;
15187 end;
15188
15189 destructor TPSAttributeType.Destroy;
15190 var
15191 i: Longint;
15192 begin
15193 for i := FFields.Count -1 downto 0 do
15194 begin
15195 TPSAttributeTypeField(FFields[i]).Free;
15196 end;
15197 FFields.Free;
15198 inherited Destroy;
15199 end;
15200
AddFieldnull15201 function TPSAttributeType.AddField: TPSAttributeTypeField;
15202 begin
15203 Result := TPSAttributeTypeField.Create(self);
15204 FFields.Add(Result);
15205 end;
15206
15207 procedure TPSAttributeType.DeleteField(I: Longint);
15208 var
15209 Fld: TPSAttributeTypeField;
15210 begin
15211 Fld := FFields[i];
15212 FFields.Delete(i);
15213 Fld.Free;
15214 end;
15215
15216 { TPSAttribute }
TPSAttribute.GetValueCountnull15217 function TPSAttribute.GetValueCount: Longint;
15218 begin
15219 Result := FValues.Count;
15220 end;
15221
TPSAttribute.GetValuenull15222 function TPSAttribute.GetValue(I: Longint): PIfRVariant;
15223 begin
15224 Result := FValues[i];
15225 end;
15226
15227 constructor TPSAttribute.Create(AttribType: TPSAttributeType);
15228 begin
15229 inherited Create;
15230 FValues := TPSList.Create;
15231 FAttribType := AttribType;
15232 end;
15233
15234 procedure TPSAttribute.DeleteValue(i: Longint);
15235 var
15236 Val: PIfRVariant;
15237 begin
15238 Val := FValues[i];
15239 FValues.Delete(i);
15240 DisposeVariant(Val);
15241 end;
15242
AddValuenull15243 function TPSAttribute.AddValue(v: PIFRVariant): Longint;
15244 begin
15245 Result := FValues.Add(v);
15246 end;
15247
15248
15249 destructor TPSAttribute.Destroy;
15250 var
15251 i: Longint;
15252 begin
15253 for i := FValues.Count -1 downto 0 do
15254 begin
15255 DisposeVariant(FValues[i]);
15256 end;
15257 FValues.Free;
15258 inherited Destroy;
15259 end;
15260
15261
15262 procedure TPSAttribute.Assign(Item: TPSAttribute);
15263 var
15264 i: Longint;
15265 p: PIfRVariant;
15266 begin
15267 for i := FValues.Count -1 downto 0 do
15268 begin
15269 DisposeVariant(FValues[i]);
15270 end;
15271 FValues.Clear;
15272 FAttribType := Item.FAttribType;
15273 for i := 0 to Item.FValues.Count -1 do
15274 begin
15275 p := DuplicateVariant(Item.FValues[i]);
15276 FValues.Add(p);
15277 end;
15278 end;
15279
15280 { TPSAttributes }
15281
TPSAttributes.GetCountnull15282 function TPSAttributes.GetCount: Longint;
15283 begin
15284 Result := FItems.Count;
15285 end;
15286
GetItemnull15287 function TPSAttributes.GetItem(I: Longint): TPSAttribute;
15288 begin
15289 Result := TPSAttribute(FItems[i]);
15290 end;
15291
15292 procedure TPSAttributes.Delete(i: Longint);
15293 var
15294 item: TPSAttribute;
15295 begin
15296 item := TPSAttribute(FItems[i]);
15297 FItems.Delete(i);
15298 Item.Free;
15299 end;
15300
Addnull15301 function TPSAttributes.Add(AttribType: TPSAttributeType): TPSAttribute;
15302 begin
15303 Result := TPSAttribute.Create(AttribType);
15304 FItems.Add(Result);
15305 end;
15306
15307 constructor TPSAttributes.Create;
15308 begin
15309 inherited Create;
15310 FItems := TPSList.Create;
15311 end;
15312
15313 destructor TPSAttributes.Destroy;
15314 var
15315 i: Longint;
15316 begin
15317 for i := FItems.Count -1 downto 0 do
15318 begin
15319 TPSAttribute(FItems[i]).Free;
15320 end;
15321 FItems.Free;
15322 inherited Destroy;
15323 end;
15324
15325 procedure TPSAttributes.Assign(attr: TPSAttributes; Move: Boolean);
15326 var
15327 newitem, item: TPSAttribute;
15328 i: Longint;
15329 begin
15330 for i := ATtr.FItems.Count -1 downto 0 do
15331 begin
15332 Item := Attr.Fitems[i];
15333 if Move then
15334 begin
15335 FItems.Add(Item);
15336 Attr.FItems.Delete(i);
15337 end else
15338 begin
15339 newitem := TPSAttribute.Create(Item.FAttribType );
15340 newitem.Assign(item);
15341 FItems.Add(NewItem);
15342 end;
15343 end;
15344
15345 end;
15346
15347
TPSAttributes.FindAttributenull15348 function TPSAttributes.FindAttribute(
15349 const Name: tbtString): TPSAttribute;
15350 var
15351 h, i: Longint;
15352
15353 begin
15354 h := MakeHash(name);
15355 for i := FItems.Count -1 downto 0 do
15356 begin
15357 Result := FItems[i];
15358 if (Result.FAttribType.NameHash = h) and (Result.FAttribType.Name = Name) then
15359 exit;
15360 end;
15361 result := nil;
15362 end;
15363
15364 { TPSParameterDecl }
15365 procedure TPSParameterDecl.SetName(const s: tbtString);
15366 begin
15367 FOrgName := s;
15368 FName := FastUppercase(s);
15369 end;
15370
15371
15372 { TPSParametersDecl }
15373
15374 procedure TPSParametersDecl.Assign(Params: TPSParametersDecl);
15375 var
15376 i: Longint;
15377 np, orgp: TPSParameterDecl;
15378 begin
15379 for i := FParams.Count -1 downto 0 do
15380 begin
15381 TPSParameterDecl(Fparams[i]).Free;
15382 end;
15383 FParams.Clear;
15384 FResult := Params.Result;
15385
15386 for i := 0 to Params.FParams.count -1 do
15387 begin
15388 orgp := Params.FParams[i];
15389 np := AddParam;
15390 np.OrgName := orgp.OrgName;
15391 np.Mode := orgp.Mode;
15392 np.aType := orgp.aType;
15393 np.DeclarePos:=orgp.DeclarePos;
15394 np.DeclareRow:=orgp.DeclareRow;
15395 np.DeclareCol:=orgp.DeclareCol;
15396 end;
15397 end;
15398
15399
GetParamnull15400 function TPSParametersDecl.GetParam(I: Longint): TPSParameterDecl;
15401 begin
15402 Result := FParams[i];
15403 end;
15404
TPSParametersDecl.GetParamCountnull15405 function TPSParametersDecl.GetParamCount: Longint;
15406 begin
15407 Result := FParams.Count;
15408 end;
15409
TPSParametersDecl.AddParamnull15410 function TPSParametersDecl.AddParam: TPSParameterDecl;
15411 begin
15412 Result := TPSParameterDecl.Create;
15413 FParams.Add(Result);
15414 end;
15415
15416 procedure TPSParametersDecl.DeleteParam(I: Longint);
15417 var
15418 param: TPSParameterDecl;
15419 begin
15420 param := FParams[i];
15421 FParams.Delete(i);
15422 Param.Free;
15423 end;
15424
15425 constructor TPSParametersDecl.Create;
15426 begin
15427 inherited Create;
15428 FParams := TPSList.Create;
15429 end;
15430
15431 destructor TPSParametersDecl.Destroy;
15432 var
15433 i: Longint;
15434 begin
15435 for i := FParams.Count -1 downto 0 do
15436 begin
15437 TPSParameterDecl(Fparams[i]).Free;
15438 end;
15439 FParams.Free;
15440 inherited Destroy;
15441 end;
15442
Samenull15443 function TPSParametersDecl.Same(d: TPSParametersDecl): boolean;
15444 var
15445 i: Longint;
15446 begin
15447 if (d = nil) or (d.ParamCount <> ParamCount) or (d.Result <> Self.Result) then
15448 Result := False
15449 else begin
15450 for i := 0 to d.ParamCount -1 do
15451 begin
15452 if (d.Params[i].Mode <> Params[i].Mode) or (d.Params[i].aType <> Params[i].aType) then
15453 begin
15454 Result := False;
15455 exit;
15456 end;
15457 end;
15458 Result := True;
15459 end;
15460 end;
15461
15462 { TPSProceduralType }
15463
15464 constructor TPSProceduralType.Create;
15465 begin
15466 inherited Create;
15467 FProcDef := TPSParametersDecl.Create;
15468
15469 end;
15470
15471 destructor TPSProceduralType.Destroy;
15472 begin
15473 FProcDef.Free;
15474 inherited Destroy;
15475 end;
15476
15477 { TPSDelphiClassItem }
15478
15479 procedure TPSDelphiClassItem.SetName(const s: tbtString);
15480 begin
15481 FOrgName := s;
15482 FName := FastUpperCase(s);
15483 FNameHash := MakeHash(FName);
15484 end;
15485
15486 constructor TPSDelphiClassItem.Create(Owner: TPSCompileTimeClass);
15487 begin
15488 inherited Create;
15489 FOwner := Owner;
15490 FDecl := TPSParametersDecl.Create;
15491 end;
15492
15493 destructor TPSDelphiClassItem.Destroy;
15494 begin
15495 FDecl.Free;
15496 inherited Destroy;
15497 end;
15498
15499 {$IFNDEF PS_NOINTERFACES}
15500 { TPSInterface }
15501
TPSInterface.CastToTypenull15502 function TPSInterface.CastToType(IntoType: TPSType;
15503 var ProcNo: Cardinal): Boolean;
15504 var
15505 P: TPSExternalProcedure;
15506 begin
15507 if (IntoType <> nil) and (IntoType.BaseType <> btInterface) then
15508 begin
15509 Result := False;
15510 exit;
15511 end;
15512 if FCastProc <> InvalidVal then
15513 begin
15514 ProcNo := FCastProc;
15515 Result := True;
15516 exit;
15517 end;
15518 ProcNo := FOwner.AddUsedFunction2(P);
rocHDRnull15519 P.RegProc := FOwner.AddFunction(ProcHDR);
15520 P.RegProc.Name := '';
15521 with P.RegProc.Decl.AddParam do
15522 begin
15523 OrgName := 'Org';
15524 aType := Self.FType;
15525 end;
15526 with P.RegProc.Decl.AddParam do
15527 begin
15528 OrgName := 'TypeNo';
15529 aType := FOwner.at2ut(FOwner.FindBaseType(btU32));
15530 end;
15531 P.RegProc.Decl.Result := FOwner.at2ut(IntoType);
15532
15533 P.RegProc.ImportDecl := 'class:+';
15534 FCastProc := ProcNo;
15535 Result := True;
15536 end;
15537
15538 constructor TPSInterface.Create(Owner: TPSPascalCompiler; InheritedFrom: TPSInterface; Guid: TGuid; const Name: tbtString; aType: TPSType);
15539 begin
15540 inherited Create;
15541 FCastProc := InvalidVal;
15542 FNilProc := InvalidVal;
15543
15544 FType := aType;
15545 FOWner := Owner;
15546 FGuid := GUID;
15547 Self.InheritedFrom := InheritedFrom;
15548
15549 FItems := TPSList.Create;
15550 FName := Name;
15551 FNameHash := MakeHash(Name);
15552 end;
15553
15554 procedure TPSInterface.SetInheritedFrom(p: TPSInterface);
15555 begin
15556 FInheritedFrom := p;
15557 end;
15558
15559 destructor TPSInterface.Destroy;
15560 var
15561 i: Longint;
15562 begin
15563 for i := FItems.Count -1 downto 0 do
15564 begin
15565 TPSInterfaceMethod(FItems[i]).Free;
15566 end;
15567 FItems.Free;
15568 inherited Destroy;
15569 end;
15570
TPSInterface.Func_Callnull15571 function TPSInterface.Func_Call(Index: TPSInterfaceMethod;
15572 var ProcNo: Cardinal): Boolean;
15573 var
15574 c: TPSInterfaceMethod;
15575 P: TPSExternalProcedure;
15576 s: tbtString;
15577 i: Longint;
15578 begin
15579 c := TPSInterfaceMethod(Index);
15580 if c.FScriptProcNo <> InvalidVal then
15581 begin
15582 Procno := c.FScriptProcNo;
15583 Result := True;
15584 exit;
15585 end;
15586 ProcNo := FOwner.AddUsedFunction2(P);
rocHDRnull15587 P.RegProc := FOwner.AddFunction(ProcHDR);
15588 P.RegProc.Name := '';
15589 FOwner.UseProc(C.Decl);
15590 P.RegProc.Decl.Assign(c.Decl);
15591 s := tbtstring('intf:.') + PS_mi2s(c.AbsoluteProcOffset) + tbtchar(ord(c.CC));
15592 if c.Decl.Result = nil then
15593 s := s + #0
15594 else
15595 s := s + #1;
15596 for i := 0 to C.Decl.ParamCount -1 do
15597 begin
15598 if c.Decl.Params[i].Mode <> pmIn then
15599 s := s + #1
15600 else
15601 s := s + #0;
15602 end;
15603 P.RegProc.ImportDecl := s;
15604 C.FScriptProcNo := ProcNo;
15605 Result := True;
15606 end;
15607
TPSInterface.Func_Findnull15608 function TPSInterface.Func_Find(const Name: tbtString;
15609 var Index: TPSInterfaceMethod): Boolean;
15610 var
15611 H: Longint;
15612 I: Longint;
15613 CurrClass: TPSInterface;
15614 C: TPSInterfaceMethod;
15615 begin
15616 H := MakeHash(Name);
15617 CurrClass := Self;
15618 while CurrClass <> nil do
15619 begin
15620 for i := CurrClass.FItems.Count -1 downto 0 do
15621 begin
15622 C := CurrClass.FItems[I];
15623 if (C.NameHash = H) and (C.Name = Name) then
15624 begin
15625 Index := c;
15626 Result := True;
15627 exit;
15628 end;
15629 end;
15630 CurrClass := CurrClass.FInheritedFrom;
15631 end;
15632 Result := False;
15633 end;
15634
TPSInterface.IsCompatibleWithnull15635 function TPSInterface.IsCompatibleWith(aType: TPSType): Boolean;
15636 var
15637 Temp: TPSInterface;
15638 begin
15639 if (atype.BaseType = btClass) then // just support it, we'll see what happens
15640 begin
15641 Result := true;
15642 exit;
15643 end;
15644 if atype.BaseType <> btInterface then
15645 begin
15646 Result := False;
15647 exit;
15648 end;
15649 temp := TPSInterfaceType(atype).FIntf;
15650 while Temp <> nil do
15651 begin
15652 if Temp = Self then
15653 begin
15654 Result := True;
15655 exit;
15656 end;
15657 Temp := Temp.FInheritedFrom;
15658 end;
15659 Result := False;
15660 end;
15661
15662 procedure TPSInterface.RegisterDummyMethod;
15663 begin
15664 FItems.Add(TPSInterfaceMethod.Create(self));
15665 end;
15666
RegisterMethodnull15667 function TPSInterface.RegisterMethod(const Declaration: tbtString;
15668 const cc: TPSCallingConvention): Boolean;
15669 begin
15670 Result := RegisterMethodEx(Declaration, cc, nil);
15671 end;
15672
RegisterMethodExnull15673 function TPSInterface.RegisterMethodEx(const Declaration: tbtString;
15674 const cc: TPSCallingConvention; const CustomParser: TPSPascalParser): Boolean;
15675 var
15676 M: TPSInterfaceMethod;
15677 DOrgName: tbtString;
15678 Func: TPMFuncType;
15679 begin
15680 M := TPSInterfaceMethod.Create(Self);
15681 if not ParseMethodEx(FOwner, '', Declaration, DOrgname, m.Decl, Func, CustomParser) then
15682 begin
15683 FItems.Add(m); // in any case, add a dummy item
15684 Result := False;
15685 exit;
15686 end;
15687 m.FName := FastUppercase(DOrgName);
15688 m.FOrgName := DOrgName;
15689 m.FNameHash := MakeHash(m.FName);
15690 m.FCC := CC;
15691 m.FScriptProcNo := InvalidVal;
15692 FItems.Add(M);
15693 Result := True;
15694 end;
15695
15696
SetNilnull15697 function TPSInterface.SetNil(var ProcNo: Cardinal): Boolean;
15698 var
15699 P: TPSExternalProcedure;
15700
15701 begin
15702 if FNilProc <> InvalidVal then
15703 begin
15704 Procno := FNilProc;
15705 Result := True;
15706 exit;
15707 end;
15708 ProcNo := FOwner.AddUsedFunction2(P);
15709 P.RegProc := FOwner.AddFunction(ProcHDR);
15710 P.RegProc.Name := '';
15711 with p.RegProc.Decl.AddParam do
15712 begin
15713 Mode := pmInOut;
15714 OrgName := 'VarNo';
15715 aType := FOwner.at2ut(Self.FType);
15716 end;
15717 P.RegProc.ImportDecl := 'class:-';
15718 FNilProc := Procno;
15719 Result := True;
15720 end;
15721
15722 { TPSInterfaceMethod }
15723
15724 constructor TPSInterfaceMethod.Create(Owner: TPSInterface);
15725 begin
15726 inherited Create;
15727 FDecl := TPSParametersDecl.Create;
15728 FOwner := Owner;
15729 FOffsetCache := InvalidVal;
15730 end;
15731
GetAbsoluteProcOffsetnull15732 function TPSInterfaceMethod.GetAbsoluteProcOffset: Cardinal;
15733 var
15734 ps: TPSInterface;
15735 begin
15736 if FOffsetCache = InvalidVal then
15737 begin
15738 FOffsetCache := FOwner.FItems.IndexOf(Self);
15739 ps := FOwner.FInheritedFrom;
15740 while ps <> nil do
15741 begin
15742 FOffsetCache := FOffsetCache + ps.FItems.Count;
15743 ps := ps.FInheritedFrom;
15744 end;
15745 end;
15746 result := FOffsetCache;
15747 end;
15748
15749
15750 destructor TPSInterfaceMethod.Destroy;
15751 begin
15752 FDecl.Free;
15753 inherited Destroy;
15754 end;
15755 {$ENDIF}
15756
15757 { TPSVariantType }
15758
GetDynInvokeParamTypenull15759 function TPSVariantType.GetDynInvokeParamType(Owner: TPSPascalCompiler) : TPSType;
15760 begin
15761 Result := Owner.at2ut(FindAndAddType(owner, '!OPENARRAYOFVARIANT', 'array of Variant'));
15762 end;
15763
GetDynInvokeProcNonull15764 function TPSVariantType.GetDynInvokeProcNo(Owner: TPSPascalCompiler; const Name: tbtString;
15765 Params: TPSParameters): Cardinal;
15766 begin
15767 Result := Owner.FindProc('IdispatchInvoke');
15768 end;
15769
GetDynIvokeResulTypenull15770 function TPSVariantType.GetDynIvokeResulType(
15771 Owner: TPSPascalCompiler): TPSType;
15772 begin
15773 Result := Owner.FindType('VARIANT');
15774 end;
15775
GetDynIvokeSelfTypenull15776 function TPSVariantType.GetDynIvokeSelfType(Owner: TPSPascalCompiler): TPSType;
15777 begin
15778 Result := Owner.at2ut(Owner.FindType('IDISPATCH'));
15779 end;
15780
15781
15782 { TPSExternalClass }
SetNilnull15783 function TPSExternalClass.SetNil(var ProcNo: Cardinal): Boolean;
15784 begin
15785 Result := False;
15786 end;
15787
15788 constructor TPSExternalClass.Create(Se: TIFPSPascalCompiler; TypeNo: TPSType);
15789 begin
15790 inherited Create;
15791 Self.SE := se;
15792 Self.FTypeNo := TypeNo;
15793 end;
15794
Func_Callnull15795 function TPSExternalClass.Func_Call(Index: Cardinal;
15796 var ProcNo: Cardinal): Boolean;
15797 begin
15798 Result := False;
15799 end;
15800
Func_Findnull15801 function TPSExternalClass.Func_Find(const Name: tbtString;
15802 var Index: Cardinal): Boolean;
15803 begin
15804 Result := False;
15805 end;
15806
IsCompatibleWithnull15807 function TPSExternalClass.IsCompatibleWith(
15808 Cl: TPSExternalClass): Boolean;
15809 begin
15810 Result := False;
15811 end;
15812
SelfTypenull15813 function TPSExternalClass.SelfType: TPSType;
15814 begin
15815 Result := nil;
15816 end;
15817
CastToTypenull15818 function TPSExternalClass.CastToType(IntoType: TPSType;
15819 var ProcNo: Cardinal): Boolean;
15820 begin
15821 Result := False;
15822 end;
15823
CompareClassnull15824 function TPSExternalClass.CompareClass(OtherTypeNo: TPSType;
15825 var ProcNo: Cardinal): Boolean;
15826 begin
15827 Result := false;
15828 end;
15829
ClassFunc_Findnull15830 function TPSExternalClass.ClassFunc_Find(const Name: tbtString; var Index: Cardinal): Boolean;
15831 begin
15832 result := false;
15833 end;
15834
ClassFunc_Callnull15835 function TPSExternalClass.ClassFunc_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean;
15836 begin
15837 result := false;
15838 end;
15839
15840
15841 { TPSValueProcVal }
15842
15843 destructor TPSValueProcVal.Destroy;
15844 begin
15845 FProcNo.Free;
15846 inherited;
15847 end;
15848
15849
15850 {
15851
15852 Internal error counter: 00020 (increase and then use)
15853
15854 }
15855 end.
15856