1 unit uPSCompiler;
2 {$I PascalScript.inc}
3 interface
4 uses
5 {$IFNDEF DELPHI3UP}{$IFNDEF PS_NOINTERFACES}{$IFNDEF LINUX}Windows, Ole2,{$ENDIF}
6 {$ENDIF}{$ENDIF}SysUtils, uPSUtils;
7
8
9 type
10 {$IFNDEF PS_NOINTERFACES}
11 TPSInterface = class;
12 {$ENDIF}
13
14 TPSParameterMode = (pmIn, pmOut, pmInOut);
15 TPSPascalCompiler = class;
16 TPSType = class;
17 TPSValue = class;
18 TPSParameters = class;
19
20 TPSSubOptType = (tMainBegin, tProcBegin, tSubBegin, tOneLiner, tifOneliner, tRepeat, tTry, tTryEnd
21 {$IFDEF PS_USESSUPPORT},tUnitInit, tUnitFinish {$ENDIF}); //nvds
22
23
24 {TPSExternalClass is used when external classes need to be called}
25 TPSCompileTimeClass = class;
26 TPSAttributes = class;
27 TPSAttribute = class;
28
29 EPSCompilerException = class(Exception) end;
30
31 TPSParameterDecl = class(TObject)
32 private
33 FName: tbtString;
34 FOrgName: tbtString;
35 FMode: TPSParameterMode;
36 FType: TPSType;
37 {$IFDEF PS_USESSUPPORT}
38 FDeclareUnit: tbtString;
39 {$ENDIF}
40 FDeclarePos: Cardinal;
41 FDeclareRow: Cardinal;
42 FDeclareCol: Cardinal;
43 procedure SetName(const s: tbtString);
44 public
45
46 property Name: tbtString read FName;
47
48 property OrgName: tbtString read FOrgName write SetName;
49
50 property aType: TPSType read FType write FType;
51
52 property Mode: TPSParameterMode read FMode write FMode;
53
54 {$IFDEF PS_USESSUPPORT}
55 property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit;
56 {$ENDIF}
57
58 property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
59
60 property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
61
62 property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
63
64 end;
65
66
67 TPSParametersDecl = class(TObject)
68 private
69 FParams: TPSList;
70 FResult: TPSType;
GetParamnull71 function GetParam(I: Longint): TPSParameterDecl;
GetParamCountnull72 function GetParamCount: Longint;
73 public
74
75 property Params[I: Longint]: TPSParameterDecl read GetParam;
76
77 property ParamCount: Longint read GetParamCount;
78
79
AddParamnull80 function AddParam: TPSParameterDecl;
81
82 procedure DeleteParam(I: Longint);
83
84
85 property Result : TPSType read FResult write FResult;
86
87
88 procedure Assign(Params: TPSParametersDecl);
89
90
Samenull91 function Same(d: TPSParametersDecl): boolean;
92
93
94 constructor Create;
95
96 destructor Destroy; override;
97 end;
98
99
100 TPSRegProc = class(TObject)
101 private
102 FNameHash: Longint;
103 FName: tbtString;
104 FDecl: TPSParametersDecl;
105 FExportName: Boolean;
106 FImportDecl: tbtString;
107 FOrgName: tbtString;
108 procedure SetName(const Value: tbtString);
109 public
110
111 property OrgName: tbtString read FOrgName write FOrgName;
112
113 property Name: tbtString read FName write SetName;
114
115 property NameHash: Longint read FNameHash;
116
117 property Decl: TPSParametersDecl read FDecl;
118
119 property ExportName: Boolean read FExportName write FExportName;
120
121 property ImportDecl: tbtString read FImportDecl write FImportDecl;
122
123
124 constructor Create;
125
126 destructor Destroy; override;
127 end;
128
129 PIFPSRegProc = TPSRegProc;
130
131 PIfRVariant = ^TIfRVariant;
132
133 TIfRVariant = record
134
135 FType: TPSType;
136 case Byte of
137 1: (tu8: TbtU8);
138 2: (tS8: TbtS8);
139 3: (tu16: TbtU16);
140 4: (ts16: TbtS16);
141 5: (tu32: TbtU32);
142 6: (ts32: TbtS32);
143 7: (tsingle: TbtSingle);
144 8: (tdouble: TbtDouble);
145 9: (textended: TbtExtended);
146 11: (tcurrency: tbtCurrency);
147 10: (tstring: Pointer);
148 {$IFNDEF PS_NOINT64}
149 17: (ts64: Tbts64);
150 {$ENDIF}
151 19: (tchar: tbtChar);
152 {$IFNDEF PS_NOWIDESTRING}
153 18: (twidestring: Pointer);
154 20: (twidechar: tbtwidechar);
155 {$ENDIF}
156 21: (ttype: TPSType);
157 22: (tunistring: Pointer);
158 end;
159
160 TPSRecordFieldTypeDef = class(TObject)
161 private
162 FFieldOrgName: tbtString;
163 FFieldName: tbtString;
164 FFieldNameHash: Longint;
165 FType: TPSType;
166 procedure SetFieldOrgName(const Value: tbtString);
167 public
168
169 property FieldOrgName: tbtString read FFieldOrgName write SetFieldOrgName;
170
171 property FieldName: tbtString read FFieldName;
172
173 property FieldNameHash: Longint read FFieldNameHash;
174
175 property aType: TPSType read FType write FType;
176 end;
177
178 PIFPSRecordFieldTypeDef = TPSRecordFieldTypeDef;
179
180 TPSType = class(TObject)
181 private
182 FNameHash: Longint;
183 FName: tbtString;
184 FBaseType: TPSBaseType;
185 {$IFDEF PS_USESSUPPORT}
186 FDeclareUnit: tbtString;
187 {$ENDIF}
188 FDeclarePos: Cardinal;
189 FDeclareRow: Cardinal;
190 FDeclareCol: Cardinal;
191 FUsed: Boolean;
192 FExportName: Boolean;
193 FOriginalName: tbtString;
194 FAttributes: TPSAttributes;
195 FFinalTypeNo: cardinal;
196 procedure SetName(const Value: tbtString);
197 public
198
199 constructor Create;
200
201 destructor Destroy; override;
202
203 property Attributes: TPSAttributes read FAttributes;
204
205
206 property FinalTypeNo: cardinal read FFinalTypeNo;
207
208
209 property OriginalName: tbtString read FOriginalName write FOriginalName;
210
211 property Name: tbtString read FName write SetName;
212
213 property NameHash: Longint read FNameHash;
214
215 property BaseType: TPSBaseType read FBaseType write FBaseType;
216
217 {$IFDEF PS_USESSUPPORT}
218 property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit;
219 {$ENDIF}
220
221 property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
222
223 property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
224
225 property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
226
227 property Used: Boolean read FUsed;
228
229 property ExportName: Boolean read FExportName write FExportName;
230
231 procedure Use;
232 end;
233
234
235 PIFPSType = TPSType;
236
237 TPSVariantType = class(TPSType)
238 private
239 public
GetDynInvokeProcNonull240 function GetDynInvokeProcNo(Owner: TPSPascalCompiler; const Name: tbtString; Params: TPSParameters): Cardinal; virtual;
GetDynIvokeSelfTypenull241 function GetDynIvokeSelfType(Owner: TPSPascalCompiler): TPSType; virtual;
GetDynInvokeParamTypenull242 function GetDynInvokeParamType(Owner: TPSPascalCompiler): TPSType; virtual;
GetDynIvokeResulTypenull243 function GetDynIvokeResulType(Owner: TPSPascalCompiler): TPSType; virtual;
244 end;
245
246
247 TPSRecordType = class(TPSType)
248 private
249 FRecordSubVals: TPSList;
250 public
251
252 constructor Create;
253
254 destructor Destroy; override;
255
RecValCountnull256 function RecValCount: Longint;
257
RecValnull258 function RecVal(I: Longint): PIFPSRecordFieldTypeDef;
259
AddRecValnull260 function AddRecVal: PIFPSRecordFieldTypeDef;
261 end;
262
263 TPSClassType = class(TPSType)
264 private
265 FCL: TPSCompiletimeClass;
266 public
267
268 property Cl: TPSCompileTimeClass read FCL write FCL;
269 end;
270 TPSExternalClass = class;
271 TPSUndefinedClassType = class(TPSType)
272 private
273 FExtClass: TPSExternalClass;
274 public
275 property ExtClass: TPSExternalClass read FExtClass write FExtClass;
276 end;
277 {$IFNDEF PS_NOINTERFACES}
278
279 TPSInterfaceType = class(TPSType)
280 private
281 FIntf: TPSInterface;
282 public
283
284 property Intf: TPSInterface read FIntf write FIntf;
285 end;
286 {$ENDIF}
287
288
289 TPSProceduralType = class(TPSType)
290 private
291 FProcDef: TPSParametersDecl;
292 public
293
294 property ProcDef: TPSParametersDecl read FProcDef;
295
296 constructor Create;
297
298 destructor Destroy; override;
299 end;
300
301 TPSArrayType = class(TPSType)
302 private
303 FArrayTypeNo: TPSType;
304 public
305
306 property ArrayTypeNo: TPSType read FArrayTypeNo write FArrayTypeNo;
307 end;
308
309 TPSStaticArrayType = class(TPSArrayType)
310 private
311 FStartOffset: Longint;
312 FLength: Cardinal;
313 public
314
315 property StartOffset: Longint read FStartOffset write FStartOffset;
316
317 property Length: Cardinal read FLength write FLength;
318 end;
319
320 TPSSetType = class(TPSType)
321 private
322 FSetType: TPSType;
GetByteSizenull323 function GetByteSize: Longint;
GetBitSizenull324 function GetBitSize: Longint;
325 public
326
327 property SetType: TPSType read FSetType write FSetType;
328
329 property ByteSize: Longint read GetByteSize;
330
331 property BitSize: Longint read GetBitSize;
332 end;
333
334 TPSTypeLink = class(TPSType)
335 private
336 FLinkTypeNo: TPSType;
337 public
338
339 property LinkTypeNo: TPSType read FLinkTypeNo write FLinkTypeNo;
340 end;
341
342 TPSEnumType = class(TPSType)
343 private
344 FHighValue: Cardinal;
345 public
346
347 property HighValue: Cardinal read FHighValue write FHighValue;
348 end;
349
350
351 TPSProcedure = class(TObject)
352 private
353 FAttributes: TPSAttributes;
354 public
355
356 property Attributes: TPSAttributes read FAttributes;
357
358
359 constructor Create;
360
361 destructor Destroy; override;
362 end;
363
364 TPSAttributeType = class;
365
366 TPSAttributeTypeField = class(TObject)
367 private
368 FOwner: TPSAttributeType;
369 FFieldOrgName: tbtString;
370 FFieldName: tbtString;
371 FFieldNameHash: Longint;
372 FFieldType: TPSType;
373 FHidden: Boolean;
374 procedure SetFieldOrgName(const Value: tbtString);
375 public
376
377 constructor Create(AOwner: TPSAttributeType);
378
379 property Owner: TPSAttributeType read FOwner;
380
381 property FieldOrgName: tbtString read FFieldOrgName write SetFieldOrgName;
382
383 property FieldName: tbtString read FFieldName;
384
385 property FieldNameHash: Longint read FFieldNameHash;
386
387 property FieldType: TPSType read FFieldType write FFieldType;
388
389 property Hidden: Boolean read FHidden write FHidden;
390 end;
391
392 TPSApplyAttributeToType = function (Sender: TPSPascalCompiler; aType: TPSType; Attr: TPSAttribute): Boolean;
393
394 TPSApplyAttributeToProc = function (Sender: TPSPascalCompiler; aProc: TPSProcedure; Attr: TPSAttribute): Boolean;
395 { An attribute type }
396 TPSAttributeType = class(TPSType)
397 private
398 FFields: TPSList;
399 FName: tbtString;
400 FOrgname: tbtString;
401 FNameHash: Longint;
402 FAAProc: TPSApplyAttributeToProc;
403 FAAType: TPSApplyAttributeToType;
GetFieldnull404 function GetField(I: Longint): TPSAttributeTypeField;
GetFieldCountnull405 function GetFieldCount: Longint;
406 procedure SetName(const s: tbtString);
407 public
408
409 property OnApplyAttributeToType: TPSApplyAttributeToType read FAAType write FAAType;
410
411 property OnApplyAttributeToProc: TPSApplyAttributeToProc read FAAProc write FAAProc;
412
413 property Fields[i: Longint]: TPSAttributeTypeField read GetField;
414
415 property FieldCount: Longint read GetFieldCount;
416
417 procedure DeleteField(I: Longint);
418
AddFieldnull419 function AddField: TPSAttributeTypeField;
420
421 property Name: tbtString read FName;
422
423 property OrgName: tbtString read FOrgName write SetName;
424
425 property NameHash: Longint read FNameHash;
426
427 constructor Create;
428
429 destructor Destroy; override;
430 end;
431
432 TPSAttribute = class(TObject)
433 private
434 FAttribType: TPSAttributeType;
435 FValues: TPSList;
GetValueCountnull436 function GetValueCount: Longint;
GetValuenull437 function GetValue(I: Longint): PIfRVariant;
438 public
439
440 constructor Create(AttribType: TPSAttributeType);
441
442 procedure Assign(Item: TPSAttribute);
443
444 property AType: TPSAttributeType read FAttribType;
445
446 property Count: Longint read GetValueCount;
447
448 property Values[i: Longint]: PIfRVariant read GetValue; default;
449
450 procedure DeleteValue(i: Longint);
451
AddValuenull452 function AddValue(v: PIFRVariant): Longint;
453
454 destructor Destroy; override;
455 end;
456
457
458 TPSAttributes = class(TObject)
459 private
460 FItems: TPSList;
GetCountnull461 function GetCount: Longint;
GetItemnull462 function GetItem(I: Longint): TPSAttribute;
463 public
464
465 procedure Assign(attr: TPSAttributes; Move: Boolean);
466
467 property Count: Longint read GetCount;
468
469 property Items[i: Longint]: TPSAttribute read GetItem; default;
470
471 procedure Delete(i: Longint);
472
Addnull473 function Add(AttribType: TPSAttributeType): TPSAttribute;
474
FindAttributenull475 function FindAttribute(const Name: tbtString): TPSAttribute;
476
477 constructor Create;
478
479 destructor Destroy; override;
480 end;
481
482
483 TPSProcVar = class(TObject)
484 private
485 FNameHash: Longint;
486 FName: tbtString;
487 FOrgName: tbtString;
488 FType: TPSType;
489 FUsed: Boolean;
490 {$IFDEF PS_USESSUPPORT}
491 FDeclareUnit: tbtString;
492 {$ENDIF}
493 FDeclarePos, FDeclareRow, FDeclareCol: Cardinal;
494 procedure SetName(const Value: tbtString);
495 public
496
497 property OrgName: tbtString read FOrgName write FOrgname;
498
499 property NameHash: Longint read FNameHash;
500
501 property Name: tbtString read FName write SetName;
502
503 property AType: TPSType read FType write FType;
504
505 property Used: Boolean read FUsed;
506
507 {$IFDEF PS_USESSUPPORT}
508 property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit;
509 {$ENDIF}
510
511 property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
512
513 property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
514
515 property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
516
517 procedure Use;
518 end;
519
520 PIFPSProcVar = TPSProcVar;
521
522 TPSExternalProcedure = class(TPSProcedure)
523 private
524 FRegProc: TPSRegProc;
525 public
526
527 property RegProc: TPSRegProc read FRegProc write FRegProc;
528 end;
529
530
531 TPSInternalProcedure = class(TPSProcedure)
532 private
533 FForwarded: Boolean;
534 FData: tbtString;
535 FNameHash: Longint;
536 FName: tbtString;
537 FDecl: TPSParametersDecl;
538 FProcVars: TPSList;
539 FUsed: Boolean;
540 FOutputDeclPosition: Cardinal;
541 FResultUsed: Boolean;
542 FLabels: TIfStringList;
543 FGotos: TIfStringList;
544 FDeclareRow: Cardinal;
545 {$IFDEF PS_USESSUPPORT}
546 FDeclareUnit: tbtString;
547 {$ENDIF}
548 FDeclarePos: Cardinal;
549 FDeclareCol: Cardinal;
550 FOriginalName: tbtString;
551 procedure SetName(const Value: tbtString);
552 public
553
554 constructor Create;
555
556 destructor Destroy; override;
557 {Attributes}
558
559
560 property Forwarded: Boolean read FForwarded write FForwarded;
561
562 property Data: tbtString read FData write FData;
563
564 property Decl: TPSParametersDecl read FDecl;
565
566 property OriginalName: tbtString read FOriginalName write FOriginalName;
567
568 property Name: tbtString read FName write SetName;
569
570 property NameHash: Longint read FNameHash;
571
572 property ProcVars: TPSList read FProcVars;
573
574 property Used: Boolean read FUsed;
575
576 {$IFDEF PS_USESSUPPORT}
577 property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit;
578 {$ENDIF}
579
580 property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
581
582 property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
583
584 property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
585
586 property OutputDeclPosition: Cardinal read FOutputDeclPosition write FOutputDeclPosition;
587
588 property ResultUsed: Boolean read FResultUsed;
589
590
591 property Labels: TIfStringList read FLabels;
592
593 property Gotos: TIfStringList read FGotos;
594
595 procedure Use;
596
597 procedure ResultUse;
598 end;
599
600 TPSVar = class(TObject)
601 private
602 FNameHash: Longint;
603 FOrgName: tbtString;
604 FName: tbtString;
605 FType: TPSType;
606 FUsed: Boolean;
607 FExportName: tbtString;
608 FDeclareRow: Cardinal;
609 {$IFDEF PS_USESSUPPORT}
610 FDeclareUnit: tbtString;
611 {$ENDIF}
612 FDeclarePos: Cardinal;
613 FDeclareCol: Cardinal;
614 FSaveAsPointer: Boolean;
615 procedure SetName(const Value: tbtString);
616 public
617
618 property SaveAsPointer: Boolean read FSaveAsPointer write FSaveAsPointer;
619
620 property ExportName: tbtString read FExportName write FExportName;
621
622 property Used: Boolean read FUsed;
623
624 property aType: TPSType read FType write FType;
625
626 property OrgName: tbtString read FOrgName write FOrgName;
627
628 property Name: tbtString read FName write SetName;
629
630 property NameHash: Longint read FNameHash;
631
632 {$IFDEF PS_USESSUPPORT}
633 property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit;
634 {$ENDIF}
635
636 property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
637
638 property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
639
640 property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
641
642 procedure Use;
643 end;
644
645 PIFPSVar = TPSVar;
646
647 TPSConstant = class(TObject)
648 private
649
650 FOrgName: tbtString;
651
652 FNameHash: Longint;
653
654 FName: tbtString;
655
656 FDeclareRow: Cardinal;
657 {$IFDEF PS_USESSUPPORT}
658 FDeclareUnit: tbtString;
659 {$ENDIF}
660 FDeclarePos: Cardinal;
661 FDeclareCol: Cardinal;
662
663 FValue: PIfRVariant;
664 procedure SetName(const Value: tbtString);
665 public
666
667 property OrgName: tbtString read FOrgName write FOrgName;
668
669 property Name: tbtString read FName write SetName;
670
671 property NameHash: Longint read FNameHash;
672
673 property Value: PIfRVariant read FValue write FValue;
674
675 {$IFDEF PS_USESSUPPORT}
676 property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit;
677 {$ENDIF}
678
679 property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
680
681 property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
682
683 property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
684
685
686 procedure SetSet(const val);
687
688
689 procedure SetInt(const Val: Longint);
690
691 procedure SetUInt(const Val: Cardinal);
692 {$IFNDEF PS_NOINT64}
693
694 procedure SetInt64(const Val: Int64);
695 {$ENDIF}
696
697 procedure SetString(const Val: tbtString);
698
699 procedure SetChar(c: tbtChar);
700 {$IFNDEF PS_NOWIDESTRING}
701
702 procedure SetWideChar(const val: WideChar);
703
704 procedure SetWideString(const val: tbtwidestring);
705 procedure SetUnicodeString(const val: tbtunicodestring);
706 {$ENDIF}
707
708 procedure SetExtended(const Val: Extended);
709
710
711 destructor Destroy; override;
712 end;
713
714 PIFPSConstant = TPSConstant;
715
716 TPSPascalCompilerErrorType = (
717 ecUnknownIdentifier,
718 ecIdentifierExpected,
719 ecCommentError,
720 ecStringError,
721 ecCharError,
722 ecSyntaxError,
723 ecUnexpectedEndOfFile,
724 ecSemicolonExpected,
725 ecBeginExpected,
726 ecPeriodExpected,
727 ecDuplicateIdentifier,
728 ecColonExpected,
729 ecUnknownType,
730 ecCloseRoundExpected,
731 ecTypeMismatch,
732 ecInternalError,
733 ecAssignmentExpected,
734 ecThenExpected,
735 ecDoExpected,
736 ecNoResult,
737 ecOpenRoundExpected,
738 ecCommaExpected,
739 ecToExpected,
740 ecIsExpected,
741 ecOfExpected,
742 ecCloseBlockExpected,
743 ecVariableExpected,
744 ecStringExpected,
745 ecEndExpected,
746 ecUnSetLabel,
747 ecNotInLoop,
748 ecInvalidJump,
749 ecOpenBlockExpected,
750 ecWriteOnlyProperty,
751 ecReadOnlyProperty,
752 ecClassTypeExpected,
753 ecCustomError,
754 ecDivideByZero,
755 ecMathError,
756 ecUnsatisfiedForward,
757 ecForwardParameterMismatch,
758 ecInvalidnumberOfParameters
759 {$IFDEF PS_USESSUPPORT}
760 , ecNotAllowed,
761 ecUnitNotFoundOrContainsErrors,
762 ecCrossReference
763 {$ENDIF}
764 );
765
766 TPSPascalCompilerHintType = (
767 ehVariableNotUsed,
768 ehFunctionNotUsed,
769 ehCustomHint
770 );
771
772 TPSPascalCompilerWarningType = (
773 ewCalculationAlwaysEvaluatesTo,
774 ewIsNotNeeded,
775 ewAbstractClass,
776 ewCustomWarning
777 );
778
779 TPSPascalCompilerMessage = class(TObject)
780 protected
781
782 FRow: Cardinal;
783
784 FCol: Cardinal;
785
786 FModuleName: tbtString;
787
788 FParam: tbtString;
789
790 FPosition: Cardinal;
791
792 procedure SetParserPos(Parser: TPSPascalParser);
793 public
794
795 property ModuleName: tbtString read FModuleName write FModuleName;
796
797 property Param: tbtString read FParam write FParam;
798
799 property Pos: Cardinal read FPosition write FPosition;
800
801 property Row: Cardinal read FRow write FRow;
802
803 property Col: Cardinal read FCol write FCol;
804
ErrorTypenull805 function ErrorType: tbtString; virtual; abstract;
806
807 procedure SetCustomPos(Pos, Row, Col: Cardinal);
808
MessageToStringnull809 function MessageToString: tbtString; virtual;
810
ShortMessageToStringnull811 function ShortMessageToString: tbtString; virtual; abstract;
812 end;
813
814 TPSPascalCompilerError = class(TPSPascalCompilerMessage)
815 protected
816
817 FError: TPSPascalCompilerErrorType;
818 public
819
820 property Error: TPSPascalCompilerErrorType read FError;
821
ErrorTypenull822 function ErrorType: tbtString; override;
ShortMessageToStringnull823 function ShortMessageToString: tbtString; override;
824 end;
825
826 TPSPascalCompilerHint = class(TPSPascalCompilerMessage)
827 protected
828
829 FHint: TPSPascalCompilerHintType;
830 public
831
832 property Hint: TPSPascalCompilerHintType read FHint;
833
ErrorTypenull834 function ErrorType: tbtString; override;
ShortMessageToStringnull835 function ShortMessageToString: tbtString; override;
836 end;
837
838 TPSPascalCompilerWarning = class(TPSPascalCompilerMessage)
839 protected
840
841 FWarning: TPSPascalCompilerWarningType;
842 public
843
844 property Warning: TPSPascalCompilerWarningType read FWarning;
845
ErrorTypenull846 function ErrorType: tbtString; override;
ShortMessageToStringnull847 function ShortMessageToString: tbtString; override;
848 end;
849 TPSDuplicCheck = set of (dcTypes, dcProcs, dcVars, dcConsts);
850
851 TPSBlockInfo = class(TObject)
852 private
853 FOwner: TPSBlockInfo;
854 FWithList: TPSList;
855 FProcNo: Cardinal;
856 FProc: TPSInternalProcedure;
857 FSubType: TPSSubOptType;
858 public
859
860 property WithList: TPSList read FWithList;
861
862 property ProcNo: Cardinal read FProcNo write FProcNo;
863
864 property Proc: TPSInternalProcedure read FProc write FProc;
865
866 property SubType: TPSSubOptType read FSubType write FSubType;
867
868 procedure Clear;
869
870 constructor Create(Owner: TPSBlockInfo);
871
872 destructor Destroy; override;
873 end;
874
875
876
877 TPSBinOperatorType = (otAdd, otSub, otMul, otDiv, otMod, otShl, otShr, otAnd, otOr, otXor, otAs, otIntDiv,
878 otGreaterEqual, otLessEqual, otGreater, otLess, otEqual,
879 otNotEqual, otIs, otIn);
880
881 TPSUnOperatorType = (otNot, otMinus, otCast);
882
883 TPSOnUseVariable = procedure (Sender: TPSPascalCompiler; VarType: TPSVariableType; VarNo: Longint; ProcNo, Position: Cardinal; const PropData: tbtString);
884
endernull885 TPSOnUses = function(Sender: TPSPascalCompiler; const Name: tbtString): Boolean;
886
endernull887 TPSOnExportCheck = function(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; const ProcDecl: tbtString): Boolean;
888
889 {$IFNDEF PS_USESSUPPORT}
890 TPSOnWriteLineEvent = function (Sender: TPSPascalCompiler; Position: Cardinal): Boolean;
891 {$ELSE}
892 TPSOnWriteLineEvent = function (Sender: TPSPascalCompiler; FileName: tbtString; Position: Cardinal): Boolean;
893 {$ENDIF}
894
895 TPSOnExternalProc = function (Sender: TPSPascalCompiler; Decl: TPSParametersDecl; const Name, FExternal: tbtString): TPSRegProc;
896
897 TPSOnTranslateLineInfoProc = procedure (Sender: TPSPascalCompiler; var Pos, Row, Col: Cardinal; var Name: tbtString);
898 TPSOnNotify = function (Sender: TPSPascalCompiler): Boolean;
899
900 TPSOnFunction = procedure(name: tbtString; Pos, Row, Col: Integer) of object;
901
902
903 TPSPascalCompiler = class
904 protected
905 FAnyString: TPSType;
906 FUnitName: tbtString;
907 FID: Pointer;
908 FOnExportCheck: TPSOnExportCheck;
909 FDefaultBoolType: TPSType;
910 FRegProcs: TPSList;
911 FConstants: TPSList;
912 FProcs: TPSList;
913 FTypes: TPSList;
914 FAttributeTypes: TPSList;
915 FVars: TPSList;
916 FOutput: tbtString;
917 FParser: TPSPascalParser;
918 FParserHadError: Boolean;
919 FMessages: TPSList;
920 FOnUses: TPSOnUses;
921 FUtf8Decode: Boolean;
922 FIsUnit: Boolean;
923 FAllowNoBegin: Boolean;
924 FAllowNoEnd: Boolean;
925 FAllowUnit: Boolean;
926 FAllowDuplicateRegister : Boolean;
927 FBooleanShortCircuit: Boolean;
928 FDebugOutput: tbtString;
929 FOnExternalProc: TPSOnExternalProc;
930 FOnUseVariable: TPSOnUseVariable;
931 FOnBeforeOutput: TPSOnNotify;
932 FOnBeforeCleanup: TPSOnNotify;
933 FOnWriteLine: TPSOnWriteLineEvent;
934 FContinueOffsets, FBreakOffsets: TPSList;
935 FOnTranslateLineInfo: TPSOnTranslateLineInfoProc;
936 FAutoFreeList: TPSList;
937 FClasses: TPSList;
938 FOnFunctionStart: TPSOnFunction;
FOnFunctionEndnull939 FOnFunctionEnd: TPSOnFunction;
940
941
942 FWithCount: Integer;
943 FTryCount: Integer;
944 FExceptFinallyCount: Integer;
945
946
947 {$IFDEF PS_USESSUPPORT}
948 FUnitInits : TPSList; //nvds
949 FUnitFinits: TPSList; //nvds
950 FUses : TPSStringList;
951 fUnits : TPSUnitList;
952 fUnit : TPSUnit;
953 fModule : tbtString;
954 {$ENDIF}
955 fInCompile : Integer;
956 {$IFNDEF PS_NOINTERFACES}
957 FInterfaces: TPSList;
958 {$ENDIF}
959
960 FCurrUsedTypeNo: Cardinal;
961 FGlobalBlock: TPSBlockInfo;
962
IsBooleannull963 function IsBoolean(aType: TPSType): Boolean;
964 {$IFNDEF PS_NOWIDESTRING}
965
GetWideStringnull966 function GetWideString(Src: PIfRVariant; var s: Boolean): tbtwidestring;
GetUnicodeStringnull967 function GetUnicodeString(Src: PIfRVariant; var s: Boolean): tbtunicodestring;
968 {$ENDIF}
PreCalcnull969 function PreCalc(FUseUsedTypes: Boolean; Var1Mod: Byte; var1: PIFRVariant; Var2Mod: Byte;
970 Var2: PIfRVariant; Cmd: TPSBinOperatorType; Pos, Row, Col: Cardinal): Boolean;
971
FindBaseTypenull972 function FindBaseType(BaseType: TPSBaseType): TPSType;
973
IsIntBoolTypenull974 function IsIntBoolType(aType: TPSType): Boolean;
GetTypeCopyLinknull975 function GetTypeCopyLink(p: TPSType): TPSType;
976
at2utnull977 function at2ut(p: TPSType): TPSType;
978 procedure UseProc(procdecl: TPSParametersDecl);
979
980
GetMsgCountnull981 function GetMsgCount: Longint;
982
GetMsgnull983 function GetMsg(l: Longint): TPSPascalCompilerMessage;
984
985
MakeExportDeclnull986 function MakeExportDecl(decl: TPSParametersDecl): tbtString;
987
988
989 procedure DefineStandardTypes;
990
991 procedure DefineStandardProcedures;
992
ReadRealnull993 function ReadReal(const s: tbtString): PIfRVariant;
ReadStringnull994 function ReadString: PIfRVariant;
ReadIntegernull995 function ReadInteger(const s: tbtString): PIfRVariant;
ReadAttributesnull996 function ReadAttributes(Dest: TPSAttributes): Boolean;
ReadConstantnull997 function ReadConstant(FParser: TPSPascalParser; StopOn: TPSPasToken): PIfRVariant;
998
ApplyAttribsToFunctionnull999 function ApplyAttribsToFunction(func: TPSProcedure): boolean;
ProcessFunctionnull1000 function ProcessFunction(AlwaysForward: Boolean; Att: TPSAttributes): Boolean;
ValidateParametersnull1001 function ValidateParameters(BlockInfo: TPSBlockInfo; Params: TPSParameters; ParamTypes: TPSParametersDecl): boolean;
1002
IsVarInCompatiblenull1003 function IsVarInCompatible(ft1, ft2: TPSType): Boolean;
GetTypeNonull1004 function GetTypeNo(BlockInfo: TPSBlockInfo; p: TPSValue): TPSType;
DoVarBlocknull1005 function DoVarBlock(proc: TPSInternalProcedure): Boolean;
DoTypeBlocknull1006 function DoTypeBlock(FParser: TPSPascalParser): Boolean;
ReadTypenull1007 function ReadType(const Name: tbtString; FParser: TPSPascalParser): TPSType;
ProcessLabelnull1008 function ProcessLabel(Proc: TPSInternalProcedure): Boolean;
ProcessSubnull1009 function ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
ProcessLabelForwardsnull1010 function ProcessLabelForwards(Proc: TPSInternalProcedure): Boolean;
1011
1012 procedure WriteDebugData(const s: tbtString);
1013
1014 procedure Debug_SavePosition(ProcNo: Cardinal; Proc: TPSInternalProcedure);
1015
1016 procedure Debug_WriteParams(ProcNo: Cardinal; Proc: TPSInternalProcedure);
1017
1018 procedure Debug_WriteLine(BlockInfo: TPSBlockInfo);
1019
1020
IsCompatibleTypenull1021 function IsCompatibleType(p1, p2: TPSType; Cast: Boolean): Boolean;
1022
IsDuplicatenull1023 function IsDuplicate(const s: tbtString; const check: TPSDuplicCheck): Boolean;
1024 {$IFDEF PS_USESSUPPORT}
IsInLocalUnitListnull1025 function IsInLocalUnitList(s: tbtString): Boolean;
1026 {$ENDIF}
1027
NewProcnull1028 function NewProc(const OriginalName, Name: tbtString): TPSInternalProcedure;
1029
AddUsedFunctionnull1030 function AddUsedFunction(var Proc: TPSInternalProcedure): Cardinal;
1031
AddUsedFunction2null1032 function AddUsedFunction2(var Proc: TPSExternalProcedure): Cardinal;
1033
1034
CheckCompatProcnull1035 function CheckCompatProc(P: TPSType; ProcNo: Cardinal): Boolean;
1036
1037
1038 procedure ParserError(Parser: TObject; Kind: TPSParserErrorKind);
1039
ReadTypeAddProcedurenull1040 function ReadTypeAddProcedure(const Name: tbtString; FParser: TPSPascalParser): TPSType;
1041
VarIsDuplicatenull1042 function VarIsDuplicate(Proc: TPSInternalProcedure; const VarNames, s: tbtString): Boolean;
1043
IsProcDuplicLabelnull1044 function IsProcDuplicLabel(Proc: TPSInternalProcedure; const s: tbtString): Boolean;
1045
1046 procedure CheckForUnusedVars(Func: TPSInternalProcedure);
ProcIsDuplicnull1047 function ProcIsDuplic(Decl: TPSParametersDecl; const FunctionName, FunctionParamNames: tbtString; const s: tbtString; Func: TPSInternalProcedure): Boolean;
1048 public
GetConstantnull1049 function GetConstant(const Name: tbtString): TPSConstant;
1050
UseExternalProcnull1051 function UseExternalProc(const Name: tbtString): TPSParametersDecl;
1052
FindProcnull1053 function FindProc(const aName: tbtString): Cardinal;
1054
GetTypeCountnull1055 function GetTypeCount: Longint;
1056
GetTypenull1057 function GetType(I: Longint): TPSType;
1058
GetVarCountnull1059 function GetVarCount: Longint;
1060
GetVarnull1061 function GetVar(I: Longint): TPSVar;
1062
GetProcCountnull1063 function GetProcCount: Longint;
1064
GetProcnull1065 function GetProc(I: Longint): TPSProcedure;
1066
GetConstCountnull1067 function GetConstCount: Longint;
1068
GetConstnull1069 function GetConst(I: Longint): TPSConstant;
1070
GetRegProcCountnull1071 function GetRegProcCount: Longint;
1072
GetRegProcnull1073 function GetRegProc(I: Longint): TPSRegProc;
1074
AddAttributeTypenull1075 function AddAttributeType: TPSAttributeType;
FindAttributeTypenull1076 function FindAttributeType(const Name: tbtString): TPSAttributeType;
1077
1078 procedure AddToFreeList(Obj: TObject);
1079
1080 property ID: Pointer read FID write FID;
1081
MakeErrornull1082 function MakeError(const Module: tbtString; E: TPSPascalCompilerErrorType; const
1083 Param: tbtString): TPSPascalCompilerMessage;
1084
MakeWarningnull1085 function MakeWarning(const Module: tbtString; E: TPSPascalCompilerWarningType;
1086 const Param: tbtString): TPSPascalCompilerMessage;
1087
MakeHintnull1088 function MakeHint(const Module: tbtString; E: TPSPascalCompilerHintType;
1089 const Param: tbtString): TPSPascalCompilerMessage;
1090
1091 {$IFNDEF PS_NOINTERFACES}
1092
AddInterfacenull1093 function AddInterface(InheritedFrom: TPSInterface; Guid: TGuid; const Name: tbtString): TPSInterface;
1094
FindInterfacenull1095 function FindInterface(const Name: tbtString): TPSInterface;
1096
1097 {$ENDIF}
AddClassnull1098 function AddClass(InheritsFrom: TPSCompileTimeClass; aClass: TClass): TPSCompileTimeClass;
1099
AddClassNnull1100 function AddClassN(InheritsFrom: TPSCompileTimeClass; const aClass: tbtString): TPSCompileTimeClass;
1101
1102
FindClassnull1103 function FindClass(const aClass: tbtString): TPSCompileTimeClass;
1104
AddFunctionnull1105 function AddFunction(const Header: tbtString): TPSRegProc;
1106
AddDelphiFunctionnull1107 function AddDelphiFunction(const Decl: tbtString): TPSRegProc;
1108
AddTypenull1109 function AddType(const Name: tbtString; const BaseType: TPSBaseType): TPSType;
1110
AddTypeSnull1111 function AddTypeS(const Name, Decl: tbtString): TPSType;
1112
AddTypeCopynull1113 function AddTypeCopy(const Name: tbtString; TypeNo: TPSType): TPSType;
1114
AddTypeCopyNnull1115 function AddTypeCopyN(const Name, FType: tbtString): TPSType;
1116
AddConstantnull1117 function AddConstant(const Name: tbtString; FType: TPSType): TPSConstant;
1118
AddConstantNnull1119 function AddConstantN(const Name, FType: tbtString): TPSConstant;
1120
AddVariablenull1121 function AddVariable(const Name: tbtString; FType: TPSType): TPSVar;
1122
AddVariableNnull1123 function AddVariableN(const Name, FType: tbtString): TPSVar;
1124
AddUsedVariablenull1125 function AddUsedVariable(const Name: tbtString; FType: TPSType): TPSVar;
1126
AddUsedVariableNnull1127 function AddUsedVariableN(const Name, FType: tbtString): TPSVar;
1128
AddUsedPtrVariablenull1129 function AddUsedPtrVariable(const Name: tbtString; FType: TPSType): TPSVar;
1130
AddUsedPtrVariableNnull1131 function AddUsedPtrVariableN(const Name, FType: tbtString): TPSVar;
1132
FindTypenull1133 function FindType(const Name: tbtString): TPSType;
1134
MakeDeclnull1135 function MakeDecl(decl: TPSParametersDecl): tbtString;
1136
Compilenull1137 function Compile(const s: tbtString): Boolean;
1138
GetOutputnull1139 function GetOutput(var s: tbtString): Boolean;
1140
GetDebugOutputnull1141 function GetDebugOutput(var s: tbtString): Boolean;
1142
1143 procedure Clear;
1144
1145 constructor Create;
1146
1147 destructor Destroy; override;
1148
1149 property MsgCount: Longint read GetMsgCount;
1150
1151 property Msg[l: Longint]: TPSPascalCompilerMessage read GetMsg;
1152
1153 property OnTranslateLineInfo: TPSOnTranslateLineInfoProc read FOnTranslateLineInfo write FOnTranslateLineInfo;
1154
1155 property OnUses: TPSOnUses read FOnUses write FOnUses;
1156
1157 property OnExportCheck: TPSOnExportCheck read FOnExportCheck write FOnExportCheck;
1158
1159 property OnWriteLine: TPSOnWriteLineEvent read FOnWriteLine write FOnWriteLine;
1160
1161 property OnExternalProc: TPSOnExternalProc read FOnExternalProc write FOnExternalProc;
1162
1163 property OnUseVariable: TPSOnUseVariable read FOnUseVariable write FOnUseVariable;
1164
1165 property OnBeforeOutput: TPSOnNotify read FOnBeforeOutput write FOnBeforeOutput;
1166
1167 property OnBeforeCleanup: TPSOnNotify read FOnBeforeCleanup write FOnBeforeCleanup;
1168
readnull1169 property OnFunctionStart: TPSOnFunction read FOnFunctionStart write FOnFunctionStart;
1170
readnull1171 property OnFunctionEnd: TPSOnFunction read FOnFunctionEnd write FOnFunctionEnd;
1172
1173 property IsUnit: Boolean read FIsUnit;
1174
1175 property AllowNoBegin: Boolean read FAllowNoBegin write FAllowNoBegin;
1176
1177 property AllowUnit: Boolean read FAllowUnit write FAllowUnit;
1178
1179 property AllowNoEnd: Boolean read FAllowNoEnd write FAllowNoEnd;
1180
1181 property AllowDuplicateRegister : Boolean read FAllowDuplicateRegister write FAllowDuplicateRegister;
1182
1183 property BooleanShortCircuit: Boolean read FBooleanShortCircuit write FBooleanShortCircuit;
1184
1185 property UTF8Decode: Boolean read FUtf8Decode write FUtf8Decode;
1186
1187 {$WARNINGS OFF}
1188 property UnitName: tbtString read FUnitName;
1189 {$WARNINGS ON}
1190 end;
1191 TIFPSPascalCompiler = TPSPascalCompiler;
1192
1193 TPSValue = class(TObject)
1194 private
1195 FPos, FRow, FCol: Cardinal;
1196 public
1197
1198 property Pos: Cardinal read FPos write FPos;
1199
1200 property Row: Cardinal read FRow write FRow;
1201
1202 property Col: Cardinal read FCol write FCol;
1203
1204 procedure SetParserPos(P: TPSPascalParser);
1205
1206 end;
1207
1208 TPSParameter = class(TObject)
1209 private
1210 FValue: TPSValue;
1211 FTempVar: TPSValue;
1212 FParamMode: TPSParameterMode;
1213 FExpectedType: TPSType;
1214 public
1215
1216 property Val: TPSValue read FValue write FValue;
1217
1218 property ExpectedType: TPSType read FExpectedType write FExpectedType;
1219
1220 property TempVar: TPSValue read FTempVar write FTempVar;
1221
1222 property ParamMode: TPSParameterMode read FParamMode write FParamMode;
1223
1224 destructor Destroy; override;
1225 end;
1226
1227 TPSParameters = class(TObject)
1228 private
1229 FItems: TPSList;
GetCountnull1230 function GetCount: Cardinal;
GetItemnull1231 function GetItem(I: Longint): TPSParameter;
1232 public
1233
1234 constructor Create;
1235
1236 destructor Destroy; override;
1237
1238 property Count: Cardinal read GetCount;
1239
1240 property Item[I: Longint]: TPSParameter read GetItem; default;
1241
1242 procedure Delete(I: Cardinal);
1243
Addnull1244 function Add: TPSParameter;
1245 end;
1246
1247 TPSSubItem = class(TObject)
1248 private
1249 FType: TPSType;
1250 public
1251
1252 property aType: TPSType read FType write FType;
1253 end;
1254
1255 TPSSubNumber = class(TPSSubItem)
1256 private
1257 FSubNo: Cardinal;
1258 public
1259
1260 property SubNo: Cardinal read FSubNo write FSubNo;
1261 end;
1262
1263 TPSSubValue = class(TPSSubItem)
1264 private
1265 FSubNo: TPSValue;
1266 public
1267
1268 property SubNo: TPSValue read FSubNo write FSubNo;
1269
1270 destructor Destroy; override;
1271 end;
1272
1273 TPSValueVar = class(TPSValue)
1274 private
1275 FRecItems: TPSList;
GetRecCountnull1276 function GetRecCount: Cardinal;
GetRecItemnull1277 function GetRecItem(I: Cardinal): TPSSubItem;
1278 public
1279 constructor Create;
1280 destructor Destroy; override;
1281
RecAddnull1282 function RecAdd(Val: TPSSubItem): Cardinal;
1283
1284 procedure RecDelete(I: Cardinal);
1285
1286 property RecItem[I: Cardinal]: TPSSubItem read GetRecItem;
1287
1288 property RecCount: Cardinal read GetRecCount;
1289 end;
1290
1291 TPSValueGlobalVar = class(TPSValueVar)
1292 private
1293 FAddress: Cardinal;
1294 public
1295
1296 property GlobalVarNo: Cardinal read FAddress write FAddress;
1297 end;
1298
1299
1300 TPSValueLocalVar = class(TPSValueVar)
1301 private
1302 FLocalVarNo: Longint;
1303 public
1304
1305 property LocalVarNo: Longint read FLocalVarNo write FLocalVarNo;
1306 end;
1307
1308 TPSValueParamVar = class(TPSValueVar)
1309 private
1310 FParamNo: Longint;
1311 public
1312
1313 property ParamNo: Longint read FParamNo write FParamNo;
1314 end;
1315
1316 TPSValueAllocatedStackVar = class(TPSValueLocalVar)
1317 private
1318 FProc: TPSInternalProcedure;
1319 public
1320
1321 property Proc: TPSInternalProcedure read FProc write FProc;
1322 destructor Destroy; override;
1323 end;
1324
1325 TPSValueData = class(TPSValue)
1326 private
1327 FData: PIfRVariant;
1328 public
1329
1330 property Data: PIfRVariant read FData write FData;
1331 destructor Destroy; override;
1332 end;
1333
1334 TPSValueReplace = class(TPSValue)
1335 private
1336 FPreWriteAllocated: Boolean;
1337 FFreeOldValue: Boolean;
1338 FFreeNewValue: Boolean;
1339 FOldValue: TPSValue;
1340 FNewValue: TPSValue;
1341 FReplaceTimes: Longint;
1342 public
1343
1344 property OldValue: TPSValue read FOldValue write FOldValue;
1345
1346 property NewValue: TPSValue read FNewValue write FNewValue;
1347 {Should it free the old value when destroyed?}
1348 property FreeOldValue: Boolean read FFreeOldValue write FFreeOldValue;
1349 property FreeNewValue: Boolean read FFreeNewValue write FFreeNewValue;
1350 property PreWriteAllocated: Boolean read FPreWriteAllocated write FPreWriteAllocated;
1351
1352 property ReplaceTimes: Longint read FReplaceTimes write FReplaceTimes;
1353
1354 constructor Create;
1355 destructor Destroy; override;
1356 end;
1357
1358
1359 TPSUnValueOp = class(TPSValue)
1360 private
1361 FVal1: TPSValue;
1362 FOperator: TPSUnOperatorType;
1363 FType: TPSType;
1364 public
1365
1366 property Val1: TPSValue read FVal1 write FVal1;
1367 {The operator}
1368 property Operator: TPSUnOperatorType read FOperator write FOperator;
1369
1370 property aType: TPSType read FType write FType;
1371 destructor Destroy; override;
1372 end;
1373
1374 TPSBinValueOp = class(TPSValue)
1375 private
1376 FVal1,
1377 FVal2: TPSValue;
1378 FOperator: TPSBinOperatorType;
1379 FType: TPSType;
1380 public
1381
1382 property Val1: TPSValue read FVal1 write FVal1;
1383
1384 property Val2: TPSValue read FVal2 write FVal2;
1385 {The operator for this value}
1386 property Operator: TPSBinOperatorType read FOperator write FOperator;
1387
1388 property aType: TPSType read FType write FType;
1389
1390 destructor Destroy; override;
1391 end;
1392
1393 TPSValueNil = class(TPSValue)
1394 end;
1395
1396 TPSValueProcPtr = class(TPSValue)
1397 private
1398 FProcNo: Cardinal;
1399 public
1400
1401 property ProcPtr: Cardinal read FProcNo write FProcNo;
1402 end;
1403
1404 TPSValueProc = class(TPSValue)
1405 private
1406 FSelfPtr: TPSValue;
1407 FParameters: TPSParameters;
1408 FResultType: TPSType;
1409 public
1410 property ResultType: TPSType read FResultType write FResultType;
1411
1412 property SelfPtr: TPSValue read FSelfPtr write FSelfPtr;
1413
1414 property Parameters: TPSParameters read FParameters write FParameters;
1415 destructor Destroy; override;
1416 end;
1417
1418 TPSValueProcNo = class(TPSValueProc)
1419 private
1420 FProcNo: Cardinal;
1421 public
1422
1423 property ProcNo: Cardinal read FProcNo write FProcNo;
1424 end;
1425
1426 TPSValueProcVal = class(TPSValueProc)
1427 private
1428 FProcNo: TPSValue;
1429 public
1430
1431 property ProcNo: TPSValue read FProcNo write FProcNo;
1432
1433 destructor Destroy; override;
1434 end;
1435
1436 TPSValueArray = class(TPSValue)
1437 private
1438 FItems: TPSList;
GetCountnull1439 function GetCount: Cardinal;
GetItemnull1440 function GetItem(I: Cardinal): TPSValue;
1441 public
Addnull1442 function Add(Item: TPSValue): Cardinal;
1443 procedure Delete(I: Cardinal);
1444 property Item[I: Cardinal]: TPSValue read GetItem;
1445 property Count: Cardinal read GetCount;
1446
1447 constructor Create;
1448 destructor Destroy; override;
1449 end;
1450
1451 TPSDelphiClassItem = class;
1452
1453 TPSPropType = (iptRW, iptR, iptW);
1454
1455 TPSCompileTimeClass = class
1456 private
1457 FInheritsFrom: TPSCompileTimeClass;
1458 FClass: TClass;
1459 FClassName: tbtString;
1460 FClassNameHash: Longint;
1461 FClassItems: TPSList;
1462 FDefaultProperty: Cardinal;
1463 FIsAbstract: Boolean;
1464 FCastProc,
1465 FNilProc: Cardinal;
1466 FType: TPSType;
1467
1468 FOwner: TPSPascalCompiler;
GetCountnull1469 function GetCount: Longint;
GetItemnull1470 function GetItem(i: Longint): TPSDelphiClassItem;
1471 public
1472
1473 property aType: TPSType read FType;
1474
1475 property Items[i: Longint]: TPSDelphiClassItem read GetItem;
1476
1477 property Count: Longint read GetCount;
1478
1479 property IsAbstract: Boolean read FIsAbstract write FIsAbstract;
1480
1481
1482 property ClassInheritsFrom: TPSCompileTimeClass read FInheritsFrom write FInheritsFrom;
1483
RegisterMethodnull1484 function RegisterMethod(const Decl: tbtString): Boolean;
1485
1486 procedure RegisterProperty(const PropertyName, PropertyType: tbtString; PropAC: TPSPropType);
1487
1488 procedure RegisterPublishedProperties;
1489
RegisterPublishedPropertynull1490 function RegisterPublishedProperty(const Name: tbtString): Boolean;
1491
1492 procedure SetDefaultPropery(const Name: tbtString);
1493
1494 constructor Create(ClassName: tbtString; aOwner: TPSPascalCompiler; aType: TPSType);
1495
CreateCnull1496 class function CreateC(FClass: TClass; aOwner: TPSPascalCompiler; aType: TPSType): TPSCompileTimeClass;
1497
1498
1499 destructor Destroy; override;
1500
1501
IsCompatibleWithnull1502 function IsCompatibleWith(aType: TPSType): Boolean;
1503
SetNilnull1504 function SetNil(var ProcNo: Cardinal): Boolean;
1505
CastToTypenull1506 function CastToType(IntoType: TPSType; var ProcNo: Cardinal): Boolean;
1507
1508
Property_Findnull1509 function Property_Find(const Name: tbtString; var Index: TPSDelphiClassItem): Boolean;
1510
Property_Getnull1511 function Property_Get(Index: TPSDelphiClassItem; var ProcNo: Cardinal): Boolean;
1512
Property_Setnull1513 function Property_Set(Index: TPSDelphiClassItem; var ProcNo: Cardinal): Boolean;
1514
Property_GetHeadernull1515 function Property_GetHeader(Index: TPSDelphiClassItem; Dest: TPSParametersDecl): Boolean;
1516
1517
Func_Findnull1518 function Func_Find(const Name: tbtString; var Index: TPSDelphiClassItem): Boolean;
1519
Func_Callnull1520 function Func_Call(Index: TPSDelphiClassItem; var ProcNo: Cardinal): Boolean;
1521
1522
ClassFunc_Findnull1523 function ClassFunc_Find(const Name: tbtString; var Index: IPointer): Boolean;
1524
ClassFunc_Callnull1525 function ClassFunc_Call(Index: IPointer; var ProcNo: Cardinal): Boolean;
1526 end;
1527
1528 TPSDelphiClassItem = class(TObject)
1529 private
1530 FOwner: TPSCompileTimeClass;
1531 FOrgName: tbtString;
1532 FName: tbtString;
1533 FNameHash: Longint;
1534 FDecl: TPSParametersDecl;
1535 procedure SetName(const s: tbtString);
1536 public
1537
1538 constructor Create(Owner: TPSCompileTimeClass);
1539
1540 destructor Destroy; override;
1541
1542 property Decl: TPSParametersDecl read FDecl;
1543
1544 property Name: tbtString read FName;
1545
1546 property OrgName: tbtString read FOrgName write SetName;
1547
1548 property NameHash: Longint read FNameHash;
1549
1550 property Owner: TPSCompileTimeClass read FOwner;
1551 end;
1552
1553 TPSDelphiClassItemMethod = class(TPSDelphiClassItem)
1554 private
1555 FMethodNo: Cardinal;
1556 public
1557
1558 property MethodNo: Cardinal read FMethodNo write FMethodNo;
1559 end;
1560
1561 TPSDelphiClassItemProperty = class(TPSDelphiClassItem)
1562 private
1563 FReadProcNo: Cardinal;
1564 FWriteProcNo: Cardinal;
1565 FAccessType: TPSPropType;
1566 public
1567
1568 property AccessType: TPSPropType read FAccessType write FAccessType;
1569
1570 property ReadProcNo: Cardinal read FReadProcNo write FReadProcNo;
1571
1572 property WriteProcNo: Cardinal read FWriteProcNo write FWriteProcNo;
1573 end;
1574
1575
1576 TPSDelphiClassItemConstructor = class(TPSDelphiClassItemMethod)
1577 end;
1578
1579 {$IFNDEF PS_NOINTERFACES}
1580
1581 TPSInterfaceMethod = class;
1582
1583 TPSInterface = class(TObject)
1584 private
1585 FOwner: TPSPascalCompiler;
1586 FType: TPSType;
1587 FInheritedFrom: TPSInterface;
1588 FGuid: TGuid;
1589 FCastProc,
1590 FNilProc: Cardinal;
1591 FItems: TPSList;
1592 FName: tbtString;
1593 FNameHash: Longint;
1594 procedure SetInheritedFrom(p: TPSInterface);
1595 public
1596
1597 constructor Create(Owner: TPSPascalCompiler; InheritedFrom: TPSInterface; Guid: TGuid; const Name: tbtString; aType: TPSType);
1598
1599 destructor Destroy; override;
1600
1601 property aType: TPSType read FType;
1602
1603 property InheritedFrom: TPSInterface read FInheritedFrom write SetInheritedFrom;
1604
1605 property Guid: TGuid read FGuid write FGuid;
1606
1607 property Name: tbtString read FName write FName;
1608
1609 property NameHash: Longint read FNameHash;
1610
1611
RegisterMethodnull1612 function RegisterMethod(const Declaration: tbtString; const cc: TPSCallingConvention): Boolean;
1613
RegisterMethodExnull1614 function RegisterMethodEx(const Declaration: tbtString; const cc: TPSCallingConvention; const CustomParser: TPSPascalParser): Boolean;
1615
1616 procedure RegisterDummyMethod;
1617
IsCompatibleWithnull1618 function IsCompatibleWith(aType: TPSType): Boolean;
1619
SetNilnull1620 function SetNil(var ProcNo: Cardinal): Boolean;
1621
CastToTypenull1622 function CastToType(IntoType: TPSType; var ProcNo: Cardinal): Boolean;
1623
Func_Findnull1624 function Func_Find(const Name: tbtString; var Index: TPSInterfaceMethod): Boolean;
1625
Func_Callnull1626 function Func_Call(Index: TPSInterfaceMethod; var ProcNo: Cardinal): Boolean;
1627 end;
1628
1629
1630 TPSInterfaceMethod = class(TObject)
1631 private
1632 FName: tbtString;
1633 FDecl: TPSParametersDecl;
1634 FNameHash: Longint;
1635 FCC: TPSCallingConvention;
1636 FScriptProcNo: Cardinal;
1637 FOrgName: tbtString;
1638 FOwner: TPSInterface;
1639 FOffsetCache: Cardinal;
GetAbsoluteProcOffsetnull1640 function GetAbsoluteProcOffset: Cardinal;
1641 public
1642
1643 property AbsoluteProcOffset: Cardinal read GetAbsoluteProcOffset;
1644
1645 property ScriptProcNo: Cardinal read FScriptProcNo;
1646
1647 property OrgName: tbtString read FOrgName;
1648
1649 property Name: tbtString read FName;
1650
1651 property NameHash: Longint read FNameHash;
1652
1653 property Decl: TPSParametersDecl read FDecl;
1654
1655 property CC: TPSCallingConvention read FCC;
1656
1657
1658 constructor Create(Owner: TPSInterface);
1659
1660 destructor Destroy; override;
1661 end;
1662 {$ENDIF}
1663
1664
1665 TPSExternalClass = class(TObject)
1666 protected
1667
1668 SE: TPSPascalCompiler;
1669
1670 FTypeNo: TPSType;
1671 public
1672
SelfTypenull1673 function SelfType: TPSType; virtual;
1674
1675 constructor Create(Se: TPSPascalCompiler; TypeNo: TPSType);
1676
ClassFunc_Findnull1677 function ClassFunc_Find(const Name: tbtString; var Index: Cardinal): Boolean; virtual;
1678
ClassFunc_Callnull1679 function ClassFunc_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
1680
Func_Findnull1681 function Func_Find(const Name: tbtString; var Index: Cardinal): Boolean; virtual;
1682
Func_Callnull1683 function Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
1684
IsCompatibleWithnull1685 function IsCompatibleWith(Cl: TPSExternalClass): Boolean; virtual;
1686
SetNilnull1687 function SetNil(var ProcNo: Cardinal): Boolean; virtual;
1688
CastToTypenull1689 function CastToType(IntoType: TPSType; var ProcNo: Cardinal): Boolean; virtual;
1690
CompareClassnull1691 function CompareClass(OtherTypeNo: TPSType; var ProcNo: Cardinal): Boolean; virtual;
1692 end;
1693
1694
ExportChecknull1695 function ExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure;
1696 Types: array of TPSBaseType; Modes: array of TPSParameterMode): Boolean;
1697
1698
1699 procedure SetVarExportName(P: TPSVar; const ExpName: tbtString);
1700
AddImportedClassVariablenull1701 function AddImportedClassVariable(Sender: TPSPascalCompiler; const VarName, VarType: tbtString): Boolean;
1702
1703 const
1704 {Invalid value, this is returned by most functions of pascal script that return a cardinal, when they fail}
1705 InvalidVal = Cardinal(-1);
1706
1707 type
1708 TIFPSCompileTimeClass = TPSCompileTimeClass;
1709 TIFPSInternalProcedure = TPSInternalProcedure;
1710 TIFPSPascalCompilerError = TPSPascalCompilerError;
1711
1712 TPMFuncType = (mftProc
1713 , mftConstructor
1714 );
1715
1716
PS_mi2snull1717 function PS_mi2s(i: Cardinal): tbtString;
1718
ParseMethodnull1719 function ParseMethod(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType): Boolean;
ParseMethodExnull1720 function ParseMethodEx(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType; CustomParser: TPSPascalParser): Boolean;
1721
DeclToBitsnull1722 function DeclToBits(const Decl: TPSParametersDecl): tbtString;
1723
NewVariantnull1724 function NewVariant(FType: TPSType): PIfRVariant;
1725 procedure DisposeVariant(p: PIfRVariant);
1726
1727 implementation
1728
1729 uses {$IFDEF DELPHI5}ComObj, {$ENDIF}{$IFDEF PS_FPC_HAS_COM}ComObj, {$ENDIF}Classes, typInfo;
1730
1731 {$IFDEF DELPHI3UP}
1732 resourceString
1733 {$ELSE}
1734 const
1735 {$ENDIF}
1736
1737 RPS_OnUseEventOnly = 'This function can only be called from within the OnUses event';
1738 RPS_UnableToRegisterFunction = 'Unable to register function %s';
1739 RPS_UnableToRegisterConst = 'Unable to register constant %s';
1740 RPS_InvalidTypeForVar = 'Invalid type for variable %s';
1741 RPS_InvalidType = 'Invalid Type';
1742 RPS_UnableToRegisterType = 'Unable to register type %s';
1743 RPS_UnknownInterface = 'Unknown interface: %s';
1744 RPS_ConstantValueMismatch = 'Constant Value Type Mismatch';
1745 RPS_ConstantValueNotAssigned = 'Constant Value is not assigned';
1746
1747 RPS_Error = 'Error';
1748 RPS_UnknownIdentifier = 'Unknown identifier ''%s''';
1749 RPS_IdentifierExpected = 'Identifier expected';
1750 RPS_CommentError = 'Comment error';
1751 RPS_StringError = 'String error';
1752 RPS_CharError = 'Char error';
1753 RPS_SyntaxError = 'Syntax error';
1754 RPS_EOF = 'Unexpected end of file';
1755 RPS_SemiColonExpected = 'Semicolon ('';'') expected';
1756 RPS_BeginExpected = '''BEGIN'' expected';
1757 RPS_PeriodExpected = 'period (''.'') expected';
1758 RPS_DuplicateIdent = 'Duplicate identifier ''%s''';
1759 RPS_ColonExpected = 'colon ('':'') expected';
1760 RPS_UnknownType = 'Unknown type ''%s''';
1761 RPS_CloseRoundExpected = 'Closing parenthesis expected';
1762 RPS_TypeMismatch = 'Type mismatch';
1763 RPS_InternalError = 'Internal error (%s)';
1764 RPS_AssignmentExpected = 'Assignment expected';
1765 RPS_ThenExpected = '''THEN'' expected';
1766 RPS_DoExpected = '''DO'' expected';
1767 RPS_NoResult = 'No result';
1768 RPS_OpenRoundExpected = 'opening parenthesis (''('')expected';
1769 RPS_CommaExpected = 'comma ('','') expected';
1770 RPS_ToExpected = '''TO'' expected';
1771 RPS_IsExpected = 'is (''='') expected';
1772 RPS_OfExpected = '''OF'' expected';
1773 RPS_CloseBlockExpected = 'Closing square bracket ('']'') expected';
1774 RPS_VariableExpected = 'Variable Expected';
1775 RPS_StringExpected = 'String Expected';
1776 RPS_EndExpected = '''END'' expected';
1777 RPS_UnSetLabel = 'Label ''%s'' not set';
1778 RPS_NotInLoop = 'Not in a loop';
1779 RPS_InvalidJump = 'Invalid jump';
1780 RPS_OpenBlockExpected = 'Opening square brackets (''['') expected';
1781 RPS_WriteOnlyProperty = 'Write-only property';
1782 RPS_ReadOnlyProperty = 'Read-only property';
1783 RPS_ClassTypeExpected = 'Class type expected';
1784 RPS_DivideByZero = 'Divide by Zero';
1785 RPS_MathError = 'Math Error';
1786 RPS_UnsatisfiedForward = 'Unsatisfied Forward %s';
1787 RPS_ForwardParameterMismatch = 'Forward Parameter Mismatch';
1788 RPS_InvalidNumberOfParameter = 'Invalid number of parameters';
1789 RPS_UnknownError = 'Unknown error';
1790 {$IFDEF PS_USESSUPPORT}
1791 RPS_NotAllowed = '%s is not allowed at this position';
1792 RPS_UnitNotFound = 'Unit ''%s'' not found or contains errors';
1793 RPS_CrossReference = 'Cross-Reference error of ''%s''';
1794 {$ENDIF}
1795
1796
1797 RPS_Hint = 'Hint';
1798 RPS_VariableNotUsed = 'Variable ''%s'' never used';
1799 RPS_FunctionNotUsed = 'Function ''%s'' never used';
1800 RPS_UnknownHint = 'Unknown hint';
1801
1802
1803 RPS_Warning = 'Warning';
1804 RPS_CalculationAlwaysEvaluatesTo = 'Calculation always evaluates to %s';
1805 RPS_IsNotNeeded = '%s is not needed';
1806 RPS_AbstractClass = 'Abstract Class Construction';
1807 RPS_UnknownWarning = 'Unknown warning';
1808
1809 {$IFDEF DEBUG }
1810 RPS_UnableToRegister = 'Unable to register %s';
1811 {$ENDIF}
1812
1813 RPS_NotArrayProperty = 'Not an array property : ''%s''';
1814 RPS_NotProperty = 'Not a property : ''%s''';
1815 RPS_UnknownProperty = 'Unknown Property : ''%s''';
1816
DeclToBitsnull1817 function DeclToBits(const Decl: TPSParametersDecl): tbtString;
1818 var
1819 i: longint;
1820 begin
1821 Result := '';
1822 if Decl.Result = nil then
1823 begin
1824 Result := Result + #0;
1825 end else
1826 Result := Result + #1;
1827 for i := 0 to Decl.ParamCount -1 do
1828 begin
1829 if Decl.Params[i].Mode <> pmIn then
1830 Result := Result + #1
1831 else
1832 Result := Result + #0;
1833 end;
1834 end;
1835
1836
1837 procedure BlockWriteByte(BlockInfo: TPSBlockInfo; b: Byte);
1838 begin
1839 BlockInfo.Proc.Data := BlockInfo.Proc.Data + tbtChar(b);
1840 end;
1841
1842 procedure BlockWriteData(BlockInfo: TPSBlockInfo; const Data; Len: Longint);
1843 begin
1844 SetLength(BlockInfo.Proc.FData, Length(BlockInfo.Proc.FData) + Len);
1845 Move(Data, BlockInfo.Proc.FData[Length(BlockInfo.Proc.FData) - Len + 1], Len);
1846 end;
1847
1848 procedure BlockWriteLong(BlockInfo: TPSBlockInfo; l: Cardinal);
1849 begin
1850 BlockWriteData(BlockInfo, l, 4);
1851 end;
1852
1853 procedure BlockWriteVariant(BlockInfo: TPSBlockInfo; p: PIfRVariant);
1854 var
1855 du8: tbtu8;
1856 du16: tbtu16;
1857 begin
1858 BlockWriteLong(BlockInfo, p^.FType.FinalTypeNo);
1859 case p.FType.BaseType of
1860 btType: BlockWriteData(BlockInfo, p^.ttype.FinalTypeno, 4);
1861 {$IFNDEF PS_NOWIDESTRING}
1862 btWideString:
1863 begin
1864 BlockWriteLong(BlockInfo, Length(tbtWideString(p^.twidestring)));
1865 BlockWriteData(BlockInfo, tbtwidestring(p^.twidestring)[1], 2*Length(tbtWideString(p^.twidestring)));
1866 end;
1867 btUnicodeString:
1868 begin
1869 BlockWriteLong(BlockInfo, Length(tbtUnicodeString(p^.twidestring)));
1870 BlockWriteData(BlockInfo, tbtUnicodeString(p^.twidestring)[1], 2*Length(tbtUnicodeString(p^.twidestring)));
1871 end;
1872 btWideChar: BlockWriteData(BlockInfo, p^.twidechar, 2);
1873 {$ENDIF}
1874 btSingle: BlockWriteData(BlockInfo, p^.tsingle, sizeof(tbtSingle));
1875 btDouble: BlockWriteData(BlockInfo, p^.tdouble, sizeof(tbtDouble));
1876 btExtended: BlockWriteData(BlockInfo, p^.textended, sizeof(tbtExtended));
1877 btCurrency: BlockWriteData(BlockInfo, p^.tcurrency, sizeof(tbtCurrency));
1878 btChar: BlockWriteData(BlockInfo, p^.tchar, 1);
1879 btSet:
1880 begin
1881 BlockWriteData(BlockInfo, tbtString(p^.tstring)[1], Length(tbtString(p^.tstring)));
1882 end;
1883 btString:
1884 begin
1885 BlockWriteLong(BlockInfo, Length(tbtString(p^.tstring)));
1886 BlockWriteData(BlockInfo, tbtString(p^.tstring)[1], Length(tbtString(p^.tstring)));
1887 end;
1888 btenum:
1889 begin
1890 if TPSEnumType(p^.FType).HighValue <=256 then
1891 begin
1892 du8 := tbtu8(p^.tu32);
1893 BlockWriteData(BlockInfo, du8, 1)
1894 end
1895 else if TPSEnumType(p^.FType).HighValue <=65536 then
1896 begin
1897 du16 := tbtu16(p^.tu32);
1898 BlockWriteData(BlockInfo, du16, 2)
1899 end;
1900 end;
1901
1902 bts8,btu8: BlockWriteData(BlockInfo, p^.tu8, 1);
1903 bts16,btu16: BlockWriteData(BlockInfo, p^.tu16, 2);
1904 bts32,btu32: BlockWriteData(BlockInfo, p^.tu32, 4);
1905 {$IFNDEF PS_NOINT64}
1906 bts64: BlockWriteData(BlockInfo, p^.ts64, 8);
1907 {$ENDIF}
1908 btProcPtr: BlockWriteData(BlockInfo, p^.tu32, 4);
1909 {$IFDEF DEBUG}
1910 {$IFNDEF FPC}
1911 else
1912 asm int 3; end;
1913 {$ENDIF}
1914 {$ENDIF}
1915 end;
1916 end;
1917
1918
1919
ExportChecknull1920 function ExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; Types: array of TPSBaseType; Modes: array of TPSParameterMode): Boolean;
1921 var
1922 i: Longint;
1923 ttype: TPSType;
1924 begin
1925 if High(Types) <> High(Modes)+1 then
1926 begin
1927 Result := False;
1928 exit;
1929 end;
1930 if High(Types) <> Proc.Decl.ParamCount then
1931 begin
1932 Result := False;
1933 exit;
1934 end;
1935 TType := Proc.Decl.Result;
1936 if TType = nil then
1937 begin
1938 if Types[0] <> btReturnAddress then
1939 begin
1940 Result := False;
1941 exit;
1942 end;
1943 end else
1944 begin
1945 if TType.BaseType <> Types[0] then
1946 begin
1947 Result := False;
1948 exit;
1949 end;
1950 end;
1951 for i := 0 to High(Modes) do
1952 begin
1953 TType := Proc.Decl.Params[i].aType;
1954 if Modes[i] <> Proc.Decl.Params[i].Mode then
1955 begin
1956 Result := False;
1957 exit;
1958 end;
1959 if TType.BaseType <> Types[i+1] then
1960 begin
1961 Result := False;
1962 exit;
1963 end;
1964 end;
1965 Result := True;
1966 end;
1967
1968 procedure SetVarExportName(P: TPSVar; const ExpName: tbtString);
1969 begin
1970 if p <> nil then
1971 p.exportname := ExpName;
1972 end;
1973
FindAndAddTypenull1974 function FindAndAddType(Owner: TPSPascalCompiler; const Name, Decl: tbtString): TPSType;
1975 var
1976 tt: TPSType;
1977 begin
1978 Result := Owner.FindType(Name);
1979 if Result = nil then
1980 begin
1981 tt := Owner.AddTypeS(Name, Decl);
1982 Result := tt;
1983 end;
1984 end;
1985
ParseMethodnull1986 function ParseMethod(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType): Boolean;
1987 begin
1988 Result := ParseMethodEx(Owner, FClassName, Decl, OrgName, DestDecl, Func, nil);
1989 end;
1990
ParseMethodExnull1991 function ParseMethodEx(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType; CustomParser: TPSPascalParser): Boolean;
1992 var
1993 Parser: TPSPascalParser;
1994 FuncType: Byte;
1995 VNames: tbtString;
1996 modifier: TPSParameterMode;
1997 VCType: TPSType;
1998 ERow, EPos, ECol: Integer;
1999
2000 begin
2001 if CustomParser = nil then begin
2002 Parser := TPSPascalParser.Create;
2003 Parser.SetText(Decl);
2004 end else
2005 Parser := CustomParser;
thennull2006 if Parser.CurrTokenId = CSTII_Function then
2007 FuncType:= 0
2008 else if Parser.CurrTokenId = CSTII_Procedure then
2009 FuncType := 1
2010 else if (Parser.CurrTokenId = CSTII_Constructor) and (FClassName <> '') then
2011 FuncType := 2
2012 else
2013 begin
2014 if Parser <> CustomParser then
2015 Parser.Free;
2016 Result := False;
2017 exit;
2018 end;
2019 Parser.Next;
2020 if Parser.CurrTokenId <> CSTI_Identifier then
2021 begin
2022 if Parser <> CustomParser then
2023 Parser.Free
2024 else
2025 Owner.MakeError('', ecIdentifierExpected, '');
2026 Result := False;
2027 exit;
2028 end; {if}
2029 OrgName := Parser.OriginalToken;
2030 Parser.Next;
2031 if Parser.CurrTokenId = CSTI_OpenRound then
2032 begin
2033 Parser.Next;
2034 if Parser.CurrTokenId <> CSTI_CloseRound then
2035 begin
2036 while True do
2037 begin
2038 if Parser.CurrTokenId = CSTII_Const then
2039 begin
2040 modifier := pmIn;
2041 Parser.Next;
2042 end
2043 else
2044 if Parser.CurrTokenId = CSTII_Var then
2045 begin
2046 modifier := pmInOut;
2047 Parser.Next;
2048 end
2049 else
2050 if Parser.CurrTokenId = CSTII_Out then
2051 begin
2052 modifier := pmOut;
2053 Parser.Next;
2054 end
2055 else
2056 modifier := pmIn;
2057 if Parser.CurrTokenId <> CSTI_Identifier then
2058 begin
2059 if Parser <> CustomParser then
2060 Parser.Free
2061 else
2062 Owner.MakeError('', ecIdentifierExpected, '');
2063 Result := False;
2064 exit;
2065 end;
2066 EPos:=Parser.CurrTokenPos;
2067 ERow:=Parser.Row;
2068 ECol:=Parser.Col;
2069
2070 VNames := Parser.OriginalToken + '|';
2071 Parser.Next;
2072 while Parser.CurrTokenId = CSTI_Comma do
2073 begin
2074 Parser.Next;
2075 if Parser.CurrTokenId <> CSTI_Identifier then
2076 begin
2077 if Parser <> CustomParser then
2078 Parser.Free
2079 else
2080 Owner.MakeError('', ecIdentifierExpected, '');
2081 Result := False;
2082 exit;
2083 end;
2084 VNames := VNames + Parser.OriginalToken + '|';
2085 Parser.Next;
2086 end;
2087 if Parser.CurrTokenId <> CSTI_Colon then
2088 begin
2089 if Parser <> CustomParser then
2090 Parser.Free
2091 else
2092 Owner.MakeError('', ecColonExpected, '');
2093 Result := False;
2094 exit;
2095 end;
2096 Parser.Next;
2097 if Parser.CurrTokenID = CSTII_Array then
2098 begin
2099 Parser.nExt;
2100 if Parser.CurrTokenId <> CSTII_Of then
2101 begin
2102 if Parser <> CustomParser then
2103 Parser.Free
2104 else
2105 Owner.MakeError('', ecOfExpected, '');
2106 Result := False;
2107 exit;
2108 end;
2109 Parser.Next;
2110 if Parser.CurrTokenId = CSTII_Const then
2111 begin
2112 VCType := FindAndAddType(Owner, '!OPENARRAYOFCONST', 'array of ___Pointer')
2113 end
2114 else begin
2115 VCType := Owner.GetTypeCopyLink(Owner.FindType(Parser.GetToken));
2116 if VCType = nil then
2117 begin
2118 if Parser <> CustomParser then
2119 Parser.Free
2120 else
2121 Owner.MakeError('', ecUnknownType, Parser.GetToken);
2122 Result := False;
2123 exit;
2124 end;
2125 case VCType.BaseType of
2126 btU8: VCType := FindAndAddType(Owner, '!OPENARRAYOFU8', 'array of Byte');
2127 btS8: VCType := FindAndAddType(Owner, '!OPENARRAYOFS8', 'array of ShortInt');
2128 btU16: VCType := FindAndAddType(Owner, '!OPENARRAYOFU16', 'array of SmallInt');
2129 btS16: VCType := FindAndAddType(Owner, '!OPENARRAYOFS16', 'array of Word');
2130 btU32: VCType := FindAndAddType(Owner, '!OPENARRAYOFU32', 'array of Cardinal');
2131 btS32: VCType := FindAndAddType(Owner, '!OPENARRAYOFS32', 'array of LongInt');
2132 btSingle: VCType := FindAndAddType(Owner, '!OPENARRAYOFSINGLE', 'array of Single');
2133 btDouble: VCType := FindAndAddType(Owner, '!OPENARRAYOFDOUBLE', 'array of Double');
2134 btExtended: VCType := FindAndAddType(Owner, '!OPENARRAYOFEXTENDED', 'array of Extended');
2135 btString: VCType := FindAndAddType(Owner, '!OPENARRAYOFSTRING', 'array of string');
2136 btPChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFPCHAR', {$IFDEF PS_PANSICHAR}'array of PAnsiChar'{$ELSE}'array of PChar'{$ENDIF});
2137 btNotificationVariant, btVariant: VCType := FindAndAddType(Owner, '!OPENARRAYOFVARIANT', 'array of Variant');
2138 {$IFNDEF PS_NOINT64}btS64: VCType := FindAndAddType(Owner, '!OPENARRAYOFS64', 'array of Int64');{$ENDIF}
2139 btChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFCHAR', 'array of Char');
2140 {$IFNDEF PS_NOWIDESTRING}
2141 btWideString: VCType := FindAndAddType(Owner, '!OPENARRAYOFWIDESTRING', 'array of WideString');
2142 btUnicodeString: VCType := FindAndAddType(Owner, '!OPENARRAYOFUNICODESTRING', 'array of UnicodeString');
2143 btWideChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFWIDECHAR', 'array of WideChar');
2144 {$ENDIF}
2145 btClass: VCType := FindAndAddType(Owner, '!OPENARRAYOFTOBJECT', 'array of TObject');
2146 btRecord: VCType := FindAndAddType(Owner, '!OPENARRAYOFRECORD_'+FastUpperCase(Parser.OriginalToken), 'array of ' +FastUpperCase(Parser.OriginalToken));
2147 btEnum: VCType := FindAndAddType(Owner, '!OPENARRAYOFENUM_' + FastUpperCase(Parser.OriginalToken), 'array of ' + FastUpperCase(Parser.OriginalToken));
2148 else
2149 begin
2150 if Parser <> CustomParser then
2151 Parser.Free;
2152 Result := False;
2153 exit;
2154 end;
2155 end;
2156 end;
2157 end else if Parser.CurrTokenID = CSTII_Const then
2158 VCType := nil // any type
2159 else begin
2160 VCType := Owner.FindType(Parser.GetToken);
2161 if VCType = nil then
2162 begin
2163 if Parser <> CustomParser then
2164 Parser.Free
2165 else
2166 Owner.MakeError('', ecUnknownType, Parser.GetToken);
2167 Result := False;
2168 exit;
2169 end;
2170 end;
2171 while Pos(tbtchar('|'), VNames) > 0 do
2172 begin
2173 with DestDecl.AddParam do
2174 begin
2175 {$IFDEF PS_USESSUPPORT}
2176 DeclareUnit:=Owner.fModule;
2177 {$ENDIF}
2178 DeclarePos := EPos;
2179 DeclareRow := ERow;
2180 DeclareCol := ECol;
2181 Mode := modifier;
2182 OrgName := copy(VNames, 1, Pos(tbtchar('|'), VNames) - 1);
2183 aType := VCType;
2184 end;
2185 Delete(VNames, 1, Pos(tbtchar('|'), VNames));
2186 end;
2187 Parser.Next;
2188 if Parser.CurrTokenId = CSTI_CloseRound then
2189 break;
2190 if Parser.CurrTokenId <> CSTI_Semicolon then
2191 begin
2192 if Parser <> CustomParser then
2193 Parser.Free
2194 else
2195 Owner.MakeError('', ecSemiColonExpected, '');
2196 Result := False;
2197 exit;
2198 end;
2199 Parser.Next;
2200 end; {while}
2201 end; {if}
2202 Parser.Next;
2203 end; {if}
2204 if FuncType = 0 then
2205 begin
2206 if Parser.CurrTokenId <> CSTI_Colon then
2207 begin
2208 if Parser <> CustomParser then
2209 Parser.Free
2210 else
2211 Owner.MakeError('', ecColonExpected, '');
2212 Result := False;
2213 exit;
2214 end;
2215
2216 Parser.Next;
2217 VCType := Owner.FindType(Parser.GetToken);
2218 if VCType = nil then
2219 begin
2220 if Parser <> CustomParser then
2221 Parser.Free
2222 else
2223 Owner.MakeError('', ecUnknownType, Parser.GetToken);
2224 Result := False;
2225 exit;
2226 end;
2227 Parser.Next;
2228 end
2229 else if FuncType = 2 then {constructor}
2230 begin
2231 VCType := Owner.FindType(FClassName)
2232 end else
2233 VCType := nil;
2234 DestDecl.Result := VCType;
2235 if Parser <> CustomParser then
2236 Parser.Free;
2237 if FuncType = 2 then
2238 Func := mftConstructor
2239 else
2240 Func := mftProc;
2241 Result := True;
2242 end;
2243
2244
2245
TPSPascalCompiler.FindProcnull2246 function TPSPascalCompiler.FindProc(const aName: tbtString): Cardinal;
2247 var
2248 l, h: Longint;
2249 x: TPSProcedure;
2250 xr: TPSRegProc;
2251 name: tbtString;
2252
2253 begin
2254 name := FastUpperCase(aName);
2255 h := MakeHash(Name);
2256 if FProcs = nil then
2257 begin
2258 result := InvalidVal;
2259 Exit;
2260 end;
2261
2262 for l := FProcs.Count - 1 downto 0 do
2263 begin
2264 x := FProcs.Data^[l];
2265 if x.ClassType = TPSInternalProcedure then
2266 begin
2267 if (TPSInternalProcedure(x).NameHash = h) and
2268 (TPSInternalProcedure(x).Name = Name) then
2269 begin
2270 Result := l;
2271 exit;
2272 end;
2273 end
2274 else
2275 begin
2276 if (TPSExternalProcedure(x).RegProc.NameHash = h) and
2277 (TPSExternalProcedure(x).RegProc.Name = Name)then
2278 begin
2279 Result := l;
2280 exit;
2281 end;
2282 end;
2283 end;
2284 for l := FRegProcs.Count - 1 downto 0 do
2285 begin
2286 xr := FRegProcs[l];
2287 if (xr.NameHash = h) and (xr.Name = Name) then
2288 begin
2289 x := TPSExternalProcedure.Create;
2290 TPSExternalProcedure(x).RegProc := xr;
2291 FProcs.Add(x);
2292 Result := FProcs.Count - 1;
2293 exit;
2294 end;
2295 end;
2296 Result := InvalidVal;
2297 end; {findfunc}
2298
UseExternalProcnull2299 function TPSPascalCompiler.UseExternalProc(const Name: tbtString): TPSParametersDecl;
2300 var
2301 ProcNo: cardinal;
2302 proc: TPSProcedure;
2303 begin
2304 ProcNo := FindProc(FastUppercase(Name));
2305 if ProcNo = InvalidVal then Result := nil
2306 else
2307 begin
2308 proc := TPSProcedure(FProcs[ProcNo]);
2309 if Proc is TPSExternalProcedure then
2310 begin
2311 Result := TPSExternalProcedure(Proc).RegProc.Decl;
2312 end else result := nil;
2313 end;
2314 end;
2315
2316
2317
TPSPascalCompiler.FindBaseTypenull2318 function TPSPascalCompiler.FindBaseType(BaseType: TPSBaseType): TPSType;
2319 var
2320 l: Longint;
2321 x: TPSType;
2322 begin
2323 for l := 0 to FTypes.Count -1 do
2324 begin
2325 X := FTypes[l];
2326 if (x.BaseType = BaseType) and (x.ClassType = TPSType) then
2327 begin
2328 Result := at2ut(x);
2329 exit;
2330 end;
2331 end;
2332 X := TPSType.Create;
2333 x.Name := '';
2334 x.BaseType := BaseType;
2335 {$IFDEF PS_USESSUPPORT}
2336 x.DeclareUnit:=fModule;
2337 {$ENDIF}
2338 x.DeclarePos := InvalidVal;
2339 x.DeclareCol := 0;
2340 x.DeclareRow := 0;
2341 FTypes.Add(x);
2342 Result := at2ut(x);
2343 end;
2344
MakeDeclnull2345 function TPSPascalCompiler.MakeDecl(decl: TPSParametersDecl): tbtString;
2346 var
2347 i: Longint;
2348 begin
2349 if Decl.Result = nil then result := '0' else
2350 result := Decl.Result.Name;
2351
2352 for i := 0 to decl.ParamCount -1 do
2353 begin
2354 if decl.GetParam(i).Mode = pmIn then
2355 Result := Result + ' @'
2356 else
2357 Result := Result + ' !';
2358 Result := Result + decl.GetParam(i).aType.Name;
2359 end;
2360 end;
2361
2362
2363 { TPSPascalCompiler }
2364
2365 const
2366 BtTypeCopy = 255;
2367
2368
2369 type
2370 TFuncType = (ftProc, ftFunc);
2371
PS_mi2snull2372 function PS_mi2s(i: Cardinal): tbtString;
2373 begin
2374 SetLength(Result, 4);
2375 Cardinal((@Result[1])^) := i;
2376 end;
2377
2378
2379
2380
TPSPascalCompiler.AddTypenull2381 function TPSPascalCompiler.AddType(const Name: tbtString; const BaseType: TPSBaseType): TPSType;
2382 begin
2383 if FProcs = nil then
2384 begin
2385 raise EPSCompilerException.Create(RPS_OnUseEventOnly);
2386 end;
2387
2388 if not(AllowDuplicateRegister) and IsDuplicate(FastUpperCase(Name),[dcTypes, dcProcs, dcVars]) then
2389 Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Name]);
2390
2391 case BaseType of
2392 btProcPtr: Result := TPSProceduralType.Create;
2393 BtTypeCopy: Result := TPSTypeLink.Create;
2394 btRecord: Result := TPSRecordType.Create;
2395 btArray: Result := TPSArrayType.Create;
2396 btStaticArray: Result := TPSStaticArrayType.Create;
2397 btEnum: Result := TPSEnumType.Create;
2398 btClass: Result := TPSClassType.Create;
2399 btExtClass: REsult := TPSUndefinedClassType.Create;
2400 btNotificationVariant, btVariant: Result := TPSVariantType.Create;
2401 {$IFNDEF PS_NOINTERFACES}
2402 btInterface: Result := TPSInterfaceType.Create;
2403 {$ENDIF}
2404 else
2405 Result := TPSType.Create;
2406 end;
2407 Result.Name := FastUppercase(Name);
2408 Result.OriginalName := Name;
2409 Result.BaseType := BaseType;
2410 {$IFDEF PS_USESSUPPORT}
2411 Result.DeclareUnit:=fModule;
2412 {$ENDIF}
2413 Result.DeclarePos := InvalidVal;
2414 Result.DeclareCol := 0;
2415 Result.DeclareRow := 0;
2416 FTypes.Add(Result);
2417 end;
2418
2419
TPSPascalCompiler.AddFunctionnull2420 function TPSPascalCompiler.AddFunction(const Header: tbtString): TPSRegProc;
2421 var
2422 Parser: TPSPascalParser;
2423 i: Integer;
Booleannull2424 IsFunction: Boolean;
2425 VNames, Name: tbtString;
2426 Decl: TPSParametersDecl;
2427 modifier: TPSParameterMode;
2428 VCType: TPSType;
2429 x: TPSRegProc;
2430 begin
2431 if FProcs = nil then
2432 raise EPSCompilerException.Create(RPS_OnUseEventOnly);
2433
2434 Parser := TPSPascalParser.Create;
2435 Parser.SetText(Header);
2436 Decl := TPSParametersDecl.Create;
2437 x := nil;
2438 try
thennull2439 if Parser.CurrTokenId = CSTII_Function then
2440 IsFunction := True
2441 else if Parser.CurrTokenId = CSTII_Procedure then
2442 IsFunction := False
2443 else
2444 Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, ['']);
2445 Parser.Next;
2446 if Parser.CurrTokenId <> CSTI_Identifier then
2447 Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, ['']);
2448 Name := Parser.OriginalToken;
2449 Parser.Next;
2450 if Parser.CurrTokenId = CSTI_OpenRound then
2451 begin
2452 Parser.Next;
2453 if Parser.CurrTokenId <> CSTI_CloseRound then
2454 begin
2455 while True do
2456 begin
2457 if Parser.CurrTokenId = CSTII_Out then
2458 begin
2459 Modifier := pmOut;
2460 Parser.Next;
2461 end else
2462 if Parser.CurrTokenId = CSTII_Const then
2463 begin
2464 Modifier := pmIn;
2465 Parser.Next;
2466 end else
2467 if Parser.CurrTokenId = CSTII_Var then
2468 begin
2469 modifier := pmInOut;
2470 Parser.Next;
2471 end
2472 else
2473 modifier := pmIn;
2474 if Parser.CurrTokenId <> CSTI_Identifier then
2475 raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
2476 VNames := Parser.OriginalToken + '|';
2477 Parser.Next;
2478 while Parser.CurrTokenId = CSTI_Comma do
2479 begin
2480 Parser.Next;
2481 if Parser.CurrTokenId <> CSTI_Identifier then
2482 Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
2483 VNames := VNames + Parser.OriginalToken + '|';
2484 Parser.Next;
2485 end;
2486 if Parser.CurrTokenId <> CSTI_Colon then
2487 begin
2488 Parser.Free;
2489 Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
2490 end;
2491 Parser.Next;
2492 VCType := FindType(Parser.GetToken);
2493 if VCType = nil then
2494 Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
2495 while Pos(tbtchar('|'), VNames) > 0 do
2496 begin
2497 with Decl.AddParam do
2498 begin
2499 Mode := modifier;
2500 OrgName := copy(VNames, 1, Pos(tbtchar('|'), VNames) - 1);
2501 aType := VCType;
2502 end;
2503 Delete(VNames, 1, Pos(tbtchar('|'), VNames));
2504 end;
2505 Parser.Next;
2506 if Parser.CurrTokenId = CSTI_CloseRound then
2507 break;
2508 if Parser.CurrTokenId <> CSTI_Semicolon then
2509 Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
2510 Parser.Next;
2511 end; {while}
2512 end; {if}
2513 Parser.Next;
2514 end; {if}
thennull2515 if IsFunction then
2516 begin
2517 if Parser.CurrTokenId <> CSTI_Colon then
2518 Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
2519
2520 Parser.Next;
2521 VCType := FindType(Parser.GetToken);
2522 if VCType = nil then
2523 Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
2524 end
2525 else
2526 VCType := nil;
2527 Decl.Result := VCType;
2528 X := TPSRegProc.Create;
2529 x.OrgName := Name;
2530 x.Name := FastUpperCase(Name);
2531 x.ExportName := True;
2532 x.Decl.Assign(decl);
2533 if Decl.Result = nil then
2534 begin
2535 x.ImportDecl := x.ImportDecl + #0;
2536 end else
2537 x.ImportDecl := x.ImportDecl + #1;
2538 for i := 0 to Decl.ParamCount -1 do
2539 begin
2540 if Decl.Params[i].Mode <> pmIn then
2541 x.ImportDecl := x.ImportDecl + #1
2542 else
2543 x.ImportDecl := x.ImportDecl + #0;
2544 end;
2545
2546 FRegProcs.Add(x);
2547 finally
2548 Decl.Free;
2549 Parser.Free;
2550 end;
2551 Result := x;
2552 end;
2553
MakeHintnull2554 function TPSPascalCompiler.MakeHint(const Module: tbtString; E: TPSPascalCompilerHintType; const Param: tbtString): TPSPascalCompilerMessage;
2555 var
2556 n: TPSPascalCompilerHint;
2557 begin
2558 N := TPSPascalCompilerHint.Create;
2559 n.FHint := e;
2560 n.SetParserPos(FParser);
2561 n.FModuleName := Module;
2562 n.FParam := Param;
2563 FMessages.Add(n);
2564 Result := n;
2565 end;
2566
TPSPascalCompiler.MakeErrornull2567 function TPSPascalCompiler.MakeError(const Module: tbtString; E:
2568 TPSPascalCompilerErrorType; const Param: tbtString): TPSPascalCompilerMessage;
2569 var
2570 n: TPSPascalCompilerError;
2571 begin
2572 N := TPSPascalCompilerError.Create;
2573 n.FError := e;
2574 n.SetParserPos(FParser);
2575 {$IFNDEF PS_USESSUPPORT}
2576 n.FModuleName := Module;
2577 {$ELSE}
2578 if Module <> '' then
2579 n.FModuleName := Module
2580 else
2581 n.FModuleName := fModule;
2582 {$ENDIF}
2583 n.FParam := Param;
2584 FMessages.Add(n);
2585 Result := n;
2586 end;
2587
MakeWarningnull2588 function TPSPascalCompiler.MakeWarning(const Module: tbtString; E:
2589 TPSPascalCompilerWarningType; const Param: tbtString): TPSPascalCompilerMessage;
2590 var
2591 n: TPSPascalCompilerWarning;
2592 begin
2593 N := TPSPascalCompilerWarning.Create;
2594 n.FWarning := e;
2595 n.SetParserPos(FParser);
2596 n.FModuleName := Module;
2597 n.FParam := Param;
2598 FMessages.Add(n);
2599 Result := n;
2600 end;
2601
2602 procedure TPSPascalCompiler.Clear;
2603 var
2604 l: Longint;
2605 begin
2606 FDebugOutput := '';
2607 FOutput := '';
2608 for l := 0 to FMessages.Count - 1 do
2609 TPSPascalCompilerMessage(FMessages[l]).Free;
2610 FMessages.Clear;
2611 for L := FAutoFreeList.Count -1 downto 0 do
2612 begin
2613 TObject(FAutoFreeList[l]).Free;
2614 end;
2615 FAutoFreeList.Clear;
2616 end;
2617
2618 procedure CopyVariantContents(Src, Dest: PIfRVariant);
2619 begin
2620 case src.FType.BaseType of
2621 btu8, bts8: dest^.tu8 := src^.tu8;
2622 btu16, bts16: dest^.tu16 := src^.tu16;
2623 btenum, btu32, bts32: dest^.tu32 := src^.tu32;
2624 btsingle: Dest^.tsingle := src^.tsingle;
2625 btdouble: Dest^.tdouble := src^.tdouble;
2626 btextended: Dest^.textended := src^.textended;
2627 btCurrency: Dest^.tcurrency := Src^.tcurrency;
2628 btchar: Dest^.tchar := src^.tchar;
2629 {$IFNDEF PS_NOINT64}bts64: dest^.ts64 := src^.ts64;{$ENDIF}
2630 btset, btstring: tbtstring(dest^.tstring) := tbtstring(src^.tstring);
2631 {$IFNDEF PS_NOWIDESTRING}
2632 btunicodestring: tbtunicodestring(dest^.tunistring) := tbtunicodestring(src^.tunistring);
2633 btwidestring: tbtwidestring(dest^.twidestring) := tbtwidestring(src^.twidestring);
2634 btwidechar: Dest^.twidechar := src^.twidechar;
2635 {$ENDIF}
2636 end;
2637 end;
2638
DuplicateVariantnull2639 function DuplicateVariant(Src: PIfRVariant): PIfRVariant;
2640 begin
2641 New(Result);
2642 FillChar(Result^, SizeOf(TIfRVariant), 0);
2643 CopyVariantContents(Src, Result);
2644 end;
2645
2646
2647 procedure InitializeVariant(Vari: PIfRVariant; FType: TPSType);
2648 begin
2649 FillChar(vari^, SizeOf(TIfRVariant), 0);
2650 if FType.BaseType = btSet then
2651 begin
2652 SetLength(tbtstring(vari^.tstring), TPSSetType(FType).ByteSize);
2653 fillchar(tbtstring(vari^.tstring)[1], length(tbtstring(vari^.tstring)), 0);
2654 end;
2655 vari^.FType := FType;
2656 end;
2657
NewVariantnull2658 function NewVariant(FType: TPSType): PIfRVariant;
2659 begin
2660 New(Result);
2661 InitializeVariant(Result, FType);
2662 end;
2663
2664 procedure FinalizeA(var s: tbtString); overload; begin s := ''; end;
2665 {$IFNDEF PS_NOWIDESTRING}
2666 procedure FinalizeW(var s: tbtwidestring); overload; begin s := ''; end;
2667 procedure FinalizeU(var s: tbtunicodestring); overload; begin s := ''; end;
2668 {$ENDIF}
2669 procedure FinalizeVariant(var p: TIfRVariant);
2670 begin
2671 if (p.FType.BaseType = btString) or (p.FType.basetype = btSet) then
2672 finalizeA(tbtstring(p.tstring))
2673 {$IFNDEF PS_NOWIDESTRING}
2674 else if p.FType.BaseType = btWideString then
2675 finalizeW(tbtWideString(p.twidestring)) // tbtwidestring
2676 else if p.FType.BaseType = btUnicodeString then
2677 finalizeU(tbtUnicodeString(p.tunistring)); // tbtwidestring
2678 {$ENDIF}
2679 end;
2680
2681 procedure DisposeVariant(p: PIfRVariant);
2682 begin
2683 if p <> nil then
2684 begin
2685 FinalizeVariant(p^);
2686 Dispose(p);
2687 end;
2688 end;
2689
2690
2691
GetTypeCopyLinknull2692 function TPSPascalCompiler.GetTypeCopyLink(p: TPSType): TPSType;
2693 begin
2694 if p = nil then
2695 Result := nil
2696 else
2697 if p.BaseType = BtTypeCopy then
2698 begin
2699 Result := TPSTypeLink(p).LinkTypeNo;
2700 end else Result := p;
2701 end;
2702
IsIntTypenull2703 function IsIntType(b: TPSBaseType): Boolean;
2704 begin
2705 case b of
2706 btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF PS_NOINT64}, btS64{$ENDIF}: Result := True;
2707 else
2708 Result := False;
2709 end;
2710 end;
2711
IsRealTypenull2712 function IsRealType(b: TPSBaseType): Boolean;
2713 begin
2714 case b of
2715 btSingle, btDouble, btCurrency, btExtended: Result := True;
2716 else
2717 Result := False;
2718 end;
2719 end;
2720
IsIntRealTypenull2721 function IsIntRealType(b: TPSBaseType): Boolean;
2722 begin
2723 case b of
2724 btSingle, btDouble, btCurrency, btExtended, btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF PS_NOINT64}, btS64{$ENDIF}:
2725 Result := True;
2726 else
2727 Result := False;
2728 end;
2729
2730 end;
2731
DiffRecnull2732 function DiffRec(p1, p2: TPSSubItem): Boolean;
2733 begin
2734 if p1.ClassType = p2.ClassType then
2735 begin
2736 if P1.ClassType = TPSSubNumber then
2737 Result := TPSSubNumber(p1).SubNo <> TPSSubNumber(p2).SubNo
2738 else if P1.ClassType = TPSSubValue then
2739 Result := TPSSubValue(p1).SubNo <> TPSSubValue(p2).SubNo
2740 else
2741 Result := False;
2742 end else Result := True;
2743 end;
2744
SameRegnull2745 function SameReg(x1, x2: TPSValue): Boolean;
2746 var
2747 I: Longint;
2748 begin
2749 if (x1.ClassType = x2.ClassType) and (X1 is TPSValueVar) then
2750 begin
2751 if
2752 ((x1.ClassType = TPSValueGlobalVar) and (TPSValueGlobalVar(x1).GlobalVarNo = TPSValueGlobalVar(x2).GlobalVarNo)) or
2753 ((x1.ClassType = TPSValueLocalVar) and (TPSValueLocalVar(x1).LocalVarNo = TPSValueLocalVar(x2).LocalVarNo)) or
2754 ((x1.ClassType = TPSValueParamVar) and (TPSValueParamVar(x1).ParamNo = TPSValueParamVar(x2).ParamNo)) or
2755 ((x1.ClassType = TPSValueAllocatedStackVar) and (TPSValueAllocatedStackVar(x1).LocalVarNo = TPSValueAllocatedStackVar(x2).LocalVarNo)) then
2756 begin
2757 if TPSValueVar(x1).GetRecCount <> TPSValueVar(x2).GetRecCount then
2758 begin
2759 Result := False;
2760 exit;
2761 end;
2762 for i := 0 to TPSValueVar(x1).GetRecCount -1 do
2763 begin
2764 if DiffRec(TPSValueVar(x1).RecItem[i], TPSValueVar(x2).RecItem[i]) then
2765 begin
2766 Result := False;
2767 exit;
2768 end;
2769 end;
2770 Result := True;
2771 end else Result := False;
2772 end
2773 else
2774 Result := False;
2775 end;
2776
GetUIntnull2777 function GetUInt(Src: PIfRVariant; var s: Boolean): Cardinal;
2778 begin
2779 case Src.FType.BaseType of
2780 btU8: Result := Src^.tu8;
2781 btS8: Result := Src^.ts8;
2782 btU16: Result := Src^.tu16;
2783 btS16: Result := Src^.ts16;
2784 btU32: Result := Src^.tu32;
2785 btS32: Result := Src^.ts32;
2786 {$IFNDEF PS_NOINT64}
2787 bts64: Result := src^.ts64;
2788 {$ENDIF}
2789 btChar: Result := ord(Src^.tchar);
2790 {$IFNDEF PS_NOWIDESTRING}
2791 btWideChar: Result := ord(tbtwidechar(src^.twidechar));
2792 {$ENDIF}
2793 btEnum: Result := src^.tu32;
2794 else
2795 begin
2796 s := False;
2797 Result := 0;
2798 end;
2799 end;
2800 end;
2801
GetIntnull2802 function GetInt(Src: PIfRVariant; var s: Boolean): Longint;
2803 begin
2804 case Src.FType.BaseType of
2805 btU8: Result := Src^.tu8;
2806 btS8: Result := Src^.ts8;
2807 btU16: Result := Src^.tu16;
2808 btS16: Result := Src^.ts16;
2809 btU32: Result := Src^.tu32;
2810 btS32: Result := Src^.ts32;
2811 {$IFNDEF PS_NOINT64}
2812 bts64: Result := src^.ts64;
2813 {$ENDIF}
2814 btChar: Result := ord(Src^.tchar);
2815 {$IFNDEF PS_NOWIDESTRING}
2816 btWideChar: Result := ord(tbtwidechar(src^.twidechar));
2817 {$ENDIF}
2818 btEnum: Result := src^.tu32;
2819 else
2820 begin
2821 s := False;
2822 Result := 0;
2823 end;
2824 end;
2825 end;
2826 {$IFNDEF PS_NOINT64}
GetInt64null2827 function GetInt64(Src: PIfRVariant; var s: Boolean): Int64;
2828 begin
2829 case Src.FType.BaseType of
2830 btU8: Result := Src^.tu8;
2831 btS8: Result := Src^.ts8;
2832 btU16: Result := Src^.tu16;
2833 btS16: Result := Src^.ts16;
2834 btU32: Result := Src^.tu32;
2835 btS32: Result := Src^.ts32;
2836 bts64: Result := src^.ts64;
2837 btChar: Result := ord(Src^.tchar);
2838 {$IFNDEF PS_NOWIDESTRING}
2839 btWideChar: Result := ord(tbtwidechar(src^.twidechar));
2840 {$ENDIF}
2841 btEnum: Result := src^.tu32;
2842 else
2843 begin
2844 s := False;
2845 Result := 0;
2846 end;
2847 end;
2848 end;
2849 {$ENDIF}
2850
GetRealnull2851 function GetReal(Src: PIfRVariant; var s: Boolean): Extended;
2852 begin
2853 case Src.FType.BaseType of
2854 btU8: Result := Src^.tu8;
2855 btS8: Result := Src^.ts8;
2856 btU16: Result := Src^.tu16;
2857 btS16: Result := Src^.ts16;
2858 btU32: Result := Src^.tu32;
2859 btS32: Result := Src^.ts32;
2860 {$IFNDEF PS_NOINT64}
2861 bts64: Result := src^.ts64;
2862 {$ENDIF}
2863 btChar: Result := ord(Src^.tchar);
2864 {$IFNDEF PS_NOWIDESTRING}
2865 btWideChar: Result := ord(tbtwidechar(src^.twidechar));
2866 {$ENDIF}
2867 btSingle: Result := Src^.tsingle;
2868 btDouble: Result := Src^.tdouble;
2869 btCurrency: Result := SRc^.tcurrency;
2870 btExtended: Result := Src^.textended;
2871 else
2872 begin
2873 s := False;
2874 Result := 0;
2875 end;
2876 end;
2877 end;
2878
GetStringnull2879 function GetString(Src: PIfRVariant; var s: Boolean): tbtString;
2880 begin
2881 case Src.FType.BaseType of
2882 btChar: Result := Src^.tchar;
2883 btString: Result := tbtstring(src^.tstring);
2884 {$IFNDEF PS_NOWIDESTRING}
2885 btWideChar: Result := tbtstring(src^.twidechar);
2886 btWideString: Result := tbtstring(tbtWideString(src^.twidestring));
2887 btUnicodeString: Result := tbtstring(tbtUnicodeString(src^.tunistring));
2888 {$ENDIF}
2889 else
2890 begin
2891 s := False;
2892 Result := '';
2893 end;
2894 end;
2895 end;
2896
2897 {$IFNDEF PS_NOWIDESTRING}
GetWideStringnull2898 function TPSPascalCompiler.GetWideString(Src: PIfRVariant; var s: Boolean): tbtwidestring;
2899 begin
2900 case Src.FType.BaseType of
2901 btChar: Result := tbtWidestring(Src^.tchar);
2902 btString: Result := tbtWidestring(tbtstring(src^.tstring));
2903 btWideChar: Result := src^.twidechar;
2904 btWideString: Result := tbtWideString(src^.twidestring);
2905 btUnicodeString: result := tbtUnicodeString(src^.tunistring);
2906 else
2907 begin
2908 s := False;
2909 Result := '';
2910 end;
2911 end;
2912 end;
TPSPascalCompiler.GetUnicodeStringnull2913 function TPSPascalCompiler.GetUnicodeString(Src: PIfRVariant; var s: Boolean): tbtunicodestring;
2914 begin
2915 case Src.FType.BaseType of
2916 btChar: Result := tbtunicodestring(Src^.tchar);
2917 btString: Result := tbtunicodestring(tbtstring(src^.tstring));
2918 btWideChar: Result := src^.twidechar;
2919 btWideString: Result := tbtWideString(src^.twidestring);
2920 btUnicodeString: result := tbtUnicodeString(src^.tunistring);
2921 else
2922 begin
2923 s := False;
2924 Result := '';
2925 end;
2926 end;
2927 end;
2928 {$ENDIF}
2929
abnull2930 function ab(b: Longint): Longint;
2931 begin
2932 ab := Longint(b = 0);
2933 end;
2934
2935 procedure Set_Union(Dest, Src: PByteArray; ByteSize: Integer);
2936 var
2937 i: Longint;
2938 begin
2939 for i := ByteSize -1 downto 0 do
2940 Dest^[i] := Dest^[i] or Src^[i];
2941 end;
2942
2943 procedure Set_Diff(Dest, Src: PByteArray; ByteSize: Integer);
2944 var
2945 i: Longint;
2946 begin
2947 for i := ByteSize -1 downto 0 do
2948 Dest^[i] := Dest^[i] and not Src^[i];
2949 end;
2950
2951 procedure Set_Intersect(Dest, Src: PByteArray; ByteSize: Integer);
2952 var
2953 i: Longint;
2954 begin
2955 for i := ByteSize -1 downto 0 do
2956 Dest^[i] := Dest^[i] and Src^[i];
2957 end;
2958
2959 procedure Set_Subset(Dest, Src: PByteArray; ByteSize: Integer; var Val: Boolean);
2960 var
2961 i: Integer;
2962 begin
2963 for i := ByteSize -1 downto 0 do
2964 begin
2965 if not (Src^[i] and Dest^[i] = Dest^[i]) then
2966 begin
2967 Val := False;
2968 exit;
2969 end;
2970 end;
2971 Val := True;
2972 end;
2973
2974 procedure Set_Equal(Dest, Src: PByteArray; ByteSize: Integer; var Val: Boolean);
2975 var
2976 i: Longint;
2977 begin
2978 for i := ByteSize -1 downto 0 do
2979 begin
2980 if Dest^[i] <> Src^[i] then
2981 begin
2982 Val := False;
2983 exit;
2984 end;
2985 end;
2986 val := True;
2987 end;
2988
2989 procedure Set_membership(Item: Longint; Src: PByteArray; var Val: Boolean);
2990 begin
2991 Val := (Src^[Item shr 3] and (1 shl (Item and 7))) <> 0;
2992 end;
2993
2994 procedure Set_MakeMember(Item: Longint; Src: PByteArray);
2995 begin
2996 Src^[Item shr 3] := Src^[Item shr 3] or (1 shl (Item and 7));
2997 end;
2998
2999 procedure ConvertToBoolean(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIFRVariant; b: Boolean);
3000 begin
3001 FinalizeVariant(var1^);
3002 if FUseUsedTypes then
3003 Var1^.FType := se.at2ut(se.FDefaultBoolType)
3004 else
3005 Var1^.FType := Se.FDefaultBoolType;
3006 var1^.tu32 := Ord(b);
3007 end;
3008
3009 procedure ConvertToString(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIFRVariant; const s: tbtString);
3010 var
3011 atype: TPSType;
3012 begin
3013 FinalizeVariant(var1^);
3014 atype := se.FindBaseType(btString);
3015 if FUseUsedTypes then
3016 InitializeVariant(var1, se.at2ut(atype))
3017 else
3018 InitializeVariant(var1, atype);
3019 tbtstring(var1^.tstring) := s;
3020 end;
3021 {$IFNDEF PS_NOWIDESTRING}
3022 procedure ConvertToUnicodeString(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIFRVariant; const s: tbtunicodestring);
3023 var
3024 atype: TPSType;
3025 begin
3026 FinalizeVariant(var1^);
3027 atype := se.FindBaseType(btUnicodeString);
3028 if FUseUsedTypes then
3029 InitializeVariant(var1, se.at2ut(atype))
3030 else
3031 InitializeVariant(var1, atype);
3032 tbtunicodestring(var1^.tunistring) := s;
3033 end;
3034 {$ENDIF}
3035 procedure ConvertToFloat(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIfRVariant; NewType: TPSType);
3036 var
3037 vartemp: PIfRVariant;
3038 b: Boolean;
3039 begin
3040 New(vartemp);
3041 b := false;
3042 if FUseUsedTypes then
3043 NewType := se.at2ut(NewType);
3044 InitializeVariant(vartemp, var1.FType);
3045 CopyVariantContents(var1, vartemp);
3046 FinalizeVariant(var1^);
3047 InitializeVariant(var1, newtype);
3048 case var1.ftype.basetype of
3049 btSingle:
3050 begin
3051 if (vartemp.ftype.BaseType = btu8) or (vartemp.ftype.BaseType = btu16) or (vartemp.ftype.BaseType = btu32) then
3052 var1^.tsingle := GetUInt(vartemp, b)
3053 else
3054 var1^.tsingle := GetInt(vartemp, b)
3055 end;
3056 btDouble:
3057 begin
3058 if (vartemp.ftype.BaseType = btu8) or (vartemp.ftype.BaseType = btu16) or (vartemp.ftype.BaseType = btu32) then
3059 var1^.tdouble := GetUInt(vartemp, b)
3060 else
3061 var1^.tdouble := GetInt(vartemp, b)
3062 end;
3063 btExtended:
3064 begin
3065 if (vartemp.ftype.BaseType = btu8) or (vartemp.ftype.BaseType = btu16) or (vartemp.ftype.BaseType = btu32) then
3066 var1^.textended:= GetUInt(vartemp, b)
3067 else
3068 var1^.textended:= GetInt(vartemp, b)
3069 end;
3070 btCurrency:
3071 begin
3072 if (vartemp.ftype.BaseType = btu8) or (vartemp.ftype.BaseType = btu16) or (vartemp.ftype.BaseType = btu32) then
3073 var1^.tcurrency:= GetUInt(vartemp, b)
3074 else
3075 var1^.tcurrency:= GetInt(vartemp, b)
3076 end;
3077 end;
3078 DisposeVariant(vartemp);
3079 end;
3080
3081
IsCompatibleTypenull3082 function TPSPascalCompiler.IsCompatibleType(p1, p2: TPSType; Cast: Boolean): Boolean;
3083 begin
3084 if
3085 ((p1.BaseType = btProcPtr) and (p2 = p1)) or
3086 (p1.BaseType = btPointer) or
3087 (p2.BaseType = btPointer) or
3088 ((p1.BaseType = btNotificationVariant) or (p1.BaseType = btVariant)) or
3089 ((p2.BaseType = btNotificationVariant) or (p2.BaseType = btVariant)) or
3090 (IsIntType(p1.BaseType) and IsIntType(p2.BaseType)) or
3091 (IsRealType(p1.BaseType) and IsIntRealType(p2.BaseType)) or
3092 (((p1.basetype = btPchar) or (p1.BaseType = btString)) and ((p2.BaseType = btString) or (p2.BaseType = btPchar))) or
3093 (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btChar)) or
3094 (((p1.BaseType = btArray) or (p1.BaseType = btStaticArray)) and (
3095 (p2.BaseType = btArray) or (p2.BaseType = btStaticArray)) and IsCompatibleType(TPSArrayType(p1).ArrayTypeNo, TPSArrayType(p2).ArrayTypeNo, False)) or
3096 ((p1.BaseType = btChar) and (p2.BaseType = btChar)) or
3097 ((p1.BaseType = btSet) and (p2.BaseType = btSet)) or
3098 {$IFNDEF PS_NOWIDESTRING}
3099 ((p1.BaseType = btChar) and (p2.BaseType = btWideChar)) or
3100 ((p1.BaseType = btWideChar) and (p2.BaseType = btChar)) or
3101 ((p1.BaseType = btWideChar) and (p2.BaseType = btWideChar)) or
3102 ((p1.BaseType = btWidestring) and (p2.BaseType = btChar)) or
3103 ((p1.BaseType = btWidestring) and (p2.BaseType = btWideChar)) or
3104 ((p1.BaseType = btWidestring) and ((p2.BaseType = btString) or (p2.BaseType = btPchar) or (p2.BaseType = btUnicodeString))) or
3105 ((p1.BaseType = btWidestring) and ((p2.BaseType = btWidestring))) or
3106 ((p1.BaseType = btUnicodeString) and (p2.BaseType = btChar)) or
3107 ((p1.BaseType = btUnicodeString) and (p2.BaseType = btWideChar)) or
3108 ((p1.BaseType = btUnicodeString) and ((p2.BaseType = btString) or (p2.BaseType = btPchar) or (p2.BaseType = btUnicodeString))) or
3109 ((p1.BaseType = btUnicodeString) and (p2.BaseType = btWidestring)) or
3110 (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btWideString)or (p2.BaseType = btUnicodeString)) or
3111 (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btWidechar)) or
3112 (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btchar)) or
3113 {$ENDIF}
3114 ((p1.BaseType = btRecord) and (p2.BaseType = btrecord) and (not IsVarInCompatible(p1, p2))) or
3115 ((p1.BaseType = btEnum) and (p2.BaseType = btEnum)) or
3116 (Cast and IsIntType(P1.BaseType) and (p2.baseType = btEnum)) or
3117 (Cast and (p1.baseType = btEnum) and IsIntType(P2.BaseType))
3118 then
3119 Result := True
3120 // nx change start - allow casting class -> integer and vice versa
3121 else if p1.BaseType = btclass then
3122 Result := TPSClassType(p1).cl.IsCompatibleWith(p2) or (p2.BaseType in [btU32, btS32])
3123 else if (p1.BaseType in [btU32, btS32]) then
3124 Result := (p2.BaseType = btClass)
3125 // nx change end
3126 {$IFNDEF PS_NOINTERFACES}
3127 else if p1.BaseType = btInterface then
3128 Result := TPSInterfaceType(p1).Intf.IsCompatibleWith(p2)
3129 {$ENDIF}
3130 else if ((p1.BaseType = btExtClass) and (p2.BaseType = btExtClass)) then
3131 begin
3132 Result := TPSUndefinedClassType(p1).ExtClass.IsCompatibleWith(TPSUndefinedClassType(p2).ExtClass);
3133 end
3134 else
3135 Result := False;
3136 end;
3137
3138
PreCalcnull3139 function TPSPascalCompiler.PreCalc(FUseUsedTypes: Boolean; Var1Mod: Byte; var1: PIFRVariant; Var2Mod: Byte; Var2: PIfRVariant; Cmd: TPSBinOperatorType; Pos, Row, Col: Cardinal): Boolean;
3140 { var1=dest, var2=src }
3141 var
3142 b: Boolean;
3143
3144 begin
3145 Result := True;
3146 try
3147 if (IsRealType(var2.FType.BaseType) and IsIntType(var1.FType.BaseType)) then
3148 ConvertToFloat(Self, FUseUsedTypes, var1, var2^.FType);
3149 case Cmd of
3150 otAdd:
3151 begin { + }
3152 case var1.FType.BaseType of
3153 btU8: var1^.tu8 := var1^.tu8 + GetUint(Var2, Result);
3154 btS8: var1^.ts8 := var1^.ts8 + GetInt(Var2, Result);
3155 btU16: var1^.tu16 := var1^.tu16 + GetUint(Var2, Result);
3156 btS16: var1^.ts16 := var1^.ts16 + Getint(Var2, Result);
3157 btEnum, btU32: var1^.tu32 := var1^.tu32 + GetUint(Var2, Result);
3158 btS32: var1^.ts32 := var1^.ts32 + Getint(Var2, Result);
3159 {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 + GetInt64(Var2, Result); {$ENDIF}
3160 btSingle: var1^.tsingle := var1^.tsingle + GetReal( Var2, Result);
3161 btDouble: var1^.tdouble := var1^.tdouble + GetReal( Var2, Result);
3162 btExtended: var1^.textended := var1^.textended + GetReal( Var2, Result);
3163 btCurrency: var1^.tcurrency := var1^.tcurrency + GetReal( Var2, Result);
3164 btSet:
3165 begin
3166 if (var1.FType = var2.FType) then
3167 begin
3168 Set_Union(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize);
3169 end else Result := False;
3170 end;
3171 btChar:
3172 begin
3173 ConvertToString(Self, FUseUsedTypes, var1, getstring(Var1, b)+getstring(Var2, b));
3174 end;
3175 btString: tbtstring(var1^.tstring) := tbtstring(var1^.tstring) + GetString(Var2, Result);
3176 {$IFNDEF PS_NOWIDESTRING}
3177 btwideString: tbtwidestring(var1^.twidestring) := tbtwidestring(var1^.twidestring) + GetWideString(Var2, Result);
3178 btUnicodeString: tbtunicodestring(var1^.tunistring) := tbtunicodestring(var1^.tunistring) + GetUnicodeString(Var2, Result);
3179 btWidechar:
3180 begin
3181 ConvertToUnicodeString(Self, FUseUsedTypes, var1, GetUnicodeString(Var1, b)+GetUnicodeString(Var2, b));
3182 end;
3183 {$ENDIF}
3184 else Result := False;
3185 end;
3186 end;
3187 otSub:
3188 begin { - }
3189 case Var1.FType.BaseType of
3190 btU8: var1^.tu8 := var1^.tu8 - GetUint(Var2, Result);
3191 btS8: var1^.ts8 := var1^.ts8 - Getint(Var2, Result);
3192 btU16: var1^.tu16 := var1^.tu16 - GetUint(Var2, Result);
3193 btS16: var1^.ts16 := var1^.ts16 - Getint(Var2, Result);
3194 btEnum, btU32: var1^.tu32 := var1^.tu32 - GetUint(Var2, Result);
3195 btS32: var1^.ts32 := var1^.ts32 - Getint(Var2, Result);
3196 {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 - GetInt64(Var2, Result); {$ENDIF}
3197 btSingle: var1^.tsingle := var1^.tsingle - GetReal( Var2, Result);
3198 btDouble: var1^.tdouble := var1^.tdouble - GetReal(Var2, Result);
3199 btExtended: var1^.textended := var1^.textended - GetReal(Var2, Result);
3200 btCurrency: var1^.tcurrency := var1^.tcurrency - GetReal( Var2, Result);
3201 btSet:
3202 begin
3203 if (var1.FType = var2.FType) then
3204 begin
3205 Set_Diff(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize);
3206 end else Result := False;
3207 end;
3208 else Result := False;
3209 end;
3210 end;
3211 otMul:
3212 begin { * }
3213 case Var1.FType.BaseType of
3214 btU8: var1^.tu8 := var1^.tu8 * GetUint(Var2, Result);
3215 btS8: var1^.ts8 := var1^.ts8 * Getint(Var2, Result);
3216 btU16: var1^.tu16 := var1^.tu16 * GetUint(Var2, Result);
3217 btS16: var1^.ts16 := var1^.ts16 * Getint(Var2, Result);
3218 btU32: var1^.tu32 := var1^.tu32 * GetUint(Var2, Result);
3219 btS32: var1^.ts32 := var1^.ts32 * Getint(Var2, Result);
3220 {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 * GetInt64(Var2, Result); {$ENDIF}
3221 btSingle: var1^.tsingle := var1^.tsingle * GetReal(Var2, Result);
3222 btDouble: var1^.tdouble := var1^.tdouble * GetReal(Var2, Result);
3223 btExtended: var1^.textended := var1^.textended * GetReal( Var2, Result);
3224 btCurrency: var1^.tcurrency := var1^.tcurrency * GetReal( Var2, Result);
3225 btSet:
3226 begin
3227 if (var1.FType = var2.FType) then
3228 begin
3229 Set_Intersect(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize);
3230 end else Result := False;
3231 end;
3232 else Result := False;
3233 end;
3234 end;
3235 {$IFDEF PS_DELPHIDIV}
3236 otDiv:
3237 begin { / }
3238 if IsIntType(var1.FType.BaseType) then
3239 ConvertToFloat(self, FUseUsedTypes, var1, Self.FindType('EXTENDED'));
3240 case Var1.FType.BaseType of
3241 btSingle: var1^.tsingle := var1^.tsingle / GetReal( Var2, Result);
3242 btDouble: var1^.tdouble := var1^.tdouble / GetReal( Var2, Result);
3243 btExtended: var1^.textended := var1^.textended / GetReal( Var2, Result);
3244 btCurrency: var1^.tcurrency := var1^.tcurrency / GetReal( Var2, Result);
3245 else Result := False;
3246 end;
3247 end;
3248 otIntDiv:
3249 begin { / }
3250 case Var1.FType.BaseType of
3251 btU8: var1^.tu8 := var1^.tu8 div GetUint(Var2, Result);
3252 btS8: var1^.ts8 := var1^.ts8 div Getint(Var2, Result);
3253 btU16: var1^.tu16 := var1^.tu16 div GetUint(Var2, Result);
3254 btS16: var1^.ts16 := var1^.ts16 div Getint(Var2, Result);
3255 btU32: var1^.tu32 := var1^.tu32 div GetUint(Var2, Result);
3256 btS32: var1^.ts32 := var1^.ts32 div Getint(Var2, Result);
3257 {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 div GetInt64(Var2, Result); {$ENDIF}
3258 else Result := False;
3259 end;
3260 end;
3261 {$ELSE}
3262 otDiv, otIntDiv:
3263 begin { / }
3264 case Var1.FType.BaseType of
3265 btU8: var1^.tu8 := var1^.tu8 div GetUint(Var2, Result);
3266 btS8: var1^.ts8 := var1^.ts8 div Getint(Var2, Result);
3267 btU16: var1^.tu16 := var1^.tu16 div GetUint(Var2, Result);
3268 btS16: var1^.ts16 := var1^.ts16 div Getint(Var2, Result);
3269 btU32: var1^.tu32 := var1^.tu32 div GetUint(Var2, Result);
3270 btS32: var1^.ts32 := var1^.ts32 div Getint(Var2, Result);
3271 {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 div GetInt64(Var2, Result); {$ENDIF}
3272 btSingle: var1^.tsingle := var1^.tsingle / GetReal( Var2, Result);
3273 btDouble: var1^.tdouble := var1^.tdouble / GetReal( Var2, Result);
3274 btExtended: var1^.textended := var1^.textended / GetReal( Var2, Result);
3275 btCurrency: var1^.tcurrency := var1^.tcurrency / GetReal( Var2, Result);
3276 else Result := False;
3277 end;
3278 end;
3279 {$ENDIF}
3280 otMod:
3281 begin { MOD }
3282 case Var1.FType.BaseType of
3283 btU8: var1^.tu8 := var1^.tu8 mod GetUint(Var2, Result);
3284 btS8: var1^.ts8 := var1^.ts8 mod Getint(Var2, Result);
3285 btU16: var1^.tu16 := var1^.tu16 mod GetUint(Var2, Result);
3286 btS16: var1^.ts16 := var1^.ts16 mod Getint(Var2, Result);
3287 btU32: var1^.tu32 := var1^.tu32 mod GetUint(Var2, Result);
3288 btS32: var1^.ts32 := var1^.ts32 mod Getint(Var2, Result);
3289 {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 mod GetInt64(Var2, Result); {$ENDIF}
3290 else Result := False;
3291 end;
3292 end;
3293 otshl:
3294 begin { SHL }
3295 case Var1.FType.BaseType of
3296 btU8: var1^.tu8 := var1^.tu8 shl GetUint(Var2, Result);
3297 btS8: var1^.ts8 := var1^.ts8 shl Getint(Var2, Result);
3298 btU16: var1^.tu16 := var1^.tu16 shl GetUint(Var2, Result);
3299 btS16: var1^.ts16 := var1^.ts16 shl Getint(Var2, Result);
3300 btU32: var1^.tu32 := var1^.tu32 shl GetUint(Var2, Result);
3301 btS32: var1^.ts32 := var1^.ts32 shl Getint(Var2, Result);
3302 {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 shl GetInt64(Var2, Result); {$ENDIF}
3303 else Result := False;
3304 end;
3305 end;
3306 otshr:
3307 begin { SHR }
3308 case Var1.FType.BaseType of
3309 btU8: var1^.tu8 := var1^.tu8 shr GetUint(Var2, Result);
3310 btS8: var1^.ts8 := var1^.ts8 shr Getint(Var2, Result);
3311 btU16: var1^.tu16 := var1^.tu16 shr GetUint(Var2, Result);
3312 btS16: var1^.ts16 := var1^.ts16 shr Getint(Var2, Result);
3313 btU32: var1^.tu32 := var1^.tu32 shr GetUint(Var2, Result);
3314 btS32: var1^.ts32 := var1^.ts32 shr Getint(Var2, Result);
3315 {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 shr GetInt64( Var2, Result); {$ENDIF}
3316 else Result := False;
3317 end;
3318 end;
3319 otAnd:
3320 begin { AND }
3321 case Var1.FType.BaseType of
3322 btU8: var1^.tu8 := var1^.tu8 and GetUint(Var2, Result);
3323 btS8: var1^.ts8 := var1^.ts8 and Getint(Var2, Result);
3324 btU16: var1^.tu16 := var1^.tu16 and GetUint(Var2, Result);
3325 btS16: var1^.ts16 := var1^.ts16 and Getint(Var2, Result);
3326 btU32: var1^.tu32 := var1^.tu32 and GetUint(Var2, Result);
3327 btS32: var1^.ts32 := var1^.ts32 and Getint(Var2, Result);
3328 btEnum: var1^.ts32 := var1^.ts32 and Getint(Var2, Result);
3329 {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 and GetInt64(Var2, Result); {$ENDIF}
3330 else Result := False;
3331 end;
3332 end;
3333 otor:
3334 begin { OR }
3335 case Var1.FType.BaseType of
3336 btU8: var1^.tu8 := var1^.tu8 or GetUint(Var2, Result);
3337 btS8: var1^.ts8 := var1^.ts8 or Getint(Var2, Result);
3338 btU16: var1^.tu16 := var1^.tu16 or GetUint(Var2, Result);
3339 btS16: var1^.ts16 := var1^.ts16 or Getint(Var2, Result);
3340 btU32: var1^.tu32 := var1^.tu32 or GetUint(Var2, Result);
3341 btS32: var1^.ts32 := var1^.ts32 or Getint(Var2, Result);
3342 {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 or GetInt64(Var2, Result); {$ENDIF}
3343 btEnum: var1^.ts32 := var1^.ts32 or Getint(Var2, Result);
3344 else Result := False;
3345 end;
3346 end;
3347 otxor:
3348 begin { XOR }
3349 case Var1.FType.BaseType of
3350 btU8: var1^.tu8 := var1^.tu8 xor GetUint(Var2, Result);
3351 btS8: var1^.ts8 := var1^.ts8 xor Getint(Var2, Result);
3352 btU16: var1^.tu16 := var1^.tu16 xor GetUint(Var2, Result);
3353 btS16: var1^.ts16 := var1^.ts16 xor Getint(Var2, Result);
3354 btU32: var1^.tu32 := var1^.tu32 xor GetUint(Var2, Result);
3355 btS32: var1^.ts32 := var1^.ts32 xor Getint(Var2, Result);
3356 {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 xor GetInt64(Var2, Result); {$ENDIF}
3357 btEnum: var1^.ts32 := var1^.ts32 xor Getint(Var2, Result);
3358 else Result := False;
3359 end;
3360 end;
3361 otGreaterEqual:
3362 begin { >= }
3363 case Var1.FType.BaseType of
3364 btU8: b := var1^.tu8 >= GetUint(Var2, Result);
3365 btS8: b := var1^.ts8 >= Getint(Var2, Result);
3366 btU16: b := var1^.tu16 >= GetUint(Var2, Result);
3367 btS16: b := var1^.ts16 >= Getint(Var2, Result);
3368 btU32: b := var1^.tu32 >= GetUint(Var2, Result);
3369 btS32: b := var1^.ts32 >= Getint(Var2, Result);
3370 {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 >= GetInt64(Var2, Result); {$ENDIF}
3371 btSingle: b := var1^.tsingle >= GetReal( Var2, Result);
3372 btDouble: b := var1^.tdouble >= GetReal( Var2, Result);
3373 btExtended: b := var1^.textended >= GetReal( Var2, Result);
3374 btCurrency: b := var1^.tcurrency >= GetReal( Var2, Result);
3375 btSet:
3376 begin
3377 if (var1.FType = var2.FType) then
3378 begin
3379 Set_Subset(var2.tstring, var1.tstring, TPSSetType(var1.FType).ByteSize, b);
3380 end else Result := False;
3381 end;
3382 else
3383 Result := False;
3384 end;
3385 ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
3386 end;
3387 otLessEqual:
3388 begin { <= }
3389 case Var1.FType.BaseType of
3390 btU8: b := var1^.tu8 <= GetUint(Var2, Result);
3391 btS8: b := var1^.ts8 <= Getint(Var2, Result);
3392 btU16: b := var1^.tu16 <= GetUint(Var2, Result);
3393 btS16: b := var1^.ts16 <= Getint(Var2, Result);
3394 btU32: b := var1^.tu32 <= GetUint(Var2, Result);
3395 btS32: b := var1^.ts32 <= Getint(Var2, Result);
3396 {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 <= GetInt64(Var2, Result); {$ENDIF}
3397 btSingle: b := var1^.tsingle <= GetReal( Var2, Result);
3398 btDouble: b := var1^.tdouble <= GetReal( Var2, Result);
3399 btExtended: b := var1^.textended <= GetReal( Var2, Result);
3400 btCurrency: b := var1^.tcurrency <= GetReal( Var2, Result);
3401 btSet:
3402 begin
3403 if (var1.FType = var2.FType) then
3404 begin
3405 Set_Subset(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize, b);
3406 end else Result := False;
3407 end;
3408 else
3409 Result := False;
3410 end;
3411 ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
3412 end;
3413 otGreater:
3414 begin { > }
3415 case Var1.FType.BaseType of
3416 btU8: b := var1^.tu8 > GetUint(Var2, Result);
3417 btS8: b := var1^.ts8 > Getint(Var2, Result);
3418 btU16: b := var1^.tu16 > GetUint(Var2, Result);
3419 btS16: b := var1^.ts16 > Getint(Var2, Result);
3420 btU32: b := var1^.tu32 > GetUint(Var2, Result);
3421 btS32: b := var1^.ts32 > Getint(Var2, Result);
3422 {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 > GetInt64(Var2, Result); {$ENDIF}
3423 btSingle: b := var1^.tsingle > GetReal( Var2, Result);
3424 btDouble: b := var1^.tdouble > GetReal( Var2, Result);
3425 btExtended: b := var1^.textended > GetReal( Var2, Result);
3426 btCurrency: b := var1^.tcurrency > GetReal( Var2, Result);
3427 else
3428 Result := False;
3429 end;
3430 ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
3431 end;
3432 otLess:
3433 begin { < }
3434 case Var1.FType.BaseType of
3435 btU8: b := var1^.tu8 < GetUint(Var2, Result);
3436 btS8: b := var1^.ts8 < Getint(Var2, Result);
3437 btU16: b := var1^.tu16 < GetUint(Var2, Result);
3438 btS16: b := var1^.ts16 < Getint(Var2, Result);
3439 btU32: b := var1^.tu32 < GetUint(Var2, Result);
3440 btS32: b := var1^.ts32 < Getint(Var2, Result);
3441 {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 < GetInt64(Var2, Result); {$ENDIF}
3442 btSingle: b := var1^.tsingle < GetReal( Var2, Result);
3443 btDouble: b := var1^.tdouble < GetReal( Var2, Result);
3444 btExtended: b := var1^.textended < GetReal( Var2, Result);
3445 btCurrency: b := var1^.tcurrency < GetReal( Var2, Result);
3446 else
3447 Result := False;
3448 end;
3449 ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
3450 end;
3451 otNotEqual:
3452 begin { <> }
3453 case Var1.FType.BaseType of
3454 btU8: b := var1^.tu8 <> GetUint(Var2, Result);
3455 btS8: b := var1^.ts8 <> Getint(Var2, Result);
3456 btU16: b := var1^.tu16 <> GetUint(Var2, Result);
3457 btS16: b := var1^.ts16 <> Getint(Var2, Result);
3458 btU32: b := var1^.tu32 <> GetUint(Var2, Result);
3459 {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 <> GetInt64(Var2, Result); {$ENDIF}
3460 btS32: b := var1^.ts32 <> Getint(Var2, Result);
3461 btSingle: b := var1^.tsingle <> GetReal( Var2, Result);
3462 btDouble: b := var1^.tdouble <> GetReal( Var2, Result);
3463 btExtended: b := var1^.textended <> GetReal( Var2, Result);
3464 btCurrency: b := var1^.tcurrency <> GetReal( Var2, Result);
3465 btEnum: b := var1^.ts32 <> Getint(Var2, Result);
3466 btString: b := tbtstring(var1^.tstring) <> GetString(var2, Result);
3467 btChar: b := var1^.tchar <> GetString(var2, Result);
3468 {$IFNDEF PS_NOWIDESTRING}
3469 btWideString: b := tbtWideString(var1^.twidestring) <> GetWideString(var2, Result);
3470 btUnicodeString: b := tbtUnicodeString(var1^.tunistring) <> GetUnicodeString(var2, Result);
3471 btWideChar: b := var1^.twidechar <> GetUnicodeString(var2, Result);
3472 {$ENDIF}
3473 btSet:
3474 begin
3475 if (var1.FType = var2.FType) then
3476 begin
3477 Set_Equal(var1.tstring, var2.tstring, TPSSetType(var1.FType).GetByteSize, b);
3478 b := not b;
3479 end else Result := False;
3480 end;
3481 else
3482 Result := False;
3483 end;
3484 ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
3485 end;
3486 otEqual:
3487 begin { = }
3488 case Var1.FType.BaseType of
3489 btU8: b := var1^.tu8 = GetUint(Var2, Result);
3490 btS8: b := var1^.ts8 = Getint(Var2, Result);
3491 btU16: b := var1^.tu16 = GetUint(Var2, Result);
3492 btS16: b := var1^.ts16 = Getint(Var2, Result);
3493 btU32: b := var1^.tu32 = GetUint(Var2, Result);
3494 btS32: b := var1^.ts32 = Getint(Var2, Result);
3495 {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 = GetInt64(Var2, Result); {$ENDIF}
3496 btSingle: b := var1^.tsingle = GetReal( Var2, Result);
3497 btDouble: b := var1^.tdouble = GetReal( Var2, Result);
3498 btExtended: b := var1^.textended = GetReal( Var2, Result);
3499 btCurrency: b := var1^.tcurrency = GetReal( Var2, Result);
3500 btEnum: b := var1^.ts32 = Getint(Var2, Result);
3501 btString: b := tbtstring(var1^.tstring) = GetString(var2, Result);
3502 btChar: b := var1^.tchar = GetString(var2, Result);
3503 {$IFNDEF PS_NOWIDESTRING}
3504 btWideString: b := tbtWideString(var1^.twidestring) = GetWideString(var2, Result);
3505 btUnicodeString: b := tbtUnicodeString(var1^.twidestring) = GetUnicodeString(var2, Result);
3506 btWideChar: b := var1^.twidechar = GetUnicodeString(var2, Result);
3507 {$ENDIF}
3508 btSet:
3509 begin
3510 if (var1.FType = var2.FType) then
3511 begin
3512 Set_Equal(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize, b);
3513 end else Result := False;
3514 end;
3515 else
3516 Result := False;
3517 end;
3518 ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
3519 end;
3520 otIn:
3521 begin
3522 if (var2.Ftype.BaseType = btset) and (TPSSetType(var2).SetType = Var1.FType) then
3523 begin
3524 Set_membership(GetUint(var1, result), var2.tstring, b);
3525 end else Result := False;
3526 end;
3527 else
3528 Result := False;
3529 end;
3530 except
3531 on E: EDivByZero do
3532 begin
3533 Result := False;
3534 MakeError('', ecDivideByZero, '');
3535 Exit;
3536 end;
3537 on E: EZeroDivide do
3538 begin
3539 Result := False;
3540 MakeError('', ecDivideByZero, '');
3541 Exit;
3542 end;
3543 on E: EMathError do
3544 begin
3545 Result := False;
3546 MakeError('', ecMathError, tbtstring(e.Message));
3547 Exit;
3548 end;
3549 on E: Exception do
3550 begin
3551 Result := False;
3552 MakeError('', ecInternalError, tbtstring(E.Message));
3553 Exit;
3554 end;
3555 end;
3556 if not Result then
3557 begin
3558 with MakeError('', ecTypeMismatch, '') do
3559 begin
3560 FPosition := Pos;
3561 FRow := Row;
3562 FCol := Col;
3563 end;
3564 end;
3565 end;
3566
IsDuplicatenull3567 function TPSPascalCompiler.IsDuplicate(const s: tbtString; const check: TPSDuplicCheck): Boolean;
3568 var
3569 h, l: Longint;
3570 x: TPSProcedure;
3571 begin
3572 if (s = 'RESULT') then
3573 begin
3574 Result := True;
3575 exit;
3576 end;
3577 h := MakeHash(s);
3578 if dcTypes in Check then
3579 for l := FTypes.Count - 1 downto 0 do
3580 begin
3581 if (TPSType(FTypes.Data[l]).NameHash = h) and
3582 (TPSType(FTypes.Data[l]).Name = s) then
3583 begin
3584 Result := True;
3585 exit;
3586 end;
3587 end;
3588
3589 if dcProcs in Check then
3590 for l := FProcs.Count - 1 downto 0 do
3591 begin
3592 x := FProcs.Data[l];
3593 if x.ClassType = TPSInternalProcedure then
3594 begin
3595 if (h = TPSInternalProcedure(x).NameHash) and (s = TPSInternalProcedure(x).Name) then
3596 begin
3597 Result := True;
3598 exit;
3599 end;
3600 end
3601 else
3602 begin
3603 if (TPSExternalProcedure(x).RegProc.NameHash = h) and
3604 (TPSExternalProcedure(x).RegProc.Name = s) then
3605 begin
3606 Result := True;
3607 exit;
3608 end;
3609 end;
3610 end;
3611 if dcVars in Check then
3612 for l := FVars.Count - 1 downto 0 do
3613 begin
3614 if (TPSVar(FVars.Data[l]).NameHash = h) and
3615 (TPSVar(FVars.Data[l]).Name = s) then
3616 begin
3617 Result := True;
3618 exit;
3619 end;
3620 end;
3621 if dcConsts in Check then
3622 for l := FConstants.Count -1 downto 0 do
3623 begin
3624 if (TPSConstant(FConstants.Data[l]).NameHash = h) and
3625 (TPSConstant(FConstants.Data[l]).Name = s) then
3626 begin
3627 Result := TRue;
3628 exit;
3629 end;
3630 end;
3631 Result := False;
3632 end;
3633
3634 procedure ClearRecSubVals(RecSubVals: TPSList);
3635 var
3636 I: Longint;
3637 begin
3638 for I := 0 to RecSubVals.Count - 1 do
3639 TPSRecordFieldTypeDef(RecSubVals[I]).Free;
3640 RecSubVals.Free;
3641 end;
3642
TPSPascalCompiler.ReadTypeAddProcedurenull3643 function TPSPascalCompiler.ReadTypeAddProcedure(const Name: tbtString; FParser: TPSPascalParser): TPSType;
3644 var
Booleannull3645 IsFunction: Boolean;
3646 VNames: tbtString;
3647 modifier: TPSParameterMode;
3648 Decl: TPSParametersDecl;
3649 VCType: TPSType;
3650 begin
thennull3651 if FParser.CurrTokenId = CSTII_Function then
3652 IsFunction := True
3653 else
3654 IsFunction := False;
3655 Decl := TPSParametersDecl.Create;
3656 try
3657 FParser.Next;
3658 if FParser.CurrTokenId = CSTI_OpenRound then
3659 begin
3660 FParser.Next;
3661 if FParser.CurrTokenId <> CSTI_CloseRound then
3662 begin
3663 while True do
3664 begin
3665 if FParser.CurrTokenId = CSTII_Const then
3666 begin
3667 Modifier := pmIn;
3668 FParser.Next;
3669 end else
3670 if FParser.CurrTokenId = CSTII_Out then
3671 begin
3672 Modifier := pmOut;
3673 FParser.Next;
3674 end else
3675 if FParser.CurrTokenId = CSTII_Var then
3676 begin
3677 modifier := pmInOut;
3678 FParser.Next;
3679 end
3680 else
3681 modifier := pmIn;
3682 if FParser.CurrTokenId <> CSTI_Identifier then
3683 begin
3684 Result := nil;
3685 if FParser = Self.FParser then
3686 MakeError('', ecIdentifierExpected, '');
3687 exit;
3688 end;
3689 VNames := FParser.OriginalToken + '|';
3690 FParser.Next;
3691 while FParser.CurrTokenId = CSTI_Comma do
3692 begin
3693 FParser.Next;
3694 if FParser.CurrTokenId <> CSTI_Identifier then
3695 begin
3696 Result := nil;
3697 if FParser = Self.FParser then
3698 MakeError('', ecIdentifierExpected, '');
3699 exit;
3700 end;
3701 VNames := VNames + FParser.GetToken + '|';
3702 FParser.Next;
3703 end;
3704 if FParser.CurrTokenId <> CSTI_Colon then
3705 begin
3706 Result := nil;
3707 if FParser = Self.FParser then
3708 MakeError('', ecColonExpected, '');
3709 exit;
3710 end;
3711 FParser.Next;
3712 if FParser.CurrTokenId <> CSTI_Identifier then
3713 begin
3714 Result := nil;
3715 if FParser = self.FParser then
3716 MakeError('', ecIdentifierExpected, '');
3717 exit;
3718 end;
3719 VCType := FindType(FParser.GetToken);
3720 if VCType = nil then
3721 begin
3722 if FParser = self.FParser then
3723 MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
3724 Result := nil;
3725 exit;
3726 end;
3727 while Pos(tbtchar('|'), VNames) > 0 do
3728 begin
3729 with Decl.AddParam do
3730 begin
3731 Mode := modifier;
3732 OrgName := copy(VNames, 1, Pos(tbtchar('|'), VNames) - 1);
3733 FType := VCType;
3734 end;
3735 Delete(VNames, 1, Pos(tbtchar('|'), VNames));
3736 end;
3737 FParser.Next;
3738 if FParser.CurrTokenId = CSTI_CloseRound then
3739 break;
3740 if FParser.CurrTokenId <> CSTI_Semicolon then
3741 begin
3742 if FParser = Self.FParser then
3743 MakeError('', ecSemicolonExpected, '');
3744 Result := nil;
3745 exit;
3746 end;
3747 FParser.Next;
3748 end; {while}
3749 end; {if}
3750 FParser.Next;
3751 end; {if}
thennull3752 if IsFunction then
3753 begin
3754 if FParser.CurrTokenId <> CSTI_Colon then
3755 begin
3756 if FParser = Self.FParser then
3757 MakeError('', ecColonExpected, '');
3758 Result := nil;
3759 exit;
3760 end;
3761 FParser.Next;
3762 if FParser.CurrTokenId <> CSTI_Identifier then
3763 begin
3764 Result := nil;
3765 if FParser = Self.FParser then
3766 MakeError('', ecIdentifierExpected, '');
3767 exit;
3768 end;
3769 VCType := self.FindType(FParser.GetToken);
3770 if VCType = nil then
3771 begin
3772 if FParser = self.FParser then
3773 MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
3774 Result := nil;
3775 exit;
3776 end;
3777 FParser.Next;
3778 end
3779 else
3780 VCType := nil;
3781 Decl.Result := VcType;
3782 VCType := TPSProceduralType.Create;
3783 VCType.Name := FastUppercase(Name);
3784 VCType.OriginalName := Name;
3785 VCType.BaseType := btProcPtr;
3786 {$IFDEF PS_USESSUPPORT}
3787 VCType.DeclareUnit:=fModule;
3788 {$ENDIF}
3789 VCType.DeclarePos := FParser.CurrTokenPos;
3790 VCType.DeclareRow := FParser.Row;
3791 VCType.DeclareCol := FParser.Col;
3792 TPSProceduralType(VCType).ProcDef.Assign(Decl);
3793 FTypes.Add(VCType);
3794 Result := VCType;
3795 finally
3796 Decl.Free;
3797 end;
3798 end; {ReadTypeAddProcedure}
3799
3800
ReadTypenull3801 function TPSPascalCompiler.ReadType(const Name: tbtString; FParser: TPSPascalParser): TPSType; // InvalidVal = Invalid
3802 var
3803 TypeNo: TPSType;
3804 h, l: Longint;
3805 FieldName,fieldorgname,s: tbtString;
3806 RecSubVals: TPSList;
3807 FArrayStart, FArrayLength: Longint;
3808 rvv: PIFPSRecordFieldTypeDef;
3809 p, p2: TPSType;
3810 tempf: PIfRVariant;
3811 {$IFNDEF PS_NOINTERFACES}
3812 InheritedFrom: tbtString;
3813 Guid: TGUID;
3814 Intf: TPSInterface;
3815 {$ENDIF}
3816 begin
ornull3817 if (FParser.CurrTokenID = CSTII_Function) or (FParser.CurrTokenID = CSTII_Procedure) then
3818 begin
3819 Result := ReadTypeAddProcedure(Name, FParser);
3820 Exit;
3821 end else if FParser.CurrTokenId = CSTII_Set then
3822 begin
3823 FParser.Next;
3824 if FParser.CurrTokenId <> CSTII_Of then
3825 begin
3826 MakeError('', ecOfExpected, '');
3827 Result := nil;
3828 Exit;
3829 end;
3830 FParser.Next;
3831 if FParser.CurrTokenID <> CSTI_Identifier then
3832 begin
3833 MakeError('', ecIdentifierExpected, '');
3834 Result := nil;
3835 exit;
3836 end;
3837 TypeNo := FindType(FParser.GetToken);
3838 if TypeNo = nil then
3839 begin
3840 MakeError('', ecUnknownIdentifier, '');
3841 Result := nil;
3842 exit;
3843 end;
3844 if (TypeNo.BaseType = btEnum) or (TypeNo.BaseType = btChar) or (TypeNo.BaseType = btU8) then
3845 begin
3846 FParser.Next;
3847 p2 := TPSSetType.Create;
3848 p2.Name := FastUppercase(Name);
3849 p2.OriginalName := Name;
3850 p2.BaseType := btSet;
3851 {$IFDEF PS_USESSUPPORT}
3852 p2.DeclareUnit:=fModule;
3853 {$ENDIF}
3854 p2.DeclarePos := FParser.CurrTokenPos;
3855 p2.DeclareRow := FParser.Row;
3856 p2.DeclareCol := FParser.Col;
3857 TPSSetType(p2).SetType := TypeNo;
3858 FTypes.Add(p2);
3859 Result := p2;
3860 end else
3861 begin
3862 MakeError('', ecTypeMismatch, '');
3863 Result := nil;
3864 end;
3865 exit;
3866 end else if FParser.CurrTokenId = CSTI_OpenRound then
3867 begin
3868 FParser.Next;
3869 L := 0;
3870 P2 := TPSEnumType.Create;
3871 P2.Name := FastUppercase(Name);
3872 p2.OriginalName := Name;
3873 p2.BaseType := btEnum;
3874 {$IFDEF PS_USESSUPPORT}
3875 p2.DeclareUnit:=fModule;
3876 {$ENDIF}
3877 p2.DeclarePos := FParser.CurrTokenPos;
3878 p2.DeclareRow := FParser.Row;
3879 p2.DeclareCol := FParser.Col;
3880 FTypes.Add(p2);
3881
3882 repeat
3883 if FParser.CurrTokenId <> CSTI_Identifier then
3884 begin
3885 if FParser = Self.FParser then
3886 MakeError('', ecIdentifierExpected, '');
3887 Result := nil;
3888 exit;
3889 end;
3890 s := FParser.OriginalToken;
3891 if IsDuplicate(FastUppercase(s), [dcTypes]) then
3892 begin
3893 if FParser = Self.FParser then
3894 MakeError('', ecDuplicateIdentifier, s);
3895 Result := nil;
3896 Exit;
3897 end;
3898 with AddConstant(s, p2) do
3899 begin
3900 FValue.tu32 := L;
3901 {$IFDEF PS_USESSUPPORT}
3902 DeclareUnit:=fModule;
3903 {$ENDIF}
3904 DeclarePos:=FParser.CurrTokenPos;
3905 DeclareRow:=FParser.Row;
3906 DeclareCol:=FParser.Col;
3907 end;
3908 Inc(L);
3909 FParser.Next;
3910 if FParser.CurrTokenId = CSTI_CloseRound then
3911 Break
3912 else if FParser.CurrTokenId <> CSTI_Comma then
3913 begin
3914 if FParser = Self.FParser then
3915 MakeError('', ecCloseRoundExpected, '');
3916 Result := nil;
3917 Exit;
3918 end;
3919 FParser.Next;
3920 until False;
3921 FParser.Next;
3922 TPSEnumType(p2).HighValue := L-1;
3923 Result := p2;
3924 exit;
3925 end else
3926 if FParser.CurrTokenId = CSTII_Array then
3927 begin
3928 FParser.Next;
3929 if FParser.CurrTokenID = CSTI_OpenBlock then
3930 begin
3931 FParser.Next;
3932 tempf := ReadConstant(FParser, CSTI_TwoDots);
3933 if tempf = nil then
3934 begin
3935 Result := nil;
3936 exit;
3937 end;
3938 case tempf.FType.BaseType of
3939 btU8: FArrayStart := tempf.tu8;
3940 btS8: FArrayStart := tempf.ts8;
3941 btU16: FArrayStart := tempf.tu16;
3942 btS16: FArrayStart := tempf.ts16;
3943 btU32: FArrayStart := tempf.tu32;
3944 btS32: FArrayStart := tempf.ts32;
3945 {$IFNDEF PS_NOINT64}
3946 bts64: FArrayStart := tempf.ts64;
3947 {$ENDIF}
3948 else
3949 begin
3950 DisposeVariant(tempf);
3951 MakeError('', ecTypeMismatch, '');
3952 Result := nil;
3953 exit;
3954 end;
3955 end;
3956 DisposeVariant(tempf);
3957 if FParser.CurrTokenID <> CSTI_TwoDots then
3958 begin
3959 MakeError('', ecPeriodExpected, '');
3960 Result := nil;
3961 exit;
3962 end;
3963 FParser.Next;
3964 tempf := ReadConstant(FParser, CSTI_CloseBlock);
3965 if tempf = nil then
3966 begin
3967 Result := nil;
3968 exit;
3969 end;
3970 case tempf.FType.BaseType of
3971 btU8: FArrayLength := tempf.tu8;
3972 btS8: FArrayLength := tempf.ts8;
3973 btU16: FArrayLength := tempf.tu16;
3974 btS16: FArrayLength := tempf.ts16;
3975 btU32: FArrayLength := tempf.tu32;
3976 btS32: FArrayLength := tempf.ts32;
3977 {$IFNDEF PS_NOINT64}
3978 bts64: FArrayLength := tempf.ts64;
3979 {$ENDIF}
3980 else
3981 DisposeVariant(tempf);
3982 MakeError('', ecTypeMismatch, '');
3983 Result := nil;
3984 exit;
3985 end;
3986 DisposeVariant(tempf);
3987 FArrayLength := FArrayLength - FArrayStart + 1;
3988 if (FArrayLength < 0) or (FArrayLength > MaxInt div 4) then
3989 begin
3990 MakeError('', ecTypeMismatch, '');
3991 Result := nil;
3992 exit;
3993 end;
3994 if FParser.CurrTokenID <> CSTI_CloseBlock then
3995 begin
3996 MakeError('', ecCloseBlockExpected, '');
3997 Result := nil;
3998 exit;
3999 end;
4000 FParser.Next;
4001 end else
4002 begin
4003 FArrayStart := 0;
4004 FArrayLength := -1;
4005 end;
4006 if FParser.CurrTokenId <> CSTII_Of then
4007 begin
4008 if FParser = Self.FParser then
4009 MakeError('', ecOfExpected, '');
4010 Result := nil;
4011 exit;
4012 end;
4013 FParser.Next;
4014 TypeNo := ReadType('', FParser);
4015 if TypeNo = nil then
4016 begin
4017 if FParser = Self.FParser then
4018 MakeError('', ecUnknownIdentifier, '');
4019 Result := nil;
4020 exit;
4021 end;
4022 if (Name = '') and (FArrayLength = -1) then
4023 begin
4024 if TypeNo.Used then
4025 begin
4026 for h := 0 to FTypes.Count -1 do
4027 begin
4028 p := FTypes[H];
4029 if (p.BaseType = btArray) and (TPSArrayType(p).ArrayTypeNo = TypeNo) and (Copy(p.Name, 1, 1) <> '!') then
4030 begin
4031 Result := p;
4032 exit;
4033 end;
4034 end;
4035 end;
4036 end;
4037 if FArrayLength <> -1 then
4038 begin
4039 p := TPSStaticArrayType.Create;
4040 TPSStaticArrayType(p).StartOffset := FArrayStart;
4041 TPSStaticArrayType(p).Length := FArrayLength;
4042 p.BaseType := btStaticArray;
4043 end else
4044 begin
4045 p := TPSArrayType.Create;
4046 p.BaseType := btArray;
4047 end;
4048 p.Name := FastUppercase(Name);
4049 p.OriginalName := Name;
4050 {$IFDEF PS_USESSUPPORT}
4051 p.DeclareUnit:=fModule;
4052 {$ENDIF}
4053 p.DeclarePos := FParser.CurrTokenPos;
4054 p.DeclareRow := FParser.Row;
4055 p.DeclareCol := FParser.Col;
4056 TPSArrayType(p).ArrayTypeNo := TypeNo;
4057 FTypes.Add(p);
4058 Result := p;
4059 Exit;
4060 end
4061 else if FParser.CurrTokenId = CSTII_Record then
4062 begin
4063 FParser.Next;
4064 RecSubVals := TPSList.Create;
4065 repeat
4066 repeat
4067 if FParser.CurrTokenId <> CSTI_Identifier then
4068 begin
4069 ClearRecSubVals(RecSubVals);
4070 if FParser = Self.FParser then
4071 MakeError('', ecIdentifierExpected, '');
4072 Result := nil;
4073 exit;
4074 end;
4075 FieldName := FParser.GetToken;
4076 s := S+FParser.OriginalToken+'|';
4077 FParser.Next;
4078 h := MakeHash(FieldName);
4079 for l := 0 to RecSubVals.Count - 1 do
4080 begin
4081 if (PIFPSRecordFieldTypeDef(RecSubVals[l]).FieldNameHash = h) and
4082 (PIFPSRecordFieldTypeDef(RecSubVals[l]).FieldName = FieldName) then
4083 begin
4084 if FParser = Self.FParser then
4085 MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
4086 ClearRecSubVals(RecSubVals);
4087 Result := nil;
4088 exit;
4089 end;
4090 end;
4091 if FParser.CurrTokenID = CSTI_Colon then Break else
4092 if FParser.CurrTokenID <> CSTI_Comma then
4093 begin
4094 if FParser = Self.FParser then
4095 MakeError('', ecColonExpected, '');
4096 ClearRecSubVals(RecSubVals);
4097 Result := nil;
4098 exit;
4099 end;
4100 FParser.Next;
4101 until False;
4102 FParser.Next;
4103 p := ReadType('', FParser);
4104 if p = nil then
4105 begin
4106 ClearRecSubVals(RecSubVals);
4107 Result := nil;
4108 exit;
4109 end;
4110 p := GetTypeCopyLink(p);
4111 if FParser.CurrTokenId <> CSTI_Semicolon then
4112 begin
4113 ClearRecSubVals(RecSubVals);
4114 if FParser = Self.FParser then
4115 MakeError('', ecSemicolonExpected, '');
4116 Result := nil;
4117 exit;
4118 end; {if}
4119 FParser.Next;
4120 while Pos(tbtchar('|'), s) > 0 do
4121 begin
4122 fieldorgname := copy(s, 1, Pos(tbtchar('|'), s)-1);
4123 Delete(s, 1, length(FieldOrgName)+1);
4124 rvv := TPSRecordFieldTypeDef.Create;
4125 rvv.FieldOrgName := fieldorgname;
4126 rvv.FType := p;
4127 RecSubVals.Add(rvv);
4128 end;
4129 until FParser.CurrTokenId = CSTII_End;
4130 FParser.Next; // skip CSTII_End
4131 P := TPSRecordType.Create;
4132 p.Name := FastUppercase(Name);
4133 p.OriginalName := Name;
4134 p.BaseType := btRecord;
4135 {$IFDEF PS_USESSUPPORT}
4136 p.DeclareUnit:=fModule;
4137 {$ENDIF}
4138 p.DeclarePos := FParser.CurrTokenPos;
4139 p.DeclareRow := FParser.Row;
4140 p.DeclareCol := FParser.Col;
4141 for l := 0 to RecSubVals.Count -1 do
4142 begin
4143 rvv := RecSubVals[l];
4144 with TPSRecordType(p).AddRecVal do
4145 begin
4146 FieldOrgName := rvv.FieldOrgName;
4147 FType := rvv.FType;
4148 end;
4149 rvv.Free;
4150 end;
4151 RecSubVals.Free;
4152 FTypes.Add(p);
4153 Result := p;
4154 Exit;
4155 {$IFNDEF PS_NOINTERFACES}
4156 end else if FParser.CurrTokenId = CSTII_Interface then
4157 begin
4158 FParser.Next;
4159 if FParser.CurrTokenId <> CSTI_OpenRound then
4160 begin
4161 MakeError('', ecOpenRoundExpected, '');
4162 Result := nil;
4163 Exit;
4164 end;
4165 FParser.Next;
4166 if FParser.CurrTokenID <> CSTI_Identifier then
4167 begin
4168 MakeError('', ecIdentifierExpected, '');
4169 Result := nil;
4170 exit;
4171 end;
4172 InheritedFrom := FParser.GetToken;
4173 TypeNo := FindType(InheritedFrom);
4174 if TypeNo = nil then
4175 begin
4176 MakeError('', ecUnknownType, FParser.GetToken);
4177 Result := nil;
4178 exit;
4179 end;
4180 if TypeNo.BaseType <> btInterface then
4181 begin
4182 MakeError('', ecTypeMismatch, '');
4183 Result := nil;
4184 Exit;
4185 end;
4186 FParser.Next;
4187 if FParser.CurrTokenId <> CSTI_CloseRound then
4188 begin
4189 MakeError('', ecCloseRoundExpected, '');
4190 Result := nil;
4191 Exit;
4192 end;
4193 {$IFNDEF PS_NOINTERFACEGUIDBRACKETS}
4194 FParser.Next;
4195 if FParser.CurrTokenId <> CSTI_OpenBlock then
4196 begin
4197 MakeError('', ecOpenBlockExpected, '');
4198 Result := nil;
4199 Exit;
4200 end;
4201 {$ENDIF}
4202 FParser.Next;
4203 if FParser.CurrTokenId <> CSTI_String then
4204 begin
4205 MakeError('', ecStringExpected, '');
4206 Result := nil;
4207 Exit;
4208 end;
4209 s := FParser.GetToken;
4210 try
4211 Guid := StringToGuid(String(Copy(s, 2, Length(s)-2)));
4212 except
4213 on e: Exception do
4214 begin
4215 MakeError('', ecCustomError, tbtstring(e.Message));
4216 Result := nil;
4217 Exit;
4218 end;
4219 end;
4220 {$IFNDEF PS_NOINTERFACEGUIDBRACKETS}
4221 FParser.Next;
4222 if FParser.CurrTokenId <> CSTI_CloseBlock then
4223 begin
4224 MakeError('', ecCloseBlockExpected, '');
4225 Result := nil;
4226 Exit;
4227 end;
4228 {$ENDIF}
4229 Intf := AddInterface(FindInterface(InheritedFrom), Guid, Name);
4230 FParser.Next;
4231 repeat
4232 if not Intf.RegisterMethodEx('', cdStdCall, FParser) then begin
4233 MakeError('', ecCustomError, 'Invalid method');
4234 Result := nil;
4235 Exit;
4236 end;
4237 FParser.Next;
4238 until FParser.CurrTokenId = CSTII_End;
4239 FParser.Next; // skip CSTII_End
4240 Result := Intf.FType;
4241 Exit;
4242 {$ENDIF}
4243 end else if FParser.CurrTokenId = CSTI_Identifier then
4244 begin
4245 s := FParser.GetToken;
4246 h := MakeHash(s);
4247 Typeno := nil;
4248 for l := 0 to FTypes.Count - 1 do
4249 begin
4250 p2 := FTypes[l];
4251 if (p2.NameHash = h) and (p2.Name = s) then
4252 begin
4253 FParser.Next;
4254 Typeno := GetTypeCopyLink(p2);
4255 Break;
4256 end;
4257 end;
4258 if Typeno = nil then
4259 begin
4260 Result := nil;
4261 if FParser = Self.FParser then
4262 MakeError('', ecUnknownType, FParser.OriginalToken);
4263 exit;
4264 end;
4265 if Name <> '' then
4266 begin
4267 p := TPSTypeLink.Create;
4268 p.Name := FastUppercase(Name);
4269 p.OriginalName := Name;
4270 p.BaseType := BtTypeCopy;
4271 {$IFDEF PS_USESSUPPORT}
4272 p.DeclareUnit:=fModule;
4273 {$ENDIF}
4274 p.DeclarePos := FParser.CurrTokenPos;
4275 p.DeclareRow := FParser.Row;
4276 p.DeclareCol := FParser.Col;
4277 TPSTypeLink(p).LinkTypeNo := TypeNo;
4278 FTypes.Add(p);
4279 Result := p;
4280 Exit;
4281 end else
4282 begin
4283 Result := TypeNo;
4284 exit;
4285 end;
4286 end;
4287 Result := nil;
4288 if FParser = Self.FParser then
4289 MakeError('', ecIdentifierExpected, '');
4290 Exit;
4291 end;
4292
VarIsDuplicatenull4293 function TPSPascalCompiler.VarIsDuplicate(Proc: TPSInternalProcedure; const Varnames, s: tbtString): Boolean;
4294 var
4295 h, l: Longint;
4296 x: TPSProcedure;
4297 v: tbtString;
4298 begin
4299 h := MakeHash(s);
4300 if (s = 'RESULT') then
4301 begin
4302 Result := True;
4303 exit;
4304 end;
4305
4306 for l := FProcs.Count - 1 downto 0 do
4307 begin
4308 x := FProcs.Data[l];
4309 if x.ClassType = TPSInternalProcedure then
4310 begin
4311 if (h = TPSInternalProcedure(x).NameHash) and (s = TPSInternalProcedure(x).Name) then
4312 begin
4313 Result := True;
4314 exit;
4315 end;
4316 end
4317 else
4318 begin
4319 if (TPSExternalProcedure(x).RegProc.NameHash = h) and (TPSExternalProcedure(x).RegProc.Name = s) then
4320 begin
4321 Result := True;
4322 exit;
4323 end;
4324 end;
4325 end;
4326 if proc <> nil then
4327 begin
4328 for l := proc.ProcVars.Count - 1 downto 0 do
4329 begin
4330 if (PIFPSProcVar(proc.ProcVars.Data[l]).NameHash = h) and
4331 (PIFPSProcVar(proc.ProcVars.Data[l]).Name = s) then
4332 begin
4333 Result := True;
4334 exit;
4335 end;
4336 end;
4337 for l := Proc.FDecl.ParamCount -1 downto 0 do
4338 begin
4339 if (Proc.FDecl.Params[l].Name = s) then
4340 begin
4341 Result := True;
4342 exit;
4343 end;
4344 end;
4345 end
4346 else
4347 begin
4348 for l := FVars.Count - 1 downto 0 do
4349 begin
4350 if (TPSVar(FVars.Data[l]).NameHash = h) and
4351 (TPSVar(FVars.Data[l]).Name = s) then
4352 begin
4353 Result := True;
4354 exit;
4355 end;
4356 end;
4357 end;
4358 v := VarNames;
4359 while Pos(tbtchar('|'), v) > 0 do
4360 begin
4361 if FastUppercase(copy(v, 1, Pos(tbtchar('|'), v) - 1)) = s then
4362 begin
4363 Result := True;
4364 exit;
4365 end;
4366 Delete(v, 1, Pos(tbtchar('|'), v));
4367 end;
4368 for l := FConstants.Count -1 downto 0 do
4369 begin
4370 if (TPSConstant(FConstants.Data[l]).NameHash = h) and
4371 (TPSConstant(FConstants.Data[l]).Name = s) then
4372 begin
4373 Result := True;
4374 exit;
4375 end;
4376 end;
4377 Result := False;
4378 end;
4379
4380
TPSPascalCompiler.DoVarBlocknull4381 function TPSPascalCompiler.DoVarBlock(proc: TPSInternalProcedure): Boolean;
4382 var
4383 VarName, s: tbtString;
4384 VarType: TPSType;
4385 VarNo: Cardinal;
4386 v: TPSVar;
4387 vp: PIFPSProcVar;
4388 EPos, ERow, ECol: Integer;
4389 begin
4390 Result := False;
4391 FParser.Next; // skip CSTII_Var
4392 if FParser.CurrTokenId <> CSTI_Identifier then
4393 begin
4394 MakeError('', ecIdentifierExpected, '');
4395 exit;
4396 end;
4397 repeat
4398 VarNAme := '';
4399 if VarIsDuplicate(proc, VarName, FParser.GetToken) then
4400 begin
4401 MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
4402 exit;
4403 end;
4404 VarName := FParser.OriginalToken + '|';
4405 Varno := 0;
4406 if @FOnUseVariable <> nil then
4407 begin
4408 if Proc <> nil then
4409 FOnUseVariable(Self, ivtVariable, Proc.ProcVars.Count + VarNo, FProcs.Count -1, FParser.CurrTokenPos, '')
4410 else
4411 FOnUseVariable(Self, ivtGlobal, FVars.Count + VarNo, InvalidVal, FParser.CurrTokenPos, '')
4412 end;
4413 EPos:=FParser.CurrTokenPos;
4414 ERow:=FParser.Row;
4415 ECol:=FParser.Col;
4416 FParser.Next;
4417 while FParser.CurrTokenId = CSTI_Comma do
4418 begin
4419 FParser.Next;
4420 if FParser.CurrTokenId <> CSTI_Identifier then
4421 begin
4422 MakeError('', ecIdentifierExpected, '');
4423 end;
4424 if VarIsDuplicate(proc, VarName, FParser.GetToken) then
4425 begin
4426 MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
4427 exit;
4428 end;
4429 VarName := VarName + FParser.OriginalToken + '|';
4430 Inc(varno);
4431 if @FOnUseVariable <> nil then
4432 begin
4433 if Proc <> nil then
4434 FOnUseVariable(Self, ivtVariable, Proc.ProcVars.Count + VarNo, FProcs.Count -1, FParser.CurrTokenPos, '')
4435 else
4436 FOnUseVariable(Self, ivtGlobal, FVars.Count + VarNo, InvalidVal, FParser.CurrTokenPos, '')
4437 end;
4438 FParser.Next;
4439 end;
4440 if FParser.CurrTokenId <> CSTI_Colon then
4441 begin
4442 MakeError('', ecColonExpected, '');
4443 exit;
4444 end;
4445 FParser.Next;
4446 VarType := at2ut(ReadType('', FParser));
4447 if VarType = nil then
4448 begin
4449 exit;
4450 end;
4451 while Pos(tbtchar('|'), VarName) > 0 do
4452 begin
4453 s := copy(VarName, 1, Pos(tbtchar('|'), VarName) - 1);
4454 Delete(VarName, 1, Pos(tbtchar('|'), VarName));
4455 if proc = nil then
4456 begin
4457 v := TPSVar.Create;
4458 v.OrgName := s;
4459 v.Name := FastUppercase(s);
4460 {$IFDEF PS_USESSUPPORT}
4461 v.DeclareUnit:=fModule;
4462 {$ENDIF}
4463 v.DeclarePos := EPos;
4464 v.DeclareRow := ERow;
4465 v.DeclareCol := ECol;
4466 v.FType := VarType;
4467 FVars.Add(v);
4468 end
4469 else
4470 begin
4471 vp := TPSProcVar.Create;
4472 vp.OrgName := s;
4473 vp.Name := FastUppercase(s);
4474 vp.aType := VarType;
4475 {$IFDEF PS_USESSUPPORT}
4476 vp.DeclareUnit:=fModule;
4477 {$ENDIF}
4478 vp.DeclarePos := EPos;
4479 vp.DeclareRow := ERow;
4480 vp.DeclareCol := ECol;
4481 proc.ProcVars.Add(vp);
4482 end;
4483 end;
4484 if FParser.CurrTokenId <> CSTI_Semicolon then
4485 begin
4486 MakeError('', ecSemicolonExpected, '');
4487 exit;
4488 end;
4489 FParser.Next;
4490 until FParser.CurrTokenId <> CSTI_Identifier;
4491 Result := True;
4492 end;
4493
NewProcnull4494 function TPSPascalCompiler.NewProc(const OriginalName, Name: tbtString): TPSInternalProcedure;
4495 begin
4496 Result := TPSInternalProcedure.Create;
4497 Result.OriginalName := OriginalName;
4498 Result.Name := Name;
4499 {$IFDEF PS_USESSUPPORT}
4500 Result.DeclareUnit:=fModule;
4501 {$ENDIF}
4502 Result.DeclarePos := FParser.CurrTokenPos;
4503 Result.DeclareRow := FParser.Row;
4504 Result.DeclareCol := FParser.Col;
4505 FProcs.Add(Result);
4506 end;
4507
IsProcDuplicLabelnull4508 function TPSPascalCompiler.IsProcDuplicLabel(Proc: TPSInternalProcedure; const s: tbtString): Boolean;
4509 var
4510 i: Longint;
4511 h: Longint;
4512 u: tbtString;
4513 begin
4514 h := MakeHash(s);
4515 if s = 'RESULT' then
4516 Result := True
4517 else if Proc.Name = s then
4518 Result := True
4519 else if IsDuplicate(s, [dcVars, dcConsts, dcProcs]) then
4520 Result := True
4521 else
4522 begin
4523 for i := 0 to Proc.Decl.ParamCount -1 do
4524 begin
4525 if Proc.Decl.Params[i].Name = s then
4526 begin
4527 Result := True;
4528 exit;
4529 end;
4530 end;
4531 for i := 0 to Proc.ProcVars.Count -1 do
4532 begin
4533 if (PIFPSProcVar(Proc.ProcVars[I]).NameHash = h) and (PIFPSProcVar(Proc.ProcVars[I]).Name = s) then
4534 begin
4535 Result := True;
4536 exit;
4537 end;
4538 end;
4539 for i := 0 to Proc.FLabels.Count -1 do
4540 begin
4541 u := Proc.FLabels[I];
4542 delete(u, 1, 4);
4543 if Longint((@u[1])^) = h then
4544 begin
4545 delete(u, 1, 4);
4546 if u = s then
4547 begin
4548 Result := True;
4549 exit;
4550 end;
4551 end;
4552 end;
4553 Result := False;
4554 end;
4555 end;
4556
4557
ProcessLabelnull4558 function TPSPascalCompiler.ProcessLabel(Proc: TPSInternalProcedure): Boolean;
4559 var
4560 CurrLabel: tbtString;
4561 begin
4562 FParser.Next;
4563 while true do
4564 begin
4565 if FParser.CurrTokenId <> CSTI_Identifier then
4566 begin
4567 MakeError('', ecIdentifierExpected, '');
4568 Result := False;
4569 exit;
4570 end;
4571 CurrLabel := FParser.GetToken;
4572 if IsProcDuplicLabel(Proc, CurrLabel) then
4573 begin
4574 MakeError('', ecDuplicateIdentifier, CurrLabel);
4575 Result := False;
4576 exit;
4577 end;
4578 FParser.Next;
4579 Proc.FLabels.Add(#$FF#$FF#$FF#$FF+PS_mi2s(MakeHash(CurrLabel))+CurrLabel);
4580 if FParser.CurrTokenId = CSTI_Semicolon then
4581 begin
4582 FParser.Next;
4583 Break;
4584 end;
4585 if FParser.CurrTokenId <> CSTI_Comma then
4586 begin
4587 MakeError('', ecCommaExpected, '');
4588 Result := False;
4589 exit;
4590 end;
4591 FParser.Next;
4592 end;
4593 Result := True;
4594 end;
4595
4596 procedure TPSPascalCompiler.Debug_SavePosition(ProcNo: Cardinal; Proc: TPSInternalProcedure);
4597 var
4598 Row,
4599 Col,
4600 Pos: Cardinal;
4601 s: tbtString;
4602 begin
4603 Row := FParser.Row;
4604 Col := FParser.Col;
4605 Pos := FParser.CurrTokenPos;
4606 {$IFNDEF PS_USESSUPPORT}
4607 s := '';
4608 {$ELSE}
4609 s := fModule;
4610 {$ENDIF}
4611 if @FOnTranslateLineInfo <> nil then
4612 FOnTranslateLineInfo(Self, Pos, Row, Col, S);
4613 {$IFDEF FPC}
4614 WriteDebugData(#4 + s + #1);
4615 WriteDebugData(Ps_mi2s(ProcNo));
4616 WriteDebugData(Ps_mi2s(Length(Proc.Data)));
4617 WriteDebugData(Ps_mi2s(Pos));
4618 WriteDebugData(Ps_mi2s(Row));
4619 WriteDebugData(Ps_mi2s(Col));
4620 {$ELSE}
4621 WriteDebugData(#4 + s + #1 + PS_mi2s(ProcNo) + PS_mi2s(Length(Proc.Data)) + PS_mi2s(Pos) + PS_mi2s(Row)+ PS_mi2s(Col));
4622 {$ENDIF}
4623 end;
4624
4625 procedure TPSPascalCompiler.Debug_WriteParams(ProcNo: Cardinal; Proc: TPSInternalProcedure);
4626 var
4627 I: Longint;
4628 s: tbtString;
4629 begin
4630 s := #2 + PS_mi2s(ProcNo);
4631 if Proc.Decl.Result <> nil then
4632 begin
4633 s := s + 'Result' + #1;
4634 end;
4635 for i := 0 to Proc.Decl.ParamCount -1 do
4636 s := s + Proc.Decl.Params[i].OrgName + #1;
4637 s := s + #0#3 + PS_mi2s(ProcNo);
4638 for I := 0 to Proc.ProcVars.Count - 1 do
4639 begin
4640 s := s + PIFPSProcVar(Proc.ProcVars[I]).OrgName + #1;
4641 end;
4642 s := s + #0;
4643 WriteDebugData(s);
4644 end;
4645
4646 procedure TPSPascalCompiler.CheckForUnusedVars(Func: TPSInternalProcedure);
4647 var
4648 i: Integer;
4649 p: PIFPSProcVar;
4650 begin
4651 for i := 0 to Func.ProcVars.Count -1 do
4652 begin
4653 p := Func.ProcVars[I];
4654 if not p.Used then
4655 begin
4656 with MakeHint({$IFDEF PS_USESSUPPORT}p.DeclareUnit{$ELSE}''{$ENDIF}, ehVariableNotUsed, p.Name) do
4657 begin
4658 FRow := p.DeclareRow;
4659 FCol := p.DeclareCol;
4660 FPosition := p.DeclarePos;
4661 end;
4662 end;
4663 end;
4664 if (not Func.ResultUsed) and (Func.Decl.Result <> nil) then
4665 begin
4666 with MakeHint({$IFDEF PS_USESSUPPORT}Func.DeclareUnit{$ELSE}''{$ENDIF}, ehVariableNotUsed, 'Result') do
4667 begin
4668 FRow := Func.DeclareRow;
4669 FCol := Func.DeclareCol;
4670 FPosition := Func.DeclarePos;
4671 end;
4672 end;
4673 end;
4674
TPSPascalCompiler.ProcIsDuplicnull4675 function TPSPascalCompiler.ProcIsDuplic(Decl: TPSParametersDecl; const FunctionName, FunctionParamNames: tbtString; const s: tbtString; Func: TPSInternalProcedure): Boolean;
4676 var
4677 i: Longint;
4678 u: tbtString;
4679 begin
4680 if s = 'RESULT' then
4681 Result := True
4682 else if FunctionName = s then
4683 Result := True
4684 else
4685 begin
4686 for i := 0 to Decl.ParamCount -1 do
4687 begin
4688 if Decl.Params[i].Name = s then
4689 begin
4690 Result := True;
4691 exit;
4692 end;
4693 GRFW(u);
4694 end;
4695 u := FunctionParamNames;
4696 while Pos(tbtchar('|'), u) > 0 do
4697 begin
4698 if copy(u, 1, Pos(tbtchar('|'), u) - 1) = s then
4699 begin
4700 Result := True;
4701 exit;
4702 end;
4703 Delete(u, 1, Pos(tbtchar('|'), u));
4704 end;
4705 if Func = nil then
4706 begin
4707 result := False;
4708 exit;
4709 end;
4710 for i := 0 to Func.ProcVars.Count -1 do
4711 begin
4712 if s = PIFPSProcVar(Func.ProcVars[I]).Name then
4713 begin
4714 Result := True;
4715 exit;
4716 end;
4717 end;
4718 for i := 0 to Func.FLabels.Count -1 do
4719 begin
4720 u := Func.FLabels[I];
4721 delete(u, 1, 4);
4722 if u = s then
4723 begin
4724 Result := True;
4725 exit;
4726 end;
4727 end;
4728 Result := False;
4729 end;
4730 end;
4731 procedure WriteProcVars(Func:TPSInternalProcedure; t: TPSList);
4732 var
4733 l: Longint;
4734 v: PIFPSProcVar;
4735 begin
4736 for l := 0 to t.Count - 1 do
4737 begin
4738 v := t[l];
4739 Func.Data := Func.Data + chr(cm_pt)+ PS_mi2s(v.AType.FinalTypeNo);
4740 end;
4741 end;
4742
4743
ApplyAttribsToFunctionnull4744 function TPSPascalCompiler.ApplyAttribsToFunction(func: TPSProcedure): boolean;
4745 var
4746 i: Longint;
4747 begin
4748 for i := 0 to Func.Attributes.Count -1 do
4749 begin
4750 if @Func.Attributes.Items[i].AType.OnApplyAttributeToProc <> nil then
4751 begin
4752 if not Func.Attributes.Items[i].AType.OnApplyAttributeToProc(Self, Func, Func.Attributes.Items[i]) then
4753 begin
4754 Result := false;
4755 exit;
4756 end;
4757 end;
4758 end;
4759 result := true;
4760 end;
4761
4762
ProcessFunctionnull4763 function TPSPascalCompiler.ProcessFunction(AlwaysForward: Boolean; Att: TPSAttributes): Boolean;
4764 var
4765 FunctionType: TFuncType;
4766 OriginalName, FunctionName: tbtString;
4767 FunctionParamNames: tbtString;
4768 FunctionTempType: TPSType;
4769 ParamNo: Cardinal;
4770 FunctionDecl: TPSParametersDecl;
4771 modifier: TPSParameterMode;
4772 Func: TPSInternalProcedure;
4773 F2: TPSProcedure;
4774 EPos, ECol, ERow: Cardinal;
4775 E2Pos, E2Col, E2Row: Cardinal;
4776 pp: TPSRegProc;
4777 pp2: TPSExternalProcedure;
4778 FuncNo, I: Longint;
4779 Block: TPSBlockInfo;
4780 begin
4781 if att = nil then
4782 begin
4783 Att := TPSAttributes.Create;
4784 if not ReadAttributes(Att) then
4785 begin
4786 att.free;
4787 Result := false;
4788 exit;
4789 end;
4790 end;
4791
4792 if FParser.CurrTokenId = CSTII_Procedure then
4793 FunctionType := ftProc
4794 else
4795 FunctionType := ftFunc;
4796 Func := nil;
4797 EPos := FParser.CurrTokenPos;
4798 ERow := FParser.Row;
4799 ECol := FParser.Col;
4800 FParser.Next;
4801 Result := False;
4802 if FParser.CurrTokenId <> CSTI_Identifier then
4803 begin
4804 MakeError('', ecIdentifierExpected, '');
4805 att.free;
4806 exit;
4807 end;
4808 if assigned(FOnFunctionStart) then
4809 {$IFDEF PS_USESSUPPORT}
4810 FOnFunctionStart(fModule + '.' + FParser.OriginalToken, EPos, ERow, ECol);
4811 {$ELSE}
4812 FOnFunctionStart(FParser.OriginalToken, EPos, ERow, ECol);
4813 {$ENDIF}
4814 EPos := FParser.CurrTokenPos;
4815 ERow := FParser.Row;
4816 ECol := FParser.Col;
4817 OriginalName := FParser.OriginalToken;
4818 FunctionName := FParser.GetToken;
4819 FuncNo := -1;
4820 for i := 0 to FProcs.Count -1 do
4821 begin
4822 f2 := FProcs[I];
4823 if (f2.ClassType = TPSInternalProcedure) and (TPSInternalProcedure(f2).Name = FunctionName) and (TPSInternalProcedure(f2).Forwarded) then
4824 begin
4825 Func := FProcs[I];
4826 FuncNo := i;
4827 Break;
4828 end;
4829 end;
4830 if (Func = nil) and IsDuplicate(FunctionName, [dcTypes, dcProcs, dcVars, dcConsts]) then
4831 begin
4832 att.free;
4833 MakeError('', ecDuplicateIdentifier, FunctionName);
4834 exit;
4835 end;
4836 FParser.Next;
4837 FunctionDecl := TPSParametersDecl.Create;
4838 try
4839 if FParser.CurrTokenId = CSTI_OpenRound then
4840 begin
4841 FParser.Next;
4842 if FParser.CurrTokenId = CSTI_CloseRound then
4843 begin
4844 FParser.Next;
4845 end
4846 else
4847 begin
4848 if FunctionType = ftFunc then
4849 ParamNo := 1
4850 else
4851 ParamNo := 0;
4852 while True do
4853 begin
4854 if FParser.CurrTokenId = CSTII_Const then
4855 begin
4856 modifier := pmIn;
4857 FParser.Next;
4858 end
4859 else
4860 if FParser.CurrTokenId = CSTII_Out then
4861 begin
4862 modifier := pmOut;
4863 FParser.Next;
4864 end
4865 else
4866 if FParser.CurrTokenId = CSTII_Var then
4867 begin
4868 modifier := pmInOut;
4869 FParser.Next;
4870 end
4871 else
4872 modifier := pmIn;
4873 if FParser.CurrTokenId <> CSTI_Identifier then
4874 begin
4875 MakeError('', ecIdentifierExpected, '');
4876 exit;
4877 end;
4878 E2Pos := FParser.CurrTokenPos;
4879 E2Row := FParser.Row;
4880 E2Col := FParser.Col;
4881 FunctionParamNames := '';
4882 if ProcIsDuplic(FunctionDecl, FunctionName, FunctionParamNames, FParser.GetToken, Func) then
4883 begin
4884 MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
4885 exit;
4886 end;
4887 FunctionParamNames := FParser.OriginalToken + '|';
4888 if @FOnUseVariable <> nil then
4889 begin
4890 FOnUseVariable(Self, ivtParam, ParamNo, FProcs.Count, FParser.CurrTokenPos, '');
4891 end;
4892 inc(ParamNo);
4893 FParser.Next;
4894 while FParser.CurrTokenId = CSTI_Comma do
4895 begin
4896 FParser.Next;
4897 if FParser.CurrTokenId <> CSTI_Identifier then
4898 begin
4899 MakeError('', ecIdentifierExpected, '');
4900 exit;
4901 end;
4902 if ProcIsDuplic(FunctionDecl, FunctionName, FunctionParamNames, FParser.GetToken, Func) then
4903 begin
4904 MakeError('', ecDuplicateIdentifier, '');
4905 exit;
4906 end;
4907 if @FOnUseVariable <> nil then
4908 begin
4909 FOnUseVariable(Self, ivtParam, ParamNo, FProcs.Count, FParser.CurrTokenPos, '');
4910 end;
4911 inc(ParamNo);
4912 FunctionParamNames := FunctionParamNames + FParser.OriginalToken +
4913 '|';
4914 FParser.Next;
4915 end;
4916 if FParser.CurrTokenId <> CSTI_Colon then
4917 begin
4918 MakeError('', ecColonExpected, '');
4919 exit;
4920 end;
4921 FParser.Next;
4922 FunctionTempType := at2ut(ReadType('', FParser));
4923 if FunctionTempType = nil then
4924 begin
4925 exit;
4926 end;
4927 while Pos(tbtchar('|'), FunctionParamNames) > 0 do
4928 begin
4929 with FunctionDecl.AddParam do
4930 begin
4931 OrgName := copy(FunctionParamNames, 1, Pos(tbtchar('|'), FunctionParamNames) - 1);
4932 Mode := modifier;
4933 aType := FunctionTempType;
4934 {$IFDEF PS_USESSUPPORT}
4935 DeclareUnit:=fModule;
4936 {$ENDIF}
4937 DeclarePos:=E2Pos;
4938 DeclareRow:=E2Row;
4939 DeclareCol:=E2Col;
4940 end;
4941 Delete(FunctionParamNames, 1, Pos(tbtchar('|'), FunctionParamNames));
4942 end;
4943 if FParser.CurrTokenId = CSTI_CloseRound then
4944 break;
4945 if FParser.CurrTokenId <> CSTI_Semicolon then
4946 begin
4947 MakeError('', ecSemicolonExpected, '');
4948 exit;
4949 end;
4950 FParser.Next;
4951 end;
4952 FParser.Next;
4953 end;
4954 end;
4955 if FunctionType = ftFunc then
4956 begin
4957 if FParser.CurrTokenId <> CSTI_Colon then
4958 begin
4959 MakeError('', ecColonExpected, '');
4960 exit;
4961 end;
4962 FParser.Next;
4963 FunctionTempType := at2ut(ReadType('', FParser));
4964 if FunctionTempType = nil then
4965 exit;
4966 FunctionDecl.Result := FunctionTempType;
4967 end;
4968 if FParser.CurrTokenId <> CSTI_Semicolon then
4969 begin
4970 MakeError('', ecSemicolonExpected, '');
4971 exit;
4972 end;
4973 FParser.Next;
4974 if (Func = nil) and (FParser.CurrTokenID = CSTII_External) then
4975 begin
4976 FParser.Next;
4977 if FParser.CurrTokenID <> CSTI_String then
4978 begin
4979 MakeError('', ecStringExpected, '');
4980 exit;
4981 end;
4982 FunctionParamNames := FParser.GetToken;
4983 FunctionParamNames := copy(FunctionParamNames, 2, length(FunctionParamNames) - 2);
4984 FParser.Next;
4985 if FParser.CurrTokenID <> CSTI_Semicolon then
4986 begin
4987 MakeError('', ecSemicolonExpected, '');
4988 exit;
4989 end;
4990 FParser.Next;
4991 if @FOnExternalProc = nil then
4992 begin
4993 MakeError('', ecSemicolonExpected, '');
4994 exit;
4995 end;
4996 pp := FOnExternalProc(Self, FunctionDecl, OriginalName, FunctionParamNames);
4997 if pp = nil then
4998 begin
4999 MakeError('', ecCustomError, '');
5000 exit;
5001 end;
5002 pp2 := TPSExternalProcedure.Create;
5003 pp2.Attributes.Assign(att, true);
5004 pp2.RegProc := pp;
5005 FProcs.Add(pp2);
5006 FRegProcs.Add(pp);
p2null5007 Result := ApplyAttribsToFunction(pp2);
5008 Exit;
5009 end else if (FParser.CurrTokenID = CSTII_Forward) or AlwaysForward then
5010 begin
5011 if Func <> nil then
5012 begin
5013 MakeError('', ecBeginExpected, '');
5014 exit;
5015 end;
5016 if not AlwaysForward then
5017 begin
5018 FParser.Next;
5019 if FParser.CurrTokenID <> CSTI_Semicolon then
5020 begin
5021 MakeError('', ecSemicolonExpected, '');
5022 Exit;
5023 end;
5024 FParser.Next;
5025 end;
5026 Func := NewProc(OriginalName, FunctionName);
5027 Func.Attributes.Assign(Att, True);
5028 Func.Forwarded := True;
5029 {$IFDEF PS_USESSUPPORT}
5030 Func.FDeclareUnit := fModule;
5031 {$ENDIF}
5032 Func.FDeclarePos := EPos;
5033 Func.FDeclareRow := ERow;
5034 Func.FDeclarePos := ECol;
5035 Func.Decl.Assign(FunctionDecl);
uncnull5036 Result := ApplyAttribsToFunction(Func);
5037 exit;
5038 end;
5039 if (Func = nil) then
5040 begin
5041 Func := NewProc(OriginalName, FunctionName);
5042 Func.Attributes.Assign(att, True);
5043 Func.Decl.Assign(FunctionDecl);
5044 {$IFDEF PS_USESSUPPORT}
5045 Func.FDeclareUnit := fModule;
5046 {$ENDIF}
5047 Func.FDeclarePos := EPos;
5048 Func.FDeclareRow := ERow;
5049 Func.FDeclareCol := ECol;
5050 FuncNo := FProcs.Count -1;
uncnull5051 if not ApplyAttribsToFunction(Func) then
5052 begin
5053 result := false;
5054 exit;
5055 end;
5056 end else begin
5057 if not FunctionDecl.Same(Func.Decl) then
5058 begin
5059 MakeError('', ecForwardParameterMismatch, '');
5060 Result := false;
5061 exit;
5062 end;
5063 Func.Forwarded := False;
5064 end;
5065 if FParser.CurrTokenID = CSTII_Export then
5066 begin
5067 FParser.Next;
5068 if FParser.CurrTokenID <> CSTI_Semicolon then
5069 begin
5070 MakeError('', ecSemicolonExpected, '');
5071 exit;
5072 end;
5073 FParser.Next;
5074 end;
5075 while FParser.CurrTokenId <> CSTII_Begin do
5076 begin
5077 if FParser.CurrTokenId = CSTII_Var then
5078 begin
5079 if not DoVarBlock(Func) then
5080 exit;
5081 end else if FParser.CurrTokenId = CSTII_Label then
5082 begin
5083 if not ProcessLabel(Func) then
5084 Exit;
5085 end else
5086 begin
5087 MakeError('', ecBeginExpected, '');
5088 exit;
5089 end;
5090 end;
5091 Debug_WriteParams(FuncNo, Func);
5092 WriteProcVars(Func, Func.ProcVars);
5093 Block := TPSBlockInfo.Create(FGlobalBlock);
5094 Block.SubType := tProcBegin;
5095 Block.ProcNo := FuncNo;
5096 Block.Proc := Func;
5097 if not ProcessSub(Block) then
5098 begin
5099 Block.Free;
5100 exit;
5101 end;
5102 Block.Free;
5103 CheckForUnusedVars(Func);
5104 Result := ProcessLabelForwards(Func);
5105 if assigned(FOnFunctionEnd) then
5106 {$IFDEF PS_USESSUPPORT}
5107 OnFunctionEnd(fModule + '.' + OriginalName, FParser.CurrTokenPos, FParser.Row, FParser.Col);
5108 {$ELSE}
5109 OnFunctionEnd(OriginalName, FParser.CurrTokenPos, FParser.Row, FParser.Col);
5110 {$ENDIF}
5111 finally
5112 FunctionDecl.Free;
5113 att.Free;
5114 end;
5115 end;
5116
GetParamTypenull5117 function GetParamType(BlockInfo: TPSBlockInfo; I: Longint): TPSType;
5118 begin
5119 if BlockInfo.Proc.Decl.Result <> nil then dec(i);
5120 if i = -1 then
5121 Result := BlockInfo.Proc.Decl.Result
5122 else
5123 begin
5124 Result := BlockInfo.Proc.Decl.Params[i].aType;
5125 end;
5126 end;
5127
GetTypeNonull5128 function TPSPascalCompiler.GetTypeNo(BlockInfo: TPSBlockInfo; p: TPSValue): TPSType;
5129 begin
5130 if p.ClassType = TPSUnValueOp then
5131 Result := TPSUnValueOp(p).aType
5132 else if p.ClassType = TPSBinValueOp then
5133 Result := TPSBinValueOp(p).aType
5134 else if p.ClassType = TPSValueArray then
5135 Result := at2ut(FindType('TVariantArray'))
5136 else if p.ClassType = TPSValueData then
5137 Result := TPSValueData(p).Data.FType
5138 else if p is TPSValueProc then
5139 Result := TPSValueProc(p).ResultType
5140 else if (p is TPSValueVar) and (TPSValueVar(p).RecCount > 0) then
5141 Result := TPSValueVar(p).RecItem[TPSValueVar(p).RecCount - 1].aType
5142 else if p.ClassType = TPSValueGlobalVar then
5143 Result := TPSVar(FVars[TPSValueGlobalVar(p).GlobalVarNo]).FType
5144 else if p.ClassType = TPSValueParamVar then
5145 Result := GetParamType(BlockInfo, TPSValueParamVar(p).ParamNo)
5146 else if p is TPSValueLocalVar then
5147 Result := TPSProcVar(BlockInfo.Proc.ProcVars[TPSValueLocalVar(p).LocalVarNo]).AType
5148 else if p.classtype = TPSValueReplace then
5149 Result := GetTypeNo(BlockInfo, TPSValueReplace(p).NewValue)
5150 else
5151 Result := nil;
5152 end;
5153
IsVarInCompatiblenull5154 function TPSPascalCompiler.IsVarInCompatible(ft1, ft2: TPSType): Boolean;
5155 begin
5156 ft1 := GetTypeCopyLink(ft1);
5157 ft2 := GetTypeCopyLink(ft2);
5158 Result := (ft1 <> ft2) and (ft2 <> nil);
5159 end;
5160
ValidateParametersnull5161 function TPSPascalCompiler.ValidateParameters(BlockInfo: TPSBlockInfo; Params: TPSParameters; ParamTypes: TPSParametersDecl): boolean;
5162 var
5163 i, c: Longint;
5164 pType: TPSType;
5165
5166 begin
5167 UseProc(ParamTypes);
5168 c := 0;
5169 for i := 0 to ParamTypes.ParamCount -1 do
5170 begin
5171 while (c < Longint(Params.Count)) and (Params[c].Val = nil) do
5172 Inc(c);
5173 if c >= Longint(Params.Count) then
5174 begin
5175 MakeError('', ecInvalidnumberOfParameters, '');
5176 Result := False;
5177 exit;
5178 end;
5179 Params[c].ExpectedType := ParamTypes.Params[i].aType;
5180 Params[c].ParamMode := ParamTypes.Params[i].Mode;
5181 if ParamTypes.Params[i].Mode <> pmIn then
5182 begin
5183 if not (Params[c].Val is TPSValueVar) then
5184 begin
5185 with MakeError('', ecVariableExpected, '') do
5186 begin
5187 Row := Params[c].Val.Row;
5188 Col := Params[c].Val.Col;
5189 Pos := Params[c].Val.Pos;
5190 end;
5191 result := false;
5192 exit;
5193 end;
5194 PType := Params[c].ExpectedType;
5195 if (PType = nil) or ((PType.BaseType = btArray) and (TPSArrayType(PType).ArrayTypeNo = nil) and (GetTypeNo(BlockInfo, Params[c].Val).BaseType = btArray)) or
5196 (PType = FAnyString) then
5197 begin
5198 Params[c].ExpectedType := GetTypeNo(BlockInfo, Params[c].Val);
5199 if PType <> nil then
5200 if (Params[c].ExpectedType = nil) or not (Params[c].ExpectedType.BaseType in [btString,
5201 {$IFNDEF PS_NOWIDESTRING}btWideString, btUnicodeString, btWideChar,{$ENDIF}
5202 btChar]) then begin
5203 MakeError('', ecTypeMismatch, '');
5204 Result := False;
5205 exit;
5206 end;
5207 if Params[c].ExpectedType.BaseType = btChar then
5208 Params[c].ExpectedType := FindBaseType(btString) else
5209 {$IFNDEF PS_NOWIDESTRING}
5210 if Params[c].ExpectedType.BaseType = btWideChar then
5211 Params[c].ExpectedType := FindBaseType(btUnicodeString);
5212 {$ENDIF}
5213 end else if (PType.BaseType = btArray) and (GetTypeNo(BlockInfo, Params[c].Val).BaseType = btArray) then
5214 begin
5215 if TPSArrayType(GetTypeNo(BlockInfo, Params[c].Val)).ArrayTypeNo <> TPSArrayType(PType).ArrayTypeNo then
5216 begin
5217 MakeError('', ecTypeMismatch, '');
5218 Result := False;
5219 exit;
5220 end;
5221 end else if IsVarInCompatible(PType, GetTypeNo(BlockInfo, Params[c].Val)) then
5222 begin
5223 MakeError('', ecTypeMismatch, '');
5224 Result := False;
5225 exit;
5226 end;
5227 end;
5228 Inc(c);
5229 end;
5230 for i := c to Params.Count -1 do
5231 begin
5232 if Params[i].Val <> nil then
5233 begin
5234 MakeError('', ecInvalidnumberOfParameters, '');
5235 Result := False;
5236 exit;
5237 end;
5238 end;
5239 Result := true;
5240 end;
5241
DoTypeBlocknull5242 function TPSPascalCompiler.DoTypeBlock(FParser: TPSPascalParser): Boolean;
5243 var
5244 VOrg,VName: tbtString;
5245 Attr: TPSAttributes;
5246 FType: TPSType;
5247 i: Longint;
5248 begin
5249 Result := False;
5250 FParser.Next;
5251 repeat
5252 Attr := TPSAttributes.Create;
5253 if not ReadAttributes(Attr) then
5254 begin
5255 Attr.Free;
5256 exit;
5257 end;
5258 if (FParser.CurrTokenID = CSTII_Procedure) or (FParser.CurrTokenID = CSTII_Function) then
5259 begin
5260 Result := ProcessFunction(false, Attr);
5261 exit;
5262 end;
5263 if FParser.CurrTokenId <> CSTI_Identifier then
5264 begin
5265 MakeError('', ecIdentifierExpected, '');
5266 Attr.Free;
5267 exit;
5268 end;
5269
5270 VName := FParser.GetToken;
5271 VOrg := FParser.OriginalToken;
5272 if IsDuplicate(VName, [dcTypes, dcProcs, dcVars]) then
5273 begin
5274 MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
5275 Attr.Free;
5276 exit;
5277 end;
5278
5279 FParser.Next;
5280 if FParser.CurrTokenId <> CSTI_Equal then
5281 begin
5282 MakeError('', ecIsExpected, '');
5283 Attr.Free;
5284 exit;
5285 end;
5286 FParser.Next;
5287 FType := ReadType(VOrg, FParser);
5288 if Ftype = nil then
5289 begin
5290 Attr.Free;
5291 Exit;
5292 end;
5293 FType.Attributes.Assign(Attr, True);
5294 for i := 0 to FType.Attributes.Count -1 do
5295 begin
5296 if @FType.Attributes[i].FAttribType.FAAType <> nil then
5297 FType.Attributes[i].FAttribType.FAAType(Self, FType, Attr[i]);
5298 end;
5299 Attr.Free;
5300 if FParser.CurrTokenID <> CSTI_Semicolon then
5301 begin
5302 MakeError('', ecSemicolonExpected, '');
5303 Exit;
5304 end;
5305 FParser.Next;
5306 until (FParser.CurrTokenId <> CSTI_Identifier) and (FParser.CurrTokenID <> CSTI_OpenBlock);
5307 Result := True;
5308 end;
5309
5310 procedure TPSPascalCompiler.Debug_WriteLine(BlockInfo: TPSBlockInfo);
5311 var
5312 b: Boolean;
5313 begin
5314 if @FOnWriteLine <> nil then begin
5315 {$IFNDEF PS_USESSUPPORT}
5316 b := FOnWriteLine(Self, FParser.CurrTokenPos);
5317 {$ELSE}
5318 b := FOnWriteLine(Self, FModule, FParser.CurrTokenPos);
5319 {$ENDIF}
5320 end else
5321 b := true;
5322 if b then Debug_SavePosition(BlockInfo.ProcNo, BlockInfo.Proc);
5323 end;
5324
5325
TPSPascalCompiler.ReadRealnull5326 function TPSPascalCompiler.ReadReal(const s: tbtString): PIfRVariant;
5327 var
5328 C: Integer;
5329 begin
5330 New(Result);
5331 InitializeVariant(Result, FindBaseType(btExtended));
5332 Val(string(s), Result^.textended, C);
5333 end;
5334
ReadStringnull5335 function TPSPascalCompiler.ReadString: PIfRVariant;
5336 {$IFNDEF PS_NOWIDESTRING}var wchar: Boolean;{$ENDIF}
5337
ParseStringnull5338 function ParseString({$IFNDEF PS_NOWIDESTRING}var res: tbtunicodestring{$ELSE}var res: tbtString{$ENDIF}): Boolean;
5339 var
5340 temp3: {$IFNDEF PS_NOWIDESTRING}tbtunicodestring{$ELSE}tbtString{$ENDIF};
5341
ChrToStrnull5342 function ChrToStr(s: tbtString): {$IFNDEF PS_NOWIDESTRING}widechar{$ELSE}tbtchar{$ENDIF};
5343 var
5344 w: Longint;
5345 begin
5346 Delete(s, 1, 1); {First char : #}
5347 w := StrToInt(s);
5348 Result := {$IFNDEF PS_NOWIDESTRING}widechar{$ELSE}tbtchar{$ENDIF}(w);
5349 {$IFNDEF PS_NOWIDESTRING}if w > $FF then wchar := true;{$ENDIF}
5350 end;
5351
PStringnull5352 function PString(s: tbtString): tbtString;
5353 var
5354 i: Longint;
5355 begin
5356 s := copy(s, 2, Length(s) - 2);
5357 i := length(s);
5358 while i > 0 do
5359 begin
5360 if (i < length(s)) and (s[i] = #39) and (s[i + 1] = #39) then
5361 begin
5362 Delete(s, i, 1);
5363 dec(i);
5364 end;
5365 dec(i);
5366 end;
5367 PString := s;
5368 end;
5369 var
5370 lastwasstring: Boolean;
5371 begin
5372 temp3 := '';
5373 while (FParser.CurrTokenId = CSTI_String) or (FParser.CurrTokenId = CSTI_Char) do
5374 begin
5375 lastwasstring := FParser.CurrTokenId = CSTI_String;
5376 if FParser.CurrTokenId = CSTI_String then
5377 begin
5378 if UTF8Decode then
5379 begin
5380 temp3 := temp3 + {$IFNDEF PS_NOWIDESTRING}{$IFDEF DELPHI6UP}System.{$IFDEF DELPHI2009UP}UTF8ToWidestring{$ELSE}UTF8Decode{$ENDIF}{$ENDIF}{$ENDIF}(PString(FParser.GetToken));
5381 {$IFNDEF PS_NOWIDESTRING}wchar:=true;{$ENDIF}
5382 end else
5383 temp3 := temp3 + {$IFNDEF PS_NOWIDESTRING}tbtUnicodestring{$ENDIF}(PString(FParser.GetToken));
5384
5385 FParser.Next;
5386 if FParser.CurrTokenId = CSTI_String then
5387 temp3 := temp3 + #39;
5388 end {if}
5389 else
5390 begin
5391 temp3 := temp3 + ChrToStr(FParser.GetToken);
5392 FParser.Next;
5393 end; {else if}
5394 if lastwasstring and (FParser.CurrTokenId = CSTI_String) then
5395 begin
5396 MakeError('', ecSyntaxError, '');
5397 result := false;
5398 exit;
5399 end;
5400 end; {while}
5401 res := temp3;
5402 result := true;
5403 end;
5404 var
5405 {$IFNDEF PS_NOWIDESTRING}
5406 w: tbtunicodestring;
5407 {$ENDIF}
5408 s: tbtString;
5409 begin
5410 {$IFNDEF PS_NOWIDESTRING}wchar:=false;{$ENDIF}
5411 if not ParseString({$IFDEF PS_NOWIDESTRING} s {$ELSE} w {$ENDIF}) then
5412 begin
5413 result := nil;
5414 exit;
5415 end;
5416 {$IFNDEF PS_NOWIDESTRING}
5417 if wchar then
5418 begin
5419 New(Result);
5420 if Length(w) = 1 then
5421 begin
5422 InitializeVariant(Result, at2ut(FindBaseType(btwidechar)));
5423 Result^.twidechar := w[1];
5424 end else begin
5425 InitializeVariant(Result, at2ut(FindBaseType(btUnicodeString)));
5426 tbtunicodestring(Result^.tunistring) := w;
5427 end;
5428 end else begin
5429 s := tbtstring(w);
5430 {$ENDIF}
5431 New(Result);
5432 if Length(s) = 1 then
5433 begin
5434 InitializeVariant(Result, at2ut(FindBaseType(btchar)));
5435 Result^.tchar := s[1];
5436 end else begin
5437 InitializeVariant(Result, at2ut(FindBaseType(btstring)));
5438 tbtstring(Result^.tstring) := s;
5439 end;
5440 {$IFNDEF PS_NOWIDESTRING}
5441 end;
5442 {$ENDIF}
5443 end;
5444
5445
TPSPascalCompiler.ReadIntegernull5446 function TPSPascalCompiler.ReadInteger(const s: tbtString): PIfRVariant;
5447 var
5448 R: {$IFNDEF PS_NOINT64}Int64;{$ELSE}Longint;{$ENDIF}
5449 begin
5450 New(Result);
5451 {$IFNDEF PS_NOINT64}
5452 r := StrToInt64Def(string(s), 0);
5453 if (r >= Low(Integer)) and (r <= High(Integer)) then
5454 begin
5455 InitializeVariant(Result, at2ut(FindBaseType(bts32)));
5456 Result^.ts32 := r;
5457 end else if (r <= $FFFFFFFF) then
5458 begin
5459 InitializeVariant(Result, at2ut(FindBaseType(btu32)));
5460 Result^.tu32 := r;
5461 end else
5462 begin
5463 InitializeVariant(Result, at2ut(FindBaseType(bts64)));
5464 Result^.ts64 := r;
5465 end;
5466 {$ELSE}
5467 r := StrToIntDef(s, 0);
5468 InitializeVariant(Result, at2ut(FindBaseType(bts32)));
5469 Result^.ts32 := r;
5470 {$ENDIF}
5471 end;
5472
TPSPascalCompiler.ProcessSubnull5473 function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
5474
AllocStackReg2null5475 function AllocStackReg2(MType: TPSType): TPSValue;
5476 var
5477 x: TPSProcVar;
5478 begin
5479 {$IFDEF DEBUG}
5480 if (mtype = nil) or (not mtype.Used) then asm int 3; end;
5481 {$ENDIF}
5482 x := TPSProcVar.Create;
5483 {$IFDEF PS_USESSUPPORT}
5484 x.DeclareUnit:=fModule;
5485 {$ENDIF}
5486 x.DeclarePos := FParser.CurrTokenPos;
5487 x.DeclareRow := FParser.Row;
5488 x.DeclareCol := FParser.Col;
5489 x.Name := '';
5490 x.AType := MType;
5491 x.Use;
5492 BlockInfo.Proc.ProcVars.Add(x);
5493 Result := TPSValueAllocatedStackVar.Create;
5494 Result.SetParserPos(FParser);
5495 TPSValueAllocatedStackVar(Result).Proc := BlockInfo.Proc;
5496 with TPSValueAllocatedStackVar(Result) do
5497 begin
5498 LocalVarNo := proc.ProcVars.Count -1;
5499 end;
5500 end;
5501
AllocStackRegnull5502 function AllocStackReg(MType: TPSType): TPSValue;
5503 begin
5504 Result := AllocStackReg2(MType);
5505 BlockWriteByte(BlockInfo, Cm_Pt);
5506 BlockWriteLong(BlockInfo, MType.FinalTypeNo);
5507 end;
5508
AllocPointernull5509 function AllocPointer(MDestType: TPSType): TPSValue;
5510 begin
5511 Result := AllocStackReg(at2ut(FindBaseType(btPointer)));
5512 TPSProcVar(BlockInfo.Proc.ProcVars[TPSValueAllocatedStackVar(Result).LocalVarNo]).AType := MDestType;
5513 end;
5514
5515 function WriteCalculation(InData, OutReg: TPSValue): Boolean; forward;
5516 function PreWriteOutRec(var X: TPSValue; FArrType: TPSType): Boolean; forward;
5517 function WriteOutRec(x: TPSValue; AllowData: Boolean): Boolean; forward;
5518 procedure AfterWriteOutRec(var x: TPSValue); forward;
5519
CheckCompatTypenull5520 function CheckCompatType(V1, v2: TPSValue): Boolean;
5521 var
5522 p1, P2: TPSType;
5523 begin
5524 p1 := GetTypeNo(BlockInfo, V1);
5525 P2 := GetTypeNo(BlockInfo, v2);
5526 if (p1 = nil) or (p2 = nil) then
5527 begin
5528 if ((p1 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p1.ClassType = TPSInterfaceType) or {$ENDIF}(p1.BaseType = btProcPtr)) and (v2.ClassType = TPSValueNil)) or
5529 ((p2 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p2.ClassType = TPSInterfaceType) or {$ENDIF}(p2.BaseType = btProcPtr)) and (v1.ClassType = TPSValueNil)) then
5530 begin
5531 Result := True;
5532 exit;
5533 end else
5534 if ((p1 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p1.ClassType = TPSInterfaceType) or {$ENDIF}(p1.ClassType = TPSClassType)) and (v2.ClassType = TPSValueNil)) or
5535 ((p2 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p2.ClassType = TPSInterfaceType) or {$ENDIF}(p2.ClassType = TPSClassType)) and (v1.ClassType = TPSValueNil)) then
5536 begin
5537 Result := True;
5538 exit;
5539 end else
5540 if ((p1 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p1.ClassType = TPSInterfaceType) or {$ENDIF}(p1.ClassType = TPSUndefinedClassType)) and (v2.ClassType = TPSValueNil)) or
5541 ((p2 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p2.ClassType = TPSInterfaceType) or {$ENDIF}(p2.ClassType = TPSUndefinedClassType)) and (v1.ClassType = TPSValueNil)) then
5542 begin
5543 Result := True;
5544 exit;
5545 end else
5546 if (v1.ClassType = TPSValueProcPtr) and (p2 <> nil) and (p2.BaseType = btProcPtr) then
5547 begin
5548 Result := CheckCompatProc(p2, TPSValueProcPtr(v1).ProcPtr);
5549 exit;
5550 end else if (v2.ClassType = TPSValueProcPtr) and (p1 <> nil) and (p1.BaseType = btProcPtr) then
5551 begin
5552 Result := CheckCompatProc(p1, TPSValueProcPtr(v2).ProcPtr);
5553 exit;
5554 end;
5555 Result := False;
5556 end else
5557 if (p1 <> nil) and (p1.BaseType = btSet) and (v2 is TPSValueArray) then
5558 begin
5559 Result := True;
5560 end else
5561 Result := IsCompatibleType(p1, p2, False);
5562 end;
5563
5564 function _ProcessFunction(ProcCall: TPSValueProc; ResultRegister: TPSValue): Boolean; forward;
ProcessFunction2null5565 function ProcessFunction2(ProcNo: Cardinal; Par: TPSParameters; ResultReg: TPSValue): Boolean;
5566 var
5567 Temp: TPSValueProcNo;
5568 i: Integer;
5569 begin
5570 Temp := TPSValueProcNo.Create;
5571 Temp.Parameters := Par;
5572 Temp.ProcNo := ProcNo;
5573 if TObject(FProcs[ProcNo]).ClassType = TPSInternalProcedure then
5574 Temp.ResultType := TPSInternalProcedure(FProcs[ProcNo]).Decl.Result
5575 else
5576 Temp.ResultType := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl.Result;
5577 if (Temp.ResultType <> nil) and (Temp.ResultType = FAnyString) then begin // workaround to make the result type match
5578 for i := 0 to Par.Count -1 do begin
5579 if Par[i].ExpectedType.BaseType in [btString{$IFNDEF PS_NOWIDESTRING}, btWideString{$ENDIF}] then
5580 Temp.ResultType := Par[i].ExpectedType;
5581 end;
5582 end;
empnull5583 Result := _ProcessFunction(Temp, ResultReg);
5584 Temp.Parameters := nil;
5585 Temp.Free;
5586 end;
5587
MakeNilnull5588 function MakeNil(NilPos, NilRow, nilCol: Cardinal;ivar: TPSValue): Boolean;
5589 var
5590 Procno: Cardinal;
5591 PF: TPSType;
5592 Par: TPSParameters;
5593 begin
5594 Pf := GetTypeNo(BlockInfo, IVar);
5595 if not (Ivar is TPSValueVar) then
5596 begin
5597 with MakeError('', ecTypeMismatch, '') do
5598 begin
5599 FPosition := nilPos;
5600 FRow := NilRow;
5601 FCol := nilCol;
5602 end;
5603 Result := False;
5604 exit;
5605 end;
5606 if (pf.BaseType = btProcPtr) then
5607 begin
5608 Result := True;
5609 end else
5610 if (pf.BaseType = btString) or (pf.BaseType = btPChar) then
5611 begin
5612 if not PreWriteOutRec(iVar, nil) then
5613 begin
5614 Result := false;
5615 exit;
5616 end;
5617 BlockWriteByte(BlockInfo, CM_A);
5618 WriteOutRec(ivar, False);
5619 BlockWriteByte(BlockInfo, 1);
5620 BlockWriteLong(BlockInfo, GetTypeNo(BlockInfo, IVar).FinalTypeNo);
5621 BlockWriteLong(BlockInfo, 0); //empty tbtString
5622 AfterWriteOutRec(ivar);
5623 Result := True;
5624 end else if (pf.BaseType = btClass) {$IFNDEF PS_NOINTERFACES}or (pf.BaseType = btInterface){$ENDIF} then
5625 begin
5626 {$IFNDEF PS_NOINTERFACES}
5627 if (pf.BaseType = btClass) then
5628 begin
5629 {$ENDIF}
5630 if not TPSClassType(pf).Cl.SetNil(ProcNo) then
5631 begin
5632 with MakeError('', ecTypeMismatch, '') do
5633 begin
5634 FPosition := nilPos;
5635 FRow := NilRow;
5636 FCol := nilCol;
5637 end;
5638 Result := False;
5639 exit;
5640 end;
5641 {$IFNDEF PS_NOINTERFACES}
5642 end else
5643 begin
5644 if not TPSInterfaceType(pf).Intf.SetNil(ProcNo) then
5645 begin
5646 with MakeError('', ecTypeMismatch, '') do
5647 begin
5648 FPosition := nilPos;
5649 FRow := NilRow;
5650 FCol := nilCol;
5651 end;
5652 Result := False;
5653 exit;
5654 end;
5655 end;
5656 {$ENDIF}
5657 Par := TPSParameters.Create;
5658 with par.Add do
5659 begin
5660 Val := IVar;
5661 ExpectedType := GetTypeNo(BlockInfo, ivar);
5662 {$IFDEF DEBUG}
5663 if not ExpectedType.Used then asm int 3; end;
5664 {$ENDIF}
5665 ParamMode := pmInOut;
5666 end;
5667 Result := ProcessFunction2(ProcNo, Par, nil);
5668
5669 Par[0].Val := nil; // don't free IVAR
5670
5671 Par.Free;
5672 end else if pf.BaseType = btExtClass then
5673 begin
5674 if not TPSUndefinedClassType(pf).ExtClass.SetNil(ProcNo) then
5675 begin
5676 with MakeError('', ecTypeMismatch, '') do
5677 begin
5678 FPosition := nilPos;
5679 FRow := NilRow;
5680 FCol := nilCol;
5681 end;
5682 Result := False;
5683 exit;
5684 end;
5685 Par := TPSParameters.Create;
5686 with par.Add do
5687 begin
5688 Val := IVar;
5689 ExpectedType := GetTypeNo(BlockInfo, ivar);
5690 ParamMode := pmInOut;
5691 end;
5692 Result := ProcessFunction2(ProcNo, Par, nil);
5693
5694 Par[0].Val := nil; // don't free IVAR
5695
5696 Par.Free;
5697 end else begin
5698 with MakeError('', ecTypeMismatch, '') do
5699 begin
5700 FPosition := nilPos;
5701 FRow := NilRow;
5702 FCol := nilCol;
5703 end;
5704 Result := False;
5705 end;
5706 end;
DoBinCalcnull5707 function DoBinCalc(BVal: TPSBinValueOp; Output: TPSValue): Boolean;
5708 var
5709 tmpp, tmpc: TPSValue;
5710 jend, jover: Cardinal;
5711 procno: Cardinal;
5712
5713 begin
5714 if BVal.Operator >= otGreaterEqual then
5715 begin
5716 if BVal.FVal1.ClassType = TPSValueNil then
5717 begin
5718 tmpp := AllocStackReg(GetTypeNo(BlockInfo, BVal.FVal2));
5719 if not MakeNil(BVal.FVal1.Pos, BVal.FVal1.Row, BVal.FVal1.Col, tmpp) then
5720 begin
5721 tmpp.Free;
5722 Result := False;
5723 exit;
5724 end;
5725 tmpc := TPSValueReplace.Create;
5726 with TPSValueReplace(tmpc) do
5727 begin
5728 OldValue := BVal.FVal1;
5729 NewValue := tmpp;
5730 end;
5731 BVal.FVal1 := tmpc;
5732 end;
5733 if BVal.FVal2.ClassType = TPSValueNil then
5734 begin
5735 tmpp := AllocStackReg(GetTypeNo(BlockInfo, BVal.FVal1));
5736 if not MakeNil(BVal.FVal2.Pos, BVal.FVal2.Row, BVal.FVal2.Col, tmpp) then
5737 begin
5738 tmpp.Free;;
5739 Result := False;
5740 exit;
5741 end;
5742 tmpc := TPSValueReplace.Create;
5743 with TPSValueReplace(tmpc) do
5744 begin
5745 OldValue := BVal.FVal2;
5746 NewValue := tmpp;
5747 end;
5748 BVal.FVal2 := tmpc;
5749 end;
5750 if GetTypeNo(BlockInfo, BVal.FVal1).BaseType = btExtClass then
5751 begin
5752 if not TPSUndefinedClassType(GetTypeNo(BlockInfo, BVal.FVal1)).ExtClass.CompareClass(GetTypeNo(BlockInfo, Bval.FVal2), ProcNo) then
5753 begin
5754 Result := False;
5755 exit;
5756 end;
5757 tmpp := TPSValueProcNo.Create;
5758 with TPSValueProcNo(tmpp) do
5759 begin
5760 ResultType := at2ut(FDefaultBoolType);
5761 Parameters := TPSParameters.Create;
5762 ProcNo := procno;
5763 Pos := BVal.Pos;
5764 Col := BVal.Col;
5765 Row := BVal.Row;
5766 with parameters.Add do
5767 begin
5768 Val := BVal.FVal1;
5769 ExpectedType := GetTypeNo(BlockInfo, Val);
5770 end;
5771 with parameters.Add do
5772 begin
5773 Val := BVal.FVal2;
5774 ExpectedType := GetTypeNo(BlockInfo, Val);
5775 end;
5776 end;
5777 if Bval.Operator = otNotEqual then
5778 begin
5779 tmpc := TPSUnValueOp.Create;
5780 TPSUnValueOp(tmpc).Operator := otNot;
5781 TPSUnValueOp(tmpc).Val1 := tmpp;
5782 TPSUnValueOp(tmpc).aType := GetTypeNo(BlockInfo, tmpp);
5783 end else tmpc := tmpp;
5784 Result := WriteCalculation(tmpc, Output);
5785 with TPSValueProcNo(tmpp) do
5786 begin
5787 Parameters[0].Val := nil;
5788 Parameters[1].Val := nil;
5789 end;
5790 tmpc.Free;
5791 if BVal.Val1.ClassType = TPSValueReplace then
5792 begin
5793 tmpp := TPSValueReplace(BVal.Val1).OldValue;
5794 BVal.Val1.Free;
5795 BVal.Val1 := tmpp;
5796 end;
5797 if BVal.Val2.ClassType = TPSValueReplace then
5798 begin
5799 tmpp := TPSValueReplace(BVal.Val2).OldValue;
5800 BVal.Val2.Free;
5801 BVal.Val2 := tmpp;
5802 end;
5803 exit;
5804 end;
5805 if not (PreWriteOutRec(Output, nil) and PreWriteOutRec(BVal.FVal1, GetTypeNo(BlockInfo, BVal.FVal2)) and PreWriteOutRec(BVal.FVal2, GetTypeNo(BlockInfo, BVal.FVal1))) then
5806 begin
5807 Result := False;
5808 exit;
5809 end;
5810 BlockWriteByte(BlockInfo, CM_CO);
5811 case BVal.Operator of
5812 otGreaterEqual: BlockWriteByte(BlockInfo, 0);
5813 otLessEqual: BlockWriteByte(BlockInfo, 1);
5814 otGreater: BlockWriteByte(BlockInfo, 2);
5815 otLess: BlockWriteByte(BlockInfo, 3);
5816 otEqual: BlockWriteByte(BlockInfo, 5);
5817 otNotEqual: BlockWriteByte(BlockInfo, 4);
5818 otIn: BlockWriteByte(BlockInfo, 6);
5819 otIs: BlockWriteByte(BlockInfo, 7);
5820 end;
5821
5822 if not (WriteOutRec(Output, False) and writeOutRec(BVal.FVal1, True) and writeOutRec(BVal.FVal2, True)) then
5823 begin
5824 Result := False;
5825 exit;
5826 end;
5827 AfterWriteOutrec(BVal.FVal1);
5828 AfterWriteOutrec(BVal.FVal2);
5829 AfterWriteOutrec(Output);
5830 if BVal.Val1.ClassType = TPSValueReplace then
5831 begin
5832 tmpp := TPSValueReplace(BVal.Val1).OldValue;
5833 BVal.Val1.Free;
5834 BVal.Val1 := tmpp;
5835 end;
5836 if BVal.Val2.ClassType = TPSValueReplace then
5837 begin
5838 tmpp := TPSValueReplace(BVal.Val2).OldValue;
5839 BVal.Val2.Free;
5840 BVal.Val2 := tmpp;
5841 end;
5842 end else begin
5843 if (BVal.aType <> nil) and (BVal.aType <> GetTypeNo(BlockInfo, Output)) then begin
5844 tmpp := AllocStackReg(BVal.aType);
5845 PreWriteOutrec(tmpp, nil);
5846 DoBinCalc(BVal, tmpp);
5847 afterwriteoutrec(tmpp);
5848 result := WriteCalculation(tmpp, output);
5849 tmpp.Free;
5850 exit;
5851 end;
5852
5853 if not PreWriteOutRec(Output, nil) then
5854 begin
5855 Result := False;
5856 exit;
5857 end;
5858 if not SameReg(Output, BVal.Val1) then
5859 begin
5860 if not WriteCalculation(BVal.FVal1, Output) then
5861 begin
5862 Result := False;
5863 exit;
5864 end;
5865 end;
5866 if (FBooleanShortCircuit) and (IsBoolean(BVal.aType)) then
5867 begin
5868 if BVal.Operator = otAnd then
5869 begin
5870 BlockWriteByte(BlockInfo, Cm_CNG);
5871 jover := Length(BlockInfo.Proc.FData);
5872 BlockWriteLong(BlockInfo, 0);
5873 WriteOutRec(Output, True);
5874 jend := Length(BlockInfo.Proc.FData);
5875 end else if BVal.Operator = otOr then
5876 begin
5877 BlockWriteByte(BlockInfo, Cm_CG);
5878 jover := Length(BlockInfo.Proc.FData);
5879 BlockWriteLong(BlockInfo, 0);
5880 WriteOutRec(Output, True);
5881 jend := Length(BlockInfo.Proc.FData);
5882 end else
5883 begin
5884 jover := 0;
5885 jend := 0;
5886 end;
5887 end else
5888 begin
5889 jover := 0;
5890 jend := 0;
5891 end;
5892 if not PreWriteOutrec(BVal.FVal2, GetTypeNo(BlockInfo, Output)) then
5893 begin
5894 Result := False;
5895 exit;
5896 end;
5897 BlockWriteByte(BlockInfo, Cm_CA);
5898 if BVAL.Operator = otIntDiv then
5899 BlockWriteByte(BlockInfo, Ord(otDiv))
5900 else
5901 BlockWriteByte(BlockInfo, Ord(BVal.Operator));
5902 if not (WriteOutRec(Output, False) and WriteOutRec(BVal.FVal2, True)) then
5903 begin
5904 Result := False;
5905 exit;
5906 end;
5907 AfterWriteOutRec(BVal.FVal2);
5908 if FBooleanShortCircuit and (IsBoolean(BVal.aType)) and (JOver <> JEnd) then
5909 begin
5910 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
5911 unaligned(Cardinal((@BlockInfo.Proc.FData[jover+1])^)) := Cardinal(Length(BlockInfo.Proc.FData)) - jend;
5912 {$else}
5913 Cardinal((@BlockInfo.Proc.FData[jover+1])^) := Cardinal(Length(BlockInfo.Proc.FData)) - jend;
5914 {$endif}
5915 end;
5916 AfterWriteOutRec(Output);
5917 end;
5918 Result := True;
5919 end;
5920
DoUnCalcnull5921 function DoUnCalc(Val: TPSUnValueOp; Output: TPSValue): Boolean;
5922 var
5923 Tmp: TPSValue;
5924 begin
5925 if not PreWriteOutRec(Output, nil) then
5926 begin
5927 Result := False;
5928 exit;
5929 end;
5930 case Val.Operator of
5931 otNot:
5932 begin
5933 if not SameReg(Val.FVal1, Output) then
5934 begin
5935 if not WriteCalculation(Val.FVal1, Output) then
5936 begin
5937 Result := False;
5938 exit;
5939 end;
5940 end;
5941 if IsBoolean(GetTypeNo(BlockInfo, Val)) then
5942 BlockWriteByte(BlockInfo, cm_bn)
5943 else
5944 BlockWriteByte(BlockInfo, cm_in);
5945 if not WriteOutRec(Output, True) then
5946 begin
5947 Result := False;
5948 exit;
5949 end;
5950 end;
5951 otMinus:
5952 begin
5953 if not SameReg(Val.FVal1, Output) then
5954 begin
5955 if not WriteCalculation(Val.FVal1, Output) then
5956 begin
5957 Result := False;
5958 exit;
5959 end;
5960 end;
5961 BlockWriteByte(BlockInfo, cm_vm);
5962 if not WriteOutRec(Output, True) then
5963 begin
5964 Result := False;
5965 exit;
5966 end;
5967 end;
5968 otCast:
5969 begin
5970 if ((Val.aType.BaseType = btChar) and (Val.aType.BaseType <> btU8)) {$IFNDEF PS_NOWIDESTRING}or
5971 ((Val.aType.BaseType = btWideChar) and (Val.aType.BaseType <> btU16)){$ENDIF} then
5972 begin
5973 Tmp := AllocStackReg(Val.aType);
5974 end else
5975 Tmp := Output;
5976 if not (PreWriteOutRec(Val.FVal1, GetTypeNo(BlockInfo, Tmp)) and PreWriteOutRec(Tmp, GetTypeNo(BlockInfo, Tmp))) then
5977 begin
5978 Result := False;
5979 if tmp <> Output then Tmp.Free;
5980 exit;
5981 end;
5982 BlockWriteByte(BlockInfo, CM_A);
5983 if not (WriteOutRec(Tmp, False) and WriteOutRec(Val.FVal1, True)) then
5984 begin
5985 Result := false;
5986 if tmp <> Output then Tmp.Free;
5987 exit;
5988 end;
5989 AfterWriteOutRec(val.Fval1);
5990 if Tmp <> Output then
5991 begin
5992 if not WriteCalculation(Tmp, Output) then
5993 begin
5994 Result := false;
5995 Tmp.Free;
5996 exit;
5997 end;
5998 end;
5999 AfterWriteOutRec(Tmp);
6000 if Tmp <> Output then
6001 Tmp.Free;
6002 end;
6003 {else donothing}
6004 end;
6005 AfterWriteOutRec(Output);
6006 Result := True;
6007 end;
6008
6009
GetAddressnull6010 function GetAddress(Val: TPSValue): Cardinal;
6011 begin
6012 if Val.ClassType = TPSValueGlobalVar then
6013 Result := TPSValueGlobalVar(val).GlobalVarNo
6014 else if Val.ClassType = TPSValueLocalVar then
6015 Result := PSAddrStackStart + TPSValueLocalVar(val).LocalVarNo + 1
6016 else if Val.ClassType = TPSValueParamVar then
6017 Result := PSAddrStackStart - TPSValueParamVar(val).ParamNo -1
6018 else if Val.ClassType = TPSValueAllocatedStackVar then
6019 Result := PSAddrStackStart + TPSValueAllocatedStackVar(val).LocalVarNo + 1
6020 else
6021 Result := InvalidVal;
6022 end;
6023
6024
PreWriteOutRecnull6025 function PreWriteOutRec(var X: TPSValue; FArrType: TPSType): Boolean;
6026 var
6027 rr: TPSSubItem;
6028 tmpp,
6029 tmpc: TPSValue;
6030 i: Longint;
MakeSetnull6031 function MakeSet(SetType: TPSSetType; arr: TPSValueArray): Boolean;
6032 var
6033 c, i: Longint;
6034 dataval: TPSValueData;
6035 mType: TPSType;
6036 begin
6037 Result := True;
6038 dataval := TPSValueData.Create;
6039 dataval.Data := NewVariant(FarrType);
6040 for i := 0 to arr.count -1 do
6041 begin
6042 mType := GetTypeNo(BlockInfo, arr.Item[i]);
6043 if (mType <> SetType.SetType) and not (IsIntType(mType.FBaseType) and IsIntType(SetType.SetType.BaseType)) then
6044 begin
6045 with MakeError('', ecTypeMismatch, '') do
6046 begin
6047 FCol := arr.item[i].Col;
6048 FRow := arr.item[i].Row;
6049 FPosition := arr.item[i].Pos;
6050 end;
6051 DataVal.Free;
6052 Result := False;
6053 exit;
6054 end;
6055 if arr.Item[i] is TPSValueData then
6056 begin
6057 c := GetInt(TPSValueData(arr.Item[i]).Data, Result);
6058 if not Result then
6059 begin
6060 dataval.Free;
6061 exit;
6062 end;
6063 if (c < Low(Byte)) or (c > High(Byte)) then
6064 begin
6065 with MakeError('', ecTypeMismatch, '') do
6066 begin
6067 FCol := arr.item[i].Col;
6068 FRow := arr.item[i].Row;
6069 FPosition := arr.item[i].Pos;
6070 end;
6071 DataVal.Free;
6072 Result := False;
6073 exit;
6074 end;
6075 Set_MakeMember(c, dataval.Data.tstring);
6076 end else
6077 begin
6078 DataVal.Free;
6079 MakeError('', ecTypeMismatch, '');
6080 Result := False;
6081 exit;
6082 end;
6083 end;
6084 tmpc := TPSValueReplace.Create;
6085 with TPSValueReplace(tmpc) do
6086 begin
6087 OldValue := x;
6088 NewValue := dataval;
6089 PreWriteAllocated := True;
6090 end;
6091 x := tmpc;
6092 end;
6093 begin
6094 Result := True;
6095 if x.ClassType = TPSValueReplace then
6096 begin
6097 if TPSValueReplace(x).PreWriteAllocated then
6098 begin
6099 inc(TPSValueReplace(x).FReplaceTimes);
6100 end;
6101 end else
6102 if x.ClassType = TPSValueProcPtr then
6103 begin
6104 if FArrType = nil then
6105 begin
6106 MakeError('', ecTypeMismatch, '');
6107 Result := False;
6108 Exit;
6109 end;
6110 tmpp := TPSValueData.Create;
6111 TPSValueData(tmpp).Data := NewVariant(FArrType);
6112 TPSValueData(tmpp).Data.tu32 := TPSValueProcPtr(x).ProcPtr;
6113 tmpc := TPSValueReplace.Create;
6114 with TPSValueReplace(tmpc) do
6115 begin
6116 PreWriteAllocated := True;
6117 OldValue := x;
6118 NewValue := tmpp;
6119 end;
6120 x := tmpc;
6121 end else
6122 if x.ClassType = TPSValueNil then
6123 begin
6124 if FArrType = nil then
6125 begin
6126 MakeError('', ecTypeMismatch, '');
6127 Result := False;
6128 Exit;
6129 end;
6130 tmpp := AllocStackReg(FArrType);
6131 if not MakeNil(x.Pos, x.Row, x.Col, tmpp) then
6132 begin
6133 tmpp.Free;
6134 Result := False;
6135 exit;
6136 end;
6137 tmpc := TPSValueReplace.Create;
6138 with TPSValueReplace(tmpc) do
6139 begin
6140 PreWriteAllocated := True;
6141 OldValue := x;
6142 NewValue := tmpp;
6143 end;
6144 x := tmpc;
6145 end else
6146 if x.ClassType = TPSValueArray then
6147 begin
6148 if FArrType = nil then
6149 begin
6150 MakeError('', ecTypeMismatch, '');
6151 Result := False;
6152 Exit;
6153 end;
6154 if TPSType(FArrType).BaseType = btSet then
6155 begin
6156 Result := MakeSet(TPSSetType(FArrType), TPSValueArray(x));
6157 exit;
6158 end;
6159 if TPSType(FarrType).BaseType = btVariant then
6160 FArrType := at2ut(FindAndAddType(self, '!OPENARRAYOFVARIANT', 'array of Variant'));
6161 if TPSType(FarrType).BaseType <> btArray then
6162 FArrType := at2ut(FindAndAddType(self, '!OPENARRAYOFVARIANT', 'array of Variant'));
6163
6164 tmpp := AllocStackReg(FArrType);
6165 tmpc := AllocStackReg(FindBaseType(bts32));
6166 BlockWriteByte(BlockInfo, CM_A);
6167 WriteOutrec(tmpc, False);
6168 BlockWriteByte(BlockInfo, 1);
6169 BlockWriteLong(BlockInfo, FindBaseType(bts32).FinalTypeNo);
6170 BlockWriteLong(BlockInfo, TPSValueArray(x).Count);
6171 BlockWriteByte(BlockInfo, CM_PV);
6172 WriteOutrec(tmpp, False);
6173 BlockWriteByte(BlockInfo, CM_C);
6174 BlockWriteLong(BlockInfo, FindProc('SetArrayLength'));
6175 BlockWriteByte(BlockInfo, CM_PO);
6176 tmpc.Free;
6177 rr := TPSSubNumber.Create;
6178 rr.aType := TPSArrayType(FArrType).ArrayTypeNo;
6179 TPSValueVar(tmpp).RecAdd(rr);
6180 for i := 0 to TPSValueArray(x).Count -1 do
6181 begin
6182 TPSSubNumber(rr).SubNo := i;
6183 tmpc := TPSValueArray(x).Item[i];
6184 if not PreWriteOutRec(tmpc, GetTypeNo(BlockInfo, tmpc)) then
6185 begin
6186 tmpp.Free;
6187 Result := false;
6188 exit;
6189 end;
6190 if TPSArrayType(FArrType).ArrayTypeNo.BaseType = btPointer then
6191 BlockWriteByte(BlockInfo, cm_spc)
6192 else
6193 BlockWriteByte(BlockInfo, cm_a);
6194 if not (WriteOutrec(tmpp, False) and WriteOutRec(tmpc, True)) then
6195 begin
6196 Tmpp.Free;
6197 Result := false;
6198 exit;
6199 end;
6200 AfterWriteOutRec(tmpc);
6201 end;
6202 TPSValueVar(tmpp).RecDelete(0);
6203 tmpc := TPSValueReplace.Create;
6204 with TPSValueReplace(tmpc) do
6205 begin
6206 PreWriteAllocated := True;
6207 OldValue := x;
6208 NewValue := tmpp;
6209 end;
6210 x := tmpc;
6211 end else if (x.ClassType = TPSUnValueOp) then
6212 begin
6213 tmpp := AllocStackReg(GetTypeNo(BlockInfo, x));
6214 if not DoUnCalc(TPSUnValueOp(x), tmpp) then
6215 begin
6216 Result := False;
6217 exit;
6218 end;
6219 tmpc := TPSValueReplace.Create;
6220 with TPSValueReplace(tmpc) do
6221 begin
6222 PreWriteAllocated := True;
6223 OldValue := x;
6224 NewValue := tmpp;
6225 end;
6226 x := tmpc;
6227 end else if (x.ClassType = TPSBinValueOp) then
6228 begin
6229 tmpp := AllocStackReg(GetTypeNo(BlockInfo, x));
6230 if not DoBinCalc(TPSBinValueOp(x), tmpp) then
6231 begin
6232 tmpp.Free;
6233 Result := False;
6234 exit;
6235 end;
6236 tmpc := TPSValueReplace.Create;
6237 with TPSValueReplace(tmpc) do
6238 begin
6239 PreWriteAllocated := True;
6240 OldValue := x;
6241 NewValue := tmpp;
6242 end;
6243 x := tmpc;
6244 end else if x is TPSValueProc then
6245 begin
6246 tmpp := AllocStackReg(TPSValueProc(x).ResultType);
6247 if not WriteCalculation(x, tmpp) then
6248 begin
6249 tmpp.Free;
6250 Result := False;
6251 exit;
6252 end;
6253 tmpc := TPSValueReplace.Create;
6254 with TPSValueReplace(tmpc) do
6255 begin
6256 PreWriteAllocated := True;
6257 OldValue := x;
6258 NewValue := tmpp;
6259 end;
6260 x := tmpc;
6261 end else if (x is TPSValueVar) and (TPSValueVar(x).RecCount <> 0) then
6262 begin
6263 if TPSValueVar(x).RecCount = 1 then
6264 begin
6265 rr := TPSValueVar(x).RecItem[0];
6266 if rr.ClassType <> TPSSubValue then
6267 exit; // there is no need pre-calculate anything
6268 if (TPSSubValue(rr).SubNo is TPSValueVar) and (TPSValueVar(TPSSubValue(rr).SubNo).RecCount = 0) then
6269 exit;
6270 end; //if
6271 tmpp := AllocPointer(GetTypeNo(BlockInfo, x));
6272 BlockWriteByte(BlockInfo, cm_sp);
6273 WriteOutRec(tmpp, True);
6274 BlockWriteByte(BlockInfo, 0);
6275 BlockWriteLong(BlockInfo, GetAddress(x));
6276 for i := 0 to TPSValueVar(x).RecCount - 1 do
6277 begin
6278 rr := TPSValueVar(x).RecItem[I];
6279 if rr.ClassType = TPSSubNumber then
6280 begin
6281 BlockWriteByte(BlockInfo, cm_sp);
6282 WriteOutRec(tmpp, false);
6283 BlockWriteByte(BlockInfo, 2);
6284 BlockWriteLong(BlockInfo, GetAddress(tmpp));
6285 BlockWriteLong(BlockInfo, TPSSubNumber(rr).SubNo);
6286 end else begin // if rr.classtype = TPSSubValue then begin
6287 tmpc := AllocStackReg(FindBaseType(btU32));
6288 if not WriteCalculation(TPSSubValue(rr).SubNo, tmpc) then
6289 begin
6290 tmpc.Free;
6291 tmpp.Free;
6292 Result := False;
6293 exit;
6294 end; //if
6295 BlockWriteByte(BlockInfo, cm_sp);
6296 WriteOutRec(tmpp, false);
6297 BlockWriteByte(BlockInfo, 3);
6298 BlockWriteLong(BlockInfo, GetAddress(tmpp));
6299 BlockWriteLong(BlockInfo, GetAddress(tmpc));
6300 tmpc.Free;
6301 end;
6302 end; // for
6303 tmpc := TPSValueReplace.Create;
6304 with TPSValueReplace(tmpc) do
6305 begin
6306 OldValue := x;
6307 NewValue := tmpp;
6308 PreWriteAllocated := True;
6309 end;
6310 x := tmpc;
6311 end;
6312
6313 end;
6314
6315 procedure AfterWriteOutRec(var x: TPSValue);
6316 var
6317 tmp: TPSValue;
6318 begin
6319 if (x.ClassType = TPSValueReplace) and (TPSValueReplace(x).PreWriteAllocated) then
6320 begin
6321 Dec(TPSValueReplace(x).FReplaceTimes);
6322 if TPSValueReplace(x).ReplaceTimes = 0 then
6323 begin
6324 tmp := TPSValueReplace(x).OldValue;
6325 x.Free;
6326 x := tmp;
6327 end;
6328 end;
6329 end; //afterwriteoutrec
6330
WriteOutRecnull6331 function WriteOutRec(x: TPSValue; AllowData: Boolean): Boolean;
6332 var
6333 rr: TPSSubItem;
6334 begin
6335 Result := True;
6336 if x.ClassType = TPSValueReplace then
6337 Result := WriteOutRec(TPSValueReplace(x).NewValue, AllowData)
6338 else if x is TPSValueVar then
6339 begin
6340 if TPSValueVar(x).RecCount = 0 then
6341 begin
6342 BlockWriteByte(BlockInfo, 0);
6343 BlockWriteLong(BlockInfo, GetAddress(x));
6344 end
6345 else
6346 begin
6347 rr := TPSValueVar(x).RecItem[0];
6348 if rr.ClassType = TPSSubNumber then
6349 begin
6350 BlockWriteByte(BlockInfo, 2);
6351 BlockWriteLong(BlockInfo, GetAddress(x));
6352 BlockWriteLong(BlockInfo, TPSSubNumber(rr).SubNo);
6353 end
6354 else
6355 begin
6356 BlockWriteByte(BlockInfo, 3);
6357 BlockWriteLong(BlockInfo, GetAddress(x));
6358 BlockWriteLong(BlockInfo, GetAddress(TPSSubValue(rr).SubNo));
6359 end;
6360 end;
6361 end else if x.ClassType = TPSValueData then
6362 begin
6363 if AllowData then
6364 begin
6365 BlockWriteByte(BlockInfo, 1);
6366 BlockWriteVariant(BlockInfo, TPSValueData(x).Data)
6367 end
6368 else
6369 begin
6370 Result := False;
6371 exit;
6372 end;
6373 end else
6374 Result := False;
6375 end;
6376
6377 function ReadParameters(IsProperty: Boolean; Dest: TPSParameters): Boolean; forward;
6378 {$IFNDEF PS_NOIDISPATCH}
6379 function ReadIDispatchParameters(const ProcName: tbtString; aVariantType: TPSVariantType; FSelf: TPSValue): TPSValue; forward;
6380 {$ENDIF}
6381 function ReadProcParameters(ProcNo: Cardinal; FSelf: TPSValue): TPSValue; forward;
6382 function ReadVarParameters(ProcNoVar: TPSValue): TPSValue; forward;
6383
6384 function calc(endOn: TPSPasToken): TPSValue; forward;
6385 procedure CheckNotificationVariant(var Val: TPSValue);
6386 var
6387 aType: TPSType;
6388 Call: TPSValueProcNo;
6389 tmp: TPSValue;
6390 begin
6391 if not (Val is TPSValueGlobalVar) then exit;
6392 aType := GetTypeNo(BlockInfo, Val);
6393 if (AType = nil) or (AType.BaseType <> btNotificationVariant) then exit;
6394 if FParser.CurrTokenId = CSTI_Assignment then
6395 begin
6396 Call := TPSValueProcNo.Create;
6397 Call.ResultType := nil;
6398 Call.SetParserPos(FParser);
6399 Call.ProcNo := FindProc('!NOTIFICATIONVARIANTSET');;
6400 Call.SetParserPos(FParser);
6401 Call.Parameters := TPSParameters.Create;
6402 Tmp := TPSValueData.Create;
6403 TPSVAlueData(tmp).Data := NewVariant(at2ut(FindBaseType(btString)));
6404 tbtString(TPSValueData(tmp).Data.tstring) := TPSVar(FVars[TPSValueGlobalVar(Val).GlobalVarNo]).OrgName;
6405 with call.Parameters.Add do
6406 begin
6407 Val := tmp;
6408 ExpectedType := TPSValueData(tmp).Data.FType;
6409 end;
6410 FParser.Next;
6411 tmp := Calc(CSTI_SemiColon);
6412 if tmp = nil then
6413 begin
6414 Val.Free;
6415 Val := nil;
6416 exit;
6417 end;
6418 with Call.Parameters.Add do
6419 begin
6420 Val := tmp;
6421 ExpectedType := at2ut(FindBaseType(btVariant));
6422 end;
6423 Val.Free;
6424 Val := Call;
6425 end else begin
6426 Call := TPSValueProcNo.Create;
6427 Call.ResultType := AT2UT(FindBaseType(btVariant));
6428 Call.SetParserPos(FParser);
6429 Call.ProcNo := FindProc('!NOTIFICATIONVARIANTGET');
6430 Call.SetParserPos(FParser);
6431 Call.Parameters := TPSParameters.Create;
6432 Tmp := TPSValueData.Create;
6433 TPSVAlueData(tmp).Data := NewVariant(at2ut(FindBaseType(btString)));
6434 tbtString(TPSValueData(tmp).Data.tstring) := TPSVar(FVars[TPSValueGlobalVar(Val).GlobalVarNo]).OrgName;
6435 with call.Parameters.Add do
6436 begin
6437 Val := tmp;
6438 ExpectedType := TPSValueData(tmp).Data.FType;
6439 end;
6440 Val.Free;
6441 Val := Call;
6442 end;
6443 end;
6444
6445 procedure CheckProcCall(var x: TPSValue);
6446 var
6447 aType: TPSType;
6448 begin
6449 if FParser.CurrTokenId in [CSTI_Dereference, CSTI_OpenRound] then
6450 begin
6451 aType := GetTypeNo(BlockInfo, x);
6452 if (aType = nil) or (aType.BaseType <> btProcPtr) then
6453 begin
6454 MakeError('', ecTypeMismatch, '');
6455 x.Free;
6456 x := nil;
6457 Exit;
6458 end;
6459 if FParser.CurrTokenId = CSTI_Dereference then
6460 FParser.Next;
6461 x := ReadVarParameters(x);
6462 end;
6463 end;
6464
6465 procedure CheckFurther(var x: TPSValue; ImplicitPeriod: Boolean);
6466 var
6467 t: Cardinal;
6468 rr: TPSSubItem;
6469 L: Longint;
6470 u: TPSType;
6471 Param: TPSParameter;
6472 tmp, tmpn: TPSValue;
6473 tmp3: TPSValueProcNo;
6474 tmp2: Boolean;
6475
FindSubRnull6476 function FindSubR(const n: tbtString; FType: TPSType): Cardinal;
6477 var
6478 h, I: Longint;
6479 rvv: PIFPSRecordFieldTypeDef;
6480 begin
6481 h := MakeHash(n);
6482 for I := 0 to TPSRecordType(FType).RecValCount - 1 do
6483 begin
6484 rvv := TPSRecordType(FType).RecVal(I);
6485 if (rvv.FieldNameHash = h) and (rvv.FieldName = n) then
6486 begin
6487 Result := I;
6488 exit;
6489 end;
6490 end;
6491 Result := InvalidVal;
6492 end;
6493
6494 begin
6495 (* if not (x is TPSValueVar) then
6496 Exit;*)
6497 u := GetTypeNo(BlockInfo, x);
6498 if u = nil then exit;
6499 while True do
6500 begin
6501 if (u.BaseType = btClass) {$IFNDEF PS_NOINTERFACES}or (u.BaseType = btInterface){$ENDIF}
6502 {$IFNDEF PS_NOIDISPATCH}or ((u.BaseType = btNotificationVariant)){$ENDIF} or (u.BaseType = btExtClass) then exit;
6503 if FParser.CurrTokenId = CSTI_OpenBlock then
6504 begin
6505 if (u.BaseType = btString) {$IFNDEF PS_NOWIDESTRING} or
6506 (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) {$ENDIF}
6507 {$IFDEF PS_HAVEVARIANT}or (u.BaseType = btVariant){$ENDIF} then
6508 begin
6509 FParser.Next;
6510 tmp := Calc(CSTI_CloseBlock);
6511 if tmp = nil then
6512 begin
6513 x.Free;
6514 x := nil;
6515 exit;
6516 end;
6517 if not IsIntType(GetTypeNo(BlockInfo, tmp).BaseType) then
6518 begin
6519 MakeError('', ecTypeMismatch, '');
6520 tmp.Free;
6521 x.Free;
6522 x := nil;
6523 exit;
6524 end;
6525 FParser.Next;
6526 if FParser.CurrTokenId = CSTI_Assignment then
6527 begin
6528 if not (x is TPSValueVar) then begin
6529 MakeError('', ecVariableExpected, '');
6530 tmp.Free;
6531 x.Free;
6532 x := nil;
6533 exit;
6534 end;
6535 {$IFDEF PS_HAVEVARIANT}if (u.BaseType = btVariant) then
6536 l := FindProc('VarArraySet') else
6537 {$ENDIF}
6538 {$IFNDEF PS_NOWIDESTRING}
6539 if (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) then
6540 l := FindProc('WStrSet')
6541 else
6542 {$ENDIF}
6543 l := FindProc('StrSet');
6544 if l = -1 then
6545 begin
6546 MakeError('', ecUnknownIdentifier, 'StrSet');
6547 tmp.Free;
6548 x.Free;
6549 x := nil;
6550 exit;
6551 end;
6552 tmp3 := TPSValueProcNo.Create;
6553 tmp3.ResultType := nil;
6554 tmp3.SetParserPos(FParser);
6555 tmp3.ProcNo := L;
6556 tmp3.SetParserPos(FParser);
6557 tmp3.Parameters := TPSParameters.Create;
6558 param := tmp3.Parameters.Add;
6559 with tmp3.Parameters.Add do
6560 begin
6561 Val := tmp;
6562 ExpectedType := GetTypeNo(BlockInfo, tmp);
6563 {$IFDEF DEBUG}
6564 if not ExpectedType.Used then asm int 3; end;
6565 {$ENDIF}
6566 end;
6567 with tmp3.Parameters.Add do
6568 begin
6569 Val := x;
6570 ExpectedType := GetTypeNo(BlockInfo, x);
6571 {$IFDEF DEBUG}
6572 if not ExpectedType.Used then asm int 3; end;
6573 {$ENDIF}
6574 ParamMode := pmInOut;
6575 end;
6576 x := tmp3;
6577 FParser.Next;
6578 tmp := Calc(CSTI_SemiColon);
6579 if tmp = nil then
6580 begin
6581 x.Free;
6582 x := nil;
6583 exit;
6584 end;
6585 {$IFDEF PS_HAVEVARIANT}if (u.BaseType <> btVariant) then {$ENDIF}
6586 begin
6587 if (GetTypeNo(BlockInfo, Tmp).BaseType <> btChar)
6588 {$IFNDEF PS_NOWIDESTRING} and (GetTypeno(BlockInfo, Tmp).BaseType <> btWideChar) {$ENDIF} then
6589 begin
6590 x.Free;
6591 x := nil;
6592 Tmp.Free;
6593 MakeError('', ecTypeMismatch, '');
6594 exit;
6595
6596 end;
6597 end;
6598 param.Val := tmp;
6599 {$IFDEF PS_HAVEVARIANT}
6600 if u.BaseType = btVariant then
6601 Param.ExpectedType := u else{$ENDIF}
6602 Param.ExpectedType := GetTypeNo(BlockInfo, tmp);
6603 {$IFDEF DEBUG}
6604 if not Param.ExpectedType.Used then asm int 3; end;
6605 {$ENDIF}
6606 end else begin
6607 {$IFDEF PS_HAVEVARIANT}if (u.BaseType = btVariant) then
6608 l := FindProc('VarArrayGet') else
6609 {$ENDIF}
6610 {$IFNDEF PS_NOWIDESTRING}
6611 if (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) then
6612 l := FindProc('WStrGet')
6613 else
6614 {$ENDIF}
6615 l := FindProc('StrGet');
6616 if l = -1 then
6617 begin
6618 MakeError('', ecUnknownIdentifier, 'StrGet');
6619 tmp.Free;
6620 x.Free;
6621 x := nil;
6622 exit;
6623 end;
6624 tmp3 := TPSValueProcNo.Create;
6625 {$IFDEF PS_HAVEVARIANT}if (u.BaseType = btVariant) then
6626 tmp3.ResultType := FindBaseType(btVariant) else
6627 {$ENDIF}
6628 {$IFNDEF PS_NOWIDESTRING}
6629 if (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) then
6630 tmp3.ResultType := FindBaseType(btWideChar)
6631 else
6632 {$ENDIF}
6633 tmp3.ResultType := FindBaseType(btChar);
6634 tmp3.ProcNo := L;
6635 tmp3.SetParserPos(FParser);
6636 tmp3.Parameters := TPSParameters.Create;
6637 with tmp3.Parameters.Add do
6638 begin
6639 Val := x;
6640 ExpectedType := GetTypeNo(BlockInfo, x);
6641 {$IFDEF DEBUG}
6642 if not ExpectedType.Used then asm int 3; end;
6643 {$ENDIF}
6644
6645 if x is TPSValueVar then
6646 ParamMode := pmInOut
6647 else
6648 parammode := pmIn;
6649 end;
6650 with tmp3.Parameters.Add do
6651 begin
6652 Val := tmp;
6653 ExpectedType := GetTypeNo(BlockInfo, tmp);
6654 {$IFDEF DEBUG}
6655 if not ExpectedType.Used then asm int 3; end;
6656 {$ENDIF}
6657 end;
6658 x := tmp3;
6659 end;
6660 Break;
6661 end else if ((u.BaseType = btArray) or (u.BaseType = btStaticArray)) and (x is TPSValueVar) then
6662 begin
6663 FParser.Next;
6664 tmp := calc(CSTI_CloseBlock);
6665 if tmp = nil then
6666 begin
6667 x.Free;
6668 x := nil;
6669 exit;
6670 end;
6671 if not IsIntType(GetTypeNo(BlockInfo, tmp).BaseType) then
6672 begin
6673 MakeError('', ecTypeMismatch, '');
6674 tmp.Free;
6675 x.Free;
6676 x := nil;
6677 exit;
6678 end;
6679 if (tmp.ClassType = TPSValueData) then
6680 begin
6681 rr := TPSSubNumber.Create;
6682 TPSValueVar(x).RecAdd(rr);
6683 if (u.BaseType = btStaticArray) then
6684 TPSSubNumber(rr).SubNo := Cardinal(GetInt(TPSValueData(tmp).Data, tmp2) - TPSStaticArrayType(u).StartOffset)
6685 else
6686 TPSSubNumber(rr).SubNo := GetUInt(TPSValueData(tmp).Data, tmp2);
6687 tmp.Free;
6688 rr.aType := TPSArrayType(u).ArrayTypeNo;
6689 u := rr.aType;
6690 end
6691 else
6692 begin
6693 if (u.BaseType = btStaticArray) then
6694 begin
6695 tmpn := TPSBinValueOp.Create;
6696 TPSBinValueOp(tmpn).Operator := otSub;
6697 TPSBinValueOp(tmpn).Val1 := tmp;
6698 tmp := TPSValueData.Create;
6699 TPSValueData(tmp).Data := NewVariant(FindBaseType(btS32));
6700 TPSValueData(tmp).Data.ts32 := TPSStaticArrayType(u).StartOffset;
6701 TPSBinValueOp(tmpn).Val2 := tmp;
6702 TPSBinValueOp(tmpn).aType := FindBaseType(btS32);
6703 tmp := tmpn;
6704 end;
6705 rr := TPSSubValue.Create;
6706 TPSValueVar(x).recAdd(rr);
6707 TPSSubValue(rr).SubNo := tmp;
6708 rr.aType := TPSArrayType(u).ArrayTypeNo;
6709 u := rr.aType;
6710 end;
6711 if FParser.CurrTokenId <> CSTI_CloseBlock then
6712 begin
6713 MakeError('', ecCloseBlockExpected, '');
6714 x.Free;
6715 x := nil;
6716 exit;
6717 end;
6718 Fparser.Next;
6719 end else begin
6720 MakeError('', ecSemicolonExpected, '');
6721 x.Free;
6722 x := nil;
6723 exit;
6724 end;
6725 end
6726 else if ((FParser.CurrTokenId = CSTI_Period) or (ImplicitPeriod))
6727 {$IFDEF PS_HAVEVARIANT}and not (u.BaseType = btVariant){$ENDIF}
6728 then
6729 begin
6730 if not ImplicitPeriod then
6731 FParser.Next;
6732 if u.BaseType = btRecord then
6733 begin
6734 t := FindSubR(FParser.GetToken, u);
6735 if t = InvalidVal then
6736 begin
6737 if ImplicitPeriod then exit;
6738 MakeError('', ecUnknownIdentifier, FParser.GetToken);
6739 x.Free;
6740 x := nil;
6741 exit;
6742 end;
6743 if (x is TPSValueProcNo) then
6744 begin
6745 ImplicitPeriod := False;
6746 FParser.Next;
6747
6748 tmp := AllocStackReg(u);
6749 WriteCalculation(x,tmp);
6750 TPSVar(BlockInfo.Proc.FProcVars[TPSValueAllocatedStackVar(tmp).LocalVarNo]).Use;
6751
6752 rr := TPSSubNumber.Create;
6753 TPSValueVar(tmp).RecAdd(rr);
6754 TPSSubNumber(rr).SubNo := t;
6755 rr.aType := TPSRecordType(u).RecVal(t).FType;
6756 u := rr.aType;
6757
6758 tmpn := TPSValueReplace.Create;
6759 with TPSValueReplace(tmpn) do
6760 begin
6761 FreeOldValue := true;
6762 FreeNewValue := true;
6763 OldValue := tmp;
6764 NewValue := AllocStackReg(u);
6765 PreWriteAllocated := true;
6766 end;
6767
6768 if not WriteCalculation(tmp,TPSValueReplace(tmpn).NewValue) then
6769 begin
6770 {MakeError('',ecInternalError,'');}
6771 x.Free;
6772 x := nil;
6773 exit;
6774 end;
6775 x.Free;
6776 x := tmpn;
6777 end else
6778 begin
6779 if not (x is TPSValueVar) then begin
6780 MakeError('', ecVariableExpected, FParser.GetToken);
6781 x.Free;
6782 x := nil;
6783 exit;
6784 end;
6785 ImplicitPeriod := False;
6786 FParser.Next;
6787 rr := TPSSubNumber.Create;
6788 TPSValueVar(x).RecAdd(rr);
6789 TPSSubNumber(rr).SubNo := t;
6790 rr.aType := TPSRecordType(u).RecVal(t).FType;
6791 u := rr.aType;
6792 end;
6793 end
6794 {$IFDEF PS_HAVEVARIANT}
6795 else if (u.BaseType = btVariant) then break else
6796 {$ELSE}
6797 ;
6798 {$ENDIF}
6799
6800 begin
6801 x.Free;
6802 MakeError('', ecSemicolonExpected, '');
6803 x := nil;
6804 exit;
6805 end;
6806 end
6807 else
6808 break;
6809 end;
6810 end;
6811
6812
6813
6814 procedure CheckClassArrayProperty(var P: TPSValue; const VarType: TPSVariableType; VarNo: Cardinal);
6815 var
6816 Tempp: TPSValue;
6817 aType: TPSClassType;
6818 procno: Cardinal;
6819 Idx: TPSDelphiClassItem;
6820 Decl: TPSParametersDecl;
6821 begin
6822 if p = nil then exit;
6823 if (GetTypeNo(BlockInfo, p) = nil) or (GetTypeNo(BlockInfo, p).BaseType <> btClass) then exit;
6824 aType := TPSClassType(GetTypeNo(BlockInfo, p));
6825 if FParser.CurrTokenID = CSTI_OpenBlock then
6826 begin
6827 if not TPSClassType(aType).Cl.Property_Find('', Idx) then
6828 begin
6829 MakeError('', ecPeriodExpected, '');
6830 p.Free;
6831 p := nil;
6832 exit;
6833 end;
6834 if VarNo <> InvalidVal then
6835 begin
6836 if @FOnUseVariable <> nil then
6837 FOnUseVariable(Self, VarType, VarNo, BlockInfo.ProcNo, FParser.CurrTokenPos, '[Default]');
6838 end;
6839 Decl := TPSParametersDecl.Create;
6840 TPSClassType(aType).Cl.Property_GetHeader(Idx, Decl);
6841 tempp := p;
6842 P := TPSValueProcNo.Create;
6843 with TPSValueProcNo(P) do
6844 begin
6845 Parameters := TPSParameters.Create;
6846 Parameters.Add;
6847 end;
6848 if not (ReadParameters(True, TPSValueProc(P).Parameters) and
6849 ValidateParameters(BlockInfo, TPSValueProc(P).Parameters, Decl)) then
6850 begin
6851 tempp.Free;
6852 Decl.Free;
6853 p.Free;
6854 p := nil;
6855 exit;
6856 end;
6857 with TPSValueProcNo(p).Parameters[0] do
6858 begin
6859 Val := tempp;
6860 ExpectedType := GetTypeNo(BlockInfo, tempp);
6861 end;
6862 if FParser.CurrTokenId = CSTI_Assignment then
6863 begin
6864 FParser.Next;
6865 TempP := Calc(CSTI_SemiColon);
6866 if TempP = nil then
6867 begin
6868 Decl.Free;
6869 P.Free;
6870 p := nil;
6871 exit;
6872 end;
6873 with TPSValueProc(p).Parameters.Add do
6874 begin
6875 Val := Tempp;
6876 ExpectedType := at2ut(Decl.Result);
6877 end;
6878 if not TPSClassType(aType).Cl.Property_Set(Idx, procno) then
6879 begin
6880 Decl.Free;
6881 MakeError('', ecReadOnlyProperty, '');
6882 p.Free;
6883 p := nil;
6884 exit;
6885 end;
6886 TPSValueProcNo(p).ProcNo := procno;
6887 TPSValueProcNo(p).ResultType := nil;
6888 end
6889 else
6890 begin
6891 if not TPSClassType(aType).Cl.Property_Get(Idx, procno) then
6892 begin
6893 Decl.Free;
6894 MakeError('', ecWriteOnlyProperty, '');
6895 p.Free;
6896 p := nil;
6897 exit;
6898 end;
6899 TPSValueProcNo(p).ProcNo := procno;
6900 TPSValueProcNo(p).ResultType := TPSExternalProcedure(FProcs[procno]).RegProc.Decl.Result;
6901 end; // if FParser.CurrTokenId = CSTI_Assign
6902 Decl.Free;
6903 end;
6904 end;
6905
6906 procedure CheckExtClass(var P: TPSValue; const VarType: TPSVariableType; VarNo: Cardinal; ImplicitPeriod: Boolean);
6907 var
6908 Temp, Idx: Cardinal;
6909 FType: TPSType;
6910 s: tbtString;
6911
6912 begin
6913 FType := GetTypeNo(BlockInfo, p);
6914 if FType = nil then Exit;
6915 if FType.BaseType <> btExtClass then Exit;
6916 while (FParser.CurrTokenID = CSTI_Period) or (ImplicitPeriod) do
6917 begin
6918 if not ImplicitPeriod then
6919 FParser.Next;
6920 if FParser.CurrTokenID <> CSTI_Identifier then
6921 begin
6922 if ImplicitPeriod then exit;
6923 MakeError('', ecIdentifierExpected, '');
6924 p.Free;
6925 P := nil;
6926 Exit;
6927 end;
6928 s := FParser.GetToken;
6929 if TPSUndefinedClassType(FType).ExtClass.Func_Find(s, Idx) then
6930 begin
6931 FParser.Next;
6932 TPSUndefinedClassType(FType).ExtClass.Func_Call(Idx, Temp);
6933 P := ReadProcParameters(Temp, P);
6934 if p = nil then
6935 begin
6936 Exit;
6937 end;
6938 end else
6939 begin
6940 if ImplicitPeriod then exit;
6941 MakeError('', ecUnknownIdentifier, s);
6942 p.Free;
6943 P := nil;
6944 Exit;
6945 end;
6946 ImplicitPeriod := False;
6947 FType := GetTypeNo(BlockInfo, p);
6948 if (FType = nil) or (FType.BaseType <> btExtClass) then Exit;
6949 end; {while}
6950 end;
6951
6952 procedure CheckClass(var P: TPSValue; const VarType: TPSVariableType; VarNo: Cardinal; ImplicitPeriod: Boolean);
6953 var
6954 Procno: Cardinal;
6955 Idx: TPSDelphiClassItem;
6956 FType: TPSType;
6957 TempP: TPSValue;
6958 Decl: TPSParametersDecl;
6959 s: tbtString;
6960
6961 pinfo, pinfonew: tbtString;
6962 ppos: Cardinal;
6963
6964 begin
6965 FType := GetTypeNo(BlockInfo, p);
6966 if FType = nil then exit;
6967 pinfo := '';
6968 if (FType.BaseType <> btClass) then Exit;
6969 while (FParser.CurrTokenID = CSTI_Period) or (ImplicitPeriod) do
6970 begin
6971 if not ImplicitPeriod then
6972 FParser.Next;
6973 if FParser.CurrTokenID <> CSTI_Identifier then
6974 begin
6975 if ImplicitPeriod then exit;
6976 MakeError('', ecIdentifierExpected, '');
6977 p.Free;
6978 P := nil;
6979 Exit;
6980 end;
6981 s := FParser.GetToken;
6982 if TPSClassType(FType).Cl.Func_Find(s, Idx) then
6983 begin
6984 FParser.Next;
6985 VarNo := InvalidVal;
6986 TPSClassType(FType).cl.Func_Call(Idx, Procno);
6987 P := ReadProcParameters(Procno, P);
6988 if p = nil then
6989 begin
6990 Exit;
6991 end;
6992 end else if TPSClassType(FType).cl.Property_Find(s, Idx) then
6993 begin
6994 ppos := FParser.CurrTokenPos;
6995 pinfonew := FParser.OriginalToken;
6996 FParser.Next;
6997 if VarNo <> InvalidVal then
6998 begin
6999 if pinfo = '' then
7000 pinfo := pinfonew
7001 else
7002 pinfo := pinfo + '.' + pinfonew;
7003 if @FOnUseVariable <> nil then
7004 FOnUseVariable(Self, VarType, VarNo, BlockInfo.ProcNo, ppos, pinfo);
7005 end;
7006 Decl := TPSParametersDecl.Create;
7007 TPSClassType(FType).cl.Property_GetHeader(Idx, Decl);
7008 TempP := P;
7009 p := TPSValueProcNo.Create;
7010 with TPSValueProcNo(p) do
7011 begin
7012 Parameters := TPSParameters.Create;
7013 Parameters.Add;
7014 Pos := FParser.CurrTokenPos;
7015 row := FParser.Row;
7016 Col := FParser.Col;
7017 end;
7018 if Decl.ParamCount <> 0 then
7019 begin
7020 if not (ReadParameters(True, TPSValueProc(P).Parameters) and
7021 ValidateParameters(BlockInfo, TPSValueProc(P).Parameters, Decl)) then
7022 begin
7023 Tempp.Free;
7024 Decl.Free;
7025 p.Free;
7026 P := nil;
7027 exit;
7028 end;
7029 end; // if
7030 with TPSValueProcNo(p).Parameters[0] do
7031 begin
7032 Val := TempP;
7033 ExpectedType := at2ut(GetTypeNo(BlockInfo, TempP));
7034 end;
7035 if FParser.CurrTokenId = CSTI_Assignment then
7036 begin
7037 FParser.Next;
7038 TempP := Calc(CSTI_SemiColon);
7039 if TempP = nil then
7040 begin
7041 Decl.Free;
7042 P.Free;
7043 p := nil;
7044 exit;
7045 end;
7046 with TPSValueProc(p).Parameters.Add do
7047 begin
7048 Val := Tempp;
7049 ExpectedType := at2ut(Decl.Result);
7050 {$IFDEF DEBUG}
7051 if not ExpectedType.Used then asm int 3; end;
7052 {$ENDIF}
7053 end;
7054
7055 if not TPSClassType(FType).cl.Property_Set(Idx, Procno) then
7056 begin
7057 MakeError('', ecReadOnlyProperty, '');
7058 Decl.Free;
7059 p.Free;
7060 p := nil;
7061 exit;
7062 end;
7063 TPSValueProcNo(p).ProcNo := Procno;
7064 TPSValueProcNo(p).ResultType := nil;
7065 Decl.Free;
7066 Exit;
7067 end else begin
7068 if not TPSClassType(FType).cl.Property_Get(Idx, Procno) then
7069 begin
7070 MakeError('', ecWriteOnlyProperty, '');
7071 Decl.Free;
7072 p.Free;
7073 p := nil;
7074 exit;
7075 end;
7076 TPSValueProcNo(p).ProcNo := ProcNo;
7077 TPSValueProcNo(p).ResultType := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl.Result;
7078 end; // if FParser.CurrTokenId = CSTI_Assign
7079 Decl.Free;
7080 end else
7081 begin
7082 if ImplicitPeriod then exit;
7083 MakeError('', ecUnknownIdentifier, s);
7084 p.Free;
7085 P := nil;
7086 Exit;
7087 end;
7088 ImplicitPeriod := False;
7089 FType := GetTypeNo(BlockInfo, p);
7090 if (FType = nil) or (FType.BaseType <> btClass) then Exit;
7091 end; {while}
7092 end;
7093 {$IFNDEF PS_NOIDISPATCH}
7094 procedure CheckIntf(var P: TPSValue; const VarType: TPSVariableType; VarNo: Cardinal; ImplicitPeriod: Boolean);
7095 var
7096 Procno: Cardinal;
7097 Idx: TPSInterfaceMethod;
7098 FType: TPSType;
7099 s: tbtString;
7100
7101 CheckArrayProperty,HasArrayProperty:boolean;
7102 begin
7103 FType := GetTypeNo(BlockInfo, p);
7104 if FType = nil then exit;
7105 if (FType.BaseType <> btInterface) and (Ftype.BaseType <> BtVariant) and (FType.BaseType = btNotificationVariant) then Exit;
7106
7107 CheckArrayProperty:=(FParser.CurrTokenID=CSTI_OpenBlock) and
7108 (Ftype.BaseType = BtVariant);
7109 while (FParser.CurrTokenID = CSTI_Period)
7110 or (ImplicitPeriod) do begin
7111
7112 HasArrayProperty:=CheckArrayProperty;
7113 if CheckArrayProperty then begin
7114 CheckArrayProperty:=false;
7115 end else begin
7116 if not ImplicitPeriod then
7117 FParser.Next;
7118 end;
7119 if FParser.CurrTokenID <> CSTI_Identifier then
7120 begin
7121 if ImplicitPeriod then exit;
7122 if not HasArrayProperty then begin
7123 MakeError('', ecIdentifierExpected, '');
7124 p.Free;
7125 P := nil;
7126 Exit;
7127 end;
7128 end;
7129 if (FType.BaseType = btVariant) or (FType.BaseType = btNotificationVariant) then
7130 begin
7131 if HasArrayProperty then begin
7132 s:='';
7133 end else begin
7134 s := FParser.OriginalToken;
7135 FParser.Next;
7136 end;
7137 ImplicitPeriod := False;
7138 FType := GetTypeNo(BlockInfo, p);
7139 p := ReadIDispatchParameters(s, TPSVariantType(FType), p);
7140 if (FType = nil) or (FType.BaseType <> btInterface) then Exit;
7141 end else
7142 begin
7143 s := FParser.GetToken;
7144 if (FType is TPSInterfaceType) and (TPSInterfaceType(FType).Intf.Func_Find(s, Idx)) then
7145 begin
7146 FParser.Next;
7147 TPSInterfaceType(FType).Intf.Func_Call(Idx, Procno);
7148 P := ReadProcParameters(Procno, P);
7149 if p = nil then
7150 begin
7151 Exit;
7152 end;
7153 end else
7154 begin
7155 if ImplicitPeriod then exit;
7156 MakeError('', ecUnknownIdentifier, s);
7157 p.Free;
7158 P := nil;
7159 Exit;
7160 end;
7161 ImplicitPeriod := False;
7162 FType := GetTypeNo(BlockInfo, p);
7163 if (FType = nil) or ((FType.BaseType <> btInterface) and (Ftype.BaseType <> btVariant) and (Ftype.BaseType <> btNotificationVariant)) then Exit;
7164 end;
7165 end; {while}
7166 end;
7167 {$ENDIF}
ExtCheckClassTypenull7168 function ExtCheckClassType(FType: TPSType; const ParserPos: Cardinal): TPSValue;
7169 var
7170 FType2: TPSType;
7171 ProcNo, Idx: Cardinal;
7172 Temp, ResV: TPSValue;
7173 begin
7174 if FParser.CurrTokenID = CSTI_OpenRound then
7175 begin
7176 FParser.Next;
7177 Temp := Calc(CSTI_CloseRound);
7178 if Temp = nil then
7179 begin
7180 Result := nil;
7181 exit;
7182 end;
7183 if FParser.CurrTokenID <> CSTI_CloseRound then
7184 begin
7185 temp.Free;
7186 MakeError('', ecCloseRoundExpected, '');
7187 Result := nil;
7188 exit;
7189 end;
7190 FType2 := GetTypeNo(BlockInfo, Temp);
7191 if (FType.basetype = BtClass) and (ftype2.BaseType = btClass) and (ftype <> ftype2) then
7192 begin
7193 if not TPSUndefinedClassType(FType2).ExtClass.CastToType(AT2UT(FType), ProcNo) then
7194 begin
7195 temp.Free;
7196 MakeError('', ecTypeMismatch, '');
7197 Result := nil;
7198 exit;
7199 end;
7200 Result := TPSValueProcNo.Create;
7201 TPSValueProcNo(Result).Parameters := TPSParameters.Create;
7202 TPSValueProcNo(Result).ResultType := at2ut(FType);
7203 TPSValueProcNo(Result).ProcNo := ProcNo;
7204 with TPSValueProcNo(Result).Parameters.Add do
7205 begin
7206 Val := Temp;
7207 ExpectedType := GetTypeNo(BlockInfo, temp);
7208 end;
7209 with TPSValueProcNo(Result).Parameters.Add do
7210 begin
7211 ExpectedType := at2ut(FindBaseType(btu32));
7212 Val := TPSValueData.Create;
7213 with TPSValueData(val) do
7214 begin
7215 SetParserPos(FParser);
7216 Data := NewVariant(ExpectedType);
7217 Data.tu32 := at2ut(FType).FinalTypeNo;
7218 end;
7219 end;
7220 FParser.Next;
7221 Exit;
7222 end;
7223 if not IsCompatibleType(FType, FType2, True) then
7224 begin
7225 temp.Free;
7226 MakeError('', ecTypeMismatch, '');
7227 Result := nil;
7228 exit;
7229 end;
7230 FParser.Next;
7231 Result := TPSUnValueOp.Create;
7232 with TPSUnValueOp(Result) do
7233 begin
7234 Operator := otCast;
7235 Val1 := Temp;
7236 SetParserPos(FParser);
7237 aType := AT2UT(FType);
7238 end;
7239 exit;
7240 end;
7241 if FParser.CurrTokenId <> CSTI_Period then
7242 begin
7243 Result := nil;
7244 MakeError('', ecPeriodExpected, '');
7245 Exit;
7246 end;
7247 if FType.BaseType <> btExtClass then
7248 begin
7249 Result := nil;
7250 MakeError('', ecClassTypeExpected, '');
7251 Exit;
7252 end;
7253 FParser.Next;
7254 if not TPSUndefinedClassType(FType).ExtClass.ClassFunc_Find(FParser.GetToken, Idx) then
7255 begin
7256 Result := nil;
7257 MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
7258 Exit;
7259 end;
7260 FParser.Next;
7261 TPSUndefinedClassType(FType).ExtClass.ClassFunc_Call(Idx, ProcNo);
7262 Temp := TPSValueData.Create;
7263 with TPSValueData(Temp) do
7264 begin
7265 Data := NewVariant(at2ut(FindBaseType(btu32)));
7266 Data.tu32 := at2ut(FType).FinalTypeNo;
7267 end;
7268 ResV := ReadProcParameters(ProcNo, Temp);
7269 if ResV <> nil then
7270 begin
7271 TPSValueProc(Resv).ResultType := at2ut(FType);
7272 Result := Resv;
7273 end else begin
7274 Result := nil;
7275 end;
7276 end;
7277
CheckClassTypenull7278 function CheckClassType(TypeNo: TPSType; const ParserPos: Cardinal): TPSValue;
7279 var
7280 FType2: TPSType;
7281 ProcNo: Cardinal;
7282 Idx: IPointer;
7283 Temp, ResV: TPSValue;
7284 dta: PIfRVariant;
7285 begin
7286 if typeno.BaseType = btExtClass then
7287 begin
7288 Result := ExtCheckClassType(TypeNo, PArserPos);
7289 exit;
7290 end;
7291 if FParser.CurrTokenID = CSTI_OpenRound then
7292 begin
7293 FParser.Next;
7294 Temp := Calc(CSTI_CloseRound);
7295 if Temp = nil then
7296 begin
7297 Result := nil;
7298 exit;
7299 end;
7300 if FParser.CurrTokenID <> CSTI_CloseRound then
7301 begin
7302 temp.Free;
7303 MakeError('', ecCloseRoundExpected, '');
7304 Result := nil;
7305 exit;
7306 end;
7307 FType2 := GetTypeNo(BlockInfo, Temp);
7308 if ((typeno.BaseType = btClass){$IFNDEF PS_NOINTERFACES} or (TypeNo.basetype = btInterface){$ENDIF}) and
7309 (ftype2<>nil) and
7310 ((ftype2.BaseType = btClass){$IFNDEF PS_NOINTERFACES} or (ftype2.BaseType = btInterface){$ENDIF}) and (TypeNo <> ftype2) then
7311 begin
7312 {$IFNDEF PS_NOINTERFACES}
7313 if FType2.basetype = btClass then
7314 begin
7315 {$ENDIF}
7316 if not TPSClassType(FType2).Cl.CastToType(AT2UT(TypeNo), ProcNo) then
7317 begin
7318 temp.Free;
7319 MakeError('', ecTypeMismatch, '');
7320 Result := nil;
7321 exit;
7322 end;
7323 {$IFNDEF PS_NOINTERFACES}
7324 end else begin
7325 if not TPSInterfaceType(FType2).Intf.CastToType(AT2UT(TypeNo), ProcNo) then
7326 begin
7327 temp.Free;
7328 MakeError('', ecTypeMismatch, '');
7329 Result := nil;
7330 exit;
7331 end;
7332 end;
7333 {$ENDIF}
7334 Result := TPSValueProcNo.Create;
7335 TPSValueProcNo(Result).Parameters := TPSParameters.Create;
7336 TPSValueProcNo(Result).ResultType := at2ut(TypeNo);
7337 TPSValueProcNo(Result).ProcNo := ProcNo;
7338 with TPSValueProcNo(Result).Parameters.Add do
7339 begin
7340 Val := Temp;
7341 ExpectedType := GetTypeNo(BlockInfo, temp);
7342 {$IFDEF DEBUG}
7343 if not ExpectedType.Used then asm int 3; end;
7344 {$ENDIF}
7345 end;
7346 with TPSValueProcNo(Result).Parameters.Add do
7347 begin
7348 ExpectedType := at2ut(FindBaseType(btu32));
7349 {$IFDEF DEBUG}
7350 if not ExpectedType.Used then asm int 3; end;
7351 {$ENDIF}
7352 Val := TPSValueData.Create;
7353 with TPSValueData(val) do
7354 begin
7355 SetParserPos(FParser);
7356 Data := NewVariant(ExpectedType);
7357 Data.tu32 := at2ut(TypeNo).FinalTypeNo;
7358 end;
7359 end;
7360 FParser.Next;
7361 Exit;
7362 end;
7363 if (FType2=nil) or not IsCompatibleType(TypeNo, FType2, True) then
7364 begin
7365 temp.Free;
7366 MakeError('', ecTypeMismatch, '');
7367 Result := nil;
7368 exit;
7369 end;
7370 FParser.Next;
7371 Result := TPSUnValueOp.Create;
7372 with TPSUnValueOp(Result) do
7373 begin
7374 Operator := otCast;
7375 Val1 := Temp;
7376 SetParserPos(FParser);
7377 aType := AT2UT(TypeNo);
7378 end;
7379
7380 exit;
7381 end else
7382 if FParser.CurrTokenId <> CSTI_Period then
7383 begin
7384 Result := TPSValueData.Create;
7385 Result.SetParserPos(FParser);
7386 New(dta);
7387 TPSValueData(Result).Data := dta;
7388 InitializeVariant(dta, at2ut(FindBaseType(btType)));
7389 dta.ttype := at2ut(TypeNo);
7390 Exit;
7391 end;
7392 if TypeNo.BaseType <> btClass then
7393 begin
7394 Result := nil;
7395 MakeError('', ecClassTypeExpected, '');
7396 Exit;
7397 end;
7398 FParser.Next;
7399 if not TPSClassType(TypeNo).Cl.ClassFunc_Find(FParser.GetToken, Idx) then
7400 begin
7401 Result := nil;
7402 MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
7403 Exit;
7404 end;
7405 FParser.Next;
7406 TPSClassType(TypeNo).Cl.ClassFunc_Call(Idx, ProcNo);
7407 Temp := TPSValueData.Create;
7408 with TPSValueData(Temp) do
7409 begin
7410 Data := NewVariant(at2ut(FindBaseType(btu32)));
7411 Data.tu32 := at2ut(TypeNo).FinalTypeNo;
7412 end;
7413 ResV := ReadProcParameters(ProcNo, Temp);
7414 if ResV <> nil then
7415 begin
7416 TPSValueProc(Resv).ResultType := at2ut(TypeNo);
7417 Result := Resv;
7418 end else begin
7419 Result := nil;
7420 end;
7421 end;
7422
GetIdentifiernull7423 function GetIdentifier(const FType: Byte): TPSValue;
7424 {
7425 FType:
7426 0 = Anything
7427 1 = Only variables
7428 2 = Not constants
7429 }
7430
7431
7432 var
7433 vt: TPSVariableType;
7434 vno: Cardinal;
7435 TWith, Temp: TPSValue;
7436 l, h: Longint;
7437 s, u: tbtString;
7438 t: TPSConstant;
7439 Temp1: TPSType;
7440 temp2: CArdinal;
7441 bi: TPSBlockInfo;
7442 lOldRecCount: Integer;
7443
7444 begin
7445 s := FParser.GetToken;
7446
7447 if FType <> 1 then
7448 begin
7449 bi := BlockInfo;
7450 while bi <> nil do
7451 begin
7452 for l := bi.WithList.Count -1 downto 0 do
7453 begin
7454 TWith := TPSValueAllocatedStackVar.Create;
7455 TPSValueAllocatedStackVar(TWith).LocalVarNo := TPSValueAllocatedStackVar(TPSValueReplace(bi.WithList[l]).NewValue).LocalVarNo;
7456 Temp := TWith;
7457 VNo := TPSValueAllocatedStackVar(Temp).LocalVarNo;
7458 lOldRecCount := TPSValueVar(TWith).GetRecCount;
7459 vt := ivtVariable;
7460 if Temp = TWith then CheckFurther(TWith, True);
7461 if Temp = TWith then CheckClass(TWith, vt, vno, True);
7462 if Temp = TWith then CheckExtClass(TWith, vt, vno, True);
7463 if (Temp <> TWith) or (Cardinal(lOldRecCount) <> TPSValueVar(TWith).GetRecCount) then
7464 begin
7465 repeat
7466 Temp := TWith;
7467 if TWith <> nil then CheckFurther(TWith, False);
7468 if TWith <> nil then CheckClass(TWith, vt, vno, False);
7469 if TWith <> nil then CheckExtClass(TWith, vt, vno, False);
7470 {$IFNDEF PS_NOIDISPATCH}if TWith <> nil then CheckIntf(TWith, vt, vno, False);{$ENDIF}
7471 if TWith <> nil then CheckProcCall(TWith);
7472 if TWith <> nil then CheckClassArrayProperty(TWith, vt, vno);
7473 vno := InvalidVal;
7474 until (TWith = nil) or (Temp = TWith);
7475 Result := TWith;
7476 Exit;
7477 end;
7478 TWith.Free;
7479 end;
7480 bi := bi.FOwner;
7481 end;
7482 end;
7483
7484 if s = 'RESULT' then
7485 begin
7486 if BlockInfo.proc.Decl.Result = nil then
7487 begin
7488 Result := nil;
7489 MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
7490 end
7491 else
7492 begin
7493 BlockInfo.Proc.ResultUse;
7494 Result := TPSValueParamVar.Create;
7495 with TPSValueParamVar(Result) do
7496 begin
7497 SetParserPos(FParser);
7498 ParamNo := 0;
7499 end;
7500 vno := 0;
7501 vt := ivtParam;
7502 if @FOnUseVariable <> nil then
7503 FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, '');
7504 FParser.Next;
7505 repeat
7506 Temp := Result;
7507 if Result <> nil then CheckFurther(Result, False);
7508 if Result <> nil then CheckClass(Result, vt, vno, False);
7509 if Result <> nil then CheckExtClass(Result, vt, vno, False);
7510 {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
7511 if Result <> nil then CheckProcCall(Result);
7512 if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
7513 vno := InvalidVal;
7514 until (Result = nil) or (Temp = Result);
7515 end;
7516 exit;
7517 end;
7518 if BlockInfo.Proc.Decl.Result = nil then
7519 l := 0
7520 else
7521 l := 1;
7522 for h := 0 to BlockInfo.proc.Decl.ParamCount -1 do
7523 begin
7524 if BlockInfo.proc.Decl.Params[h].Name = s then
7525 begin
7526 Result := TPSValueParamVar.Create;
7527 with TPSValueParamVar(Result) do
7528 begin
7529 SetParserPos(FParser);
7530 ParamNo := l;
7531 end;
7532 vt := ivtParam;
7533 vno := L;
7534 if @FOnUseVariable <> nil then
7535 FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, '');
7536 FParser.Next;
7537 repeat
7538 Temp := Result;
7539 if Result <> nil then CheckFurther(Result, False);
7540 if Result <> nil then CheckClass(Result, vt, vno, False);
7541 if Result <> nil then CheckExtClass(Result, vt, vno, False);
7542 {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
7543 if Result <> nil then CheckProcCall(Result);
7544 if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
7545 vno := InvalidVal;
7546 until (Result = nil) or (Temp = Result);
7547 exit;
7548 end;
7549 Inc(l);
7550 GRFW(u);
7551 end;
7552
7553 h := MakeHash(s);
7554
7555 for l := 0 to BlockInfo.Proc.ProcVars.Count - 1 do
7556 begin
7557 if (PIFPSProcVar(BlockInfo.Proc.ProcVars[l]).NameHash = h) and
7558 (PIFPSProcVar(BlockInfo.Proc.ProcVars[l]).Name = s) then
7559 begin
7560 PIFPSProcVar(BlockInfo.Proc.ProcVars[l]).Use;
7561 vno := l;
7562 vt := ivtVariable;
7563 if @FOnUseVariable <> nil then
7564 FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, '');
7565 Result := TPSValueLocalVar.Create;
7566 with TPSValueLocalVar(Result) do
7567 begin
7568 LocalVarNo := l;
7569 SetParserPos(FParser);
7570 end;
7571 FParser.Next;
7572 repeat
7573 Temp := Result;
7574 if Result <> nil then CheckFurther(Result, False);
7575 if Result <> nil then CheckClass(Result, vt, vno, False);
7576 if Result <> nil then CheckExtClass(Result, vt, vno, False);
7577 {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
7578 if Result <> nil then CheckProcCall(Result);
7579 if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
7580 vno := InvalidVal;
7581 until (Result = nil) or (Temp = Result);
7582
7583 exit;
7584 end;
7585 end;
7586
7587 for l := 0 to FVars.Count - 1 do
7588 begin
7589 if (TPSVar(FVars[l]).NameHash = h) and
7590 (TPSVar(FVars[l]).Name = s) {$IFDEF PS_USESSUPPORT} and
7591 (IsInLocalUnitList(TPSVar(FVars[l]).FDeclareUnit)){$ENDIF} then
7592 begin
7593 TPSVar(FVars[l]).Use;
7594 Result := TPSValueGlobalVar.Create;
7595 with TPSValueGlobalVar(Result) do
7596 begin
7597 SetParserPos(FParser);
7598 GlobalVarNo := l;
7599
7600 end;
7601 vt := ivtGlobal;
7602 vno := l;
7603 if @FOnUseVariable <> nil then
7604 FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, '');
7605 FParser.Next;
7606 repeat
7607 Temp := Result;
7608 if Result <> nil then CheckNotificationVariant(Result);
7609 if Result <> nil then CheckFurther(Result, False);
7610 if Result <> nil then CheckClass(Result, vt, vno, False);
7611 if Result <> nil then CheckExtClass(Result, vt, vno, False);
7612 {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
7613 if Result <> nil then CheckProcCall(Result);
7614 if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
7615 vno := InvalidVal;
7616 until (Result = nil) or (Temp = Result);
7617 exit;
7618 end;
7619 end;
7620 Temp1 := FindType(FParser.GetToken);
7621 if Temp1 <> nil then
7622 begin
7623 l := FParser.CurrTokenPos;
7624 if FType = 1 then
7625 begin
7626 Result := nil;
7627 MakeError('', ecVariableExpected, FParser.OriginalToken);
7628 exit;
7629 end;
7630 vt := ivtGlobal;
7631 vno := InvalidVal;
7632 FParser.Next;
7633 Result := CheckClassType(Temp1, l);
7634 repeat
7635 Temp := Result;
7636 if Result <> nil then CheckFurther(Result, False);
7637 if Result <> nil then CheckClass(Result, vt, vno, False);
7638 if Result <> nil then CheckExtClass(Result, vt, vno, False);
7639 {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
7640 if Result <> nil then CheckProcCall(Result);
7641 if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
7642 vno := InvalidVal;
7643 until (Result = nil) or (Temp = Result);
7644
7645 exit;
7646 end;
7647 Temp2 := FindProc(FParser.GetToken);
7648 if Temp2 <> InvalidVal then
7649 begin
7650 if FType = 1 then
7651 begin
7652 Result := nil;
7653 MakeError('', ecVariableExpected, FParser.OriginalToken);
7654 exit;
7655 end;
7656 FParser.Next;
7657 Result := ReadProcParameters(Temp2, nil);
7658 if Result = nil then
7659 exit;
7660 Result.SetParserPos(FParser);
7661 vt := ivtGlobal;
7662 vno := InvalidVal;
7663 repeat
7664 Temp := Result;
7665 if Result <> nil then CheckFurther(Result, False);
7666 if Result <> nil then CheckClass(Result, vt, vno, False);
7667 if Result <> nil then CheckExtClass(Result, vt, vno, False);
7668 {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
7669 if Result <> nil then CheckProcCall(Result);
7670 if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
7671 vno := InvalidVal;
7672 until (Result = nil) or (Temp = Result);
7673 exit;
7674 end;
7675 for l := 0 to FConstants.Count -1 do
7676 begin
7677 t := TPSConstant(FConstants[l]);
7678 if (t.NameHash = h) and (t.Name = s) {$IFDEF PS_USESSUPPORT} and
7679 (IsInLocalUnitList(t.FDeclareUnit)) {$ENDIF} then
7680 begin
7681 if FType <> 0 then
7682 begin
7683 Result := nil;
7684 MakeError('', ecVariableExpected, FParser.OriginalToken);
7685 exit;
7686 end;
7687 fparser.next;
7688 Result := TPSValueData.Create;
7689 with TPSValueData(Result) do
7690 begin
7691 SetParserPos(FParser);
7692 Data := NewVariant(at2ut(t.Value.FType));
7693 CopyVariantContents(t.Value, Data);
7694 end;
7695 vt := ivtGlobal;
7696 vno := InvalidVal;
7697 repeat
7698 Temp := Result;
7699 if Result <> nil then CheckFurther(Result, False);
7700 if Result <> nil then CheckClass(Result, vt, vno, False);
7701 if Result <> nil then CheckExtClass(Result, vt, vno, False);
7702 {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
7703 if Result <> nil then CheckProcCall(Result);
7704 if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
7705 vno := InvalidVal;
7706 until (Result = nil) or (Temp = Result);
7707 exit;
7708 end;
7709 end;
7710 Result := nil;
7711 MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
7712 end;
7713
calcnull7714 function calc(endOn: TPSPasToken): TPSValue;
7715 function TryEvalConst(var P: TPSValue): Boolean; forward;
7716
7717
7718 function ReadExpression: TPSValue; forward;
7719 function ReadTerm: TPSValue; forward;
ReadFactornull7720 function ReadFactor: TPSValue;
7721 var
7722 NewVar: TPSValue;
7723 NewVarU: TPSUnValueOp;
7724 Proc: TPSProcedure;
7725 function ReadArray: Boolean;
7726 var
7727 tmp: TPSValue;
7728 begin
7729 FParser.Next;
7730 NewVar := TPSValueArray.Create;
7731 NewVar.SetParserPos(FParser);
7732 if FParser.CurrTokenID <> CSTI_CloseBlock then
7733 begin
7734 while True do
7735 begin
7736 tmp := nil;
7737 Tmp := ReadExpression();
7738 if Tmp = nil then
7739 begin
7740 Result := False;
7741 NewVar.Free;
7742 exit;
7743 end;
7744 if not TryEvalConst(tmp) then
7745 begin
7746 tmp.Free;
7747 NewVar.Free;
7748 Result := False;
7749 exit;
7750 end;
7751 TPSValueArray(NewVar).Add(tmp);
7752 if FParser.CurrTokenID = CSTI_CloseBlock then Break;
7753 if FParser.CurrTokenID <> CSTI_Comma then
7754 begin
7755 MakeError('', ecCloseBlockExpected, '');
7756 NewVar.Free;
7757 Result := False;
7758 exit;
7759 end;
7760 FParser.Next;
7761 end;
7762 end;
7763 FParser.Next;
7764 Result := True;
7765 end;
7766
CallAssignednull7767 function CallAssigned(P: TPSValue): TPSValue;
7768 var
7769 temp: TPSValueProcNo;
7770 begin
7771 temp := TPSValueProcNo.Create;
7772 temp.ProcNo := FindProc('!ASSIGNED');
7773 temp.ResultType := at2ut(FDefaultBoolType);
7774 temp.Parameters := TPSParameters.Create;
7775 with Temp.Parameters.Add do
7776 begin
7777 Val := p;
7778 ExpectedType := GetTypeNo(BlockInfo, p);
7779 {$IFDEF DEBUG}
7780 if not ExpectedType.Used then asm int 3; end;
7781 {$ENDIF}
7782 FParamMode := pmIn;
7783 end;
7784 Result := Temp;
7785 end;
7786
CallSuccnull7787 function CallSucc(P: TPSValue): TPSValue;
7788 var
7789 temp: TPSBinValueOp;
7790 begin
7791 temp := TPSBinValueOp.Create;
7792 temp.SetParserPos(FParser);
7793 temp.FOperator := otAdd;
7794 temp.FVal2 := TPSValueData.Create;
7795 TPSValueData(Temp.FVal2).Data := NewVariant(FindBaseType(bts32));
7796 TPSValueData(Temp.FVal2).Data.ts32 := 1;
7797 temp.FVal1 := p;
7798 Temp.FType := GetTypeNo(BlockInfo, P);
7799 result := temp;
7800 end;
7801
CallPrednull7802 function CallPred(P: TPSValue): TPSValue;
7803 var
7804 temp: TPSBinValueOp;
7805 begin
7806 temp := TPSBinValueOp.Create;
7807 temp.SetParserPos(FParser);
7808 temp.FOperator := otSub;
7809 temp.FVal2 := TPSValueData.Create;
7810 TPSValueData(Temp.FVal2).Data := NewVariant(FindBaseType(bts32));
7811 TPSValueData(Temp.FVal2).Data.ts32 := 1;
7812 temp.FVal1 := p;
7813 Temp.FType := GetTypeNo(BlockInfo, P);
7814 result := temp;
7815 end;
7816
7817 begin
7818 case fParser.CurrTokenID of
7819 CSTI_OpenBlock:
7820 begin
7821 if not ReadArray then
7822 begin
7823 Result := nil;
7824 exit;
7825 end;
7826 end;
7827 CSTII_Not:
7828 begin
7829 FParser.Next;
7830 NewVar := ReadFactor;
7831 if NewVar = nil then
7832 begin
7833 Result := nil;
7834 exit;
7835 end;
7836 NewVarU := TPSUnValueOp.Create;
7837 NewVarU.SetParserPos(FParser);
7838 NewVarU.aType := GetTypeNo(BlockInfo, NewVar);
7839 NewVarU.Operator := otNot;
7840 NewVarU.Val1 := NewVar;
7841 NewVar := NewVarU;
7842 end;
7843 CSTI_Plus:
7844 begin
7845 FParser.Next;
7846 NewVar := ReadTerm;
7847 if NewVar = nil then
7848 begin
7849 Result := nil;
7850 exit;
7851 end;
7852 end;
7853 CSTI_Minus:
7854 begin
7855 FParser.Next;
7856 NewVar := ReadTerm;
7857 if NewVar = nil then
7858 begin
7859 Result := nil;
7860 exit;
7861 end;
7862 NewVarU := TPSUnValueOp.Create;
7863 NewVarU.SetParserPos(FParser);
7864 NewVarU.aType := GetTypeNo(BlockInfo, NewVar);
7865 NewVarU.Operator := otMinus;
7866 NewVarU.Val1 := NewVar;
7867 NewVar := NewVarU;
7868 end;
7869 CSTII_Nil:
7870 begin
7871 FParser.Next;
7872 NewVar := TPSValueNil.Create;
7873 NewVar.SetParserPos(FParser);
7874 end;
7875 CSTI_AddressOf:
7876 begin
7877 FParser.Next;
7878 if FParser.CurrTokenID <> CSTI_Identifier then
7879 begin
7880 MakeError('', ecIdentifierExpected, '');
7881 Result := nil;
7882 exit;
7883 end;
7884 NewVar := TPSValueProcPtr.Create;
7885 NewVar.SetParserPos(FParser);
7886 TPSValueProcPtr(NewVar).ProcPtr := FindProc(FParser.GetToken);
7887 if TPSValueProcPtr(NewVar).ProcPtr = InvalidVal then
7888 begin
7889 MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
7890 NewVar.Free;
7891 Result := nil;
7892 exit;
7893 end;
7894 Proc := FProcs[TPSValueProcPtr(NewVar).ProcPtr];
7895 if Proc.ClassType <> TPSInternalProcedure then
7896 begin
7897 MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
7898 NewVar.Free;
7899 Result := nil;
7900 exit;
7901 end;
7902 FParser.Next;
7903 end;
7904 CSTI_OpenRound:
7905 begin
7906 FParser.Next;
7907 NewVar := ReadExpression();
7908 if NewVar = nil then
7909 begin
7910 Result := nil;
7911 exit;
7912 end;
7913 if FParser.CurrTokenId <> CSTI_CloseRound then
7914 begin
7915 NewVar.Free;
7916 Result := nil;
7917 MakeError('', ecCloseRoundExpected, '');
7918 exit;
7919 end;
7920 FParser.Next;
7921 end;
7922 CSTI_Char, CSTI_String:
7923 begin
7924 NewVar := TPSValueData.Create;
7925 NewVar.SetParserPos(FParser);
7926 TPSValueData(NewVar).Data := ReadString;
7927 if TPSValueData(NewVar).Data = nil then
7928 begin
7929 NewVar.Free;
7930 Result := nil;
7931 exit;
7932 end;
7933 end;
7934 CSTI_HexInt, CSTI_Integer:
7935 begin
7936 NewVar := TPSValueData.Create;
7937 NewVar.SetParserPos(FParser);
7938 TPSValueData(NewVar).Data := ReadInteger(FParser.GetToken);
7939 FParser.Next;
7940 end;
7941 CSTI_Real:
7942 begin
7943 NewVar := TPSValueData.Create;
7944 NewVar.SetParserPos(FParser);
7945 TPSValueData(NewVar).Data := ReadReal(FParser.GetToken);
7946 FParser.Next;
7947 end;
7948 CSTII_Ord:
7949 begin
7950 FParser.Next;
7951 if fParser.Currtokenid <> CSTI_OpenRound then
7952 begin
7953 Result := nil;
7954 MakeError('', ecOpenRoundExpected, '');
7955 exit;
7956 end;
7957 FParser.Next;
7958 NewVar := ReadExpression();
7959 if NewVar = nil then
7960 begin
7961 Result := nil;
7962 exit;
7963 end;
7964 if FParser.CurrTokenId <> CSTI_CloseRound then
7965 begin
7966 NewVar.Free;
7967 Result := nil;
7968 MakeError('', ecCloseRoundExpected, '');
7969 exit;
7970 end;
7971 if not ((GetTypeNo(BlockInfo, NewVar).BaseType = btChar) or
7972 {$IFNDEF PS_NOWIDESTRING} (GetTypeNo(BlockInfo, NewVar).BaseType = btWideChar) or{$ENDIF}
7973 (GetTypeNo(BlockInfo, NewVar).BaseType = btEnum) or (IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType))) then
7974 begin
7975 NewVar.Free;
7976 Result := nil;
7977 MakeError('', ecTypeMismatch, '');
7978 exit;
7979 end;
7980 NewVarU := TPSUnValueOp.Create;
7981 NewVarU.SetParserPos(FParser);
7982 NewVarU.Operator := otCast;
7983 NewVarU.FType := at2ut(FindBaseType(btu32));
7984 NewVarU.Val1 := NewVar;
7985 NewVar := NewVarU;
7986 FParser.Next;
7987 end;
7988 CSTII_Chr:
7989 begin
7990 FParser.Next;
7991 if fParser.Currtokenid <> CSTI_OpenRound then
7992 begin
7993 Result := nil;
7994 MakeError('', ecOpenRoundExpected, '');
7995 exit;
7996 end;
7997 FParser.Next;
7998 NewVar := ReadExpression();
7999 if NewVar = nil then
8000 begin
8001 Result := nil;
8002 exit;
8003 end;
8004 if FParser.CurrTokenId <> CSTI_CloseRound then
8005 begin
8006 NewVar.Free;
8007 Result := nil;
8008 MakeError('', ecCloseRoundExpected, '');
8009 exit;
8010 end;
8011 if not (IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType)) then
8012 begin
8013 NewVar.Free;
8014 Result := nil;
8015 MakeError('', ecTypeMismatch, '');
8016 exit;
8017 end;
8018 NewVarU := TPSUnValueOp.Create;
8019 NewVarU.SetParserPos(FParser);
8020 NewVarU.Operator := otCast;
8021 NewVarU.FType := at2ut(FindBaseType(btChar));
8022 NewVarU.Val1 := NewVar;
8023 NewVar := NewVarU;
8024 FParser.Next;
8025 end;
8026 CSTI_Identifier:
8027 begin
8028 if FParser.GetToken = 'SUCC' then
8029 begin
8030 FParser.Next;
8031 if FParser.CurrTokenID <> CSTI_OpenRound then
8032 begin
8033 Result := nil;
8034 MakeError('', ecOpenRoundExpected, '');
8035 exit;
8036 end;
8037 FParser.Next;
8038 NewVar := ReadExpression;
8039 if NewVar = nil then
8040 begin
8041 result := nil;
8042 exit;
8043 end;
8044 if (GetTypeNo(BlockInfo, NewVar) = nil) or (not IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType) and
8045 (GetTypeNo(BlockInfo, NewVar).BaseType <> btEnum)) then
8046 begin
8047 NewVar.Free;
8048 Result := nil;
8049 MakeError('', ecTypeMismatch, '');
8050 exit;
8051 end;
8052 if FParser.CurrTokenID <> CSTI_CloseRound then
8053 begin
8054 NewVar.Free;
8055 Result := nil;
8056 MakeError('', eccloseRoundExpected, '');
8057 exit;
8058 end;
8059 NewVar := CallSucc(NewVar);
8060 FParser.Next;
8061 end else
8062 if FParser.GetToken = 'PRED' then
8063 begin
8064 FParser.Next;
8065 if FParser.CurrTokenID <> CSTI_OpenRound then
8066 begin
8067 Result := nil;
8068 MakeError('', ecOpenRoundExpected, '');
8069 exit;
8070 end;
8071 FParser.Next;
8072 NewVar := ReadExpression;
8073 if NewVar = nil then
8074 begin
8075 result := nil;
8076 exit;
8077 end;
8078 if (GetTypeNo(BlockInfo, NewVar) = nil) or (not IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType) and
8079 (GetTypeNo(BlockInfo, NewVar).BaseType <> btEnum)) then
8080 begin
8081 NewVar.Free;
8082 Result := nil;
8083 MakeError('', ecTypeMismatch, '');
8084 exit;
8085 end;
8086 if FParser.CurrTokenID <> CSTI_CloseRound then
8087 begin
8088 NewVar.Free;
8089 Result := nil;
8090 MakeError('', eccloseRoundExpected, '');
8091 exit;
8092 end;
8093 NewVar := CallPred(NewVar);
8094 FParser.Next;
8095 end else
8096 if FParser.GetToken = 'ASSIGNED' then
8097 begin
8098 FParser.Next;
8099 if FParser.CurrTokenID <> CSTI_OpenRound then
8100 begin
8101 Result := nil;
8102 MakeError('', ecOpenRoundExpected, '');
8103 exit;
8104 end;
8105 FParser.Next;
8106 NewVar := GetIdentifier(0);
8107 if NewVar = nil then
8108 begin
8109 result := nil;
8110 exit;
8111 end;
8112 if (GetTypeNo(BlockInfo, NewVar) = nil) or
8113 ((GetTypeNo(BlockInfo, NewVar).BaseType <> btClass) and
8114 (GetTypeNo(BlockInfo, NewVar).BaseType <> btInterface) and
8115 (GetTypeNo(BlockInfo, NewVar).BaseType <> btPChar) and
8116 (GetTypeNo(BlockInfo, NewVar).BaseType <> btString)) then
8117 begin
8118 NewVar.Free;
8119 Result := nil;
8120 MakeError('', ecTypeMismatch, '');
8121 exit;
8122 end;
8123 if FParser.CurrTokenID <> CSTI_CloseRound then
8124 begin
8125 NewVar.Free;
8126 Result := nil;
8127 MakeError('', eccloseRoundExpected, '');
8128 exit;
8129 end;
8130 NewVar := CallAssigned(NewVar);
8131 FParser.Next;
8132 end else
8133 begin
8134 NewVar := GetIdentifier(0);
8135 if NewVar = nil then
8136 begin
8137 Result := nil;
8138 exit;
8139 end;
8140 end;
8141 end;
8142 else
8143 begin
8144 MakeError('', ecSyntaxError, '');
8145 Result := nil;
8146 exit;
8147 end;
8148 end; {case}
8149 Result := NewVar;
8150 end; // ReadFactor
8151
GetResultTypenull8152 function GetResultType(p1, P2: TPSValue; Cmd: TPSBinOperatorType): TPSType;
8153 var
8154 pp, t1, t2: PIFPSType;
8155 begin
8156 t1 := GetTypeNo(BlockInfo, p1);
8157 t2 := GetTypeNo(BlockInfo, P2);
8158 if (t1 = nil) or (t2 = nil) then
8159 begin
8160 if ((p1.ClassType = TPSValueNil) or (p2.ClassType = TPSValueNil)) and ((t1 <> nil) or (t2 <> nil)) then
8161 begin
8162 if p1.ClassType = TPSValueNil then
8163 pp := t2
8164 else
8165 pp := t1;
8166 if (pp.BaseType = btPchar) or (pp.BaseType = btString) or (pp.BaseType = btClass) {$IFNDEF PS_NOINTERFACES}or (pp.BaseType =btInterface){$ENDIF} or (pp.BaseType = btProcPtr) then
8167 Result := AT2UT(FDefaultBoolType)
8168 else
8169 Result := nil;
8170 exit;
8171 end;
8172 Result := nil;
8173 exit;
8174 end;
8175 case Cmd of
8176 otAdd: {plus}
8177 begin
8178 if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
8179 ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
8180 (t2.BaseType = btString) or
8181 {$IFNDEF PS_NOWIDESTRING}
8182 (t2.BaseType = btwideString) or
8183 (t2.BaseType = btUnicodestring) or
8184 (t2.BaseType = btwidechar) or
8185 {$ENDIF}
8186 (t2.BaseType = btPchar) or
8187 (t2.BaseType = btChar) or
8188 (isIntRealType(t2.BaseType))) then
8189 Result := t1
8190 else
8191 if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and (
8192 ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
8193 (t1.BaseType = btString) or
8194 {$IFNDEF PS_NOWIDESTRING}
8195 (t1.BaseType = btUnicodestring) or
8196 (t1.BaseType = btwideString) or
8197 (t1.BaseType = btwidechar) or
8198 {$ENDIF}
8199 (t1.BaseType = btPchar) or
8200 (t1.BaseType = btChar) or
8201 (isIntRealType(t1.BaseType))) then
8202 Result := t2
8203 else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) then
8204 Result := t1
8205 else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
8206 Result := t1
8207 else if IsIntRealType(t1.BaseType) and
8208 IsIntRealType(t2.BaseType) then
8209 begin
8210 if IsRealType(t1.BaseType) then
8211 Result := t1
8212 else
8213 Result := t2;
8214 end
8215 else if (t1.basetype = btSet) and (t2.Name = 'TVARIANTARRAY') then
8216 Result := t1
8217 else if (t2.basetype = btSet) and (t1.Name = 'TVARIANTARRAY') then
8218 Result := t2
8219 else if ((t1.BaseType = btPchar) or(t1.BaseType = btString) or (t1.BaseType = btChar)) and ((t2.BaseType = btPchar) or(t2.BaseType = btString) or (t2.BaseType = btChar)) then
8220 Result := at2ut(FindBaseType(btString))
8221 {$IFNDEF PS_NOWIDESTRING}
8222 else if ((t1.BaseType = btString) or (t1.BaseType = btChar) or (t1.BaseType = btPchar)or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar) or (t1.BaseType = btUnicodeString)) and
8223 ((t2.BaseType = btString) or (t2.BaseType = btChar) or (t2.BaseType = btPchar) or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar) or (t2.BaseType = btUnicodeString)) then
8224 Result := at2ut(FindBaseType(btUnicodeString))
8225 {$ENDIF}
8226 else
8227 Result := nil;
8228 end;
8229
8230 otSub, otMul, otIntDiv, otDiv: { - * / }
8231 begin
8232 if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
8233 ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
8234 (isIntRealType(t2.BaseType))) then
8235 begin
8236 Result := t1;
8237 {$IFDEF PS_DELPHIDIV}
8238 if Cmd = otDiv then
8239 result := FindBaseType(btExtended);
8240 {$ENDIF}
8241 end
8242 else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) and ((cmd = otSub) or (cmd = otMul)) then
8243 Result := t1
8244 else if (t1.basetype = btSet) and (t2.Name = 'TVARIANTARRAY') and ((cmd = otSub) or (cmd = otMul)) then
8245 Result := t1
8246 else if (t2.basetype = btSet) and (t1.Name = 'TVARIANTARRAY') and ((cmd = otSub) or (cmd = otMul)) then
8247 Result := t2
8248 else
8249 if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and (
8250 ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
8251 (isIntRealType(t1.BaseType))) then
8252 begin
8253 Result := t2;
8254 {$IFDEF PS_DELPHIDIV}
8255 if Cmd = otDiv then
8256 result := FindBaseType(btExtended);
8257 {$ENDIF}
8258 end
8259 else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then begin
8260 Result := t1;
8261 {$IFDEF PS_DELPHIDIV}
8262 if Cmd = otDiv then
8263 result := FindBaseType(btExtended);
8264 {$ENDIF}
8265 end else if IsIntRealType(t1.BaseType) and
8266 IsIntRealType(t2.BaseType) then
8267 begin
8268 if IsRealType(t1.BaseType) then
8269 Result := t1
8270 else
8271 Result := t2;
8272 {$IFDEF PS_DELPHIDIV}
8273 if Cmd = otIntDiv then //intdiv only works
8274 result := nil;
8275 {$ENDIF}
8276 end
8277 else
8278 Result := nil;
8279 end;
8280 otAnd, otOr, otXor: {and,or,xor}
8281 begin
8282 if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
8283 ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
8284 (isIntType(t2.BaseType))) then
8285 Result := t1
8286 else
8287 if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and (
8288 ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
8289 (isIntType(t1.BaseType))) then
8290 Result := t2
8291 else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
8292 Result := t1
8293 else if (IsBoolean(t1)) and ((t2 = t1) or ((t2.BaseType = btVariant)
8294 or (t2.BaseType = btNotificationVariant))) then
8295 begin
8296 Result := t1;
8297 if ((p1.ClassType = TPSValueData) or (p2.ClassType = TPSValueData)) then
8298 begin
8299 if cmd = otAnd then {and}
8300 begin
8301 if p1.ClassType = TPSValueData then
8302 begin
8303 if (TPSValueData(p1).FData^.tu8 <> 0) then
8304 begin
8305 with MakeWarning('', ewIsNotNeeded, '"True and"') do
8306 if p1.Pos>0 then
8307 begin
8308 FRow := p1.Row;
8309 FCol := p1.Col;
8310 FPosition := p1.Pos;
8311 end;
8312 end else
8313 begin
8314 with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'False') do
8315 begin
8316 FRow := p1.Row;
8317 FCol := p1.Col;
8318 FPosition := p1.Pos;
8319 end;
8320 end;
8321 end else begin
8322 if (TPSValueData(p2).Data.tu8 <> 0) then
8323 begin
8324 with MakeWarning('', ewIsNotNeeded, '"and True"') do
8325 if p2.Pos>0 then
8326 begin
8327 FRow := p2.Row;
8328 FCol := p2.Col;
8329 FPosition := p2.Pos;
8330 end;
8331 end
8332 else
8333 begin
8334 with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'False') do
8335 begin
8336 FRow := p2.Row;
8337 FCol := p2.Col;
8338 FPosition := p2.Pos;
8339 end;
8340 end;
8341 end;
8342 end else if cmd = otOr then {or}
8343 begin
8344 if p1.ClassType = TPSValueData then
8345 begin
8346 if (TPSValueData(p1).Data.tu8 <> 0) then
8347 begin
8348 with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'True') do
8349 begin
8350 FRow := p1.Row;
8351 FCol := p1.Col;
8352 FPosition := p1.Pos;
8353 end;
8354 end
8355 else
8356 begin
8357 with MakeWarning('', ewIsNotNeeded, '"False or"') do
8358 begin
8359 FRow := p1.Row;
8360 FCol := p1.Col;
8361 FPosition := p1.Pos;
8362 end;
8363 end
8364 end else begin
8365 if (TPSValueData(p2).Data.tu8 <> 0) then
8366 begin
8367 with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'True') do
8368 begin
8369 FRow := p2.Row;
8370 FCol := p2.Col;
8371 FPosition := p1.Pos;
8372 end;
8373 end
8374 else
8375 begin
8376 with MakeWarning('', ewIsNotNeeded, '"or False"') do
8377 begin
8378 FRow := p2.Row;
8379 FCol := p2.Col;
8380 FPosition := p2.Pos;
8381 end;
8382 end
8383 end;
8384 end;
8385 end;
8386 end else
8387 Result := nil;
8388 end;
8389 otMod, otShl, otShr: {mod,shl,shr}
8390 begin
8391 if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
8392 ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
8393 (isIntType(t2.BaseType))) then
8394 Result := t1
8395 else
8396 if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and (
8397 ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
8398 (isIntType(t1.BaseType))) then
8399 Result := t2
8400 else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
8401 Result := t1
8402 else
8403 Result := nil;
8404 end;
8405 otGreater, otLess, otGreaterEqual, otLessEqual: { >=, <=, >, <}
8406 begin
8407 if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
8408 ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
8409 (t2.BaseType = btString) or
8410 (t2.BaseType = btPchar) or
8411 (t2.BaseType = btChar) or
8412 (isIntRealType(t2.BaseType))) then
8413 Result := FDefaultBoolType
8414 else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) and ((cmd = otGreaterEqual) or (cmd = otLessEqual)) then
8415 Result := FDefaultBoolType
8416 else
8417 if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and (
8418 ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
8419 (t1.BaseType = btString) or
8420 (t1.BaseType = btPchar) or
8421 (t1.BaseType = btChar) or
8422 (isIntRealType(t1.BaseType))) then
8423 Result := FDefaultBoolType
8424 else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
8425 Result := FDefaultBoolType
8426 else if IsIntRealType(t1.BaseType) and
8427 IsIntRealType(t2.BaseType) then
8428 Result := FDefaultBoolType
8429 else if
8430 ((t1.BaseType = btString) or (t1.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar) or (t1.BaseType = btUnicodestring){$ENDIF}) and
8431 ((t2.BaseType = btString) or (t2.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar) or (t2.BaseType = btUnicodestring){$ENDIF}) then
8432 Result := FDefaultBoolType
8433 else if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) then
8434 Result := FDefaultBoolType
8435 else
8436 Result := nil;
8437 end;
8438 otEqual, otNotEqual: {=, <>}
8439 begin
8440 if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
8441 ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
8442 (t2.BaseType = btString) or
8443 (t2.BaseType = btPchar) or
8444 (t2.BaseType = btChar) or
8445 (isIntRealType(t2.BaseType))) then
8446 Result := FDefaultBoolType
8447 else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) then
8448 Result := FDefaultBoolType
8449 else
8450 if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and (
8451 ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
8452 (t1.BaseType = btString) or
8453 (t1.BaseType = btPchar) or
8454 (t1.BaseType = btChar) or
8455 (isIntRealType(t1.BaseType))) then
8456 Result := FDefaultBoolType
8457 else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
8458 Result := FDefaultBoolType
8459 else if IsIntRealType(t1.BaseType) and
8460 IsIntRealType(t2.BaseType) then
8461 Result := FDefaultBoolType
8462 else if
8463 ((t1.BaseType = btString) or (t1.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar) or (t1.BaseType = btUnicodestring){$ENDIF}) and
8464 ((t2.BaseType = btString) or (t2.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar) or (t2.BaseType = btUnicodestring){$ENDIF}) then
8465 Result := FDefaultBoolType
8466 else if (t1.basetype = btSet) and (t2.Name = 'TVARIANTARRAY') then
8467 Result := FDefaultBoolType
8468 else if (t2.basetype = btSet) and (t1.Name = 'TVARIANTARRAY') then
8469 Result := FDefaultBoolType
8470 else if (t1.BaseType = btEnum) and (t1 = t2) then
8471 Result := FDefaultBoolType
8472 else if (t1.BaseType = btClass) and (t2.BaseType = btClass) then
8473 Result := FDefaultBoolType
8474 else if (t1 = t2) then
8475 Result := FDefaultBoolType
8476 else if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) then
8477 Result := FDefaultBoolType
8478 else Result := nil;
8479 end;
8480 otIn:
8481 begin
8482 if (t2.Name = 'TVARIANTARRAY') then
8483 Result := FDefaultBoolType
8484 else
8485 if (t2.BaseType = btSet) and (TPSSetType(t2).SetType = t1) then
8486 Result := FDefaultBoolType
8487 else
8488 Result := nil;
8489 end;
8490 otIs:
8491 begin
8492 if t2.BaseType = btType then
8493 begin
8494 Result := FDefaultBoolType
8495 end else
8496 Result := nil;
8497 end;
8498 otAs:
8499 begin
8500 if t2.BaseType = btType then
8501 begin
8502 Result := at2ut(TPSValueData(p2).Data.ttype);
8503 end else
8504 Result := nil;
8505 end;
8506 else
8507 Result := nil;
8508 end;
8509 end;
8510
8511
ReadTermnull8512 function ReadTerm: TPSValue;
8513 var
8514 F1, F2: TPSValue;
8515 fType: TPSType;
8516 F: TPSBinValueOp;
8517 Token: TPSPasToken;
8518 Op: TPSBinOperatorType;
8519 begin
8520 F1 := ReadFactor;
8521 if F1 = nil then
8522 begin
8523 Result := nil;
8524 exit;
8525 end;
8526 while FParser.CurrTokenID in [CSTI_Multiply, CSTI_Divide, CSTII_Div, CSTII_Mod, CSTII_And, CSTII_Shl, CSTII_Shr, CSTII_As] do
8527 begin
8528 Token := FParser.CurrTokenID;
8529 FParser.Next;
8530 F2 := ReadFactor;
8531 if f2 = nil then
8532 begin
8533 f1.Free;
8534 Result := nil;
8535 exit;
8536 end;
8537 case Token of
8538 CSTI_Multiply: Op := otMul;
8539 CSTI_Divide: Op := otDiv;
8540 CSTII_div: Op := otIntDiv;
8541 CSTII_mod: Op := otMod;
8542 CSTII_and: Op := otAnd;
8543 CSTII_shl: Op := otShl;
8544 CSTII_shr: Op := otShr;
8545 CSTII_As: Op := otAs;
8546 else
8547 Op := otAdd;
8548 end;
8549 if (Op = otAs) and (f2 is TPSValueData) and (TPSValueData(f2).Data.FType.BaseType = btType) then begin
8550 fType := TPSValueData(f2).Data.ttype;
8551 f2.Free;
8552 f2 := TPSUnValueOp.Create;
8553 TPSUnValueOp(F2).Val1 := f1;
8554 TPSUnValueOp(F2).SetParserPos(FParser);
8555 TPSUnValueOp(f2).FType := fType;
8556 TPSUnValueOp(f2).Operator := otCast;
8557 f1 := f2;
8558 end else begin
8559 F := TPSBinValueOp.Create;
8560 f.Val1 := F1;
8561 f.Val2 := F2;
8562 f.Operator := Op;
8563 f.aType := GetResultType(F1, F2, Op);
8564 if f.aType = nil then
8565 begin
8566 MakeError('', ecTypeMismatch, '');
8567 f.Free;
8568 Result := nil;
8569 exit;
8570 end;
8571 f1 := f;
8572 end;
8573 end;
8574 Result := F1;
8575 end; // ReadTerm
8576
ReadSimpleExpressionnull8577 function ReadSimpleExpression: TPSValue;
8578 var
8579 F1, F2: TPSValue;
8580 F: TPSBinValueOp;
8581 Token: TPSPasToken;
8582 Op: TPSBinOperatorType;
8583 begin
8584 F1 := ReadTerm;
8585 if F1 = nil then
8586 begin
8587 Result := nil;
8588 exit;
8589 end;
8590 while FParser.CurrTokenID in [CSTI_Plus, CSTI_Minus, CSTII_Or, CSTII_Xor] do
8591 begin
8592 Token := FParser.CurrTokenID;
8593 FParser.Next;
8594 F2 := ReadTerm;
8595 if f2 = nil then
8596 begin
8597 f1.Free;
8598 Result := nil;
8599 exit;
8600 end;
8601 case Token of
8602 CSTI_Plus: Op := otAdd;
8603 CSTI_Minus: Op := otSub;
8604 CSTII_or: Op := otOr;
8605 CSTII_xor: Op := otXor;
8606 else
8607 Op := otAdd;
8608 end;
8609 F := TPSBinValueOp.Create;
8610 f.Val1 := F1;
8611 f.Val2 := F2;
8612 f.Operator := Op;
8613 f.aType := GetResultType(F1, F2, Op);
8614 if f.aType = nil then
8615 begin
8616 MakeError('', ecTypeMismatch, '');
8617 f.Free;
8618 Result := nil;
8619 exit;
8620 end;
8621 f1 := f;
8622 end;
8623 Result := F1;
8624 end; // ReadSimpleExpression
8625
8626
ReadExpressionnull8627 function ReadExpression: TPSValue;
8628 var
8629 F1, F2: TPSValue;
8630 F: TPSBinValueOp;
8631 Token: TPSPasToken;
8632 Op: TPSBinOperatorType;
8633 begin
8634 F1 := ReadSimpleExpression;
8635 if F1 = nil then
8636 begin
8637 Result := nil;
8638 exit;
8639 end;
8640 while FParser.CurrTokenID in [ CSTI_GreaterEqual, CSTI_LessEqual, CSTI_Greater, CSTI_Less, CSTI_Equal, CSTI_NotEqual, CSTII_in, CSTII_is] do
8641 begin
8642 Token := FParser.CurrTokenID;
8643 FParser.Next;
8644 F2 := ReadSimpleExpression;
8645 if f2 = nil then
8646 begin
8647 f1.Free;
8648 Result := nil;
8649 exit;
8650 end;
8651 case Token of
8652 CSTI_GreaterEqual: Op := otGreaterEqual;
8653 CSTI_LessEqual: Op := otLessEqual;
8654 CSTI_Greater: Op := otGreater;
8655 CSTI_Less: Op := otLess;
8656 CSTI_Equal: Op := otEqual;
8657 CSTI_NotEqual: Op := otNotEqual;
8658 CSTII_in: Op := otIn;
8659 CSTII_is: Op := otIs;
8660 else
8661 Op := otAdd;
8662 end;
8663 F := TPSBinValueOp.Create;
8664 f.Val1 := F1;
8665 f.Val2 := F2;
8666 f.Operator := Op;
8667 f.aType := GetResultType(F1, F2, Op);
8668 if f.aType = nil then
8669 begin
8670 MakeError('', ecTypeMismatch, '');
8671 f.Free;
8672 Result := nil;
8673 exit;
8674 end;
8675 f1 := f;
8676 end;
8677 Result := F1;
8678 end; // ReadExpression
8679
TryEvalConstnull8680 function TryEvalConst(var P: TPSValue): Boolean;
8681 var
8682 preplace: TPSValue;
8683 begin
8684 if p is TPSBinValueOp then
8685 begin
8686 if not (TryEvalConst(TPSBinValueOp(p).FVal1) and TryEvalConst(TPSBinValueOp(p).FVal2)) then
8687 begin
8688 Result := False;
8689 exit;
8690 end;
8691 if (TPSBinValueOp(p).FVal1.ClassType = TPSValueData) and (TPSBinValueOp(p).FVal2.ClassType = TPSValueData) then
8692 begin
8693 if not PreCalc(True, 0, TPSValueData(TPSBinValueOp(p).Val1).Data, 0, TPSValueData(TPSBinValueOp(p).Val2).Data, TPSBinValueOp(p).Operator, p.Pos, p.Row, p.Col) then
8694 begin
8695 Result := False;
8696 exit;
8697 end;
8698 preplace := TPSValueData.Create;
8699 preplace.Pos := p.Pos;
8700 preplace.Row := p.Row;
8701 preplace.Col := p.Col;
8702 TPSValueData(preplace).Data := TPSValueData(TPSBinValueOp(p).Val1).Data;
8703 TPSValueData(TPSBinValueOp(p).Val1).Data := nil;
8704 p.Free;
8705 p := preplace;
8706 end;
8707 end else if p is TPSUnValueOp then
8708 begin
8709 if not TryEvalConst(TPSUnValueOp(p).FVal1) then
8710 begin
8711 Result := False;
8712 exit;
8713 end;
8714 if TPSUnValueOp(p).FVal1.ClassType = TPSValueData then
8715 begin
8716 //
8717 case TPSUnValueOp(p).Operator of
8718 otNot:
8719 begin
8720 case TPSValueData(TPSUnValueOp(p).FVal1).Data^.FType.BaseType of
8721 btEnum:
8722 begin
8723 if IsBoolean(TPSValueData(TPSUnValueOp(p).FVal1).Data^.FType) then
8724 begin
8725 TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8 := (not TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8) and 1;
8726 end else
8727 begin
8728 MakeError('', ecTypeMismatch, '');
8729 Result := False;
8730 exit;
8731 end;
8732 end;
8733 btU8: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8734 btU16: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8735 btU32: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu32 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu32;
8736 bts8: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts8 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts8;
8737 bts16: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts16 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts16;
8738 bts32: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts32 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts32;
8739 {$IFNDEF PS_NOINT64}
8740 bts64: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8741 {$ENDIF}
8742 else
8743 begin
8744 MakeError('', ecTypeMismatch, '');
8745 Result := False;
8746 exit;
8747 end;
8748 end;
8749 preplace := TPSUnValueOp(p).Val1;
8750 TPSUnValueOp(p).Val1 := nil;
8751 p.Free;
8752 p := preplace;
8753 end;
8754 otMinus:
8755 begin
8756 case TPSValueData(TPSUnValueOp(p).FVal1).Data^.FType.BaseType of
8757 btU8: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8758 btU16: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8759 btU32: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu32 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu32;
8760 bts8: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts8 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts8;
8761 bts16: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts16 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts16;
8762 bts32: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts32 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts32;
8763 {$IFNDEF PS_NOINT64}
8764 bts64: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8765 {$ENDIF}
8766 btSingle: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tsingle := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tsingle;
8767 btDouble: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tdouble := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tdouble;
8768 btExtended: TPSValueData(TPSUnValueOp(p).FVal1).Data^.textended := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.textended;
8769 btCurrency: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tcurrency := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tcurrency;
8770 else
8771 begin
8772 MakeError('', ecTypeMismatch, '');
8773 Result := False;
8774 exit;
8775 end;
8776 end;
8777 preplace := TPSUnValueOp(p).Val1;
8778 TPSUnValueOp(p).Val1 := nil;
8779 p.Free;
8780 p := preplace;
8781 end;
8782 otCast:
8783 begin
8784 preplace := TPSValueData.Create;
8785 TPSValueData(preplace).Data := NewVariant(TPSUnValueOp(p).FType);
8786 case TPSUnValueOp(p).FType.BaseType of
8787 btU8:
8788 begin
8789 case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
8790 btchar: TPSValueData(preplace).Data.tu8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
8791 {$IFNDEF PS_NOWIDESTRING}
8792 btwidechar: TPSValueData(preplace).Data.tu8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
8793 {$ENDIF}
8794 btU8: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8795 btS8: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
8796 btU16: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8797 btS16: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
8798 btU32: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
8799 btS32: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
8800 {$IFNDEF PS_NOINT64}
8801 btS64: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8802 {$ENDIF}
8803 else
8804 begin
8805 MakeError('', ecTypeMismatch, '');
8806 preplace.Free;
8807 Result := False;
8808 exit;
8809 end;
8810 end;
8811 end;
8812 btS8:
8813 begin
8814 case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
8815 btchar: TPSValueData(preplace).Data.ts8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
8816 {$IFNDEF PS_NOWIDESTRING}
8817 btwidechar: TPSValueData(preplace).Data.ts8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
8818 {$ENDIF}
8819 btU8: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8820 btS8: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
8821 btU16: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8822 btS16: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
8823 btU32: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
8824 btS32: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
8825 {$IFNDEF PS_NOINT64}
8826 btS64: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8827 {$ENDIF}
8828 else
8829 begin
8830 MakeError('', ecTypeMismatch, '');
8831 preplace.Free;
8832 Result := False;
8833 exit;
8834 end;
8835 end;
8836 end;
8837 btU16:
8838 begin
8839 case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
8840 btchar: TPSValueData(preplace).Data.tu16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
8841 {$IFNDEF PS_NOWIDESTRING}
8842 btwidechar: TPSValueData(preplace).Data.tu16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
8843 {$ENDIF}
8844 btU8: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8845 btS8: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
8846 btU16: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8847 btS16: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
8848 btU32: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
8849 btS32: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
8850 {$IFNDEF PS_NOINT64}
8851 btS64: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8852 {$ENDIF}
8853 else
8854 begin
8855 MakeError('', ecTypeMismatch, '');
8856 preplace.Free;
8857 Result := False;
8858 exit;
8859 end;
8860 end;
8861 end;
8862 bts16:
8863 begin
8864 case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
8865 btchar: TPSValueData(preplace).Data.ts16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
8866 {$IFNDEF PS_NOWIDESTRING}
8867 btwidechar: TPSValueData(preplace).Data.ts16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
8868 {$ENDIF}
8869 btU8: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8870 btS8: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
8871 btU16: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8872 btS16: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
8873 btU32: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
8874 btS32: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
8875 {$IFNDEF PS_NOINT64}
8876 btS64: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8877 {$ENDIF}
8878 else
8879 begin
8880 MakeError('', ecTypeMismatch, '');
8881 preplace.Free;
8882 Result := False;
8883 exit;
8884 end;
8885 end;
8886 end;
8887 btU32:
8888 begin
8889 case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
8890 btchar: TPSValueData(preplace).Data.tu32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
8891 {$IFNDEF PS_NOWIDESTRING}
8892 btwidechar: TPSValueData(preplace).Data.tu32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
8893 {$ENDIF}
8894 btU8: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8895 btS8: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
8896 btU16: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8897 btS16: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
8898 btU32: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
8899 btS32: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
8900 {$IFNDEF PS_NOINT64}
8901 btS64: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8902 {$ENDIF}
8903 else
8904 begin
8905 MakeError('', ecTypeMismatch, '');
8906 preplace.Free;
8907 Result := False;
8908 exit;
8909 end;
8910 end;
8911 end;
8912 btS32:
8913 begin
8914 case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
8915 btchar: TPSValueData(preplace).Data.ts32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
8916 {$IFNDEF PS_NOWIDESTRING}
8917 btwidechar: TPSValueData(preplace).Data.ts32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
8918 {$ENDIF}
8919 btU8: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8920 btS8: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
8921 btU16: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8922 btS16: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
8923 btU32: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
8924 btS32: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
8925 {$IFNDEF PS_NOINT64}
8926 btS64: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8927 {$ENDIF}
8928 else
8929 begin
8930 MakeError('', ecTypeMismatch, '');
8931 preplace.Free;
8932 Result := False;
8933 exit;
8934 end;
8935 end;
8936 end;
8937 {$IFNDEF PS_NOINT64}
8938 btS64:
8939 begin
8940 case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
8941 btchar: TPSValueData(preplace).Data.ts64 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
8942 {$IFNDEF PS_NOWIDESTRING}
8943 btwidechar: TPSValueData(preplace).Data.ts64 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
8944 {$ENDIF}
8945 btU8: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
8946 btS8: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
8947 btU16: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
8948 btS16: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
8949 btU32: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
8950 btS32: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
8951 btS64: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
8952 else
8953 begin
8954 MakeError('', ecTypeMismatch, '');
8955 preplace.Free;
8956 Result := False;
8957 exit;
8958 end;
8959 end;
8960 end;
8961 {$ENDIF}
8962 btChar:
8963 begin
8964 case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
8965 btchar: TPSValueData(preplace).Data.tchar := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar;
8966 btU8: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8);
8967 btS8: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8);
8968 btU16: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16);
8969 btS16: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16);
8970 btU32: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32);
8971 btS32: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32);
8972 {$IFNDEF PS_NOINT64}
8973 btS64: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64);
8974 {$ENDIF}
8975 else
8976 begin
8977 MakeError('', ecTypeMismatch, '');
8978 Result := False;
8979 preplace.Free;
8980 exit;
8981 end;
8982 end;
8983 end;
8984 else
8985 begin
8986 MakeError('', ecTypeMismatch, '');
8987 Result := False;
8988 preplace.Free;
8989 exit;
8990 end;
8991 end;
8992 p.Free;
8993 p := preplace;
8994 end;
8995 else
8996 begin
8997 MakeError('', ecTypeMismatch, '');
8998 Result := False;
8999 exit;
9000 end;
9001 end; // case
9002 end; // if
9003 end;
9004 Result := True;
9005 end;
9006
9007 var
9008 Temp, Val: TPSValue;
9009 vt: TPSVariableType;
9010
9011 begin
9012 Val := ReadExpression;
9013 if Val = nil then
9014 begin
9015 Result := nil;
9016 exit;
9017 end;
9018 vt := ivtGlobal;
9019 repeat
9020 Temp := Val;
9021 if Val <> nil then CheckFurther(Val, False);
9022 if Val <> nil then CheckClass(Val, vt, InvalidVal, False);
9023 if Val <> nil then CheckExtClass(Val, vt, InvalidVal, False);
9024 {$IFNDEF PS_NOIDISPATCH}if Val <> nil then CheckIntf(Val, vt, InvalidVal, False);{$ENDIF}
9025 if Val <> nil then CheckProcCall(Val);
9026 if Val<> nil then CheckClassArrayProperty(Val, vt, InvalidVal);
9027 until (Val = nil) or (Temp = Val);
9028
9029 if not TryEvalConst(Val) then
9030 begin
9031 Val.Free;
9032 Result := nil;
9033 exit;
9034 end;
9035 Result := Val;
9036 end;
9037
ReadParametersnull9038 function ReadParameters(IsProperty: Boolean; Dest: TPSParameters): Boolean;
9039 var
9040 sr,cr: TPSPasToken;
9041 begin
9042 if IsProperty then
9043 begin
9044 sr := CSTI_OpenBlock;
9045 cr := CSTI_CloseBlock;
9046 end else begin
9047 sr := CSTI_OpenRound;
9048 cr := CSTI_CloseRound;
9049 end;
9050 if FParser.CurrTokenId = sr then
9051 begin
9052 FParser.Next;
9053 if FParser.CurrTokenId = cr then
9054 begin
9055 FParser.Next;
9056 Result := True;
9057 exit;
9058 end;
9059 end else
9060 begin
9061 result := True;
9062 exit;
9063 end;
9064 repeat
9065 with Dest.Add do
9066 begin
9067 Val := calc(CSTI_CloseRound);
9068 if Val = nil then
9069 begin
9070 result := false;
9071 exit;
9072 end;
9073 end;
9074 if FParser.CurrTokenId = cr then
9075 begin
9076 FParser.Next;
9077 Break;
9078 end;
9079 if FParser.CurrTokenId <> CSTI_Comma then
9080 begin
9081 MakeError('', ecCommaExpected, '');
9082 Result := false;
9083 exit;
9084 end; {if}
9085 FParser.Next;
9086 until False;
9087 Result := true;
9088 end;
9089
ReadProcParametersnull9090 function ReadProcParameters(ProcNo: Cardinal; FSelf: TPSValue): TPSValue;
9091 var
9092 Decl: TPSParametersDecl;
9093 begin
9094 if TPSProcedure(FProcs[ProcNo]).ClassType = TPSInternalProcedure then
9095 Decl := TPSInternalProcedure(FProcs[ProcNo]).Decl
9096 else
9097 Decl := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl;
9098 UseProc(Decl);
9099 Result := TPSValueProcNo.Create;
9100 TPSValueProcNo(Result).ProcNo := ProcNo;
9101 TPSValueProcNo(Result).ResultType := Decl.Result;
9102 with TPSValueProcNo(Result) do
9103 begin
9104 SetParserPos(FParser);
9105 Parameters := TPSParameters.Create;
9106 if FSelf <> nil then
9107 begin
9108 Parameters.Add;
9109 end;
9110 end;
9111
9112 if not ReadParameters(False, TPSValueProc(Result).Parameters) then
9113 begin
9114 FSelf.Free;
9115 Result.Free;
9116 Result := nil;
9117 exit;
9118 end;
9119
9120 if not ValidateParameters(BlockInfo, TPSValueProc(Result).Parameters, Decl) then
9121 begin
9122 FSelf.Free;
9123 Result.Free;
9124 Result := nil;
9125 exit;
9126 end;
9127 if FSelf <> nil then
9128 begin
9129 with TPSValueProcNo(Result).Parameters[0] do
9130 begin
9131 Val := FSelf;
9132 ExpectedType := GetTypeNo(BlockInfo, FSelf);
9133 end;
9134 end;
9135 end;
9136 {$IFNDEF PS_NOIDISPATCH}
9137
ReadIDispatchParametersnull9138 function ReadIDispatchParameters(const ProcName: tbtString; aVariantType: TPSVariantType; FSelf: TPSValue): TPSValue;
9139 var
9140 Par: TPSParameters;
9141 PropSet: Boolean;
9142 i: Longint;
9143 Temp: TPSValue;
9144 begin
9145 Par := TPSParameters.Create;
9146 try
9147 if not ReadParameters(FParser.CurrTokenID = CSTI_OpenBlock, Par) then
9148 begin
9149 FSelf.Free;
9150 Result := nil;
9151 exit;
9152 end;
9153
9154 if FParser.CurrTokenID = CSTI_Assignment then
9155 begin
9156 FParser.Next;
9157 PropSet := True;
9158 Temp := calc(CSTI_SemiColon);
9159 if temp = nil then
9160 begin
9161 FSelf.Free;
9162 Result := nil;
9163 exit;
9164 end;
9165 with par.Add do
9166 begin
9167 FValue := Temp;
9168 end;
9169 end else
9170 begin
9171 PropSet := False;
9172 end;
9173
9174 Result := TPSValueProcNo.Create;
9175 TPSValueProcNo(Result).ResultType := aVariantType;
9176 with TPSValueProcNo(Result) do
9177 begin
9178 SetParserPos(FParser);
9179 Parameters := TPSParameters.Create;
9180 if FSelf <> nil then
9181 begin
9182 with Parameters.Add do
9183 begin
9184 Val := FSelf;
9185 ExpectedType := aVariantType.GetDynIvokeSelfType(Self);
9186 end;
9187 with Parameters.Add do
9188 begin
9189 Val := TPSValueData.Create;
9190 TPSValueData(Val).Data := NewVariant(FDefaultBoolType);
9191 TPSValueData(Val).Data.tu8 := Ord(PropSet);
9192 ExpectedType := FDefaultBoolType;
9193 end;
9194
9195 with Parameters.Add do
9196 begin
9197 Val := TPSValueData.Create;
9198 TPSValueData(Val).Data := NewVariant(FindBaseType(btString));
9199 tbtString(TPSValueData(Val).data.tString) := Procname;
9200 ExpectedType := FindBaseType(btString);
9201 end;
9202
9203 with Parameters.Add do
9204 begin
9205 val := TPSValueArray.Create;
9206 ExpectedType := aVariantType.GetDynInvokeParamType(Self);
9207 temp := Val;
9208 end;
9209 for i := 0 to Par.Count -1 do
9210 begin
9211 TPSValueArray(Temp).Add(par.Item[i].Val);
9212 par.Item[i].val := nil;
9213 end;
9214 end;
9215 end;
9216 TPSValueProcNo(Result).ProcNo := aVariantType.GetDynInvokeProcNo(Self, ProcName, TPSValueProcNo(Result).Parameters);
9217 finally
9218 Par.Free;
9219 end;
9220
9221 end;
9222
9223 {$ENDIF}
9224
ReadVarParametersnull9225 function ReadVarParameters(ProcNoVar: TPSValue): TPSValue;
9226 var
9227 Decl: TPSParametersDecl;
9228 begin
9229 Decl := TPSProceduralType(GetTypeNo(BlockInfo, ProcnoVar)).ProcDef;
9230 UseProc(Decl);
9231
9232 Result := TPSValueProcVal.Create;
9233
9234 with TPSValueProcVal(Result) do
9235 begin
9236 ResultType := Decl.Result;
9237 ProcNo := ProcNoVar;
9238 Parameters := TPSParameters.Create;
9239 end;
9240
9241 if not ReadParameters(False, TPSValueProc(Result).Parameters) then
9242 begin
9243 Result.Free;
9244 Result := nil;
9245 exit;
9246 end;
9247
9248 if not ValidateParameters(BlockInfo, TPSValueProc(Result).Parameters, Decl) then
9249 begin
9250 Result.Free;
9251 Result := nil;
9252 exit;
9253 end;
9254 end;
9255
9256
WriteCalculationnull9257 function WriteCalculation(InData, OutReg: TPSValue): Boolean;
9258
CheckOutregnull9259 function CheckOutreg(Where, Outreg: TPSValue; aRoot: Boolean): Boolean;
9260 var
9261 i: Longint;
9262 begin
9263 Result := False;
9264 if Outreg is TPSValueReplace
9265 then Outreg:=TPSValueReplace(Outreg).OldValue;
9266 if Where is TPSValueVar then begin
9267 if TPSValueVar(Where).GetRecCount > 0 then result := true;
9268 if SAmeReg(Where, OutReg) and not aRoot then
9269 result := true;
9270 end else
9271 if Where.ClassType = TPSUnValueOp then
9272 begin
9273 if CheckOutReg(TPSUnValueOp(Where).Val1, OutReg, aRoot) then
9274 Result := True;
9275 end else if Where.ClassType = TPSBinValueOp then
9276 begin
9277 if CheckOutreg(TPSBinValueOp(Where).Val1, OutReg, aRoot) or CheckOutreg(TPSBinValueOp(Where).Val2, OutReg, False) then
9278 Result := True;
9279 end else if Where is TPSValueVar then
9280 begin
9281 if SameReg(Where, OutReg) then
9282 Result := True;
9283 end else if Where is TPSValueProc then
9284 begin
9285 for i := 0 to TPSValueProc(Where).Parameters.Count -1 do
9286 begin
9287 if Checkoutreg(TPSValueProc(Where).Parameters[i].Val, Outreg, false) then
9288 begin
9289 Result := True;
9290 break;
9291 end;
9292 end;
9293 end;
9294 end;
9295 begin
9296 if not CheckCompatType(Outreg, InData) then
9297 begin
9298 MakeError('', ecTypeMismatch, '');
9299 Result := False;
9300 exit;
9301 end;
9302 if SameReg(OutReg, InData) then
9303 begin
9304 Result := True;
9305 exit;
9306 end;
9307 if InData is TPSValueProc then
9308 begin
PSValueProcnull9309 Result := _ProcessFunction(TPSValueProc(indata), OutReg)
9310 end else begin
9311 if not PreWriteOutRec(OutReg, nil) then
9312 begin
9313 Result := False;
9314 exit;
9315 end;
9316 if (not CheckOutReg(InData, OutReg, true)) and (InData is TPSBinValueOp) or (InData is TPSUnValueOp) then
9317 begin
9318 if InData is TPSBinValueOp then
9319 begin
9320 if not DoBinCalc(TPSBinValueOp(InData), OutReg) then
9321 begin
9322 AfterWriteOutRec(OutReg);
9323 Result := False;
9324 exit;
9325 end;
9326 end else
9327 begin
9328 if not DoUnCalc(TPSUnValueOp(InData), OutReg) then
9329 begin
9330 AfterWriteOutRec(OutReg);
9331 Result := False;
9332 exit;
9333 end;
9334 end;
9335 end else if (InData is TPSBinValueOp) and (not CheckOutReg(TPSBinValueOp(InData).Val2, OutReg, false)) then
9336 begin
9337 if not DoBinCalc(TPSBinValueOp(InData), OutReg) then
9338 begin
9339 AfterWriteOutRec(OutReg);
9340 Result := False;
9341 exit;
9342 end;
9343 end else begin
9344 if not PreWriteOutRec(InData, GetTypeNo(BlockInfo, OutReg)) then
9345 begin
9346 Result := False;
9347 exit;
9348 end;
9349 BlockWriteByte(BlockInfo, CM_A);
9350 if not (WriteOutRec(OutReg, False) and WriteOutRec(InData, True)) then
9351 begin
9352 Result := False;
9353 exit;
9354 end;
9355 AfterWriteOutRec(InData);
9356 end;
9357 AfterWriteOutRec(OutReg);
9358 Result := True;
9359 end;
9360 end; {WriteCalculation}
9361
9362
_ProcessFunctionnull9363 function _ProcessFunction(ProcCall: TPSValueProc; ResultRegister: TPSValue): Boolean;
9364 var
9365 res: TPSType;
9366 tmp: TPSParameter;
9367 lTv: TPSValue;
9368 resreg: TPSValue;
9369 l: Longint;
9370
Cleanupnull9371 function Cleanup: Boolean;
9372 var
9373 i: Longint;
9374 begin
9375 for i := 0 to ProcCall.Parameters.Count -1 do
9376 begin
9377 if ProcCall.Parameters[i].TempVar <> nil then
9378 ProcCall.Parameters[i].TempVar.Free;
9379 ProcCall.Parameters[i].TempVar := nil;
9380 end;
9381 if ProcCall is TPSValueProcVal then
9382 AfterWriteOutRec(TPSValueProcVal(ProcCall).fProcNo);
9383 if ResReg <> nil then
9384 AfterWriteOutRec(resreg);
9385 if ResReg <> nil then
9386 begin
9387 if ResReg <> ResultRegister then
9388 begin
9389 if ResultRegister <> nil then
9390 begin
9391 if not WriteCalculation(ResReg, ResultRegister) then
9392 begin
9393 Result := False;
9394 resreg.Free;
9395 exit;
9396 end;
9397 end;
9398 resreg.Free;
9399 end;
9400 end;
9401 Result := True;
9402 end;
9403
9404 begin
9405 Res := ProcCall.ResultType;
9406 if ProcCall.ResultType = FAnyString then
9407 begin
9408 for l := ProcCall.Parameters.Count - 1 downto 0 do
9409 begin
9410 Tmp := ProcCall.Parameters[l];
9411 if (Tmp.ParamMode <> pmOut) and (Tmp.ExpectedType = FAnyString) then
9412 begin
9413 Res := GetTypeNo(BlockInfo, tmp.Val);
9414 Break;
9415 end;
9416 end;
9417 end;
9418 Result := False;
9419 if (res = nil) and (ResultRegister <> nil) then
9420 begin
9421 MakeError('', ecNoResult, '');
9422 exit;
9423 end
9424 else if (res <> nil) then
9425 begin
9426 if (ResultRegister = nil) or (Res <> GetTypeNo(BlockInfo, ResultRegister)) then
9427 begin
9428 resreg := AllocStackReg(res);
9429
9430 end else resreg := ResultRegister;
9431 end
9432 else
9433 resreg := nil;
9434 if ResReg <> nil then
9435 begin
9436 if not PreWriteOutRec(resreg, nil) then
9437 begin
9438 Cleanup;
9439 exit;
9440 end;
9441 end;
9442 if Proccall is TPSValueProcVal then
9443 begin
9444 if not PreWriteOutRec(TPSValueProcVal(ProcCall).fProcNo, nil) then
9445 begin
9446 Cleanup;
9447 exit;
9448 end;
9449 end;
9450 for l := ProcCall.Parameters.Count - 1 downto 0 do
9451 begin
9452 Tmp := ProcCall.Parameters[l];
9453 if (Tmp.ParamMode <> pmIn) then
9454 begin
9455 if IsVarInCompatible(GetTypeNo(BlockInfo, tmp.Val), tmp.ExpectedType) then
9456 begin
9457 with MakeError('', ecTypeMismatch, '') do
9458 begin
9459 pos := tmp.Val.Pos;
9460 row := tmp.Val.row;
9461 col := tmp.Val.col;
9462 end;
9463 Cleanup;
9464 exit;
9465 end;
9466 if Copy(tmp.ExpectedType.Name, 1, 10) = '!OPENARRAY' then begin
9467 tmp.TempVar := AllocPointer(tmp.ExpectedType);
9468 lTv := AllocStackReg(tmp.ExpectedType);
9469 if not PreWriteOutRec(Tmp.FValue, nil) then
9470 begin
9471 cleanup;
9472 exit;
9473 end;
9474 BlockWriteByte(BlockInfo, CM_A);
9475 WriteOutRec(lTv, False);
9476 WriteOutRec(Tmp.FValue, False);
9477 AfterWriteOutRec(Tmp.FValue);
9478
9479 BlockWriteByte(BlockInfo, cm_sp);
9480 WriteOutRec(tmp.TempVar, False);
9481 WriteOutRec(lTv, False);
9482
9483 lTv.Free;
9484 // BlockWriteByte(BlockInfo, CM_PO); // pop the temp var
9485
9486 end else begin
9487 tmp.TempVar := AllocPointer(GetTypeNo(BlockInfo, Tmp.FValue));
9488 if not PreWriteOutRec(Tmp.FValue, nil) then
9489 begin
9490 cleanup;
9491 exit;
9492 end;
9493 BlockWriteByte(BlockInfo, cm_sp);
9494 WriteOutRec(tmp.TempVar, False);
9495 WriteOutRec(Tmp.FValue, False);
9496 AfterWriteOutRec(Tmp.FValue);
9497 end;
9498 end
9499 else
9500 begin
9501 if (Tmp.ExpectedType = nil) or (Tmp.ExpectedType = FAnyString) then
9502 Tmp.ExpectedType := GetTypeNo(BlockInfo, tmp.Val);
9503 if Tmp.ExpectedType.BaseType = btPChar then
9504 begin
9505 Tmp.TempVar := AllocStackReg(at2ut(FindBaseType(btstring)))
9506 end else
9507 begin
9508 Tmp.TempVar := AllocStackReg(Tmp.ExpectedType);
9509 end;
9510 if not WriteCalculation(Tmp.Val, Tmp.TempVar) then
9511 begin
9512 Cleanup;
9513 exit;
9514 end;
9515 end;
9516 end; {for}
9517 if res <> nil then
9518 begin
9519 BlockWriteByte(BlockInfo, CM_PV);
9520
9521 if not WriteOutRec(resreg, False) then
9522 begin
9523 Cleanup;
9524 MakeError('', ecInternalError, '00015');
9525 exit;
9526 end;
9527 end;
9528 if ProcCall is TPSValueProcVal then
9529 begin
9530 BlockWriteByte(BlockInfo, Cm_cv);
9531 WriteOutRec(TPSValueProcVal(ProcCall).ProcNo, True);
9532 end else begin
9533 BlockWriteByte(BlockInfo, CM_C);
9534 BlockWriteLong(BlockInfo, TPSValueProcNo(ProcCall).ProcNo);
9535 end;
9536 if res <> nil then
9537 BlockWriteByte(BlockInfo, CM_PO);
9538 if not Cleanup then
9539 begin
9540 Result := False;
9541 exit;
9542 end;
9543 Result := True;
9544 end; {ProcessVarFunction}
9545
HasInvalidJumpsnull9546 function HasInvalidJumps(StartPos, EndPos: Cardinal): Boolean;
9547 var
9548 I, J: Longint;
9549 Ok: LongBool;
9550 FLabelsInBlock: TIfStringList;
9551 s: tbtString;
9552 begin
9553 FLabelsInBlock := TIfStringList.Create;
9554 for i := 0 to BlockInfo.Proc.FLabels.Count -1 do
9555 begin
9556 s := BlockInfo.Proc.FLabels[I];
9557 if (Cardinal((@s[1])^) >= StartPos) and (Cardinal((@s[1])^) <= EndPos) then
9558 begin
9559 Delete(s, 1, 8);
9560 FLabelsInBlock.Add(s);
9561 end;
9562 end;
9563 for i := 0 to BlockInfo.Proc.FGotos.Count -1 do
9564 begin
9565 s := BlockInfo.Proc.FGotos[I];
9566 if (Cardinal((@s[1])^) >= StartPos) and (Cardinal((@s[1])^) <= EndPos) then
9567 begin
9568 Delete(s, 1, 4);
9569 s := BlockInfo.Proc.FLabels[Cardinal((@s[1])^)];
9570 Delete(s,1,8);
9571 OK := False;
9572 for J := 0 to FLabelsInBlock.Count -1 do
9573 begin
9574 if FLabelsInBlock[J] = s then
9575 begin
9576 Ok := True;
9577 Break;
9578 end;
9579 end;
9580 if not Ok then
9581 begin
9582 MakeError('', ecInvalidJump, '');
9583 Result := True;
9584 FLabelsInBlock.Free;
9585 exit;
9586 end;
9587 end else begin
9588 Delete(s, 1, 4);
9589 s := BlockInfo.Proc.FLabels[Cardinal((@s[1])^)];
9590 Delete(s,1,8);
9591 OK := True;
9592 for J := 0 to FLabelsInBlock.Count -1 do
9593 begin
9594 if FLabelsInBlock[J] = s then
9595 begin
9596 Ok := False;
9597 Break;
9598 end;
9599 end;
9600 if not Ok then
9601 begin
9602 MakeError('', ecInvalidJump, '');
9603 Result := True;
9604 FLabelsInBlock.Free;
9605 exit;
9606 end;
9607 end;
9608 end;
9609 FLabelsInBlock.Free;
9610 Result := False;
9611 end;
9612
ProcessFornull9613 function ProcessFor: Boolean;
9614 { Process a for x := y to z do }
9615 var
9616 VariableVar: TPSValue;
9617 TempBool,
9618 InitVal,
9619 finVal: TPSValue;
9620 Block: TPSBlockInfo;
9621 Backwards: Boolean;
9622 FPos, NPos, EPos, RPos: Longint;
9623 OldCO, OldBO: TPSList;
9624 I: Longint;
9625 iOldWithCount: Integer;
9626 iOldTryCount: Integer;
9627 iOldExFnlCount: Integer;
9628 lType: TPSType;
9629 begin
9630 Debug_WriteLine(BlockInfo);
9631 Result := False;
9632 FParser.Next;
9633 if FParser.CurrTokenId <> CSTI_Identifier then
9634 begin
9635 MakeError('', ecIdentifierExpected, '');
9636 exit;
9637 end;
9638 VariableVar := GetIdentifier(1);
9639 if VariableVar = nil then
9640 exit;
9641 lType := GetTypeNo(BlockInfo, VariableVar);
9642 if lType = nil then begin
9643 MakeError('', ecTypeMismatch, '');
9644 VariableVar.Free;
9645 exit;
9646 end;
9647 case lType.BaseType of
9648 btU8, btS8, btU16, btS16, btU32, btS32, {$IFNDEF PS_NOINT64} btS64, {$ENDIF} btVariant, btEnum: ;
9649 else
9650 begin
9651 MakeError('', ecTypeMismatch, '');
9652 VariableVar.Free;
9653 exit;
9654 end;
9655 end;
9656 if FParser.CurrTokenId <> CSTI_Assignment then
9657 begin
9658 MakeError('', ecAssignmentExpected, '');
9659 VariableVar.Free;
9660 exit;
9661 end;
9662 FParser.Next;
9663 InitVal := calc(CSTII_DownTo);
9664 if InitVal = nil then
9665 begin
9666 VariableVar.Free;
9667 exit;
9668 end;
9669 if FParser.CurrTokenId = CSTII_To then
9670 Backwards := False
9671 else if FParser.CurrTokenId = CSTII_DownTo then
9672 Backwards := True
9673 else
9674 begin
9675 MakeError('', ecToExpected, '');
9676 VariableVar.Free;
9677 InitVal.Free;
9678 exit;
9679 end;
9680 FParser.Next;
9681 finVal := calc(CSTII_do);
9682 if finVal = nil then
9683 begin
9684 VariableVar.Free;
9685 InitVal.Free;
9686 exit;
9687 end;
9688 lType := GetTypeNo(BlockInfo, finVal);
9689 if lType = nil then begin
9690 MakeError('', ecTypeMismatch, '');
9691 VariableVar.Free;
9692 InitVal.Free;
9693 exit;
9694 end;
9695 case lType.BaseType of
9696 btVariant, btEnum, btU8, btS8, btU16, btS16, btU32, {$IFNDEF PS_NOINT64} btS64, {$ENDIF} btS32: ;
9697 else
9698 begin
9699 MakeError('', ecTypeMismatch, '');
9700 VariableVar.Free;
9701 InitVal.Free;
9702 exit;
9703 end;
9704 end;
9705 if FParser.CurrTokenId <> CSTII_do then
9706 begin
9707 MakeError('', ecDoExpected, '');
9708 finVal.Free;
9709 InitVal.Free;
9710 VariableVar.Free;
9711 exit;
9712 end;
9713 FParser.Next;
9714 if not WriteCalculation(InitVal, VariableVar) then
9715 begin
9716 VariableVar.Free;
9717 InitVal.Free;
9718 finVal.Free;
9719 exit;
9720 end;
9721 InitVal.Free;
9722 TempBool := AllocStackReg(at2ut(FDefaultBoolType));
9723 NPos := Length(BlockInfo.Proc.Data);
9724 if not (PreWriteOutRec(VariableVar, nil) and PreWriteOutRec(finVal, nil)) then
9725 begin
9726 TempBool.Free;
9727 VariableVar.Free;
9728 finVal.Free;
9729 exit;
9730 end;
9731 BlockWriteByte(BlockInfo, CM_CO);
9732 if Backwards then
9733 begin
9734 BlockWriteByte(BlockInfo, 0); { >= }
9735 end
9736 else
9737 begin
9738 BlockWriteByte(BlockInfo, 1); { <= }
9739 end;
9740 if not (WriteOutRec(TempBool, False) and WriteOutRec(VariableVar, True) and WriteOutRec(finVal, True)) then
9741 begin
9742 TempBool.Free;
9743 VariableVar.Free;
9744 finVal.Free;
9745 exit;
9746 end;
9747 AfterWriteOutRec(finVal);
9748 AfterWriteOutRec(VariableVar);
9749 finVal.Free;
9750 BlockWriteByte(BlockInfo, Cm_CNG);
9751 EPos := Length(BlockInfo.Proc.Data);
9752 BlockWriteLong(BlockInfo, $12345678);
9753 WriteOutRec(TempBool, False);
9754 RPos := Length(BlockInfo.Proc.Data);
9755 OldCO := FContinueOffsets;
9756 FContinueOffsets := TPSList.Create;
9757 OldBO := FBreakOffsets;
9758 FBreakOffsets := TPSList.Create;
9759 Block := TPSBlockInfo.Create(BlockInfo);
9760 Block.SubType := tOneLiner;
9761
9762 iOldWithCount := FWithCount;
9763 FWithCount := 0;
9764 iOldTryCount := FTryCount;
9765 FTryCount := 0;
9766 iOldExFnlCount := FExceptFinallyCount;
9767 FExceptFinallyCount := 0;
9768
9769 if not ProcessSub(Block) then
9770 begin
9771 Block.Free;
9772 TempBool.Free;
9773 VariableVar.Free;
9774 FBreakOffsets.Free;
9775 FContinueOffsets.Free;
9776 FContinueOffsets := OldCO;
9777 FBreakOffsets := OldBo;
9778
9779 FWithCount := iOldWithCount;
9780 FTryCount := iOldTryCount;
9781 FExceptFinallyCount := iOldExFnlCount;
9782
9783 exit;
9784 end;
9785 Block.Free;
9786 FPos := Length(BlockInfo.Proc.Data);
9787 if not PreWriteOutRec(VariableVar, nil) then
9788 begin
9789 TempBool.Free;
9790 VariableVar.Free;
9791 FBreakOffsets.Free;
9792 FContinueOffsets.Free;
9793 FContinueOffsets := OldCO;
9794 FBreakOffsets := OldBo;
9795
9796 FWithCount := iOldWithCount;
9797 FTryCount := iOldTryCount;
9798 FExceptFinallyCount := iOldExFnlCount;
9799
9800 exit;
9801 end;
9802 if Backwards then
9803 BlockWriteByte(BlockInfo, cm_dec)
9804 else
9805 BlockWriteByte(BlockInfo, cm_inc);
9806 if not WriteOutRec(VariableVar, False) then
9807 begin
9808 TempBool.Free;
9809 VariableVar.Free;
9810 FBreakOffsets.Free;
9811 FContinueOffsets.Free;
9812 FContinueOffsets := OldCO;
9813 FBreakOffsets := OldBo;
9814
9815 FWithCount := iOldWithCount;
9816 FTryCount := iOldTryCount;
9817 FExceptFinallyCount := iOldExFnlCount;
9818
9819 exit;
9820 end;
9821 AfterWriteOutRec(VariableVar);
9822 BlockWriteByte(BlockInfo, Cm_G);
9823 BlockWriteLong(BlockInfo, Longint(NPos - Length(BlockInfo.Proc.Data) - 4));
9824 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
9825 unaligned(Longint((@BlockInfo.Proc.Data[EPos + 1])^)) := Length(BlockInfo.Proc.Data) - RPos;
9826 {$else}
9827 Longint((@BlockInfo.Proc.Data[EPos + 1])^) := Length(BlockInfo.Proc.Data) - RPos;
9828 {$endif}
9829 for i := 0 to FBreakOffsets.Count -1 do
9830 begin
9831 EPos := IPointer(FBreakOffsets[I]);
9832 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
9833 unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(EPos);
9834 {$else}
9835 Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos);
9836 {$endif}
9837 end;
9838 for i := 0 to FContinueOffsets.Count -1 do
9839 begin
9840 EPos := IPointer(FContinueOffsets[I]);
9841 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
9842 unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Longint(FPos) - Longint(EPos);
9843 {$else}
9844 Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(FPos) - Longint(EPos);
9845 {$endif}
9846 end;
9847 FBreakOffsets.Free;
9848 FContinueOffsets.Free;
9849 FContinueOffsets := OldCO;
9850 FBreakOffsets := OldBo;
9851
9852 FWithCount := iOldWithCount;
9853 FTryCount := iOldTryCount;
9854 FExceptFinallyCount := iOldExFnlCount;
9855
9856 TempBool.Free;
9857 VariableVar.Free;
9858 if HasInvalidJumps(RPos, Length(BlockInfo.Proc.Data)) then
9859 begin
9860 Result := False;
9861 exit;
9862 end;
9863 Result := True;
9864 end; {ProcessFor}
9865
ProcessWhilenull9866 function ProcessWhile: Boolean;
9867 var
9868 vin, vout: TPSValue;
9869 SPos, EPos: Cardinal;
9870 OldCo, OldBO: TPSList;
9871 I: Longint;
9872 Block: TPSBlockInfo;
9873
9874 iOldWithCount: Integer;
9875 iOldTryCount: Integer;
9876 iOldExFnlCount: Integer;
9877
9878 begin
9879 Result := False;
9880 Debug_WriteLine(BlockInfo);
9881 FParser.Next;
9882 vout := calc(CSTII_do);
9883 if vout = nil then
9884 exit;
9885 if FParser.CurrTokenId <> CSTII_do then
9886 begin
9887 vout.Free;
9888 MakeError('', ecDoExpected, '');
9889 exit;
9890 end;
9891 vin := AllocStackReg(at2ut(FDefaultBoolType));
9892 SPos := Length(BlockInfo.Proc.Data); // start position
9893 OldCo := FContinueOffsets;
9894 FContinueOffsets := TPSList.Create;
9895 OldBO := FBreakOffsets;
9896 FBreakOffsets := TPSList.Create;
9897 if not WriteCalculation(vout, vin) then
9898 begin
9899 vout.Free;
9900 vin.Free;
9901 FBreakOffsets.Free;
9902 FContinueOffsets.Free;
9903 FContinueOffsets := OldCO;
9904 FBreakOffsets := OldBo;
9905 exit;
9906 end;
9907 vout.Free;
9908 FParser.Next; // skip DO
9909 BlockWriteByte(BlockInfo, Cm_CNG); // only goto if expression is false
9910 BlockWriteLong(BlockInfo, $12345678);
9911 EPos := Length(BlockInfo.Proc.Data);
9912 if not WriteOutRec(vin, False) then
9913 begin
9914 MakeError('', ecInternalError, '00017');
9915 vin.Free;
9916 FBreakOffsets.Free;
9917 FContinueOffsets.Free;
9918 FContinueOffsets := OldCO;
9919 FBreakOffsets := OldBo;
9920 exit;
9921 end;
9922 Block := TPSBlockInfo.Create(BlockInfo);
9923 Block.SubType := tOneLiner;
9924
9925 iOldWithCount := FWithCount;
9926 FWithCount := 0;
9927 iOldTryCount := FTryCount;
9928 FTryCount := 0;
9929 iOldExFnlCount := FExceptFinallyCount;
9930 FExceptFinallyCount := 0;
9931
9932 if not ProcessSub(Block) then
9933 begin
9934 Block.Free;
9935 vin.Free;
9936 FBreakOffsets.Free;
9937 FContinueOffsets.Free;
9938 FContinueOffsets := OldCO;
9939 FBreakOffsets := OldBo;
9940
9941 FWithCount := iOldWithCount;
9942 FTryCount := iOldTryCount;
9943 FExceptFinallyCount := iOldExFnlCount;
9944
9945 exit;
9946 end;
9947 Block.Free;
9948 Debug_WriteLine(BlockInfo);
9949 BlockWriteByte(BlockInfo, Cm_G);
9950 BlockWriteLong(BlockInfo, Longint(SPos) - Length(BlockInfo.Proc.Data) - 4);
9951 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
9952 unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(EPos) - 5;
9953 {$else}
9954 Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos) - 5;
9955 {$endif}
9956 for i := 0 to FBreakOffsets.Count -1 do
9957 begin
9958 EPos := Cardinal(FBreakOffsets[I]);
9959 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
9960 unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(EPos);
9961 {$else}
9962 Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos);
9963 {$endif}
9964 end;
9965 for i := 0 to FContinueOffsets.Count -1 do
9966 begin
9967 EPos := Cardinal(FContinueOffsets[I]);
9968 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
9969 unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Longint(SPos) - Longint(EPos);
9970 {$else}
9971 Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(SPos) - Longint(EPos);
9972 {$endif}
9973 end;
9974 FBreakOffsets.Free;
9975 FContinueOffsets.Free;
9976 FContinueOffsets := OldCO;
9977 FBreakOffsets := OldBo;
9978
9979 FWithCount := iOldWithCount;
9980 FTryCount := iOldTryCount;
9981 FExceptFinallyCount := iOldExFnlCount;
9982
9983 vin.Free;
9984 if HasInvalidJumps(EPos, Length(BlockInfo.Proc.Data)) then
9985 begin
9986 Result := False;
9987 exit;
9988 end;
9989 Result := True;
9990 end;
9991
ProcessRepeatnull9992 function ProcessRepeat: Boolean;
9993 var
9994 vin, vout: TPSValue;
9995 CPos, SPos, EPos: Cardinal;
9996 I: Longint;
9997 OldCo, OldBO: TPSList;
9998 Block: TPSBlockInfo;
9999
10000 iOldWithCount: Integer;
10001 iOldTryCount: Integer;
10002 iOldExFnlCount: Integer;
10003
10004 begin
10005 Result := False;
10006 Debug_WriteLine(BlockInfo);
10007 FParser.Next;
10008 OldCo := FContinueOffsets;
10009 FContinueOffsets := TPSList.Create;
10010 OldBO := FBreakOffsets;
10011 FBreakOffsets := TPSList.Create;
10012 vin := AllocStackReg(at2ut(FDefaultBoolType));
10013 SPos := Length(BlockInfo.Proc.Data);
10014 Block := TPSBlockInfo.Create(BlockInfo);
10015 Block.SubType := tRepeat;
10016
10017 iOldWithCount := FWithCount;
10018 FWithCount := 0;
10019 iOldTryCount := FTryCount;
10020 FTryCount := 0;
10021 iOldExFnlCount := FExceptFinallyCount;
10022 FExceptFinallyCount := 0;
10023
10024 if not ProcessSub(Block) then
10025 begin
10026 Block.Free;
10027 FBreakOffsets.Free;
10028 FContinueOffsets.Free;
10029 FContinueOffsets := OldCO;
10030 FBreakOffsets := OldBo;
10031
10032 FWithCount := iOldWithCount;
10033 FTryCount := iOldTryCount;
10034 FExceptFinallyCount := iOldExFnlCount;
10035
10036 vin.Free;
10037 exit;
10038 end;
10039 Block.Free;
10040 FParser.Next; //cstii_until
10041 vout := calc(CSTI_Semicolon);
10042 if vout = nil then
10043 begin
10044 FBreakOffsets.Free;
10045 FContinueOffsets.Free;
10046 FContinueOffsets := OldCO;
10047 FBreakOffsets := OldBo;
10048
10049 FWithCount := iOldWithCount;
10050 FTryCount := iOldTryCount;
10051 FExceptFinallyCount := iOldExFnlCount;
10052
10053 vin.Free;
10054 exit;
10055 end;
10056 CPos := Length(BlockInfo.Proc.Data);
10057 if not WriteCalculation(vout, vin) then
10058 begin
10059 vout.Free;
10060 vin.Free;
10061 FBreakOffsets.Free;
10062 FContinueOffsets.Free;
10063 FContinueOffsets := OldCO;
10064 FBreakOffsets := OldBo;
10065
10066 FWithCount := iOldWithCount;
10067 FTryCount := iOldTryCount;
10068 FExceptFinallyCount := iOldExFnlCount;
10069
10070 exit;
10071 end;
10072 vout.Free;
10073 BlockWriteByte(BlockInfo, Cm_CNG);
10074 BlockWriteLong(BlockInfo, $12345678);
10075 EPos := Length(BlockInfo. Proc.Data);
10076 if not WriteOutRec(vin, False) then
10077 begin
10078 MakeError('', ecInternalError, '00016');
10079 vin.Free;
10080 FBreakOffsets.Free;
10081 FContinueOffsets.Free;
10082 FContinueOffsets := OldCO;
10083 FBreakOffsets := OldBo;
10084
10085 FWithCount := iOldWithCount;
10086 FTryCount := iOldTryCount;
10087 FExceptFinallyCount := iOldExFnlCount;
10088
10089 exit;
10090 end;
10091 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10092 unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Longint(SPos) -
10093 Length(BlockInfo.Proc.Data);
10094 {$else}
10095 Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(SPos) -
10096 Length(BlockInfo.Proc.Data);
10097 {$endif}
10098 for i := 0 to FBreakOffsets.Count -1 do
10099 begin
10100 EPos := Cardinal(FBreakOffsets[I]);
10101 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10102 unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo. Proc.Data) - Longint(EPos);
10103 {$else}
10104 Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo. Proc.Data) - Longint(EPos);
10105 {$endif}
10106 end;
10107 for i := 0 to FContinueOffsets.Count -1 do
10108 begin
10109 EPos := Cardinal(FContinueOffsets[I]);
10110 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10111 unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Longint(CPos) - Longint(EPos);
10112 {$else}
10113 Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(CPos) - Longint(EPos);
10114 {$endif}
10115 end;
10116 FBreakOffsets.Free;
10117 FContinueOffsets.Free;
10118 FContinueOffsets := OldCO;
10119 FBreakOffsets := OldBo;
10120
10121 FWithCount := iOldWithCount;
10122 FTryCount := iOldTryCount;
10123 FExceptFinallyCount := iOldExFnlCount;
10124
10125 vin.Free;
10126 if HasInvalidJumps(SPos, Length(BlockInfo. Proc.Data)) then
10127 begin
10128 Result := False;
10129 exit;
10130 end;
10131 Result := True;
10132 end; {ProcessRepeat}
10133
ProcessIfnull10134 function ProcessIf: Boolean;
10135 var
10136 vout, vin: TPSValue;
10137 SPos, EPos: Cardinal;
10138 Block: TPSBlockInfo;
10139 begin
10140 Result := False;
10141 Debug_WriteLine(BlockInfo);
10142 FParser.Next;
10143 vout := calc(CSTII_Then);
10144 if vout = nil then
10145 exit;
10146 if FParser.CurrTokenId <> CSTII_Then then
10147 begin
10148 vout.Free;
10149 MakeError('', ecThenExpected, '');
10150 exit;
10151 end;
10152 vin := AllocStackReg(at2ut(FDefaultBoolType));
10153 if not WriteCalculation(vout, vin) then
10154 begin
10155 vout.Free;
10156 vin.Free;
10157 exit;
10158 end;
10159 vout.Free;
10160 BlockWriteByte(BlockInfo, cm_sf);
10161 if not WriteOutRec(vin, False) then
10162 begin
10163 MakeError('', ecInternalError, '00018');
10164 vin.Free;
10165 exit;
10166 end;
10167 BlockWriteByte(BlockInfo, 1);
10168 vin.Free;
10169 BlockWriteByte(BlockInfo, cm_fg);
10170 BlockWriteLong(BlockInfo, $12345678);
10171 SPos := Length(BlockInfo.Proc.Data);
10172 FParser.Next; // skip then
10173 Block := TPSBlockInfo.Create(BlockInfo);
10174 Block.SubType := tifOneliner;
10175 if not ProcessSub(Block) then
10176 begin
10177 Block.Free;
10178 exit;
10179 end;
10180 Block.Free;
10181 if FParser.CurrTokenId = CSTII_Else then
10182 begin
10183 BlockWriteByte(BlockInfo, Cm_G);
10184 BlockWriteLong(BlockInfo, $12345678);
10185 EPos := Length(BlockInfo.Proc.Data);
10186 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10187 unaligned(Longint((@BlockInfo.Proc.Data[SPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(SPos);
10188 {$else}
10189 Longint((@BlockInfo.Proc.Data[SPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(SPos);
10190 {$endif}
10191 FParser.Next;
10192 Block := TPSBlockInfo.Create(BlockInfo);
10193 Block.SubType := tOneLiner;
10194 if not ProcessSub(Block) then
10195 begin
10196 Block.Free;
10197 exit;
10198 end;
10199 Block.Free;
10200 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10201 unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(EPos);
10202 {$else}
10203 Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos);
10204 {$endif}
10205 end
10206 else
10207 begin
10208 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10209 unaligned(Longint((@BlockInfo.Proc.Data[SPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(SPos) + 5 - 5;
10210 {$else}
10211 Longint((@BlockInfo.Proc.Data[SPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(SPos) + 5 - 5;
10212 {$endif}
10213 end;
10214 Result := True;
10215 end; {ProcessIf}
10216
_ProcessLabelnull10217 function _ProcessLabel: Longint; {0 = failed; 1 = successful; 2 = no label}
10218 var
10219 I, H: Longint;
10220 s: tbtString;
10221 begin
10222 h := MakeHash(FParser.GetToken);
10223 for i := 0 to BlockInfo.Proc.FLabels.Count -1 do
10224 begin
10225 s := BlockInfo.Proc.FLabels[I];
10226 delete(s, 1, 4);
10227 if Longint((@s[1])^) = h then
10228 begin
10229 delete(s, 1, 4);
10230 if s = FParser.GetToken then
10231 begin
10232 s := BlockInfo.Proc.FLabels[I];
10233 Cardinal((@s[1])^) := Length(BlockInfo.Proc.Data);
10234 BlockInfo.Proc.FLabels[i] := s;
10235 FParser.Next;
10236 if fParser.CurrTokenId = CSTI_Colon then
10237 begin
10238 Result := 1;
10239 FParser.Next;
10240 exit;
10241 end else begin
10242 MakeError('', ecColonExpected, '');
10243 Result := 0;
10244 Exit;
10245 end;
10246 end;
10247 end;
10248 end;
10249 result := 2;
10250 end;
10251
ProcessIdentifiernull10252 function ProcessIdentifier: Boolean;
10253 var
10254 vin, vout: TPSValue;
10255 begin
10256 Result := False;
10257 Debug_WriteLine(BlockInfo);
10258 vin := Calc(CSTI_Assignment);//GetIdentifier(2);
10259 if vin <> nil then
10260 begin
10261 if vin is TPSValueVar then
10262 begin // assignment needed
10263 if FParser.CurrTokenId <> CSTI_Assignment then
10264 begin
10265 MakeError('', ecAssignmentExpected, '');
10266 vin.Free;
10267 exit;
10268 end;
10269 FParser.Next;
10270 vout := calc(CSTI_Semicolon);
10271 if vout = nil then
10272 begin
10273 vin.Free;
10274 exit;
10275 end;
10276 if not WriteCalculation(vout, vin) then
10277 begin
10278 vin.Free;
10279 vout.Free;
10280 exit;
10281 end;
10282 vin.Free;
10283 vout.Free;
10284 end else if vin is TPSValueProc then
10285 begin
PSValueProcnull10286 Result := _ProcessFunction(TPSValueProc(vin), nil);
10287 vin.Free;
10288 Exit;
10289 end else
10290 begin
10291 MakeError('', ecInternalError, '20');
10292 vin.Free;
10293 REsult := False;
10294 exit;
10295 end;
10296 end
10297 else
10298 begin
10299 Result := False;
10300 exit;
10301 end;
10302 Result := True;
10303 end; {ProcessIdentifier}
10304
ProcessCasenull10305 function ProcessCase: Boolean;
10306 var
10307 V1, V2, TempRec, Val, CalcItem: TPSValue;
10308 p: TPSBinValueOp;
10309 SPos, CurrP: Cardinal;
10310 I: Longint;
10311 EndReloc: TPSList;
10312 Block: TPSBlockInfo;
10313
NewRecnull10314 function NewRec(val: TPSValue): TPSValueReplace;
10315 begin
10316 Result := TPSValueReplace.Create;
10317 Result.SetParserPos(FParser);
10318 Result.FNewValue := Val;
10319 Result.FreeNewValue := False;
10320 end;
10321
Combinenull10322 function Combine(v1, v2: TPSValue; Op: TPSBinOperatorType): TPSValue;
10323 begin
10324 if V1 = nil then
10325 begin
10326 Result := v2;
10327 end else if v2 = nil then
10328 begin
10329 Result := V1;
10330 end else
10331 begin
10332 Result := TPSBinValueOp.Create;
10333 TPSBinValueOp(Result).FType := FDefaultBoolType;
10334 TPSBinValueOp(Result).Operator := Op;
10335 Result.SetParserPos(FParser);
10336 TPSBinValueOp(Result).FVal1 := V1;
10337 TPSBinValueOp(Result).FVal2 := V2;
10338 end;
10339 end;
10340
10341
10342 begin
10343 Debug_WriteLine(BlockInfo);
10344 FParser.Next;
10345 Val := calc(CSTII_of);
10346 if Val = nil then
10347 begin
10348 ProcessCase := False;
10349 exit;
10350 end; {if}
10351 if FParser.CurrTokenId <> CSTII_Of then
10352 begin
10353 MakeError('', ecOfExpected, '');
10354 val.Free;
10355 ProcessCase := False;
10356 exit;
10357 end; {if}
10358 FParser.Next;
10359 TempRec := AllocStackReg(GetTypeNo(BlockInfo, Val));
10360 if not WriteCalculation(Val, TempRec) then
10361 begin
10362 TempRec.Free;
10363 val.Free;
10364 ProcessCase := False;
10365 exit;
10366 end; {if}
10367 val.Free;
10368 EndReloc := TPSList.Create;
10369 CalcItem := AllocStackReg(at2ut(FDefaultBoolType));
10370 SPos := Length(BlockInfo.Proc.Data);
10371 repeat
10372 V1 := nil;
10373 while true do
10374 begin
10375 Val := calc(CSTI_Colon);
10376 if (Val = nil) then
10377 begin
10378 V1.Free;
10379 CalcItem.Free;
10380 TempRec.Free;
10381 EndReloc.Free;
10382 ProcessCase := False;
10383 exit;
10384 end; {if}
10385 if fParser.CurrTokenID = CSTI_TwoDots then begin
10386 FParser.Next;
10387 V2 := Calc(CSTI_colon);
10388 if V2 = nil then begin
10389 V1.Free;
10390 CalcItem.Free;
10391 TempRec.Free;
10392 EndReloc.Free;
10393 ProcessCase := False;
10394 Val.Free;
10395 exit;
10396 end;
10397 p := TPSBinValueOp.Create;
10398 p.SetParserPos(FParser);
10399 p.Operator := otGreaterEqual;
10400 p.aType := at2ut(FDefaultBoolType);
10401 p.Val2 := Val;
10402 p.Val1 := NewRec(TempRec);
10403 Val := p;
10404 p := TPSBinValueOp.Create;
10405 p.SetParserPos(FParser);
10406 p.Operator := otLessEqual;
10407 p.aType := at2ut(FDefaultBoolType);
10408 p.Val2 := V2;
10409 p.Val1 := NewRec(TempRec);
10410 P := TPSBinValueOp(Combine(Val,P, otAnd));
10411 end else begin
10412 p := TPSBinValueOp.Create;
10413 p.SetParserPos(FParser);
10414 p.Operator := otEqual;
10415 p.aType := at2ut(FDefaultBoolType);
10416 p.Val1 := Val;
10417 p.Val2 := NewRec(TempRec);
10418 end;
10419 V1 := Combine(V1, P, otOr);
10420 if FParser.CurrTokenId = CSTI_Colon then Break;
10421 if FParser.CurrTokenID <> CSTI_Comma then
10422 begin
10423 MakeError('', ecColonExpected, '');
10424 V1.Free;
10425 CalcItem.Free;
10426 TempRec.Free;
10427 EndReloc.Free;
10428 ProcessCase := False;
10429 exit;
10430 end;
10431 FParser.Next;
10432 end;
10433 FParser.Next;
10434 if not WriteCalculation(V1, CalcItem) then
10435 begin
10436 CalcItem.Free;
10437 v1.Free;
10438 EndReloc.Free;
10439 ProcessCase := False;
10440 exit;
10441 end;
10442 v1.Free;
10443 BlockWriteByte(BlockInfo, Cm_CNG);
10444 BlockWriteLong(BlockInfo, $12345678);
10445 CurrP := Length(BlockInfo.Proc.Data);
10446 WriteOutRec(CalcItem, False);
10447 Block := TPSBlockInfo.Create(BlockInfo);
10448 Block.SubType := tifOneliner;
10449 if not ProcessSub(Block) then
10450 begin
10451 Block.Free;
10452 CalcItem.Free;
10453 TempRec.Free;
10454 EndReloc.Free;
10455 ProcessCase := False;
10456 exit;
10457 end;
10458 Block.Free;
10459 BlockWriteByte(BlockInfo, Cm_G);
10460 BlockWriteLong(BlockInfo, $12345678);
10461 EndReloc.Add(Pointer(Length(BlockInfo.Proc.Data)));
10462 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10463 unaligned(Cardinal((@BlockInfo.Proc.Data[CurrP - 3])^)) := Cardinal(Length(BlockInfo.Proc.Data)) - CurrP - 5;
10464 {$else}
10465 Cardinal((@BlockInfo.Proc.Data[CurrP - 3])^) := Cardinal(Length(BlockInfo.Proc.Data)) - CurrP - 5;
10466 {$endif}
10467 if FParser.CurrTokenID = CSTI_Semicolon then FParser.Next;
10468 if FParser.CurrTokenID = CSTII_Else then
10469 begin
10470 FParser.Next;
10471 Block := TPSBlockInfo.Create(BlockInfo);
10472 Block.SubType := tOneliner;
10473 if not ProcessSub(Block) then
10474 begin
10475 Block.Free;
10476 CalcItem.Free;
10477 TempRec.Free;
10478 EndReloc.Free;
10479 ProcessCase := False;
10480 exit;
10481 end;
10482 Block.Free;
10483 if FParser.CurrTokenID = CSTI_Semicolon then FParser.Next;
10484 if FParser.CurrtokenId <> CSTII_End then
10485 begin
10486 MakeError('', ecEndExpected, '');
10487 CalcItem.Free;
10488 TempRec.Free;
10489 EndReloc.Free;
10490 ProcessCase := False;
10491 exit;
10492 end;
10493 end;
10494 until FParser.CurrTokenID = CSTII_End;
10495 FParser.Next;
10496 for i := 0 to EndReloc.Count -1 do
10497 begin
10498 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10499 unaligned(Cardinal((@BlockInfo.Proc.Data[Cardinal(EndReloc[I])- 3])^)) := Cardinal(Length(BlockInfo.Proc.Data)) - Cardinal(EndReloc[I]);
10500 {$else}
10501 Cardinal((@BlockInfo.Proc.Data[Cardinal(EndReloc[I])- 3])^) := Cardinal(Length(BlockInfo.Proc.Data)) - Cardinal(EndReloc[I]);
10502 {$endif}
10503 end;
10504 CalcItem.Free;
10505 TempRec.Free;
10506 EndReloc.Free;
10507 if FContinueOffsets <> nil then
10508 begin
10509 for i := 0 to FContinueOffsets.Count -1 do
10510 begin
10511 if Cardinal(FContinueOffsets[i]) >= SPos then
10512 begin
10513 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10514 unaligned(Byte((@BlockInfo.Proc.Data[Longint(FContinueOffsets[i]) - 4])^)) := Cm_P2G;
10515 {$else}
10516 Byte((@BlockInfo.Proc.Data[Longint(FContinueOffsets[i]) - 4])^) := Cm_P2G;
10517 {$endif}
10518 end;
10519 end;
10520 end;
10521 if FBreakOffsets <> nil then
10522 begin
10523 for i := 0 to FBreakOffsets.Count -1 do
10524 begin
10525 if Cardinal(FBreakOffsets[i]) >= SPos then
10526 begin
10527 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
10528 unaligned(Byte((@BlockInfo.Proc.Data[Longint(FBreakOffsets[i]) - 4])^)) := Cm_P2G;
10529 {$else}
10530 Byte((@BlockInfo.Proc.Data[Longint(FBreakOffsets[i]) - 4])^) := Cm_P2G;
10531 {$endif}
10532 end;
10533 end;
10534 end;
10535 if HasInvalidJumps(SPos, Length(BlockInfo.Proc.Data)) then
10536 begin
10537 Result := False;
10538 exit;
10539 end;
10540 Result := True;
10541 end; {ProcessCase}
ProcessGotonull10542 function ProcessGoto: Boolean;
10543 var
10544 I, H: Longint;
10545 s: tbtString;
10546 begin
10547 Debug_WriteLine(BlockInfo);
10548 FParser.Next;
10549 h := MakeHash(FParser.GetToken);
10550 for i := 0 to BlockInfo.Proc.FLabels.Count -1 do
10551 begin
10552 s := BlockInfo.Proc.FLabels[I];
10553 delete(s, 1, 4);
10554 if Longint((@s[1])^) = h then
10555 begin
10556 delete(s, 1, 4);
10557 if s = FParser.GetToken then
10558 begin
10559 FParser.Next;
10560 BlockWriteByte(BlockInfo, Cm_G);
10561 BlockWriteLong(BlockInfo, $12345678);
10562 BlockInfo.Proc.FGotos.Add(PS_mi2s(length(BlockInfo.Proc.Data))+PS_mi2s(i));
10563 Result := True;
10564 exit;
10565 end;
10566 end;
10567 end;
10568 MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
10569 Result := False;
10570 end; {ProcessGoto}
10571
ProcessWithnull10572 function ProcessWith: Boolean;
10573 var
10574 Block: TPSBlockInfo;
10575 aVar, aReplace: TPSValue;
10576 aType: TPSType;
10577
10578 iStartOffset: Integer;
10579
10580 tmp: TPSValue;
10581 begin
10582 Debug_WriteLine(BlockInfo);
10583 Block := TPSBlockInfo.Create(BlockInfo);
10584 Block.SubType := tOneLiner;
10585
10586 FParser.Next;
10587 repeat
10588 aVar := GetIdentifier(0);
10589 if aVar = nil then
10590 begin
10591 block.Free;
10592 Result := False;
10593 exit;
10594 end;
10595 AType := GetTypeNo(BlockInfo, aVar);
10596 if (AType = nil) or ((aType.BaseType <> btRecord) and (aType.BaseType <> btClass)) then
10597 begin
10598 MakeError('', ecClassTypeExpected, '');
10599 Block.Free;
10600 Result := False;
10601 exit;
10602 end;
10603
10604 aReplace := TPSValueReplace.Create;
10605 aReplace.SetParserPos(FParser);
10606 TPSValueReplace(aReplace).FreeOldValue := True;
10607 TPSValueReplace(aReplace).FreeNewValue := True;
10608 TPSValueReplace(aReplace).OldValue := aVar;
10609
10610 //if aVar.InheritsFrom(TPSVar) then TPSVar(aVar).Use;
10611 tmp := AllocPointer(GetTypeNo(BlockInfo, aVar));
10612 TPSProcVar(BlockInfo.Proc.ProcVars[TPSValueAllocatedStackVar(tmp).LocalVarNo]).Use;
10613 PreWriteOutRec(tmp,GetTypeNo(BlockInfo, tmp));
10614 PreWriteOutRec(aVar,GetTypeNo(BlockInfo, aVar));
10615 BlockWriteByte(BlockInfo, cm_sp);
10616 WriteOutRec(tmp, false);
10617 WriteOutRec(aVar, false);
10618 TPSValueReplace(aReplace).NewValue := tmp;
10619
10620
10621
10622 Block.WithList.Add(aReplace);
10623
10624 if FParser.CurrTokenID = CSTII_do then
10625 begin
10626 FParser.Next;
10627 Break;
10628 end else
10629 if FParser.CurrTokenId <> CSTI_Comma then
10630 begin
10631 MakeError('', ecDoExpected, '');
10632 Block.Free;
10633 Result := False;
10634 exit;
10635 end;
10636 FParser.Next;
10637 until False;
10638
10639
10640 inc(FWithCount);
10641
10642 iStartOffset := Length(Block.Proc.Data);
10643
10644 if not (ProcessSub(Block) and (not HasInvalidJumps(iStartOffset,Length(BlockInfo.Proc.Data) + 1)) ) then
10645 begin
10646 dec(FWithCount);
10647 Block.Free;
10648 Result := False;
10649 exit;
10650 end;
10651 dec(FWithCount);
10652
10653 AfterWriteOutRec(aVar);
10654 AfterWriteOutRec(tmp);
10655 Block.Free;
10656 Result := True;
10657 end;
10658
ProcessTrynull10659 function ProcessTry: Boolean;
10660 var
10661 FStartOffset: Cardinal;
10662 iBlockStartOffset: Integer;
10663 Block: TPSBlockInfo;
10664 begin
10665 FParser.Next;
10666 BlockWriteByte(BlockInfo, cm_puexh);
10667 FStartOffset := Length(BlockInfo.Proc.Data) + 1;
10668 BlockWriteLong(BlockInfo, InvalidVal);
10669 BlockWriteLong(BlockInfo, InvalidVal);
10670 BlockWriteLong(BlockInfo, InvalidVal);
10671 BlockWriteLong(BlockInfo, InvalidVal);
10672 Block := TPSBlockInfo.Create(BlockInfo);
10673 Block.SubType := tTry;
10674 inc(FTryCount);
10675 if ProcessSub(Block) and (not HasInvalidJumps(FStartOffset,Length(BlockInfo.Proc.Data) + 1)) then
10676 begin
10677 dec(FTryCount);
10678 Block.Free;
10679 BlockWriteByte(BlockInfo, cm_poexh);
10680 BlockWriteByte(BlockInfo, 0);
10681 if FParser.CurrTokenID = CSTII_Except then
10682 begin
10683 FParser.Next;
10684 Cardinal((@BlockInfo.Proc.Data[FStartOffset + 4])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
10685 iBlockStartOffset := Length(BlockInfo.Proc.Data) ;
10686 Block := TPSBlockInfo.Create(BlockInfo);
10687 Block.SubType := tTryEnd;
10688 inc(FExceptFinallyCount);
10689 if ProcessSub(Block) and (not HasInvalidJumps(iBlockStartOffset,Length(BlockInfo.Proc.Data) + 1)) then
10690 begin
10691 dec(FExceptFinallyCount);
10692 Block.Free;
10693 BlockWriteByte(BlockInfo, cm_poexh);
10694 BlockWriteByte(BlockInfo, 2);
10695 if FParser.CurrTokenId = CSTII_Finally then
10696 begin
10697 Cardinal((@BlockInfo.Proc.Data[FStartOffset + 8])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
10698 iBlockStartOffset := Length(BlockInfo.Proc.Data) ;
10699 Block := TPSBlockInfo.Create(BlockInfo);
10700 Block.SubType := tTryEnd;
10701 FParser.Next;
10702 inc(FExceptFinallyCount);
10703 if ProcessSub(Block) and (not HasInvalidJumps(iBlockStartOffset,Length(BlockInfo.Proc.Data) + 1)) then
10704 begin
10705 dec(FExceptFinallyCount);
10706 Block.Free;
10707 if FParser.CurrTokenId = CSTII_End then
10708 begin
10709 BlockWriteByte(BlockInfo, cm_poexh);
10710 BlockWriteByte(BlockInfo, 3);
10711 end else begin
10712 MakeError('', ecEndExpected, '');
10713 Result := False;
10714 exit;
10715 end;
10716 end else
10717 begin
10718 Block.Free;
10719 Result := False;
10720 dec(FExceptFinallyCount);
10721 exit;
10722 end;
10723 end else if FParser.CurrTokenID <> CSTII_End then
10724 begin
10725 MakeError('', ecEndExpected, '');
10726 Result := False;
10727 exit;
10728 end;
10729 FParser.Next;
10730 end else
10731 begin
10732 Block.Free;
10733 Result := False;
10734 dec(FExceptFinallyCount);
10735 exit;
10736 end;
10737 end else if FParser.CurrTokenId = CSTII_Finally then
10738 begin
10739 FParser.Next;
10740 Cardinal((@BlockInfo.Proc.Data[FStartOffset])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
10741 iBlockStartOffset := Length(BlockInfo.Proc.Data) ;
10742 Block := TPSBlockInfo.Create(BlockInfo);
10743 Block.SubType := tTryEnd;
10744 inc(FExceptFinallyCount);
10745 if ProcessSub(Block) and (not HasInvalidJumps(iBlockStartOffset,Length(BlockInfo.Proc.Data) + 1)) then
10746 begin
10747 dec(FExceptFinallyCount);
10748 Block.Free;
10749 BlockWriteByte(BlockInfo, cm_poexh);
10750 BlockWriteByte(BlockInfo, 1);
10751 if FParser.CurrTokenId = CSTII_Except then
10752 begin
10753 Cardinal((@BlockInfo.Proc.Data[FStartOffset + 4])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
10754 iBlockStartOffset := Length(BlockInfo.Proc.Data) ;
10755 FParser.Next;
10756 Block := TPSBlockInfo.Create(BlockInfo);
10757 Block.SubType := tTryEnd;
10758 inc(FExceptFinallyCount);
10759 if ProcessSub(Block) and (not HasInvalidJumps(iBlockStartOffset,Length(BlockInfo.Proc.Data) + 1)) then
10760 begin
10761 dec(FExceptFinallyCount);
10762 Block.Free;
10763 if FParser.CurrTokenId = CSTII_End then
10764 begin
10765 BlockWriteByte(BlockInfo, cm_poexh);
10766 BlockWriteByte(BlockInfo, 2);
10767 end else begin
10768 MakeError('', ecEndExpected, '');
10769 Result := False;
10770 exit;
10771 end;
10772 end else
10773 begin
10774 Block.Free;
10775 Result := False;
10776 dec(FExceptFinallyCount);
10777 exit;
10778 end;
10779 end else if FParser.CurrTokenID <> CSTII_End then
10780 begin
10781 MakeError('', ecEndExpected, '');
10782 Result := False;
10783 exit;
10784 end;
10785 FParser.Next;
10786 end else
10787 begin
10788 Block.Free;
10789 Result := False;
10790 dec(FExceptFinallyCount);
10791 exit;
10792 end;
10793 end;
10794 end else
10795 begin
10796 Block.Free;
10797 Result := False;
10798 dec(FTryCount);
10799 exit;
10800 end;
10801 Cardinal((@BlockInfo.Proc.Data[FStartOffset + 12])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
10802 Result := True;
10803 end; {ProcessTry}
10804
10805 var
10806 i: Integer;
10807 Block: TPSBlockInfo;
10808
10809 begin
10810 ProcessSub := False;
10811 if (BlockInfo.SubType = tProcBegin) or (BlockInfo.SubType= tMainBegin) or
10812 {$IFDEF PS_USESSUPPORT}
10813 (BlockInfo.SubType = tUnitInit) or (BlockInfo.SubType= tUnitFinish) or // NvdS
10814 {$endif}
10815 (BlockInfo.SubType= tSubBegin) then
10816 begin
10817 FParser.Next; // skip CSTII_Begin
10818 end;
10819 while True do
10820 begin
10821 case FParser.CurrTokenId of
10822 CSTII_Goto:
10823 begin
10824 if not ProcessGoto then
10825 Exit;
10826 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10827 break;
10828 end;
10829 CSTII_With:
10830 begin
10831 if not ProcessWith then
10832 Exit;
10833 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10834 break;
10835 end;
10836 CSTII_Try:
10837 begin
10838 if not ProcessTry then
10839 Exit;
10840 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10841 break;
10842 end;
10843 CSTII_Finally, CSTII_Except:
10844 begin
10845 if (BlockInfo.SubType = tTry) or (BlockInfo.SubType = tTryEnd) then
10846 Break
10847 else
10848 begin
10849 MakeError('', ecEndExpected, '');
10850 Exit;
10851 end;
10852 end;
10853 CSTII_Begin:
10854 begin
10855 Block := TPSBlockInfo.Create(BlockInfo);
10856 Block.SubType := tSubBegin;
10857 if not ProcessSub(Block) then
10858 begin
10859 Block.Free;
10860 Exit;
10861 end;
10862 Block.Free;
10863
10864 FParser.Next; // skip END
10865 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10866 break;
10867 end;
10868 CSTI_Semicolon:
10869 begin
10870
10871 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10872 break
10873 else FParser.Next;
10874 end;
10875 CSTII_until:
10876 begin
10877 Debug_WriteLine(BlockInfo);
10878 if BlockInfo.SubType = tRepeat then
10879 begin
10880 break;
10881 end
10882 else
10883 begin
10884 MakeError('', ecIdentifierExpected, '');
10885 exit;
10886 end;
10887 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10888 break;
10889 end;
10890 CSTII_Else:
10891 begin
10892 if BlockInfo.SubType = tifOneliner then
10893 break
10894 else
10895 begin
10896 MakeError('', ecIdentifierExpected, '');
10897 exit;
10898 end;
10899 end;
10900 CSTII_repeat:
10901 begin
10902 if not ProcessRepeat then
10903 exit;
10904 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10905 break;
10906 end;
10907 CSTII_For:
10908 begin
10909 if not ProcessFor then
10910 exit;
10911 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10912 break;
10913 end;
10914 CSTII_While:
10915 begin
10916 if not ProcessWhile then
10917 exit;
10918 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10919 break;
10920 end;
10921 CSTII_Exit:
10922 begin
10923 Debug_WriteLine(BlockInfo);
10924 BlockWriteByte(BlockInfo, Cm_R);
10925 FParser.Next;
10926 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10927 break;
10928 end;
10929 CSTII_Case:
10930 begin
10931 if not ProcessCase then
10932 exit;
10933 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10934 break;
10935 end;
10936 CSTII_If:
10937 begin
10938 if not ProcessIf then
10939 exit;
10940 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10941 break;
10942 end;
10943 CSTI_OpenRound,
10944 CSTI_Identifier:
10945 begin
10946 case _ProcessLabel of
10947 0: Exit;
10948 1: ;
10949 else
10950 begin
10951 if FParser.GetToken = 'BREAK' then
10952 begin
10953 if FBreakOffsets = nil then
10954 begin
10955 MakeError('', ecNotInLoop, '');
10956 exit;
10957 end;
10958 for i := 0 to FExceptFinallyCount - 1 do
10959 begin
10960 BlockWriteByte(BlockInfo, cm_poexh);
10961 BlockWriteByte(BlockInfo, 1);
10962 end;
10963
10964 for i := 0 to FTryCount - 1 do
10965 begin
10966 BlockWriteByte(BlockInfo, cm_poexh);
10967 BlockWriteByte(BlockInfo, 0);
10968 BlockWriteByte(BlockInfo, cm_poexh);
10969 BlockWriteByte(BlockInfo, 1);
10970 end;
10971
10972 for i := 0 to FWithCount - 1 do
10973 BlockWriteByte(BlockInfo,cm_po);
10974 BlockWriteByte(BlockInfo, Cm_G);
10975 BlockWriteLong(BlockInfo, $12345678);
10976 FBreakOffsets.Add(Pointer(Length(BlockInfo.Proc.Data)));
10977 FParser.Next;
10978 if (BlockInfo.SubType= tifOneliner) or (BlockInfo.SubType = TOneLiner) then
10979 break;
10980 end else if FParser.GetToken = 'CONTINUE' then
10981 begin
10982 if FBreakOffsets = nil then
10983 begin
10984 MakeError('', ecNotInLoop, '');
10985 exit;
10986 end;
10987 for i := 0 to FExceptFinallyCount - 1 do
10988 begin
10989 BlockWriteByte(BlockInfo, cm_poexh);
10990 BlockWriteByte(BlockInfo, 1);
10991 end;
10992
10993 for i := 0 to FTryCount - 1 do
10994 begin
10995 BlockWriteByte(BlockInfo, cm_poexh);
10996 BlockWriteByte(BlockInfo, 0);
10997 BlockWriteByte(BlockInfo, cm_poexh);
10998 BlockWriteByte(BlockInfo, 1);
10999 end;
11000
11001 for i := 0 to FWithCount - 1 do
11002 BlockWriteByte(BlockInfo,cm_po);
11003 BlockWriteByte(BlockInfo, Cm_G);
11004 BlockWriteLong(BlockInfo, $12345678);
11005 FContinueOffsets.Add(Pointer(Length(BlockInfo.Proc.Data)));
11006 FParser.Next;
11007 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
11008 break;
11009 end else
11010 if not ProcessIdentifier then
11011 exit;
11012 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
11013 break;
11014 end;
11015 end; {case}
11016
11017 if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
11018 break;
11019
11020 end;
11021 {$IFDEF PS_USESSUPPORT}
11022 CSTII_Finalization: //NvdS
11023 begin //
11024 if (BlockInfo.SubType = tUnitInit) then //
11025 begin //
11026 break; //
11027 end //
11028 else //
11029 begin //
11030 MakeError('', ecIdentifierExpected, ''); //
11031 exit; //
11032 end; //
11033 end; //nvds
11034 {$endif}
11035 CSTII_End:
11036 begin
11037 if (BlockInfo.SubType = tTryEnd) or (BlockInfo.SubType = tMainBegin) or
11038 (BlockInfo.SubType = tSubBegin) or (BlockInfo.SubType = tifOneliner) or
11039 (BlockInfo.SubType = tProcBegin) or (BlockInfo.SubType = TOneLiner)
11040 {$IFDEF PS_USESSUPPORT} or (BlockInfo.SubType = tUnitInit) or (BlockInfo.SubType = tUnitFinish) {$endif} then //nvds
11041 begin
11042 break;
11043 end
11044 else
11045 begin
11046 MakeError('', ecIdentifierExpected, '');
11047 exit;
11048 end;
11049 end;
11050 CSTI_EOF:
11051 begin
11052 MakeError('', ecUnexpectedEndOfFile, '');
11053 exit;
11054 end;
11055 else
11056 begin
11057 MakeError('', ecIdentifierExpected, '');
11058 exit;
11059 end;
11060 end;
11061 end;
11062 if (BlockInfo.SubType = tMainBegin) or (BlockInfo.SubType = tProcBegin)
11063 {$IFDEF PS_USESSUPPORT} or (BlockInfo.SubType = tUnitInit) or (BlockInfo.SubType = tUnitFinish) {$endif} then //nvds
11064 begin
11065 Debug_WriteLine(BlockInfo);
11066 BlockWriteByte(BlockInfo, Cm_R);
11067 {$IFDEF PS_USESSUPPORT}
11068 if FParser.CurrTokenId = CSTII_End then //nvds
11069 begin
11070 {$endif}
11071 FParser.Next; // skip end
11072 if ((BlockInfo.SubType = tMainBegin)
11073 {$IFDEF PS_USESSUPPORT} or (BlockInfo.SubType = tUnitInit) or (BlockInfo.SubType = tUnitFinish){$endif}) //nvds
11074 and (FParser.CurrTokenId <> CSTI_Period) then
11075 begin
11076 MakeError('', ecPeriodExpected, '');
11077 exit;
11078 end;
11079 if (BlockInfo.SubType = tProcBegin) and (FParser.CurrTokenId <> CSTI_Semicolon) then
11080 begin
11081 MakeError('', ecSemicolonExpected, '');
11082 exit;
11083 end;
11084 FParser.Next;
11085 {$IFDEF PS_USESSUPPORT}
11086 end; //nvds
11087 {$endif}
11088 end
11089 else if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
11090 begin
11091 if (FParser.CurrTokenID <> CSTII_Else) and (FParser.CurrTokenID <> CSTII_End) then
11092 if FParser.CurrTokenID <> CSTI_Semicolon then
11093 begin
11094 MakeError('', ecSemicolonExpected, '');
11095 exit;
11096 end;
11097 end;
11098
11099 ProcessSub := True;
11100 end;
11101 procedure TPSPascalCompiler.UseProc(procdecl: TPSParametersDecl);
11102 var
11103 i: Longint;
11104 begin
11105 if procdecl.Result <> nil then
11106 procdecl.Result := at2ut(procdecl.Result);
11107 for i := 0 to procdecl.ParamCount -1 do
11108 begin
11109 procdecl.Params[i].aType := at2ut(procdecl.Params[i].aType);
11110 end;
11111 end;
11112
at2utnull11113 function TPSPascalCompiler.at2ut(p: TPSType): TPSType;
11114 var
11115 i: Longint;
11116 begin
11117 p := GetTypeCopyLink(p);
11118 if p = nil then
11119 begin
11120 Result := nil;
11121 exit;
11122 end;
11123 if not p.Used then
11124 begin
11125 p.Use;
11126 case p.BaseType of
11127 btStaticArray, btArray: TPSArrayType(p).ArrayTypeNo := at2ut(TPSArrayType(p).ArrayTypeNo);
11128 btRecord:
11129 begin
11130 for i := 0 to TPSRecordType(p).RecValCount -1 do
11131 begin
11132 TPSRecordType(p).RecVal(i).aType := at2ut(TPSRecordType(p).RecVal(i).aType);
11133 end;
11134 end;
11135 btSet: TPSSetType(p).SetType := at2ut(TPSSetType(p).SetType);
11136 btProcPtr:
11137 begin
11138 UseProc(TPSProceduralType(p).ProcDef);
11139 end;
11140 end;
11141 p.FFinalTypeNo := FCurrUsedTypeNo;
11142 inc(FCurrUsedTypeNo);
11143 end;
11144 Result := p;
11145 end;
11146
TPSPascalCompiler.ProcessLabelForwardsnull11147 function TPSPascalCompiler.ProcessLabelForwards(Proc: TPSInternalProcedure): Boolean;
11148 var
11149 i: Longint;
11150 s, s2: tbtString;
11151 begin
11152 for i := 0 to Proc.FLabels.Count -1 do
11153 begin
11154 s := Proc.FLabels[I];
11155 if Longint((@s[1])^) = -1 then
11156 begin
11157 delete(s, 1, 8);
11158 MakeError('', ecUnSetLabel, s);
11159 Result := False;
11160 exit;
11161 end;
11162 end;
11163 for i := Proc.FGotos.Count -1 downto 0 do
11164 begin
11165 s := Proc.FGotos[I];
11166 s2 := Proc.FLabels[Cardinal((@s[5])^)];
11167 Cardinal((@Proc.Data[Cardinal((@s[1])^)-3])^) := Cardinal((@s2[1])^) - Cardinal((@s[1])^) ;
11168 end;
11169 Result := True;
11170 end;
11171
11172
11173 type
11174 TCompilerState = (csStart, csProgram, csUnit, csUses, csInterface, csInterfaceUses, csImplementation);
11175
TPSPascalCompiler.Compilenull11176 function TPSPascalCompiler.Compile(const s: tbtString): Boolean;
11177 var
11178 Position: TCompilerState;
11179 i: Longint;
11180 {$IFDEF PS_USESSUPPORT}
11181 OldFileName: tbtString;
11182 OldParser : TPSPascalParser;
11183 OldIsUnit : Boolean;
11184 OldUnit : TPSUnit;
11185 {$ENDIF}
11186
11187 procedure Cleanup;
11188 var
11189 I: Longint;
11190 PT: TPSType;
11191 begin
11192 {$IFDEF PS_USESSUPPORT}
11193 if fInCompile>1 then
11194 begin
11195 dec(fInCompile);
11196 exit;
11197 end;
11198 {$ENDIF}
11199
11200 if @FOnBeforeCleanup <> nil then
11201 FOnBeforeCleanup(Self); // no reason it actually read the result of this call
11202 FGlobalBlock.Free;
11203 FGlobalBlock := nil;
11204
11205 for I := 0 to FRegProcs.Count - 1 do
11206 TObject(FRegProcs[I]).Free;
11207 FRegProcs.Free;
11208 for i := 0 to FConstants.Count -1 do
11209 begin
11210 TPSConstant(FConstants[I]).Free;
11211 end;
11212 Fconstants.Free;
11213 for I := 0 to FVars.Count - 1 do
11214 begin
11215 TPSVar(FVars[I]).Free;
11216 end;
11217 FVars.Free;
11218 FVars := nil;
11219 for I := 0 to FProcs.Count - 1 do
11220 TPSProcedure(FProcs[I]).Free;
11221 FProcs.Free;
11222 FProcs := nil;
11223 //reverse free types: a custom type's attribute value type may point to a base type
11224 for I := FTypes.Count - 1 downto 0 do
11225 begin
11226 PT := FTypes[I];
11227 pt.Free;
11228 end;
11229 FTypes.Free;
11230
11231 {$IFNDEF PS_NOINTERFACES}
11232 for i := FInterfaces.Count -1 downto 0 do
11233 TPSInterface(FInterfaces[i]).Free;
11234 FInterfaces.Free;
11235 {$ENDIF}
11236
11237 for i := FClasses.Count -1 downto 0 do
11238 begin
11239 TPSCompileTimeClass(FClasses[I]).Free;
11240 end;
11241 FClasses.Free;
11242 for i := FAttributeTypes.Count -1 downto 0 do
11243 begin
11244 TPSAttributeType(FAttributeTypes[i]).Free;
11245 end;
11246 FAttributeTypes.Free;
11247 FAttributeTypes := nil;
11248
11249 {$IFDEF PS_USESSUPPORT}
11250 for I := 0 to FUnitInits.Count - 1 do //nvds
11251 begin //nvds
11252 TPSBlockInfo(FUnitInits[I]).free; //nvds
11253 end; //nvds
11254 FUnitInits.Free; //nvds
11255 FUnitInits := nil; //
11256 for I := 0 to FUnitFinits.Count - 1 do //nvds
11257 begin //nvds
11258 TPSBlockInfo(FUnitFinits[I]).free; //nvds
11259 end; //nvds
11260 FUnitFinits.Free; //
11261 FUnitFinits := nil; //
11262
11263 FreeAndNil(fUnits);
11264 FreeAndNil(FUses);
11265 fInCompile:=0;
11266 {$ENDIF}
11267 end;
11268
11269 function MakeOutput: Boolean;
11270
11271 procedure WriteByte(b: Byte);
11272 begin
11273 FOutput := FOutput + tbtChar(b);
11274 end;
11275
11276 procedure WriteData(const Data; Len: Longint);
11277 var
11278 l: Longint;
11279 begin
11280 if Len < 0 then Len := 0;
11281 l := Length(FOutput);
11282 SetLength(FOutput, l + Len);
11283 Move(Data, FOutput[l + 1], Len);
11284 end;
11285
11286 procedure WriteLong(l: Cardinal);
11287 begin
11288 WriteData(l, 4);
11289 end;
11290
11291 procedure WriteVariant(p: PIfRVariant);
11292 begin
11293 WriteLong(p^.FType.FinalTypeNo);
11294 case p.FType.BaseType of
11295 btType: WriteLong(p^.ttype.FinalTypeNo);
11296 {$IFNDEF PS_NOWIDESTRING}
11297 btWideString:
11298 begin
11299 WriteLong(Length(tbtWideString(p^.twidestring)));
11300 WriteData(tbtwidestring(p^.twidestring)[1], 2*Length(tbtWideString(p^.twidestring)));
11301 end;
11302 btUnicodeString:
11303 begin
11304 WriteLong(Length(tbtUnicodestring(p^.twidestring)));
11305 WriteData(tbtUnicodestring(p^.twidestring)[1], 2*Length(tbtUnicodestring(p^.twidestring)));
11306 end;
11307 btWideChar: WriteData(p^.twidechar, 2);
11308 {$ENDIF}
11309 btSingle: WriteData(p^.tsingle, sizeof(tbtSingle));
11310 btDouble: WriteData(p^.tsingle, sizeof(tbtDouble));
11311 btExtended: WriteData(p^.tsingle, sizeof(tbtExtended));
11312 btCurrency: WriteData(p^.tsingle, sizeof(tbtCurrency));
11313 btChar: WriteData(p^.tchar, 1);
11314 btSet:
11315 begin
11316 WriteData(tbtString(p^.tstring)[1], Length(tbtString(p^.tstring)));
11317 end;
11318 btString:
11319 begin
11320 WriteLong(Length(tbtString(p^.tstring)));
11321 WriteData(tbtString(p^.tstring)[1], Length(tbtString(p^.tstring)));
11322 end;
11323 btenum:
11324 begin
11325 if TPSEnumType(p^.FType).HighValue <=256 then
11326 WriteData( p^.tu32, 1)
11327 else if TPSEnumType(p^.FType).HighValue <=65536 then
11328 WriteData(p^.tu32, 2)
11329 else
11330 WriteData(p^.tu32, 4);
11331 end;
11332 bts8,btu8: WriteData(p^.tu8, 1);
11333 bts16,btu16: WriteData(p^.tu16, 2);
11334 bts32,btu32: WriteData(p^.tu32, 4);
11335 {$IFNDEF PS_NOINT64}
11336 bts64: WriteData(p^.ts64, 8);
11337 {$ENDIF}
11338 btProcPtr: WriteData(p^.tu32, 4);
11339 {$IFDEF DEBUG}
11340 else
11341 asm int 3; end;
11342 {$ENDIF}
11343 end;
11344 end;
11345
11346 procedure WriteAttributes(attr: TPSAttributes);
11347 var
11348 i, j: Longint;
11349 begin
11350 WriteLong(attr.Count);
11351 for i := 0 to Attr.Count -1 do
11352 begin
11353 j := Length(attr[i].FAttribType.Name);
11354 WriteLong(j);
11355 WriteData(Attr[i].FAttribType.Name[1], j);
11356 WriteLong(Attr[i].Count);
11357 for j := 0 to Attr[i].Count -1 do
11358 begin
11359 WriteVariant(Attr[i][j]);
11360 end;
11361 end;
11362 end;
11363
11364 procedure WriteTypes;
11365 var
11366 l, n: Longint;
11367 bt: TPSBaseType;
11368 x: TPSType;
11369 s: tbtString;
11370 FExportName: tbtString;
11371 Items: TPSList;
11372 procedure WriteTypeNo(TypeNo: Cardinal);
11373 begin
11374 WriteData(TypeNo, 4);
11375 end;
11376 begin
11377 Items := TPSList.Create;
11378 try
11379 for l := 0 to FCurrUsedTypeNo -1 do
11380 Items.Add(nil);
11381 for l := 0 to FTypes.Count -1 do
11382 begin
11383 x := FTypes[l];
11384 if x.Used then
11385 Items[x.FinalTypeNo] := x;
11386 end;
11387 for l := 0 to Items.Count - 1 do
11388 begin
11389 x := Items[l];
11390 if x.FExportName then
11391 FExportName := x.Name
11392 else
11393 FExportName := '';
11394 if (x.BaseType = btExtClass) and (x is TPSUndefinedClassType) then
11395 begin
11396 x := GetTypeCopyLink(TPSUndefinedClassType(x).ExtClass.SelfType);
11397 end;
11398 bt := x.BaseType;
11399 if (x.BaseType = btType) or (x.BaseType = btNotificationVariant) then
11400 begin
11401 bt := btU32;
11402 end else
11403 if (x.BaseType = btEnum) then begin
11404 if TPSEnumType(x).HighValue <= 256 then
11405 bt := btU8
11406 else if TPSEnumType(x).HighValue <= 65536 then
11407 bt := btU16
11408 else
11409 bt := btU32;
11410 end;
11411 if FExportName <> '' then
11412 begin
11413 WriteByte(bt + 128);
11414 end
11415 else
11416 WriteByte(bt);
11417 {$IFNDEF PS_NOINTERFACES} if x.BaseType = btInterface then
11418 begin
11419 WriteData(TPSInterfaceType(x).Intf.Guid, Sizeof(TGuid));
11420 end else {$ENDIF} if x.BaseType = btClass then
11421 begin
11422 WriteLong(Length(TPSClassType(X).Cl.FClassName));
11423 WriteData(TPSClassType(X).Cl.FClassName[1], Length(TPSClassType(X).Cl.FClassName));
11424 end else
11425 if (x.BaseType = btProcPtr) then
11426 begin
11427 s := DeclToBits(TPSProceduralType(x).ProcDef);
11428 WriteLong(Length(s));
11429 WriteData(s[1], Length(s));
11430 end else
11431 if (x.BaseType = btSet) then
11432 begin
11433 WriteLong(TPSSetType(x).BitSize);
11434 end else
11435 if (x.BaseType = btArray) or (x.basetype = btStaticArray) then
11436 begin
11437 WriteLong(TPSArrayType(x).ArrayTypeNo.FinalTypeNo);
11438 if (x.baseType = btstaticarray) then begin
11439 WriteLong(TPSStaticArrayType(x).Length);
11440 WriteLong(TPSStaticArrayType(x).StartOffset); //<-additional StartOffset
11441 end;
11442 end else if x.BaseType = btRecord then
11443 begin
11444 n := TPSRecordType(x).RecValCount;
11445 WriteData( n, 4);
11446 for n := 0 to TPSRecordType(x).RecValCount - 1 do
11447 WriteTypeNo(TPSRecordType(x).RecVal(n).FType.FinalTypeNo);
11448 end;
11449 if FExportName <> '' then
11450 begin
11451 WriteLong(Length(FExportName));
11452 WriteData(FExportName[1], length(FExportName));
11453 end;
11454 WriteAttributes(x.Attributes);
11455 end;
11456 finally
11457 Items.Free;
11458 end;
11459 end;
11460
11461 procedure WriteVars;
11462 var
11463 l,j : Longint;
11464 x: TPSVar;
11465 begin
11466 for l := 0 to FVars.Count - 1 do
11467 begin
11468 x := FVars[l];
11469 if x.SaveAsPointer then
11470 begin
11471 for j := FTypes.count -1 downto 0 do
11472 begin
11473 if TPSType(FTypes[j]).BaseType = btPointer then
11474 begin
11475 WriteLong(TPSType(FTypes[j]).FinalTypeNo);
11476 break;
11477 end;
11478 end;
11479 end else
11480 WriteLong(x.FType.FinalTypeNo);
11481 if x.exportname <> '' then
11482 begin
11483 WriteByte( 1);
11484 WriteLong(Length(X.ExportName));
11485 WriteData( X.ExportName[1], length(X.ExportName));
11486 end else
11487 WriteByte( 0);
11488 end;
11489 end;
11490
11491 procedure WriteProcs;
11492 var
11493 l: Longint;
11494 xp: TPSProcedure;
11495 xo: TPSInternalProcedure;
11496 xe: TPSExternalProcedure;
11497 s: tbtString;
11498 att: Byte;
11499 begin
11500 for l := 0 to FProcs.Count - 1 do
11501 begin
11502 xp := FProcs[l];
11503 if xp.Attributes.Count <> 0 then att := 4 else att := 0;
11504 if xp.ClassType = TPSInternalProcedure then
11505 begin
11506 xo := TPSInternalProcedure(xp);
11507 xo.OutputDeclPosition := Length(FOutput);
11508 WriteByte(att or 2); // exported
11509 WriteLong(0); // offset is unknown at this time
11510 WriteLong(0); // length is also unknown at this time
11511 WriteLong(Length(xo.Name));
11512 WriteData( xo.Name[1], length(xo.Name));
11513 s := MakeExportDecl(xo.Decl);
11514 WriteLong(Length(s));
11515 WriteData( s[1], length(S));
11516 end
11517 else
11518 begin
11519 xe := TPSExternalProcedure(xp);
11520 if xe.RegProc.ImportDecl <> '' then
11521 begin
11522 WriteByte( att or 3); // imported
11523 if xe.RegProc.FExportName then
11524 begin
11525 WriteByte(Length(xe.RegProc.Name));
11526 WriteData(xe.RegProc.Name[1], Length(xe.RegProc.Name) and $FF);
11527 end else begin
11528 WriteByte(0);
11529 end;
11530 WriteLong(Length(xe.RegProc.ImportDecl));
11531 WriteData(xe.RegProc.ImportDecl[1], Length(xe.RegProc.ImportDecl));
11532 end else begin
11533 WriteByte(att or 1); // imported
11534 WriteByte(Length(xe.RegProc.Name));
11535 WriteData(xe.RegProc.Name[1], Length(xe.RegProc.Name) and $FF);
11536 end;
11537 end;
11538 if xp.Attributes.Count <> 0 then
11539 WriteAttributes(xp.Attributes);
11540 end;
11541 end;
11542
11543 procedure WriteProcs2;
11544 var
11545 l: Longint;
11546 L2: Cardinal;
11547 x: TPSProcedure;
11548 begin
11549 for l := 0 to FProcs.Count - 1 do
11550 begin
11551 x := FProcs[l];
11552 if x.ClassType = TPSInternalProcedure then
11553 begin
11554 if TPSInternalProcedure(x).Data = '' then
11555 TPSInternalProcedure(x).Data := Chr(Cm_R);
11556 L2 := Length(FOutput);
11557 Move(L2, FOutput[TPSInternalProcedure(x).OutputDeclPosition + 2], 4);
11558 // write position
11559 WriteData(TPSInternalProcedure(x).Data[1], Length(TPSInternalProcedure(x).Data));
11560 L2 := Cardinal(Length(FOutput)) - L2;
11561 Move(L2, FOutput[TPSInternalProcedure(x).OutputDeclPosition + 6], 4); // write length
11562 end;
11563 end;
11564 end;
11565
11566
11567
11568 {$IFDEF PS_USESSUPPORT}
11569 function FindMainProc: Cardinal;
11570 var
11571 l: Longint;
11572 Proc : TPSInternalProcedure;
11573 ProcData : tbtString;
11574 Calls : Integer;
11575
11576 procedure WriteProc(const aData: Longint);
11577 var
11578 l: Longint;
11579 begin
11580 ProcData := ProcData + Chr(cm_c);
11581 l := Length(ProcData);
11582 SetLength(ProcData, l + 4);
11583 Move(aData, ProcData[l + 1], 4);
11584 inc(Calls);
11585 end;
11586 begin
11587 ProcData := ''; Calls := 1;
11588 for l := 0 to FUnitInits.Count-1 do
11589 if (FUnitInits[l] <> nil) and
11590 (TPSBlockInfo(FUnitInits[l]).Proc.Data<>'') then
11591 WriteProc(TPSBlockInfo(FUnitInits[l]).FProcNo);
11592
11593 WriteProc(FGlobalBlock.FProcNo);
11594
11595 for l := FUnitFinits.Count-1 downto 0 do
11596 if (FUnitFinits[l] <> nil) and
11597 (TPSBlockInfo(FUnitFinits[l]).Proc.Data<>'') then
11598 WriteProc(TPSBlockInfo(FUnitFinits[l]).FProcNo);
11599
11600 if Calls = 1 then begin
11601 Result := FGlobalBlock.FProcNo;
11602 end else
11603 begin
11604 Proc := NewProc('Master proc', '!MASTERPROC');
11605 Result := FindProc('!MASTERPROC');
11606 Proc.data := Procdata + Chr(cm_R);
11607 end;
11608 end;
11609 {$ELSE}
11610 function FindMainProc: Cardinal;
11611 var
11612 l: Longint;
11613 begin
11614 for l := 0 to FProcs.Count - 1 do
11615 begin
11616 if (TPSProcedure(FProcs[l]).ClassType = TPSInternalProcedure) and
11617 (TPSInternalProcedure(FProcs[l]).Name = PSMainProcName) then
11618 begin
11619 Result := l;
11620 exit;
11621 end;
11622 end;
11623 Result := InvalidVal;
11624 end;
11625 {$ENDIF}
11626
11627 procedure CreateDebugData;
11628 var
11629 I: Longint;
11630 p: TPSProcedure;
11631 pv: TPSVar;
11632 s: tbtString;
11633 begin
11634 s := #0;
11635 for I := 0 to FProcs.Count - 1 do
11636 begin
11637 p := FProcs[I];
11638 if p.ClassType = TPSInternalProcedure then
11639 begin
11640 if TPSInternalProcedure(p).Name = PSMainProcName then
11641 s := s + #1
11642 else
11643 s := s + TPSInternalProcedure(p).OriginalName + #1;
11644 end
11645 else
11646 begin
11647 s := s+ TPSExternalProcedure(p).RegProc.OrgName + #1;
11648 end;
11649 end;
11650 s := s + #0#1;
11651 for I := 0 to FVars.Count - 1 do
11652 begin
11653 pv := FVars[I];
11654 s := s + pv.OrgName + #1;
11655 end;
11656 s := s + #0;
11657 WriteDebugData(s);
11658 end;
11659
11660 var //nvds
11661 MainProc : Cardinal; //nvds
11662
11663 begin
11664 if @FOnBeforeOutput <> nil then
11665 begin
11666 if not FOnBeforeOutput(Self) then
11667 begin
11668 Result := false;
11669 exit;
11670 end;
11671 end;
11672 MainProc := FindMainProc; //NvdS (need it here becose FindMainProc can create a New proc.
11673 CreateDebugData;
11674 WriteLong(PSValidHeader);
11675 WriteLong(PSCurrentBuildNo);
11676 WriteLong(FCurrUsedTypeNo);
11677 WriteLong(FProcs.Count);
11678 WriteLong(FVars.Count);
11679 WriteLong(MainProc); //nvds
11680 WriteLong(0);
11681 WriteTypes;
11682 WriteProcs;
11683 WriteVars;
11684 WriteProcs2;
11685
11686 Result := true;
11687 end;
11688
11689 function CheckExports: Boolean;
11690 var
11691 i: Longint;
11692 p: TPSProcedure;
11693 begin
11694 if @FOnExportCheck = nil then
11695 begin
11696 result := true;
11697 exit;
11698 end;
11699 for i := 0 to FProcs.Count -1 do
11700 begin
11701 p := FProcs[I];
11702 if p.ClassType = TPSInternalProcedure then
11703 begin
11704 if not FOnExportCheck(Self, TPSInternalProcedure(p), MakeDecl(TPSInternalProcedure(p).Decl)) then
11705 begin
11706 Result := false;
11707 exit;
11708 end;
11709 end;
11710 end;
11711 Result := True;
11712 end;
11713 function DoConstBlock: Boolean;
11714 var
11715 COrgName: tbtString;
11716 CTemp, CValue: PIFRVariant;
11717 Cp: TPSConstant;
11718 TokenPos, TokenRow, TokenCol: Integer;
11719 begin
11720 FParser.Next;
11721 repeat
11722 if FParser.CurrTokenID <> CSTI_Identifier then
11723 begin
11724 MakeError('', ecIdentifierExpected, '');
11725 Result := False;
11726 Exit;
11727 end;
11728 TokenPos := FParser.CurrTokenPos;
11729 TokenRow := FParser.Row;
11730 TokenCol := FParser.Col;
11731 COrgName := FParser.OriginalToken;
11732 if IsDuplicate(FastUpperCase(COrgName), [dcVars, dcProcs, dcConsts]) then
11733 begin
11734 MakeError('', ecDuplicateIdentifier, COrgName);
11735 Result := False;
11736 exit;
11737 end;
11738 FParser.Next;
11739 if FParser.CurrTokenID <> CSTI_Equal then
11740 begin
11741 MakeError('', ecIsExpected, '');
11742 Result := False;
11743 Exit;
11744 end;
11745 FParser.Next;
11746 CValue := ReadConstant(FParser, CSTI_SemiColon);
11747 if CValue = nil then
11748 begin
11749 Result := False;
11750 Exit;
11751 end;
11752 if FParser.CurrTokenID <> CSTI_Semicolon then
11753 begin
11754 MakeError('', ecSemicolonExpected, '');
11755 Result := False;
11756 exit;
11757 end;
11758 cp := TPSConstant.Create;
11759 cp.Orgname := COrgName;
11760 cp.Name := FastUpperCase(COrgName);
11761 {$IFDEF PS_USESSUPPORT}
11762 cp.DeclareUnit:=fModule;
11763 {$ENDIF}
11764 cp.DeclarePos := TokenPos;
11765 cp.DeclareRow := TokenRow;
11766 cp.DeclareCol := TokenCol;
11767 New(CTemp);
11768 InitializeVariant(CTemp, CValue.FType);
11769 CopyVariantContents(cvalue, CTemp);
11770 cp.Value := CTemp;
11771 FConstants.Add(cp);
11772 DisposeVariant(CValue);
11773 FParser.Next;
11774 until FParser.CurrTokenId <> CSTI_Identifier;
11775 Result := True;
11776 end;
11777
11778 function ProcessUses: Boolean;
11779 var
11780 {$IFNDEF PS_USESSUPPORT}
11781 FUses: TIfStringList;
11782 {$ENDIF}
11783 I: Longint;
11784 s: tbtString;
11785 {$IFDEF PS_USESSUPPORT}
11786 Parse: Boolean;
11787 ParseUnit: tbtString;
11788 ParserPos: TPSPascalParser;
11789 {$ENDIF}
11790 begin
11791 FParser.Next;
11792 {$IFNDEF PS_USESSUPPORT}
11793 FUses := TIfStringList.Create;
11794 FUses.Add('System');
11795 {$ENDIF}
11796 repeat
11797 if FParser.CurrTokenID <> CSTI_Identifier then
11798 begin
11799 MakeError('', ecIdentifierExpected, '');
11800 {$IFNDEF PS_USESSUPPORT}
11801 FUses.Free;
11802 {$ENDIF}
11803 Result := False;
11804 exit;
11805 end;
11806 s := FParser.GetToken;
11807 {$IFDEF PS_USESSUPPORT}
11808 Parse:=true;
11809 {$ENDIF}
11810 for i := 0 to FUses.Count -1 do
11811 begin
11812 if FUses[I] = s then
11813 begin
11814 {$IFNDEF PS_USESSUPPORT}
11815 MakeError('', ecDuplicateIdentifier, s);
11816 FUses.Free;
11817 Result := False;
11818 exit;
11819 {$ELSE}
11820 Parse:=false;
11821 {$ENDIF}
11822 end;
11823 end;
11824 {$IFDEF PS_USESSUPPORT}
11825 if fUnits.GetUnit(S).HasUses(fModule) then
11826 begin
11827 MakeError('', ecCrossReference, s);
11828 Result := False;
11829 exit;
11830 end;
11831
11832 fUnit.AddUses(S);
11833
11834 if Parse then
11835 begin
11836 {$ENDIF}
11837 FUses.Add(s);
11838 if @FOnUses <> nil then
11839 begin
11840 try
11841 {$IFDEF PS_USESSUPPORT}
11842 OldFileName:=fModule;
11843 fModule:=FParser.OriginalToken;
11844 ParseUnit:=FParser.OriginalToken;
11845 ParserPos:=FParser;
11846 {$ENDIF}
11847 if not OnUses(Self, FParser.GetToken) then
11848 begin
11849 {$IFNDEF PS_USESSUPPORT}
11850 FUses.Free;
11851 {$ELSE}
11852 FParser:=ParserPos;
11853 fModule:=OldFileName;
11854 MakeError(OldFileName, ecUnitNotFoundOrContainsErrors, ParseUnit);
11855 {$ENDIF}
11856 Result := False;
11857 exit;
11858 end;
11859 {$IFDEF PS_USESSUPPORT}
11860 fModule:=OldFileName;
11861 {$ENDIF}
11862 except
11863 on e: Exception do
11864 begin
11865 MakeError('', ecCustomError, tbtstring(e.Message));
11866 {$IFNDEF PS_USESSUPPORT}
11867 FUses.Free;
11868 {$ENDIF}
11869 Result := False;
11870 exit;
11871 end;
11872 end;
11873 end;
11874 {$IFDEF PS_USESSUPPORT}
11875 end;
11876 {$ENDIF}
11877 FParser.Next;
11878 if FParser.CurrTokenID = CSTI_Semicolon then break
11879 else if FParser.CurrTokenId <> CSTI_Comma then
11880 begin
11881 MakeError('', ecSemicolonExpected, '');
11882 Result := False;
11883 {$IFNDEF PS_USESSUPPORT}
11884 FUses.Free;
11885 {$ENDIF}
11886 exit;
11887 end;
11888 FParser.Next;
11889 until False;
11890 {$IFNDEF PS_USESSUPPORT}
11891 FUses.Free;
11892 {$ENDIF}
11893 FParser.next;
11894 Result := True;
11895 end;
11896
11897 var
11898 Proc: TPSProcedure;
11899 {$IFDEF PS_USESSUPPORT}
11900 Block : TPSBlockInfo; //nvds
11901 {$ENDIF}
11902 begin
11903 Result := False;
11904 FWithCount := -1;
11905
11906 {$IFDEF PS_USESSUPPORT}
11907 if fInCompile=0 then
11908 begin
11909 {$ENDIF}
11910 FUnitName := '';
11911 FCurrUsedTypeNo := 0;
11912 FIsUnit := False;
11913 Clear;
11914 FParserHadError := False;
11915 FParser.SetText(s);
11916 FAttributeTypes := TPSList.Create;
11917 FProcs := TPSList.Create;
11918 FConstants := TPSList.Create;
11919 FVars := TPSList.Create;
11920 FTypes := TPSList.Create;
11921 FRegProcs := TPSList.Create;
11922 FClasses := TPSList.Create;
11923
11924 {$IFDEF PS_USESSUPPORT}
11925 FUnitInits := TPSList.Create; //nvds
11926 FUnitFinits:= TPSList.Create; //nvds
11927
11928 FUses:=TIFStringList.Create;
11929 FUnits:=TPSUnitList.Create;
11930 {$ENDIF}
11931 {$IFNDEF PS_NOINTERFACES} FInterfaces := TPSList.Create;{$ENDIF}
11932
11933 FGlobalBlock := TPSBlockInfo.Create(nil);
11934 FGlobalBlock.SubType := tMainBegin;
11935
11936 FGlobalBlock.Proc := NewProc(PSMainProcNameOrg, PSMainProcName);
11937 FGlobalBlock.ProcNo := FindProc(PSMainProcName);
11938
11939 {$IFDEF PS_USESSUPPORT}
11940 OldFileName:=fModule;
11941 fModule:='System';
11942 FUses.Add('System');
11943 {$ENDIF}
11944 {$IFNDEF PS_NOSTANDARDTYPES}
11945 DefineStandardTypes;
11946 DefineStandardProcedures;
11947 {$ENDIF}
11948 if @FOnUses <> nil then
11949 begin
11950 try
11951 if not OnUses(Self, 'SYSTEM') then
11952 begin
11953 Cleanup;
11954 exit;
11955 end;
11956 except
11957 on e: Exception do
11958 begin
11959 MakeError('', ecCustomError, tbtstring(e.Message));
11960 Cleanup;
11961 exit;
11962 end;
11963 end;
11964 end;
11965 {$IFDEF PS_USESSUPPORT}
11966 fModule:=OldFileName;
11967 OldParser:=nil;
11968 OldUnit:=nil;
11969 OldIsUnit:=false; // defaults
11970 end
11971 else
11972 begin
11973 OldParser:=FParser;
11974 OldIsUnit:=FIsUnit;
11975 OldUnit:=fUnit;
11976 FParser:=TPSPascalParser.Create;
11977 FParser.SetText(s);
11978 end;
11979
11980 fUnit:=fUnits.GetUnit(fModule);
11981
11982 inc(fInCompile);
11983 {$ENDIF}
11984
11985 Position := csStart;
11986 repeat
11987 if FParser.CurrTokenId = CSTI_EOF then
11988 begin
11989 if FParserHadError then
11990 begin
11991 Cleanup;
11992 exit;
11993 end;
11994 if FAllowNoEnd then
11995 Break
11996 else
11997 begin
11998 MakeError('', ecUnexpectedEndOfFile, '');
11999 Cleanup;
12000 exit;
12001 end;
12002 end;
12003 if (FParser.CurrTokenId = CSTII_Program) and (Position = csStart) then
12004 begin
12005 {$IFDEF PS_USESSUPPORT}
12006 if fInCompile>1 then
12007 begin
12008 MakeError('', ecNotAllowed, 'program');
12009 Cleanup;
12010 exit;
12011 end;
12012 {$ENDIF}
12013 Position := csProgram;
12014 FParser.Next;
12015 if FParser.CurrTokenId <> CSTI_Identifier then
12016 begin
12017 MakeError('', ecIdentifierExpected, '');
12018 Cleanup;
12019 exit;
12020 end;
12021 FParser.Next;
12022 if FParser.CurrTokenId <> CSTI_Semicolon then
12023 begin
12024 MakeError('', ecSemicolonExpected, '');
12025 Cleanup;
12026 exit;
12027 end;
12028 FParser.Next;
12029 end else
12030 if (Fparser.CurrTokenID = CSTII_Implementation) and ((Position = csinterface) or (position = csInterfaceUses)) then
12031 begin
12032 Position := csImplementation;
12033 FParser.Next;
12034 end else
12035 if (Fparser.CurrTokenID = CSTII_Interface) and (Position = csUnit) then
12036 begin
12037 Position := csInterface;
12038 FParser.Next;
12039 end else
12040 if (FParser.CurrTokenId = CSTII_Unit) and (Position = csStart) and (FAllowUnit) then
12041 begin
12042 Position := csUnit;
12043 FIsUnit := True;
12044 FParser.Next;
12045 if FParser.CurrTokenId <> CSTI_Identifier then
12046 begin
12047 MakeError('', ecIdentifierExpected, '');
12048 Cleanup;
12049 exit;
12050 end;
12051 if fInCompile = 1 then
12052 FUnitName := FParser.OriginalToken;
12053 FParser.Next;
12054 if FParser.CurrTokenId <> CSTI_Semicolon then
12055 begin
12056 MakeError('', ecSemicolonExpected, '');
12057 Cleanup;
12058 exit;
12059 end;
12060 FParser.Next;
12061 end
12062 else if (FParser.CurrTokenID = CSTII_Uses) and ((Position < csuses) or (Position = csInterface)) then
12063 begin
12064 if (Position = csInterface) or (Position =csInterfaceUses)
12065 then Position := csInterfaceUses
12066 else Position := csUses;
12067 if not ProcessUses then
12068 begin
12069 Cleanup;
12070 exit;
12071 end;
12072 end else if (FParser.CurrTokenId = CSTII_Procedure) or
12073 (FParser.CurrTokenId = CSTII_Function) or (FParser.CurrTokenID = CSTI_OpenBlock) then
12074 begin
12075 if (Position = csInterface) or (position = csInterfaceUses) then
12076 begin
12077 if not ProcessFunction(True, nil) then
12078 begin
12079 Cleanup;
12080 exit;
12081 end;
12082 end else begin
12083 Position := csUses;
12084 if not ProcessFunction(False, nil) then
12085 begin
12086 Cleanup;
12087 exit;
12088 end;
12089 end;
12090 end
12091 else if (FParser.CurrTokenId = CSTII_Label) then
12092 begin
12093 if (Position = csInterface) or (Position =csInterfaceUses)
12094 then Position := csInterfaceUses
12095 else Position := csUses;
12096 if not ProcessLabel(FGlobalBlock.Proc) then
12097 begin
12098 Cleanup;
12099 exit;
12100 end;
12101 end
12102 else if (FParser.CurrTokenId = CSTII_Var) then
12103 begin
12104 if (Position = csInterface) or (Position =csInterfaceUses)
12105 then Position := csInterfaceUses
12106 else Position := csUses;
12107 if not DoVarBlock(nil) then
12108 begin
12109 Cleanup;
12110 exit;
12111 end;
12112 end
12113 else if (FParser.CurrTokenId = CSTII_Const) then
12114 begin
12115 if (Position = csInterface) or (Position =csInterfaceUses)
12116 then Position := csInterfaceUses
12117 else Position := csUses;
12118 if not DoConstBlock then
12119 begin
12120 Cleanup;
12121 exit;
12122 end;
12123 end
12124 else if (FParser.CurrTokenId = CSTII_Type) then
12125 begin
12126 if (Position = csInterface) or (Position =csInterfaceUses)
12127 then Position := csInterfaceUses
12128 else Position := csUses;
12129 if not DoTypeBlock(FParser) then
12130 begin
12131 Cleanup;
12132 exit;
12133 end;
12134 end
12135 else if (FParser.CurrTokenId = CSTII_Begin)
12136 {$IFDEF PS_USESSUPPORT}
12137 or ((FParser.CurrTokenID = CSTII_initialization) and FIsUnit) {$ENDIF} then //nvds
12138 begin
12139 {$IFDEF PS_USESSUPPORT}
12140 if FIsUnit then
12141 begin
12142 Block := TPSBlockInfo.Create(nil); //nvds
12143 Block.SubType := tUnitInit; //nvds
12144 Block.Proc := NewProc(PSMainProcNameOrg+'_'+fModule, FastUpperCase(PSMainProcName+'_'+fModule)); //nvds
12145 Block.ProcNo := FindProc(PSMainProcName+'_'+fModule); //nvds
12146 Block.Proc.DeclareUnit:= fModule;
12147 Block.Proc.DeclarePos := FParser.CurrTokenPos;
12148 Block.Proc.DeclareRow := FParser.Row;
12149 Block.Proc.DeclareCol := FParser.Col;
12150 Block.Proc.Use;
12151 FUnitInits.Add(Block);
12152 if ProcessSub(Block) then
12153 begin
12154 if (Fparser.CurrTokenId = CSTI_EOF) THEN break;
12155 end
12156 else
12157 begin
12158 Cleanup;
12159 exit;
12160 end;
12161 end
12162 else
12163 begin
12164 FGlobalBlock.Proc.DeclareUnit:= fModule;
12165 {$ENDIF}
12166 FGlobalBlock.Proc.DeclarePos := FParser.CurrTokenPos;
12167 FGlobalBlock.Proc.DeclareRow := FParser.Row;
12168 FGlobalBlock.Proc.DeclareCol := FParser.Col;
12169 if ProcessSub(FGlobalBlock) then
12170 begin
12171 break;
12172 end
12173 else
12174 begin
12175 Cleanup;
12176 exit;
12177 end;
12178 {$IFDEF PS_USESSUPPORT}
12179 end;
12180 {$ENDIF}
12181 end
12182 {$IFDEF PS_USESSUPPORT}
12183 else if ((FParser.CurrTokenID = CSTII_finalization) and FIsUnit) then //NvdS
12184 begin
12185 Block := TPSBlockInfo.Create(nil);
12186 Block.SubType := tUnitFinish;
12187 Block.Proc := NewProc('!Finish_'+fModule, '!FINISH_'+FastUppercase(fModule));
12188 Block.ProcNo := FindProc('!FINISH_'+FastUppercase(fModule));
12189 Block.Proc.DeclareUnit:= fModule;
12190
12191 Block.Proc.DeclarePos := FParser.CurrTokenPos;
12192 Block.Proc.DeclareRow := FParser.Row;
12193 Block.Proc.DeclareCol := FParser.Col;
12194 Block.Proc.use;
12195 FUnitFinits.Add(Block);
12196 if ProcessSub(Block) then
12197 begin
12198 break;
12199 end else begin
12200 Cleanup;
12201 Result := False; //Cleanup;
12202 exit;
12203 end;
12204 end
12205 {$endif}
12206 else if (Fparser.CurrTokenId = CSTII_End) and (FAllowNoBegin or FIsUnit) then
12207 begin
12208 FParser.Next;
12209 if FParser.CurrTokenID <> CSTI_Period then
12210 begin
12211 MakeError('', ecPeriodExpected, '');
12212 Cleanup;
12213 exit;
12214 end;
12215 break;
12216 end else
12217 begin
12218 MakeError('', ecBeginExpected, '');
12219 Cleanup;
12220 exit;
12221 end;
12222 until False;
12223
12224 {$IFDEF PS_USESSUPPORT}
12225 dec(fInCompile);
12226 if fInCompile=0 then
12227 begin
12228 {$ENDIF}
12229 if not ProcessLabelForwards(FGlobalBlock.Proc) then
12230 begin
12231 Cleanup;
12232 exit;
12233 end;
12234 // NVDS: Do we need to check here also do a ProcessLabelForwards() for each Initialisation/finalization block?
12235
12236 for i := 0 to FProcs.Count -1 do
12237 begin
12238 Proc := FProcs[I];
12239 if (Proc.ClassType = TPSInternalProcedure) and (TPSInternalProcedure(Proc).Forwarded) then
12240 begin
12241 with MakeError('', ecUnsatisfiedForward, TPSInternalProcedure(Proc).Name) do
12242 begin
12243 FPosition := TPSInternalProcedure(Proc).DeclarePos;
12244 FRow := TPSInternalProcedure(Proc).DeclareRow;
12245 FCol := TPSInternalProcedure(Proc).DeclareCol;
12246 end;
12247 Cleanup;
12248 Exit;
12249 end;
12250 end;
12251 if not CheckExports then
12252 begin
12253 Cleanup;
12254 exit;
12255 end;
12256 for i := 0 to FVars.Count -1 do
12257 begin
12258 if not TPSVar(FVars[I]).Used then
12259 begin
12260 with MakeHint({$IFDEF PS_USESSUPPORT}TPSVar(FVars[I]).DeclareUnit{$ELSE}''{$ENDIF}, ehVariableNotUsed, TPSVar(FVars[I]).Name) do
12261 begin
12262 FPosition := TPSVar(FVars[I]).DeclarePos;
12263 FRow := TPSVar(FVars[I]).DeclareRow;
12264 FCol := TPSVar(FVars[I]).DeclareCol;
12265 end;
12266 end;
12267 end;
12268
12269 Result := MakeOutput;
12270 Cleanup;
12271 {$IFDEF PS_USESSUPPORT}
12272 end
12273 else
12274 begin
12275 fParser.Free;
12276 fParser:=OldParser;
12277 fIsUnit:=OldIsUnit;
12278 fUnit:=OldUnit;
12279 result:=true;
12280 end;
12281 {$ENDIF}
12282 end;
12283
12284 constructor TPSPascalCompiler.Create;
12285 begin
12286 inherited Create;
12287 FParser := TPSPascalParser.Create;
12288 FParser.OnParserError := ParserError;
12289 FAutoFreeList := TPSList.Create;
12290 FOutput := '';
12291 FAllowDuplicateRegister := true;
12292 {$IFDEF PS_USESSUPPORT}
12293 FAllowUnit := true;
12294 {$ENDIF}
12295 FMessages := TPSList.Create;
12296 end;
12297
12298 destructor TPSPascalCompiler.Destroy;
12299 begin
12300 Clear;
12301 FAutoFreeList.Free;
12302
12303 FMessages.Free;
12304 FParser.Free;
12305 inherited Destroy;
12306 end;
12307
GetOutputnull12308 function TPSPascalCompiler.GetOutput(var s: tbtString): Boolean;
12309 begin
12310 if Length(FOutput) <> 0 then
12311 begin
12312 s := FOutput;
12313 Result := True;
12314 end
12315 else
12316 Result := False;
12317 end;
12318
GetMsgnull12319 function TPSPascalCompiler.GetMsg(l: Longint): TPSPascalCompilerMessage;
12320 begin
12321 Result := FMessages[l];
12322 end;
12323
GetMsgCountnull12324 function TPSPascalCompiler.GetMsgCount: Longint;
12325 begin
12326 Result := FMessages.Count;
12327 end;
12328
12329 procedure TPSPascalCompiler.DefineStandardTypes;
12330 var
12331 i: Longint;
12332 begin
12333 AddType('Byte', btU8);
12334 FDefaultBoolType := AddTypeS('Boolean', '(False, True)');
12335 FDefaultBoolType.ExportName := True;
12336 with TPSEnumType(AddType('LongBool', btEnum)) do
12337 begin
12338 HighValue := 2147483647; // make sure it's gonna be a 4 byte var
12339 end;
12340 with TPSEnumType(AddType('WordBool', btEnum)) do
12341 begin
12342 HighValue := 65535; // make sure it's gonna be a 2 byte var
12343 end;
12344 with TPSEnumType(AddType('ByteBool', btEnum)) do
12345 begin
12346 HighValue := 255; // make sure it's gonna be a 1 byte var
12347 end;
12348 //following 2 IFDEFs should actually be UNICODE IFDEFs...
12349 AddType({$IFDEF PS_PANSICHAR}'AnsiChar'{$ELSE}'Char'{$ENDIF}, btChar);
12350 {$IFDEF PS_PANSICHAR}
12351 AddType('Char', btWideChar);
12352 {$ENDIF}
12353 {$IFNDEF PS_NOWIDESTRING}
12354 AddType('WideChar', btWideChar);
12355 AddType('WideString', btWideString);
12356 AddType('UnicodeString', btUnicodeString);
12357 {$ENDIF}
12358 AddType('AnsiString', btString);
12359 {$IFNDEF PS_NOWIDESTRING}
12360 {$IFDEF DELPHI2009UP}
12361 AddType('string', btUnicodeString);
12362 AddType('NativeString', btUnicodeString);
12363 {$ELSE}
12364 AddType('string', btString);
12365 AddType('NativeString', btString);
12366 {$ENDIF}
12367 {$ELSE}
12368 AddType('string', btString);
12369 AddType('NativeString', btString);
12370 {$ENDIF}
12371 FAnyString := AddType('AnyString', btString);
12372 AddType('ShortInt', btS8);
12373 AddType('Word', btU16);
12374 AddType('SmallInt', btS16);
12375 AddType('LongInt', btS32);
12376 at2ut(AddType('___Pointer', btPointer));
12377 AddType('LongWord', btU32);
12378 AddTypeCopyN('Integer', 'LongInt');
12379 AddTypeCopyN('Cardinal', 'LongWord');
12380 AddType('tbtString', btString);
12381 {$IFNDEF PS_NOINT64}
12382 AddType('Int64', btS64);
12383 {$ENDIF}
12384 AddType('Single', btSingle);
12385 AddType('Double', btDouble);
12386 AddType('Extended', btExtended);
12387 AddType('Currency', btCurrency);
12388 AddType({$IFDEF PS_PANSICHAR}'PAnsiChar'{$ELSE}'PChar'{$ENDIF}, btPChar);
12389 AddType('Variant', btVariant);
12390 AddType('!NotificationVariant', btNotificationVariant);
12391 for i := FTypes.Count -1 downto 0 do AT2UT(FTypes[i]);
12392 TPSArrayType(AddType('TVariantArray', btArray)).ArrayTypeNo := FindType('Variant');
12393
donull12394 with AddFunction('function Assigned(I: LongInt): Boolean;') do
12395 begin
12396 Name := '!ASSIGNED';
12397 end;
12398
donull12399 with AddFunction('procedure _T(Name: tbtString; V: Variant);') do
12400 begin
12401 Name := '!NOTIFICATIONVARIANTSET';
12402 end;
donull12403 with AddFunction('function _T(Name: tbtString): Variant;') do
12404 begin
12405 Name := '!NOTIFICATIONVARIANTGET';
12406 end;
12407 end;
12408
12409
TPSPascalCompiler.FindTypenull12410 function TPSPascalCompiler.FindType(const Name: tbtString): TPSType;
12411 var
12412 i, n: Longint;
12413 RName: tbtString;
12414 begin
12415 if FProcs = nil then begin Result := nil; exit;end;
12416 RName := Fastuppercase(Name);
12417 n := makehash(rname);
12418 for i := FTypes.Count - 1 downto 0 do
12419 begin
12420 Result := FTypes.Data[I];
12421 if (Result.NameHash = n) and (Result.name = rname) then
12422 begin
12423 Result := GetTypeCopyLink(Result);
12424 exit;
12425 end;
12426 end;
12427 result := nil;
12428 end;
12429
TPSPascalCompiler.AddConstantnull12430 function TPSPascalCompiler.AddConstant(const Name: tbtString; FType: TPSType): TPSConstant;
12431 var
12432 pc: TPSConstant;
12433 val: PIfRVariant;
12434 begin
12435 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
12436
12437 FType := GetTypeCopyLink(FType);
12438 if FType = nil then
12439 Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterConst, [name]);
12440
12441 if not(AllowDuplicateRegister) and IsDuplicate(FastUpperCase(Name),[dcProcs, dcVars, dcConsts]) then
12442 Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Name]);
12443
12444 pc := TPSConstant.Create;
12445 pc.OrgName := name;
12446 pc.Name := FastUppercase(name);
12447 pc.DeclarePos:=InvalidVal;
12448 {$IFDEF PS_USESSUPPORT}
12449 pc.DeclareUnit:=fModule;
12450 {$ENDIF}
12451 New(Val);
12452 InitializeVariant(Val, FType);
12453 pc.Value := Val;
12454 FConstants.Add(pc);
12455 result := pc;
12456 end;
12457
TPSPascalCompiler.ReadAttributesnull12458 function TPSPascalCompiler.ReadAttributes(Dest: TPSAttributes): Boolean;
12459 var
12460 Att: TPSAttributeType;
12461 at: TPSAttribute;
12462 varp: PIfRVariant;
12463 h, i: Longint;
12464 s: tbtString;
12465 begin
12466 if FParser.CurrTokenID <> CSTI_OpenBlock then begin Result := true; exit; end;
12467 FParser.Next;
12468 if FParser.CurrTokenID <> CSTI_Identifier then
12469 begin
12470 MakeError('', ecIdentifierExpected, '');
12471 Result := False;
12472 exit;
12473 end;
12474 s := FParser.GetToken;
12475 h := MakeHash(s);
12476 att := nil;
12477 for i := FAttributeTypes.count -1 downto 0 do
12478 begin
12479 att := FAttributeTypes[i];
12480 if (att.FNameHash = h) and (att.FName = s) then
12481 Break;
12482 att := nil;
12483 end;
12484 if att = nil then
12485 begin
12486 MakeError('', ecUnknownIdentifier, '');
12487 Result := False;
12488 exit;
12489 end;
12490 FParser.Next;
12491 i := 0;
12492 at := Dest.Add(att);
12493 while att.Fields[i].Hidden do
12494 begin
12495 at.AddValue(NewVariant(at2ut(att.Fields[i].FieldType)));
12496 inc(i);
12497 end;
12498 if FParser.CurrTokenId <> CSTI_OpenRound then
12499 begin
12500 MakeError('', ecOpenRoundExpected, '');
12501 Result := False;
12502 exit;
12503 end;
12504 FParser.Next;
12505 if i < Att.FieldCount then
12506 begin
12507 while i < att.FieldCount do
12508 begin
12509 varp := ReadConstant(FParser, CSTI_CloseRound);
12510 if varp = nil then
12511 begin
12512 Result := False;
12513 exit;
12514 end;
12515 at.AddValue(varp);
12516 if not IsCompatibleType(varp.FType, Att.Fields[i].FieldType, False) then
12517 begin
12518 MakeError('', ecTypeMismatch, '');
12519 Result := False;
12520 exit;
12521 end;
12522 Inc(i);
12523 while (i < Att.FieldCount) and (att.Fields[i].Hidden) do
12524 begin
12525 at.AddValue(NewVariant(at2ut(att.Fields[i].FieldType)));
12526 inc(i);
12527 end;
12528 if i >= Att.FieldCount then
12529 begin
12530 break;
12531 end else
12532 begin
12533 if FParser.CurrTokenID <> CSTI_Comma then
12534 begin
12535 MakeError('', ecCommaExpected, '');
12536 Result := False;
12537 exit;
12538 end;
12539 end;
12540 FParser.Next;
12541 end;
12542 end;
12543 if FParser.CurrTokenID <> CSTI_CloseRound then
12544 begin
12545 MakeError('', ecCloseRoundExpected, '');
12546 Result := False;
12547 exit;
12548 end;
12549 FParser.Next;
12550 if FParser.CurrTokenID <> CSTI_CloseBlock then
12551 begin
12552 MakeError('', ecCloseBlockExpected, '');
12553 Result := False;
12554 exit;
12555 end;
12556 FParser.Next;
12557 Result := True;
12558 end;
12559
12560 type
12561 TConstOperation = class(TObject)
12562 private
12563 FDeclPosition, FDeclRow, FDeclCol: Cardinal;
12564 public
12565 property DeclPosition: Cardinal read FDeclPosition write FDeclPosition;
12566 property DeclRow: Cardinal read FDeclRow write FDeclRow;
12567 property DeclCol: Cardinal read FDeclCol write FDeclCol;
12568 procedure SetPos(Parser: TPSPascalParser);
12569 end;
12570
12571 TUnConstOperation = class(TConstOperation)
12572 private
12573 FOpType: TPSUnOperatorType;
12574 FVal1: TConstOperation;
12575 public
12576 property OpType: TPSUnOperatorType read FOpType write FOpType;
12577 property Val1: TConstOperation read FVal1 write FVal1;
12578
12579 destructor Destroy; override;
12580 end;
12581
12582 TBinConstOperation = class(TConstOperation)
12583 private
12584 FOpType: TPSBinOperatorType;
12585 FVal2: TConstOperation;
12586 FVal1: TConstOperation;
12587 public
12588 property OpType: TPSBinOperatorType read FOpType write FOpType;
12589 property Val1: TConstOperation read FVal1 write FVal1;
12590 property Val2: TConstOperation read FVal2 write FVal2;
12591
12592 destructor Destroy; override;
12593 end;
12594
12595 TConstData = class(TConstOperation)
12596 private
12597 FData: PIfRVariant;
12598 public
12599 property Data: PIfRVariant read FData write FData;
12600 destructor Destroy; override;
12601 end;
12602
12603
IsBooleannull12604 function TPSPascalCompiler.IsBoolean(aType: TPSType): Boolean;
12605 begin
12606 Result := (AType = FDefaultBoolType)
12607 or (AType.Name = 'LONGBOOL')
12608 or (AType.Name = 'WORDBOOL')
12609 or (AType.Name = 'BYTEBOOL');
12610 end;
12611
12612
TPSPascalCompiler.ReadConstantnull12613 function TPSPascalCompiler.ReadConstant(FParser: TPSPascalParser; StopOn: TPSPasToken): PIfRVariant;
12614
12615 function ReadExpression: TConstOperation; forward;
12616 function ReadTerm: TConstOperation; forward;
ReadFactornull12617 function ReadFactor: TConstOperation;
12618 var
12619 NewVar: TConstOperation;
12620 NewVarU: TUnConstOperation;
GetConstantIdentifiernull12621 function GetConstantIdentifier: PIfRVariant;
12622 var
12623 s: tbtString;
12624 sh: Longint;
12625 i: Longint;
12626 p: TPSConstant;
12627 begin
12628 s := FParser.GetToken;
12629 sh := MakeHash(s);
12630 for i := FConstants.Count -1 downto 0 do
12631 begin
12632 p := FConstants[I];
12633 if (p.NameHash = sh) and (p.Name = s) then
12634 begin
12635 New(Result);
12636 InitializeVariant(Result, p.Value.FType);
12637 CopyVariantContents(P.Value, Result);
12638 FParser.Next;
12639 exit;
12640 end;
12641 end;
12642 MakeError('', ecUnknownIdentifier, '');
12643 Result := nil;
12644 end;
12645 begin
12646 case fParser.CurrTokenID of
12647 CSTII_Not:
12648 begin
12649 FParser.Next;
12650 NewVar := ReadFactor;
12651 if NewVar = nil then
12652 begin
12653 Result := nil;
12654 exit;
12655 end;
12656 NewVarU := TUnConstOperation.Create;
12657 NewVarU.OpType := otNot;
12658 NewVarU.Val1 := NewVar;
12659 NewVar := NewVarU;
12660 end;
12661 CSTI_Minus:
12662 begin
12663 FParser.Next;
12664 NewVar := ReadTerm;
12665 if NewVar = nil then
12666 begin
12667 Result := nil;
12668 exit;
12669 end;
12670 NewVarU := TUnConstOperation.Create;
12671 NewVarU.OpType := otMinus;
12672 NewVarU.Val1 := NewVar;
12673 NewVar := NewVarU;
12674 end;
12675 CSTI_OpenRound:
12676 begin
12677 FParser.Next;
12678 NewVar := ReadExpression;
12679 if NewVar = nil then
12680 begin
12681 Result := nil;
12682 exit;
12683 end;
12684 if FParser.CurrTokenId <> CSTI_CloseRound then
12685 begin
12686 NewVar.Free;
12687 Result := nil;
12688 MakeError('', ecCloseRoundExpected, '');
12689 exit;
12690 end;
12691 FParser.Next;
12692 end;
12693 CSTI_Char, CSTI_String:
12694 begin
12695 NewVar := TConstData.Create;
12696 NewVar.SetPos(FParser);
12697 TConstData(NewVar).Data := ReadString;
12698 end;
12699 CSTI_HexInt, CSTI_Integer:
12700 begin
12701 NewVar := TConstData.Create;
12702 NewVar.SetPos(FParser);
12703 TConstData(NewVar).Data := ReadInteger(FParser.GetToken);
12704 FParser.Next;
12705 end;
12706 CSTI_Real:
12707 begin
12708 NewVar := TConstData.Create;
12709 NewVar.SetPos(FParser);
12710 TConstData(NewVar).Data := ReadReal(FParser.GetToken);
12711 FParser.Next;
12712 end;
12713 CSTI_Identifier:
12714 begin
12715 NewVar := TConstData.Create;
12716 NewVar.SetPos(FParser);
12717 TConstData(NewVar).Data := GetConstantIdentifier;
12718 if TConstData(NewVar).Data = nil then
12719 begin
12720 NewVar.Free;
12721 Result := nil;
12722 exit;
12723 end
12724 end;
12725 else
12726 begin
12727 MakeError('', ecSyntaxError, '');
12728 Result := nil;
12729 exit;
12730 end;
12731 end; {case}
12732 Result := NewVar;
12733 end; // ReadFactor
12734
ReadTermnull12735 function ReadTerm: TConstOperation;
12736 var
12737 F1, F2: TConstOperation;
12738 F: TBinConstOperation;
12739 Token: TPSPasToken;
12740 Op: TPSBinOperatorType;
12741 begin
12742 F1 := ReadFactor;
12743 if F1 = nil then
12744 begin
12745 Result := nil;
12746 exit;
12747 end;
12748 while FParser.CurrTokenID in [CSTI_Multiply, CSTI_Divide, CSTII_Div, CSTII_Mod, CSTII_And, CSTII_Shl, CSTII_Shr] do
12749 begin
12750 Token := FParser.CurrTokenID;
12751 FParser.Next;
12752 F2 := ReadFactor;
12753 if f2 = nil then
12754 begin
12755 f1.Free;
12756 Result := nil;
12757 exit;
12758 end;
12759 case Token of
12760 CSTI_Multiply: Op := otMul;
12761 CSTI_Divide: Op := otDiv;
12762 CSTII_Div: Op := otIntDiv;
12763 CSTII_mod: Op := otMod;
12764 CSTII_and: Op := otAnd;
12765 CSTII_shl: Op := otShl;
12766 CSTII_shr: Op := otShr;
12767 else
12768 Op := otAdd;
12769 end;
12770 F := TBinConstOperation.Create;
12771 f.Val1 := F1;
12772 f.Val2 := F2;
12773 f.OpType := Op;
12774 f1 := f;
12775 end;
12776 Result := F1;
12777 end; // ReadTerm
12778
ReadSimpleExpressionnull12779 function ReadSimpleExpression: TConstOperation;
12780 var
12781 F1, F2: TConstOperation;
12782 F: TBinConstOperation;
12783 Token: TPSPasToken;
12784 Op: TPSBinOperatorType;
12785 begin
12786 F1 := ReadTerm;
12787 if F1 = nil then
12788 begin
12789 Result := nil;
12790 exit;
12791 end;
12792 while FParser.CurrTokenID in [CSTI_Plus, CSTI_Minus, CSTII_Or, CSTII_Xor] do
12793 begin
12794 Token := FParser.CurrTokenID;
12795 FParser.Next;
12796 F2 := ReadTerm;
12797 if f2 = nil then
12798 begin
12799 f1.Free;
12800 Result := nil;
12801 exit;
12802 end;
12803 case Token of
12804 CSTI_Plus: Op := otAdd;
12805 CSTI_Minus: Op := otSub;
12806 CSTII_or: Op := otOr;
12807 CSTII_xor: Op := otXor;
12808 else
12809 Op := otAdd;
12810 end;
12811 F := TBinConstOperation.Create;
12812 f.Val1 := F1;
12813 f.Val2 := F2;
12814 f.OpType := Op;
12815 f1 := f;
12816 end;
12817 Result := F1;
12818 end; // ReadSimpleExpression
12819
12820
ReadExpressionnull12821 function ReadExpression: TConstOperation;
12822 var
12823 F1, F2: TConstOperation;
12824 F: TBinConstOperation;
12825 Token: TPSPasToken;
12826 Op: TPSBinOperatorType;
12827 begin
12828 F1 := ReadSimpleExpression;
12829 if F1 = nil then
12830 begin
12831 Result := nil;
12832 exit;
12833 end;
12834 while FParser.CurrTokenID in [ CSTI_GreaterEqual, CSTI_LessEqual, CSTI_Greater, CSTI_Less, CSTI_Equal, CSTI_NotEqual] do
12835 begin
12836 Token := FParser.CurrTokenID;
12837 FParser.Next;
12838 F2 := ReadSimpleExpression;
12839 if f2 = nil then
12840 begin
12841 f1.Free;
12842 Result := nil;
12843 exit;
12844 end;
12845 case Token of
12846 CSTI_GreaterEqual: Op := otGreaterEqual;
12847 CSTI_LessEqual: Op := otLessEqual;
12848 CSTI_Greater: Op := otGreater;
12849 CSTI_Less: Op := otLess;
12850 CSTI_Equal: Op := otEqual;
12851 CSTI_NotEqual: Op := otNotEqual;
12852 else
12853 Op := otAdd;
12854 end;
12855 F := TBinConstOperation.Create;
12856 f.Val1 := F1;
12857 f.Val2 := F2;
12858 f.OpType := Op;
12859 f1 := f;
12860 end;
12861 Result := F1;
12862 end; // ReadExpression
12863
12864
EvalConstnull12865 function EvalConst(P: TConstOperation): PIfRVariant;
12866 var
12867 p1, p2: PIfRVariant;
12868 begin
12869 if p is TBinConstOperation then
12870 begin
12871 p1 := EvalConst(TBinConstOperation(p).Val1);
12872 if p1 = nil then begin Result := nil; exit; end;
12873 p2 := EvalConst(TBinConstOperation(p).Val2);
12874 if p2 = nil then begin DisposeVariant(p1); Result := nil; exit; end;
12875 if not PreCalc(False, 0, p1, 0, p2, TBinConstOperation(p).OpType, p.DeclPosition, p.DeclRow, p.DeclCol) then
12876 begin
12877 DisposeVariant(p1);
12878 DisposeVariant(p2);
12879 // MakeError('', ecTypeMismatch, '');
12880 result := nil;
12881 exit;
12882 end;
12883 DisposeVariant(p2);
12884 Result := p1;
12885 end else if p is TUnConstOperation then
12886 begin
12887 with TUnConstOperation(P) do
12888 begin
12889 p1 := EvalConst(Val1);
12890 case OpType of
12891 otNot:
12892 case p1.FType.BaseType of
12893 btU8: p1.tu8 := not p1.tu8;
12894 btU16: p1.tu16 := not p1.tu16;
12895 btU32: p1.tu32 := not p1.tu32;
12896 bts8: p1.ts8 := not p1.ts8;
12897 bts16: p1.ts16 := not p1.ts16;
12898 bts32: p1.ts32 := not p1.ts32;
12899 {$IFNDEF PS_NOINT64}
12900 bts64: p1.ts64 := not p1.ts64;
12901 {$ENDIF}
12902 else
12903 begin
12904 MakeError('', ecTypeMismatch, '');
12905 DisposeVariant(p1);
12906 Result := nil;
12907 exit;
12908 end;
12909 end;
12910 otMinus:
12911 case p1.FType.BaseType of
12912 btU8: p1.tu8 := -p1.tu8;
12913 btU16: p1.tu16 := -p1.tu16;
12914 btU32: p1.tu32 := -p1.tu32;
12915 bts8: p1.ts8 := -p1.ts8;
12916 bts16: p1.ts16 := -p1.ts16;
12917 bts32: p1.ts32 := -p1.ts32;
12918 {$IFNDEF PS_NOINT64}
12919 bts64: p1.ts64 := -p1.ts64;
12920 {$ENDIF}
12921 btDouble: p1.tdouble := - p1.tDouble;
12922 btSingle: p1.tsingle := - p1.tsingle;
12923 btCurrency: p1.tcurrency := - p1.tcurrency;
12924 btExtended: p1.textended := - p1.textended;
12925 else
12926 begin
12927 MakeError('', ecTypeMismatch, '');
12928 DisposeVariant(p1);
12929 Result := nil;
12930 exit;
12931 end;
12932 end;
12933 else
12934 begin
12935 DisposeVariant(p1);
12936 Result := nil;
12937 exit;
12938 end;
12939 end;
12940 end;
12941 Result := p1;
12942 end else
12943 begin
12944 if ((p as TConstData).Data.FType.BaseType = btString)
12945 and (length(tbtstring((p as TConstData).Data.tstring)) =1) then
12946 begin
12947 New(p1);
12948 InitializeVariant(p1, FindBaseType(btChar));
12949 p1.tchar := tbtstring((p as TConstData).Data.tstring)[1];
12950 Result := p1;
12951 end else begin
12952 New(p1);
12953 InitializeVariant(p1, (p as TConstData).Data.FType);
12954 CopyVariantContents((p as TConstData).Data, p1);
12955 Result := p1;
12956 end;
12957 end;
12958 end;
12959
12960 var
12961 Val: TConstOperation;
12962 begin
12963 Val := ReadExpression;
12964 if val = nil then
12965 begin
12966 Result := nil;
12967 exit;
12968 end;
12969 Result := EvalConst(Val);
12970 Val.Free;
12971 end;
12972
12973 procedure TPSPascalCompiler.WriteDebugData(const s: tbtString);
12974 begin
12975 FDebugOutput := FDebugOutput + s;
12976 end;
12977
TPSPascalCompiler.GetDebugOutputnull12978 function TPSPascalCompiler.GetDebugOutput(var s: tbtString): Boolean;
12979 begin
12980 if Length(FDebugOutput) <> 0 then
12981 begin
12982 s := FDebugOutput;
12983 Result := True;
12984 end
12985 else
12986 Result := False;
12987 end;
12988
TPSPascalCompiler.AddUsedFunctionnull12989 function TPSPascalCompiler.AddUsedFunction(var Proc: TPSInternalProcedure): Cardinal;
12990 begin
12991 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
12992 Proc := TPSInternalProcedure.Create;
12993 FProcs.Add(Proc);
12994 Result := FProcs.Count - 1;
12995 end;
12996
12997 {$IFNDEF PS_NOINTERFACES}
12998 const
12999 IUnknown_Guid: TGuid = (D1: 0; d2: 0; d3: 0; d4: ($c0,00,00,00,00,00,00,$46));
13000 IDispatch_Guid: Tguid = (D1: $20400; D2: $0; D3: $0; D4:($C0, $0, $0, $0, $0, $0, $0, $46));
13001 {$ENDIF}
13002
13003 procedure TPSPascalCompiler.DefineStandardProcedures;
13004 var
13005 p: TPSRegProc;
13006 begin
13007 { The following needs to be in synch in these 3 functions:
13008 -UPSCompiler.TPSPascalCompiler.DefineStandardProcedures
13009 -UPSRuntime.DefProc
13010 -UPSRuntime.TPSExec.RegisterStandardProcs
13011 }
13012 {$IFNDEF PS_NOINT64}
13013 AddFunction('function IntToStr(I: Int64): string;');
13014 {$ELSE}
13015 AddFunction('function IntToStr(I: Integer): string;');
13016 {$ENDIF}
13017 AddFunction('function StrToInt(S: string): LongInt;');
AddFunctionnull13018 AddFunction('function StrToIntDef(S: string; def: LongInt): LongInt;');
13019 AddFunction('function Copy(S: AnyString; iFrom, iCount: LongInt): AnyString;');
AddFunctionnull13020 AddFunction('function Pos(SubStr, S: AnyString): LongInt;');
13021 AddFunction('procedure Delete(var S: AnyString; iFrom, iCount: LongInt);');
AddFunctionnull13022 AddFunction('procedure Insert(S: AnyString; var s2: AnyString; iPos: LongInt);');
Decl.AddParam.OrgNamenull13023 AddFunction('function GetArrayLength: Integer;').Decl.AddParam.OrgName := 'Arr';
13024 p := AddFunction('procedure SetArrayLength;');
withnull13025 with P.Decl.AddParam do
13026 begin
13027 OrgName := 'arr';
13028 Mode := pmInOut;
13029 end;
13030 with P.Decl.AddParam do
13031 begin
13032 OrgName := 'count';
13033 aType := FindBaseType(btS32);
13034 end;
13035 AddFunction('function StrGet(var S: string; I: Integer): Char;');
AddFunctionnull13036 AddFunction('function StrGet2(S: string; I: Integer): Char;');
13037 AddFunction('procedure StrSet(C: Char; I: Integer; var S: string);');
13038 {$IFNDEF PS_NOWIDESTRING}
13039 AddFunction('function WStrGet(var S: AnyString; I: Integer): WideChar;');
13040 AddFunction('procedure WStrSet(C: AnyString; I: Integer; var S: AnyString);');
13041 {$ENDIF}
13042 AddDelphiFunction('function VarArrayGet(var S: Variant; I: Integer): Variant;');
13043 AddDelphiFunction('procedure VarArraySet(C: Variant; I: Integer; var S: Variant);');
AddFunctionnull13044 AddFunction('function AnsiUpperCase(S: string): string;');
13045 AddFunction('function AnsiLowerCase(S: string): string;');
AddFunctionnull13046 AddFunction('function UpperCase(S: AnyString): AnyString;');
13047 AddFunction('function LowerCase(S: AnyString): AnyString;');
AddFunctionnull13048 AddFunction('function Trim(S: AnyString): AnyString;');
Decl.AddParam.OrgNamenull13049 AddFunction('function Length: Integer;').Decl.AddParam.OrgName := 'S';
Declnull13050 with AddFunction('procedure SetLength;').Decl do
13051 begin
13052 with AddParam do
13053 begin
13054 OrgName:='s';
13055 Mode:=pmInOut;
13056 end;
13057 with AddParam do
13058 begin
13059 OrgName:='NewLength';
13060 aType:=FindBaseType(btS32); //Integer
13061 end;
13062 end;
13063 {$IFNDEF PS_NOINT64}
Decl.AddParam.OrgNamenull13064 AddFunction('function Low: Int64;').Decl.AddParam.OrgName := 'X';
Decl.AddParam.OrgNamenull13065 AddFunction('function High: Int64;').Decl.AddParam.OrgName := 'X';
13066 {$ELSE}
Decl.AddParam.OrgNamenull13067 AddFunction('function Low: Integer;').Decl.AddParam.OrgName := 'X';
Decl.AddParam.OrgNamenull13068 AddFunction('function High: Integer;').Decl.AddParam.OrgName := 'X';
13069 {$ENDIF}
Declnull13070 with AddFunction('procedure Dec;').Decl do begin
13071 with AddParam do
13072 begin
13073 OrgName:='x';
13074 Mode:=pmInOut;
13075 end;
13076 end;
Declnull13077 with AddFunction('procedure Inc;').Decl do begin
13078 with AddParam do
13079 begin
13080 OrgName:='x';
13081 Mode:=pmInOut;
13082 end;
13083 end;
Declnull13084 with AddFunction('procedure Include;').Decl do begin
13085 with AddParam do
13086 begin
13087 OrgName:='s';
13088 Mode:=pmInOut;
13089 end;
13090 with AddParam do
13091 begin
13092 OrgName:='m';
13093 Mode:=pmIn;
13094 end;
13095 end;
Declnull13096 with AddFunction('procedure Exclude;').Decl do begin
13097 with AddParam do
13098 begin
13099 OrgName:='s';
13100 Mode:=pmInOut;
13101 end;
13102 with AddParam do
13103 begin
13104 OrgName:='m';
13105 Mode:=pmIn;
13106 end;
13107 end;
13108 AddFunction('function Sin(E: Extended): Extended;');
AddFunctionnull13109 AddFunction('function Cos(E: Extended): Extended;');
13110 AddFunction('function Sqrt(E: Extended): Extended;');
AddFunctionnull13111 AddFunction('function Round(E: Extended): LongInt;');
13112 AddFunction('function Trunc(E: Extended): LongInt;');
AddFunctionnull13113 AddFunction('function Int(E: Extended): Extended;');
13114 AddFunction('function Pi: Extended;');
AddFunctionnull13115 AddFunction('function Abs(E: Extended): Extended;');
13116 AddFunction('function StrToFloat(S: string): Extended;');
AddFunctionnull13117 AddFunction('function FloatToStr(E: Extended): string;');
13118 AddFunction('function PadL(S: AnyString; I: LongInt): AnyString;');
AddFunctionnull13119 AddFunction('function PadR(S: AnyString; I: LongInt): AnyString;');
13120 AddFunction('function PadZ(S: AnyString; I: LongInt): AnyString;');
AddFunctionnull13121 AddFunction('function Replicate(C: Char; I: LongInt): string;');
13122 AddFunction('function StringOfChar(C: Char; I: LongInt): string;');
AddTypeSnull13123 AddTypeS('TVarType', 'Word');
13124 AddConstantN('varEmpty', 'Word').Value.tu16 := varempty;
13125 AddConstantN('varNull', 'Word').Value.tu16 := varnull;
13126 AddConstantN('varSmallInt', 'Word').Value.tu16 := varsmallint;
13127 AddConstantN('varInteger', 'Word').Value.tu16 := varinteger;
13128 AddConstantN('varSingle', 'Word').Value.tu16 := varsingle;
13129 AddConstantN('varDouble', 'Word').Value.tu16 := vardouble;
13130 AddConstantN('varCurrency', 'Word').Value.tu16 := varcurrency;
13131 AddConstantN('varDate', 'Word').Value.tu16 := vardate;
13132 AddConstantN('varOleStr', 'Word').Value.tu16 := varolestr;
13133 AddConstantN('varDispatch', 'Word').Value.tu16 := vardispatch;
13134 AddConstantN('varError', 'Word').Value.tu16 := varerror;
13135 AddConstantN('varBoolean', 'Word').Value.tu16 := varboolean;
13136 AddConstantN('varVariant', 'Word').Value.tu16 := varvariant;
13137 AddConstantN('varUnknown', 'Word').Value.tu16 := varunknown;
13138 {$IFDEF DELPHI6UP}
13139 AddConstantN('varShortInt', 'Word').Value.tu16 := varshortint;
13140 AddConstantN('varByte', 'Word').Value.tu16 := varbyte;
13141 AddConstantN('varWord', 'Word').Value.tu16 := varword;
13142 AddConstantN('varLongWord', 'Word').Value.tu16 := varlongword;
13143 AddConstantN('varInt64', 'Word').Value.tu16 := varint64;
13144 {$ENDIF}
13145 {$IFDEF DELPHI5UP}
13146 AddConstantN('varStrArg', 'Word').Value.tu16 := varstrarg;
13147 AddConstantN('varAny', 'Word').Value.tu16 := varany;
13148 {$ENDIF}
13149 AddConstantN('varString', 'Word').Value.tu16 := varstring;
13150 AddConstantN('varTypeMask', 'Word').Value.tu16 := vartypemask;
13151 AddConstantN('varArray', 'Word').Value.tu16 := vararray;
13152 AddConstantN('varByRef', 'Word').Value.tu16 := varByRef;
13153 {$IFDEF UNICODE}
13154 AddConstantN('varUString', 'Word').Value.tu16 := varUString;
13155 {$ENDIF}
13156 AddDelphiFunction('function Unassigned: Variant;');
AddDelphiFunctionnull13157 AddDelphiFunction('function VarIsEmpty(const V: Variant): Boolean;');
13158 {$IFDEF DELPHI7UP}
13159 AddDelphiFunction('function VarIsClear(const V: Variant): Boolean;');
13160 {$ENDIF}
13161 AddDelphiFunction('function Null: Variant;');
13162 AddDelphiFunction('function VarIsNull(const V: Variant): Boolean;');
AddDelphiFunctionnull13163 AddDelphiFunction('function VarType(const V: Variant): TVarType;');
13164 addTypeS('TIFException', '(ErNoError, erCannotImport, erInvalidType, ErInternalError, '+
13165 'erInvalidHeader, erInvalidOpcode, erInvalidOpcodeParameter, erNoMainProc, erOutOfGlobalVarsRange, '+
13166 'erOutOfProcRange, ErOutOfRange, erOutOfStackRange, ErTypeMismatch, erUnexpectedEof, '+
13167 'erVersionError, ErDivideByZero, ErMathError,erCouldNotCallProc, erOutofRecordRange, '+
13168 'erOutOfMemory, erException, erNullPointerException, erNullVariantError, erInterfaceNotSupported, erCustomError)');
13169 AddFunction('procedure RaiseLastException;');
AddFunctionnull13170 AddFunction('procedure RaiseException(Ex: TIFException; Param: string);');
13171 AddFunction('function ExceptionType: TIFException;');
AddFunctionnull13172 AddFunction('function ExceptionParam: string;');
13173 AddFunction('function ExceptionProc: Cardinal;');
AddFunctionnull13174 AddFunction('function ExceptionPos: Cardinal;');
13175 AddFunction('function ExceptionToString(er: TIFException; Param: string): string;');
13176 {$IFNDEF PS_NOINT64}
13177 AddFunction('function StrToInt64(S: string): Int64;');
13178 AddFunction('function Int64ToStr(I: Int64): string;');
AddFunctionnull13179 AddFunction('function StrToInt64Def(S: string; def: Int64): Int64;');
13180 {$ENDIF}
13181
Decl.AddParamnull13182 with AddFunction('function SizeOf: LongInt;').Decl.AddParam do
13183 begin
13184 OrgName := 'Data';
13185 end;
13186 {$IFNDEF PS_NOINTERFACES}
13187 with AddInterface(nil, IUnknown_Guid, 'IUnknown') do
13188 begin
13189 RegisterDummyMethod; // Query Interface
13190 RegisterDummyMethod; // _AddRef
13191 RegisterDummyMethod; // _Release
13192 end;
13193 with AddInterface(nil, IUnknown_Guid, 'IInterface') do
13194 begin
13195 RegisterDummyMethod; // Query Interface
13196 RegisterDummyMethod; // _AddRef
13197 RegisterDummyMethod; // _Release
13198 end;
13199
13200 {$IFNDEF PS_NOIDISPATCH}
13201 with AddInterface(FindInterface('IUnknown'), IDispatch_Guid, 'IDispatch') do
13202 begin
13203 RegisterDummyMethod; // GetTypeCount
13204 RegisterDummyMethod; // GetTypeInfo
13205 RegisterDummyMethod; // GetIdsOfName
13206 RegisterDummyMethod; // Invoke
13207 end;
13208 with TPSInterfaceType(FindType('IDispatch')) do
13209 begin
13210 ExportName := True;
13211 end;
13212 AddDelphiFunction('function IdispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: string; Par: array of Variant): Variant;');
13213 {$ENDIF}
13214 {$ENDIF}
13215 end;
13216
TPSPascalCompiler.GetTypeCountnull13217 function TPSPascalCompiler.GetTypeCount: Longint;
13218 begin
13219 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13220 Result := FTypes.Count;
13221 end;
13222
TPSPascalCompiler.GetTypenull13223 function TPSPascalCompiler.GetType(I: Longint): TPSType;
13224 begin
13225 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13226 Result := FTypes[I];
13227 end;
13228
GetVarCountnull13229 function TPSPascalCompiler.GetVarCount: Longint;
13230 begin
13231 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13232 Result := FVars.Count;
13233 end;
13234
TPSPascalCompiler.GetVarnull13235 function TPSPascalCompiler.GetVar(I: Longint): TPSVar;
13236 begin
13237 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13238 Result := FVars[i];
13239 end;
13240
GetProcCountnull13241 function TPSPascalCompiler.GetProcCount: Longint;
13242 begin
13243 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13244 Result := FProcs.Count;
13245 end;
13246
GetProcnull13247 function TPSPascalCompiler.GetProc(I: Longint): TPSProcedure;
13248 begin
13249 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13250 Result := FProcs[i];
13251 end;
13252
13253
13254
13255
TPSPascalCompiler.AddUsedFunction2null13256 function TPSPascalCompiler.AddUsedFunction2(var Proc: TPSExternalProcedure): Cardinal;
13257 begin
13258 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13259 Proc := TPSExternalProcedure.Create;
13260 FProcs.Add(Proc);
13261 Result := FProcs.Count -1;
13262 end;
13263
AddVariablenull13264 function TPSPascalCompiler.AddVariable(const Name: tbtString; FType: TPSType): TPSVar;
13265 var
13266 P: TPSVar;
13267 s:tbtString;
13268 begin
13269 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13270 if FType = nil then raise EPSCompilerException.CreateFmt(RPS_InvalidTypeForVar, [Name]);
13271 s := Fastuppercase(Name);
13272 if IsDuplicate(s,[dcVars]) then raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Name]);
13273
13274 p := TPSVar.Create;
13275 p.OrgName := Name;
13276 p.Name := s;
13277 p.FType := AT2UT(FType);
13278 p.exportname := p.Name;
13279 FVars.Add(p);
13280 Result := P;
13281 end;
13282
TPSPascalCompiler.AddAttributeTypenull13283 function TPSPascalCompiler.AddAttributeType: TPSAttributeType;
13284 begin
13285 if FAttributeTypes = nil then Raise Exception.Create(RPS_OnUseEventOnly);
13286 Result := TPSAttributeType.Create;
13287 FAttributeTypes.Add(Result);
13288 end;
13289
TPSPascalCompiler.FindAttributeTypenull13290 function TPSPascalCompiler.FindAttributeType(const Name: tbtString): TPSAttributeType;
13291 var
13292 h, i: Integer;
13293 n: tbtString;
13294 begin
13295 if FAttributeTypes = nil then Raise Exception.Create(RPS_OnUseEventOnly);
13296 n := FastUpperCase(Name);
13297 h := MakeHash(n);
13298 for i := FAttributeTypes.Count -1 downto 0 do
13299 begin
13300 result := TPSAttributeType(FAttributeTypes[i]);
13301 if (Result.NameHash = h) and (Result.Name = n) then
13302 exit;
13303 end;
13304 result := nil;
13305 end;
TPSPascalCompiler.GetConstCountnull13306 function TPSPascalCompiler.GetConstCount: Longint;
13307 begin
13308 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13309 result := FConstants.Count;
13310 end;
13311
GetConstnull13312 function TPSPascalCompiler.GetConst(I: Longint): TPSConstant;
13313 begin
13314 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13315 Result := TPSConstant(FConstants[i]);
13316 end;
13317
GetRegProcCountnull13318 function TPSPascalCompiler.GetRegProcCount: Longint;
13319 begin
13320 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13321 Result := FRegProcs.Count;
13322 end;
13323
GetRegProcnull13324 function TPSPascalCompiler.GetRegProc(I: Longint): TPSRegProc;
13325 begin
13326 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13327 Result := TPSRegProc(FRegProcs[i]);
13328 end;
13329
13330
13331 procedure TPSPascalCompiler.AddToFreeList(Obj: TObject);
13332 begin
13333 FAutoFreeList.Add(Obj);
13334 end;
13335
TPSPascalCompiler.AddConstantNnull13336 function TPSPascalCompiler.AddConstantN(const Name,
13337 FType: tbtString): TPSConstant;
13338 begin
13339 Result := AddConstant(Name, FindType(FType));
13340 end;
13341
TPSPascalCompiler.AddTypeCopynull13342 function TPSPascalCompiler.AddTypeCopy(const Name: tbtString;
13343 TypeNo: TPSType): TPSType;
13344 begin
13345 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13346 TypeNo := GetTypeCopyLink(TypeNo);
13347 if Typeno = nil then raise EPSCompilerException.Create(RPS_InvalidType);
13348 Result := AddType(Name, BtTypeCopy);
13349 TPSTypeLink(Result).LinkTypeNo := TypeNo;
13350 end;
13351
TPSPascalCompiler.AddTypeCopyNnull13352 function TPSPascalCompiler.AddTypeCopyN(const Name,
13353 FType: tbtString): TPSType;
13354 begin
13355 Result := AddTypeCopy(Name, FindType(FType));
13356 end;
13357
13358
TPSPascalCompiler.AddUsedVariablenull13359 function TPSPascalCompiler.AddUsedVariable(const Name: tbtString;
13360 FType: TPSType): TPSVar;
13361 begin
13362 Result := AddVariable(Name, FType);
13363 if Result <> nil then
13364 Result.Use;
13365 end;
13366
TPSPascalCompiler.AddUsedVariableNnull13367 function TPSPascalCompiler.AddUsedVariableN(const Name,
13368 FType: tbtString): TPSVar;
13369 begin
13370 Result := AddVariable(Name, FindType(FType));
13371 if Result <> nil then
13372 Result.Use;
13373 end;
13374
AddVariableNnull13375 function TPSPascalCompiler.AddVariableN(const Name,
13376 FType: tbtString): TPSVar;
13377 begin
13378 Result := AddVariable(Name, FindType(FType));
13379 end;
13380
TPSPascalCompiler.AddUsedPtrVariablenull13381 function TPSPascalCompiler.AddUsedPtrVariable(const Name: tbtString; FType: TPSType): TPSVar;
13382 begin
13383 Result := AddVariable(Name, FType);
13384 if Result <> nil then
13385 begin
13386 result.SaveAsPointer := True;
13387 Result.Use;
13388 end;
13389 end;
13390
AddUsedPtrVariableNnull13391 function TPSPascalCompiler.AddUsedPtrVariableN(const Name, FType: tbtString): TPSVar;
13392 begin
13393 Result := AddVariable(Name, FindType(FType));
13394 if Result <> nil then
13395 begin
13396 result.SaveAsPointer := True;
13397 Result.Use;
13398 end;
13399 end;
13400
AddTypeSnull13401 function TPSPascalCompiler.AddTypeS(const Name, Decl: tbtString): TPSType;
13402 var
13403 Parser: TPSPascalParser;
13404 begin
13405 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13406 Parser := TPSPascalParser.Create;
13407 Parser.SetText(Decl);
13408
13409 if not(AllowDuplicateRegister) and (FindType(Name)<>nil) then
13410 Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Name]);
13411
13412 Result := ReadType(Name, Parser);
13413 if Result<>nil then
13414 begin
13415 Result.ExportName := True;
13416 Result.DeclarePos:=InvalidVal;
13417 {$IFDEF PS_USESSUPPORT}
13418 Result.DeclareUnit:=fModule;
13419 {$ENDIF}
13420 Result.DeclareRow:=0;
13421 Result.DeclareCol:=0;
13422 end;
13423 Parser.Free;
13424 if result = nil then Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterType, [name]);
13425 end;
13426
13427
TPSPascalCompiler.CheckCompatProcnull13428 function TPSPascalCompiler.CheckCompatProc(P: TPSType; ProcNo: Cardinal): Boolean;
13429 var
13430 i: Longint;
13431 s1, s2: TPSParametersDecl;
13432 begin
13433 if p.BaseType <> btProcPtr then begin
13434 Result := False;
13435 Exit;
13436 end;
13437
13438 S1 := TPSProceduralType(p).ProcDef;
13439
13440 if TPSProcedure(FProcs[ProcNo]).ClassType = TPSInternalProcedure then
13441 s2 := TPSInternalProcedure(FProcs[ProcNo]).Decl
13442 else
13443 s2 := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl;
13444 if (s1.Result <> s2.Result) or (s1.ParamCount <> s2.ParamCount) then
13445 begin
13446 Result := False;
13447 Exit;
13448 end;
13449 for i := 0 to s1.ParamCount -1 do
13450 begin
13451 if (s1.Params[i].Mode <> s2.Params[i].Mode) or (s1.Params[i].aType <> s2.Params[i].aType) then
13452 begin
13453 Result := False;
13454 Exit;
13455 end;
13456 end;
13457 Result := True;
13458 end;
13459
MakeExportDeclnull13460 function TPSPascalCompiler.MakeExportDecl(decl: TPSParametersDecl): tbtString;
13461 var
13462 i: Longint;
13463 begin
13464 if Decl.Result = nil then result := '-1' else
13465 result := IntToStr(Decl.Result.FinalTypeNo);
13466
13467 for i := 0 to decl.ParamCount -1 do
13468 begin
13469 if decl.GetParam(i).Mode = pmIn then
13470 Result := Result + ' @'
13471 else
13472 Result := Result + ' !';
13473 Result := Result + inttostr(decl.GetParam(i).aType.FinalTypeNo);
13474 end;
13475 end;
13476
13477
TPSPascalCompiler.IsIntBoolTypenull13478 function TPSPascalCompiler.IsIntBoolType(aType: TPSType): Boolean;
13479 begin
13480 if Isboolean(aType) then begin Result := True; exit;end;
13481
13482 case aType.BaseType of
13483 btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF PS_NOINT64}, btS64{$ENDIF}: Result := True;
13484 else
13485 Result := False;
13486 end;
13487 end;
13488
13489
13490 procedure TPSPascalCompiler.ParserError(Parser: TObject;
13491 Kind: TPSParserErrorKind);
13492 begin
13493 FParserHadError := True;
13494 case Kind of
13495 ICOMMENTERROR: MakeError('', ecCommentError, '');
13496 ISTRINGERROR: MakeError('', ecStringError, '');
13497 ICHARERROR: MakeError('', ecCharError, '');
13498 else
13499 MakeError('', ecSyntaxError, '');
13500 end;
13501 end;
13502
13503
AddDelphiFunctionnull13504 function TPSPascalCompiler.AddDelphiFunction(const Decl: tbtString): TPSRegProc;
13505 var
13506 p: TPSRegProc;
13507 pDecl: TPSParametersDecl;
13508 DOrgName: tbtString;
13509 FT: TPMFuncType;
13510 i: Longint;
13511
13512 begin
13513 pDecl := TPSParametersDecl.Create;
13514 p := nil;
13515 try
13516 if not ParseMethod(Self, '', Decl, DOrgName, pDecl, FT) then
13517 Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Decl]);
13518
13519 if (FindProc(DOrgName)<>InvalidVal) and not(FAllowDuplicateRegister) then
13520 Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Decl]);
13521
13522 p := TPSRegProc.Create;
13523 P.Name := FastUppercase(DOrgName);
13524 p.OrgName := DOrgName;
13525 p.ExportName := True;
13526 p.Decl.Assign(pDecl);
13527
13528 FRegProcs.Add(p);
13529
13530 if pDecl.Result = nil then
13531 begin
13532 p.ImportDecl := p.ImportDecl + #0;
13533 end else
13534 p.ImportDecl := p.ImportDecl + #1;
13535 for i := 0 to pDecl.ParamCount -1 do
13536 begin
13537 if pDecl.Params[i].Mode <> pmIn then
13538 p.ImportDecl := p.ImportDecl + #1
13539 else
13540 p.ImportDecl := p.ImportDecl + #0;
13541 end;
13542 finally
13543 pDecl.Free;
13544 end;
13545 Result := p;
13546 end;
13547
13548 {$IFNDEF PS_NOINTERFACES}
AddInterfacenull13549 function TPSPascalCompiler.AddInterface(InheritedFrom: TPSInterface; Guid: TGuid; const Name: tbtString): TPSInterface;
13550 var
13551 f: TPSType;
13552 begin
13553 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13554 f := FindType(Name);
13555 if (f<>nil) and not(FAllowDuplicateRegister) then
13556 Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Name]);
13557
13558 if (f <> nil) and (f is TPSInterfaceType) then
13559 begin
13560 result := TPSInterfaceType(f).Intf;
13561 Result.Guid := Guid;
13562 Result.InheritedFrom := InheritedFrom;
13563 exit;
13564 end;
13565 f := AddType(Name, btInterface);
13566 Result := TPSInterface.Create(Self, InheritedFrom, GUID, FastUppercase(Name), f);
13567 FInterfaces.Add(Result);
13568 TPSInterfaceType(f).Intf := Result;
13569 end;
13570
TPSPascalCompiler.FindInterfacenull13571 function TPSPascalCompiler.FindInterface(const Name: tbtString): TPSInterface;
13572 var
13573 n: tbtString;
13574 i, nh: Longint;
13575 begin
13576 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13577 n := FastUpperCase(Name);
13578 nh := MakeHash(n);
13579 for i := FInterfaces.Count -1 downto 0 do
13580 begin
13581 Result := FInterfaces[i];
13582 if (Result.NameHash = nh) and (Result.Name = N) then
13583 exit;
13584 end;
13585 raise EPSCompilerException.CreateFmt(RPS_UnknownInterface, [Name]);
13586 end;
13587 {$ENDIF}
TPSPascalCompiler.AddClassnull13588 function TPSPascalCompiler.AddClass(InheritsFrom: TPSCompileTimeClass; aClass: TClass): TPSCompileTimeClass;
13589 var
13590 f: TPSType;
13591 begin
13592 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13593 Result := FindClass(tbtstring(aClass.ClassName));
13594 if (Result<>nil) and not(FAllowDuplicateRegister) then
13595 Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [aClass.ClassName]);
13596 if Result <> nil then
13597 begin
13598 if InheritsFrom <> nil then
13599 Result.FInheritsFrom := InheritsFrom;
13600 exit;
13601 end;
13602 f := AddType(tbtstring(aClass.ClassName), btClass);
13603 Result := TPSCompileTimeClass.CreateC(aClass, Self, f);
13604 Result.FInheritsFrom := InheritsFrom;
13605 FClasses.Add(Result);
13606 TPSClassType(f).Cl := Result;
13607 f.ExportName := True;
13608 end;
13609
TPSPascalCompiler.AddClassNnull13610 function TPSPascalCompiler.AddClassN(InheritsFrom: TPSCompileTimeClass; const aClass: tbtString): TPSCompileTimeClass;
13611 var
13612 f: TPSType;
13613 begin
13614 if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
13615 Result := FindClass(aClass);
13616 if (Result<>nil) and (Result.FInheritsFrom<>nil) and not(FAllowDuplicateRegister) then
13617 Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [aClass]);
13618 if Result <> nil then
13619 begin
13620 if InheritsFrom <> nil then
13621 Result.FInheritsFrom := InheritsFrom;
13622 exit;
13623 end;
13624 f := AddType(aClass, btClass);
13625 Result := TPSCompileTimeClass.Create(FastUppercase(aClass), Self, f);
13626 TPSClassType(f).Cl := Result;
13627 Result.FInheritsFrom := InheritsFrom;
13628 FClasses.Add(Result);
13629 TPSClassType(f).Cl := Result;
13630 f.ExportName := True;
13631 end;
13632
TPSPascalCompiler.FindClassnull13633 function TPSPascalCompiler.FindClass(const aClass: tbtString): TPSCompileTimeClass;
13634 var
13635 i: Longint;
13636 Cl: tbtString;
13637 H: Longint;
13638 x: TPSCompileTimeClass;
13639 begin
13640 cl := FastUpperCase(aClass);
13641 H := MakeHash(Cl);
13642 for i :=0 to FClasses.Count -1 do
13643 begin
13644 x := FClasses[I];
13645 if (X.FClassNameHash = H) and (X.FClassName = Cl) then
13646 begin
13647 Result := X;
13648 Exit;
13649 end;
13650 end;
13651 Result := nil;
13652 end;
13653
13654
13655
13656 { }
13657
TransDoubleToStrnull13658 function TransDoubleToStr(D: Double): tbtString;
13659 begin
13660 SetLength(Result, SizeOf(Double));
13661 Double((@Result[1])^) := D;
13662 end;
13663
TransSingleToStrnull13664 function TransSingleToStr(D: Single): tbtString;
13665 begin
13666 SetLength(Result, SizeOf(Single));
13667 Single((@Result[1])^) := D;
13668 end;
13669
TransExtendedToStrnull13670 function TransExtendedToStr(D: Extended): tbtString;
13671 begin
13672 SetLength(Result, SizeOf(Extended));
13673 Extended((@Result[1])^) := D;
13674 end;
13675
TransLongintToStrnull13676 function TransLongintToStr(D: Longint): tbtString;
13677 begin
13678 SetLength(Result, SizeOf(Longint));
13679 Longint((@Result[1])^) := D;
13680 end;
13681
TransCardinalToStrnull13682 function TransCardinalToStr(D: Cardinal): tbtString;
13683 begin
13684 SetLength(Result, SizeOf(Cardinal));
13685 Cardinal((@Result[1])^) := D;
13686 end;
13687
TransWordToStrnull13688 function TransWordToStr(D: Word): tbtString;
13689 begin
13690 SetLength(Result, SizeOf(Word));
13691 Word((@Result[1])^) := D;
13692 end;
13693
TransSmallIntToStrnull13694 function TransSmallIntToStr(D: SmallInt): tbtString;
13695 begin
13696 SetLength(Result, SizeOf(SmallInt));
13697 SmallInt((@Result[1])^) := D;
13698 end;
13699
TransByteToStrnull13700 function TransByteToStr(D: Byte): tbtString;
13701 begin
13702 SetLength(Result, SizeOf(Byte));
13703 Byte((@Result[1])^) := D;
13704 end;
13705
TransShortIntToStrnull13706 function TransShortIntToStr(D: ShortInt): tbtString;
13707 begin
13708 SetLength(Result, SizeOf(ShortInt));
13709 ShortInt((@Result[1])^) := D;
13710 end;
13711
GetConstantnull13712 function TPSPascalCompiler.GetConstant(const Name: tbtString): TPSConstant;
13713 var
13714 h, i: Longint;
13715 n: tbtString;
13716
13717 begin
13718 n := FastUppercase(name);
13719 h := MakeHash(n);
13720 for i := 0 to FConstants.Count -1 do
13721 begin
13722 result := TPSConstant(FConstants[i]);
13723 if (Result.NameHash = h) and (Result.Name = n) then exit;
13724 end;
13725 result := nil;
13726 end;
13727
13728 {$IFDEF PS_USESSUPPORT}
IsInLocalUnitListnull13729 function TPSPascalCompiler.IsInLocalUnitList(s: tbtstring): Boolean;
13730 begin
13731 s:=FastUpperCase(s);
13732 if (s = '') or (s=FastUpperCase(fModule)) or (s='SYSTEM') then
13733 begin
13734 result:=true;
13735 exit;
13736 end;
13737 result:=fUnit.HasUses(S);
13738 end;
13739 {$ENDIF}
13740
13741 { TPSType }
13742
13743 constructor TPSType.Create;
13744 begin
13745 inherited Create;
13746 FAttributes := TPSAttributes.Create;
13747 FFinalTypeNo := InvalidVal;
13748 end;
13749
13750 destructor TPSType.Destroy;
13751 begin
13752 FAttributes.Free;
13753 inherited Destroy;
13754 end;
13755
13756 procedure TPSType.SetName(const Value: tbtString);
13757 begin
13758 FName := Value;
13759 FNameHash := MakeHash(Value);
13760 end;
13761
13762 procedure TPSType.Use;
13763 begin
13764 FUsed := True;
13765 end;
13766
13767 { TPSRecordType }
13768
TPSRecordType.AddRecValnull13769 function TPSRecordType.AddRecVal: PIFPSRecordFieldTypeDef;
13770 begin
13771 Result := TPSRecordFieldTypeDef.Create;
13772 FRecordSubVals.Add(Result);
13773 end;
13774
13775 constructor TPSRecordType.Create;
13776 begin
13777 inherited Create;
13778 FRecordSubVals := TPSList.Create;
13779 end;
13780
13781 destructor TPSRecordType.Destroy;
13782 var
13783 i: Longint;
13784 begin
13785 for i := FRecordSubVals.Count -1 downto 0 do
13786 TPSRecordFieldTypeDef(FRecordSubVals[I]).Free;
13787 FRecordSubVals.Free;
13788 inherited Destroy;
13789 end;
13790
TPSRecordType.RecValnull13791 function TPSRecordType.RecVal(I: Longint): PIFPSRecordFieldTypeDef;
13792 begin
13793 Result := FRecordSubVals[I]
13794 end;
13795
TPSRecordType.RecValCountnull13796 function TPSRecordType.RecValCount: Longint;
13797 begin
13798 Result := FRecordSubVals.Count;
13799 end;
13800
13801
13802 { TPSRegProc }
13803
13804 constructor TPSRegProc.Create;
13805 begin
13806 inherited Create;
13807 FDecl := TPSParametersDecl.Create;
13808 end;
13809
13810 destructor TPSRegProc.Destroy;
13811 begin
13812 FDecl.Free;
13813 inherited Destroy;
13814 end;
13815
13816 procedure TPSRegProc.SetName(const Value: tbtString);
13817 begin
13818 FName := Value;
13819 FNameHash := MakeHash(FName);
13820 end;
13821
13822 { TPSRecordFieldTypeDef }
13823
13824 procedure TPSRecordFieldTypeDef.SetFieldOrgName(const Value: tbtString);
13825 begin
13826 FFieldOrgName := Value;
13827 FFieldName := FastUppercase(Value);
13828 FFieldNameHash := MakeHash(FFieldName);
13829 end;
13830
13831 { TPSProcVar }
13832
13833 procedure TPSProcVar.SetName(const Value: tbtString);
13834 begin
13835 FName := Value;
13836 FNameHash := MakeHash(FName);
13837 end;
13838
13839 procedure TPSProcVar.Use;
13840 begin
13841 FUsed := True;
13842 end;
13843
13844
13845
13846 { TPSInternalProcedure }
13847
13848 constructor TPSInternalProcedure.Create;
13849 begin
13850 inherited Create;
13851 FProcVars := TPSList.Create;
13852 FLabels := TIfStringList.Create;
13853 FGotos := TIfStringList.Create;
13854 FDecl := TPSParametersDecl.Create;
13855 end;
13856
13857 destructor TPSInternalProcedure.Destroy;
13858 var
13859 i: Longint;
13860 begin
13861 FDecl.Free;
13862 for i := FProcVars.Count -1 downto 0 do
13863 TPSProcVar(FProcVars[I]).Free;
13864 FProcVars.Free;
13865 FGotos.Free;
13866 FLabels.Free;
13867 inherited Destroy;
13868 end;
13869
13870 procedure TPSInternalProcedure.ResultUse;
13871 begin
13872 FResultUsed := True;
13873 end;
13874
13875 procedure TPSInternalProcedure.SetName(const Value: tbtString);
13876 begin
13877 FName := Value;
13878 FNameHash := MakeHash(FName);
13879 end;
13880
13881 procedure TPSInternalProcedure.Use;
13882 begin
13883 FUsed := True;
13884 end;
13885
13886 { TPSProcedure }
13887 constructor TPSProcedure.Create;
13888 begin
13889 inherited Create;
13890 FAttributes := TPSAttributes.Create;
13891 end;
13892
13893 destructor TPSProcedure.Destroy;
13894 begin
13895 FAttributes.Free;
13896 inherited Destroy;
13897 end;
13898
13899 { TPSVar }
13900
13901 procedure TPSVar.SetName(const Value: tbtString);
13902 begin
13903 FName := Value;
13904 FNameHash := MakeHash(Value);
13905 end;
13906
13907 procedure TPSVar.Use;
13908 begin
13909 FUsed := True;
13910 end;
13911
13912 { TPSConstant }
13913
13914 destructor TPSConstant.Destroy;
13915 begin
13916 DisposeVariant(Value);
13917 inherited Destroy;
13918 end;
13919
13920 procedure TPSConstant.SetChar(c: tbtChar);
13921 begin
13922 if (FValue <> nil) then
13923 begin
13924 case FValue.FType.BaseType of
13925 btChar: FValue.tchar := c;
13926 btString: tbtString(FValue.tstring) := c;
13927 {$IFNDEF PS_NOWIDESTRING}
13928 btWideString: tbtwidestring(FValue.twidestring) := tbtWidestring(c);
13929 btUnicodeString: tbtUnicodestring(FValue.twidestring) := tbtUnicodestring(c);
13930 {$ENDIF}
13931 else
13932 raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
13933 end;
13934 end else
13935 raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
13936 end;
13937
13938 procedure TPSConstant.SetExtended(const Val: Extended);
13939 begin
13940 if (FValue <> nil) then
13941 begin
13942 case FValue.FType.BaseType of
13943 btSingle: FValue.tsingle := Val;
13944 btDouble: FValue.tdouble := Val;
13945 btExtended: FValue.textended := Val;
13946 btCurrency: FValue.tcurrency := Val;
13947 else
13948 raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
13949 end;
13950 end else
13951 raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
13952 end;
13953
13954 procedure TPSConstant.SetInt(const Val: Longint);
13955 begin
13956 if (FValue <> nil) then
13957 begin
13958 case FValue.FType.BaseType of
13959 btEnum: FValue.tu32 := Val;
13960 btU32, btS32: FValue.ts32 := Val;
13961 btU16, btS16: FValue.ts16 := Val;
13962 btU8, btS8: FValue.ts8 := Val;
13963 btSingle: FValue.tsingle := Val;
13964 btDouble: FValue.tdouble := Val;
13965 btExtended: FValue.textended := Val;
13966 btCurrency: FValue.tcurrency := Val;
13967 {$IFNDEF PS_NOINT64}
13968 bts64: FValue.ts64 := Val;
13969 {$ENDIF}
13970 else
13971 raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
13972 end;
13973 end else
13974 raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
13975 end;
13976 {$IFNDEF PS_NOINT64}
13977 procedure TPSConstant.SetInt64(const Val: Int64);
13978 begin
13979 if (FValue <> nil) then
13980 begin
13981 case FValue.FType.BaseType of
13982 btEnum: FValue.tu32 := Val;
13983 btU32, btS32: FValue.ts32 := Val;
13984 btU16, btS16: FValue.ts16 := Val;
13985 btU8, btS8: FValue.ts8 := Val;
13986 btSingle: FValue.tsingle := Val;
13987 btDouble: FValue.tdouble := Val;
13988 btExtended: FValue.textended := Val;
13989 btCurrency: FValue.tcurrency := Val;
13990 bts64: FValue.ts64 := Val;
13991 else
13992 raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
13993 end;
13994 end else
13995 raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
13996 end;
13997 {$ENDIF}
13998 procedure TPSConstant.SetName(const Value: tbtString);
13999 begin
14000 FName := Value;
14001 FNameHash := MakeHash(Value);
14002 end;
14003
14004
14005 procedure TPSConstant.SetSet(const val);
14006 begin
14007 if (FValue <> nil) then
14008 begin
14009 case FValue.FType.BaseType of
14010 btSet:
14011 begin
14012 if length(tbtstring(FValue.tstring)) <> TPSSetType(FValue.FType).ByteSize then
14013 SetLength(tbtstring(FValue.tstring), TPSSetType(FValue.FType).ByteSize);
14014 Move(Val, FValue.tstring^, TPSSetType(FValue.FType).ByteSize);
14015 end;
14016 else
14017 raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
14018 end;
14019 end else
14020 raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
14021 end;
14022
14023 procedure TPSConstant.SetString(const Val: tbtString);
14024 begin
14025 if (FValue <> nil) then
14026 begin
14027 case FValue.FType.BaseType of
14028 btChar: FValue.tchar := (Val+#0)[1];
14029 btString: tbtString(FValue.tstring) := val;
14030 {$IFNDEF PS_NOWIDESTRING}
14031 btWideChar: FValue.twidechar := WideChar((Val+#0)[1]);
14032 btWideString: tbtwidestring(FValue.twidestring) := tbtwidestring(val);
14033 btUnicodeString: tbtunicodestring(FValue.tunistring) := tbtunicodestring(val);
14034 {$ENDIF}
14035 else
14036 raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
14037 end;
14038 end else
14039 raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
14040 end;
14041
14042 procedure TPSConstant.SetUInt(const Val: Cardinal);
14043 begin
14044 if (FValue <> nil) then
14045 begin
14046 case FValue.FType.BaseType of
14047 btEnum: FValue.tu32 := Val;
14048 btU32, btS32: FValue.tu32 := Val;
14049 btU16, btS16: FValue.tu16 := Val;
14050 btU8, btS8: FValue.tu8 := Val;
14051 btSingle: FValue.tsingle := Val;
14052 btDouble: FValue.tdouble := Val;
14053 btExtended: FValue.textended := Val;
14054 btCurrency: FValue.tcurrency := Val;
14055 {$IFNDEF PS_NOINT64}
14056 bts64: FValue.ts64 := Val;
14057 {$ENDIF}
14058 else
14059 raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
14060 end;
14061 end else
14062 raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
14063 end;
14064
14065 {$IFNDEF PS_NOWIDESTRING}
14066 procedure TPSConstant.SetWideChar(const val: WideChar);
14067 begin
14068 if (FValue <> nil) then
14069 begin
14070 case FValue.FType.BaseType of
14071 btString: tbtString(FValue.tstring) := tbtstring(val);
14072 btWideChar: FValue.twidechar := val;
14073 btWideString: tbtwidestring(FValue.twidestring) := val;
14074 btUnicodeString: tbtUnicodestring(FValue.tUniString) := val;
14075 else
14076 raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
14077 end;
14078 end else
14079 raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
14080 end;
14081
14082 procedure TPSConstant.SetWideString(const val: tbtwidestring);
14083 begin
14084 if (FValue <> nil) then
14085 begin
14086 case FValue.FType.BaseType of
14087 btString: tbtString(FValue.tstring) := tbtstring(val);
14088 btWideString: tbtwidestring(FValue.twidestring) := val;
14089 btUnicodeString: tbtunicodestring(FValue.tunistring) := val;
14090 else
14091 raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
14092 end;
14093 end else
14094 raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
14095 end;
14096 procedure TPSConstant.SetUnicodeString(const val: tbtunicodestring);
14097 begin
14098 if (FValue <> nil) then
14099 begin
14100 case FValue.FType.BaseType of
14101 btString: tbtString(FValue.tstring) := tbtstring(val);
14102 btWideString: tbtwidestring(FValue.twidestring) := val;
14103 btUnicodeString: tbtunicodestring(FValue.tunistring) := val;
14104 else
14105 raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
14106 end;
14107 end else
14108 raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
14109 end;
14110 {$ENDIF}
14111 { TPSPascalCompilerError }
14112
TPSPascalCompilerError.ErrorTypenull14113 function TPSPascalCompilerError.ErrorType: tbtString;
14114 begin
14115 Result := tbtstring(RPS_Error);
14116 end;
14117
TPSPascalCompilerError.ShortMessageToStringnull14118 function TPSPascalCompilerError.ShortMessageToString: tbtString;
14119 begin
14120 case Error of
14121 ecUnknownIdentifier: Result := tbtstring(Format (RPS_UnknownIdentifier, [Param]));
14122 ecIdentifierExpected: Result := tbtstring(RPS_IdentifierExpected);
14123 ecCommentError: Result := tbtstring(RPS_CommentError);
14124 ecStringError: Result := tbtstring(RPS_StringError);
14125 ecCharError: Result := tbtstring(RPS_CharError);
14126 ecSyntaxError: Result := tbtstring(RPS_SyntaxError);
14127 ecUnexpectedEndOfFile: Result := tbtstring(RPS_EOF);
14128 ecSemicolonExpected: Result := tbtstring(RPS_SemiColonExpected);
14129 ecBeginExpected: Result := tbtstring(RPS_BeginExpected);
14130 ecPeriodExpected: Result := tbtstring(RPS_PeriodExpected);
14131 ecDuplicateIdentifier: Result := tbtstring(Format (RPS_DuplicateIdent, [Param]));
14132 ecColonExpected: Result := tbtstring(RPS_ColonExpected);
14133 ecUnknownType: Result := tbtstring(Format (RPS_UnknownType, [Param]));
14134 ecCloseRoundExpected: Result := tbtstring(RPS_CloseRoundExpected);
14135 ecTypeMismatch: Result := tbtstring(RPS_TypeMismatch);
14136 ecInternalError: Result := tbtstring(Format (RPS_InternalError, [Param]));
14137 ecAssignmentExpected: Result := tbtstring(RPS_AssignmentExpected);
14138 ecThenExpected: Result := tbtstring(RPS_ThenExpected);
14139 ecDoExpected: Result := tbtstring(RPS_DoExpected);
14140 ecNoResult: Result := tbtstring(RPS_NoResult);
14141 ecOpenRoundExpected: Result := tbtstring(RPS_OpenRoundExpected);
14142 ecCommaExpected: Result := tbtstring(RPS_CommaExpected);
14143 ecToExpected: Result := tbtstring(RPS_ToExpected);
14144 ecIsExpected: Result := tbtstring(RPS_IsExpected);
14145 ecOfExpected: Result := tbtstring(RPS_OfExpected);
14146 ecCloseBlockExpected: Result := tbtstring(RPS_CloseBlockExpected);
14147 ecVariableExpected: Result := tbtstring(RPS_VariableExpected);
14148 ecStringExpected: result := tbtstring(RPS_StringExpected);
14149 ecEndExpected: Result := tbtstring(RPS_EndExpected);
14150 ecUnSetLabel: Result := tbtstring(Format (RPS_UnSetLabel, [Param]));
14151 ecNotInLoop: Result := tbtstring(RPS_NotInLoop);
14152 ecInvalidJump: Result := tbtstring(RPS_InvalidJump);
14153 ecOpenBlockExpected: Result := tbtstring(RPS_OpenBlockExpected);
14154 ecWriteOnlyProperty: Result := tbtstring(RPS_WriteOnlyProperty);
14155 ecReadOnlyProperty: Result := tbtstring(RPS_ReadOnlyProperty);
14156 ecClassTypeExpected: Result := tbtstring(RPS_ClassTypeExpected);
14157 ecCustomError: Result := Param;
14158 ecDivideByZero: Result := tbtstring(RPS_DivideByZero);
14159 ecMathError: Result := tbtstring(RPS_MathError);
14160 ecUnsatisfiedForward: Result := tbtstring(Format (RPS_UnsatisfiedForward, [Param]));
14161 ecForwardParameterMismatch: Result := tbtstring(RPS_ForwardParameterMismatch);
14162 ecInvalidnumberOfParameters: Result := tbtstring(RPS_InvalidNumberOfParameter);
14163 {$IFDEF PS_USESSUPPORT}
14164 ecNotAllowed : Result:=tbtstring(Format(RPS_NotAllowed,[Param]));
14165 ecUnitNotFoundOrContainsErrors: Result:=tbtstring(Format(RPS_UnitNotFound,[Param]));
14166 ecCrossReference: Result:=tbtstring(Format(RPS_CrossReference,[Param]));
14167 {$ENDIF}
14168 else
14169 Result := tbtstring(RPS_UnknownError);
14170 end;
14171 Result := Result;
14172 end;
14173
14174
14175 { TPSPascalCompilerHint }
14176
TPSPascalCompilerHint.ErrorTypenull14177 function TPSPascalCompilerHint.ErrorType: tbtString;
14178 begin
14179 Result := tbtstring(RPS_Hint);
14180 end;
14181
TPSPascalCompilerHint.ShortMessageToStringnull14182 function TPSPascalCompilerHint.ShortMessageToString: tbtString;
14183 begin
14184 case Hint of
14185 ehVariableNotUsed: Result := tbtstring(Format (RPS_VariableNotUsed, [Param]));
14186 ehFunctionNotUsed: Result := tbtstring(Format (RPS_FunctionNotUsed, [Param]));
14187 ehCustomHint: Result := Param;
14188 else
14189 Result := tbtstring(RPS_UnknownHint);
14190 end;
14191 end;
14192
14193 { TPSPascalCompilerWarning }
14194
ErrorTypenull14195 function TPSPascalCompilerWarning.ErrorType: tbtString;
14196 begin
14197 Result := tbtstring(RPS_Warning);
14198 end;
14199
TPSPascalCompilerWarning.ShortMessageToStringnull14200 function TPSPascalCompilerWarning.ShortMessageToString: tbtString;
14201 begin
14202 case Warning of
14203 ewCustomWarning: Result := Param;
14204 ewCalculationAlwaysEvaluatesTo: Result := tbtstring(Format (RPS_CalculationAlwaysEvaluatesTo, [Param]));
14205 ewIsNotNeeded: Result := tbtstring(Format (RPS_IsNotNeeded, [Param]));
14206 ewAbstractClass: Result := tbtstring(RPS_AbstractClass);
14207 else
14208 Result := tbtstring(RPS_UnknownWarning);
14209 end;
14210 end;
14211
14212 { TPSPascalCompilerMessage }
14213
TPSPascalCompilerMessage.MessageToStringnull14214 function TPSPascalCompilerMessage.MessageToString: tbtString;
14215 begin
14216 Result := '['+ErrorType+'] '+FModuleName+'('+IntToStr(FRow)+':'+IntToStr(FCol)+'): '+ShortMessageToString;
14217 end;
14218
14219 procedure TPSPascalCompilerMessage.SetParserPos(Parser: TPSPascalParser);
14220 begin
14221 FPosition := Parser.CurrTokenPos;
14222 FRow := Parser.Row;
14223 FCol := Parser.Col;
14224 end;
14225
14226 procedure TPSPascalCompilerMessage.SetCustomPos(Pos, Row, Col: Cardinal);
14227 begin
14228 FPosition := Pos;
14229 FRow := Row;
14230 FCol := Col;
14231 end;
14232
14233 { TUnConstOperation }
14234
14235 destructor TUnConstOperation.Destroy;
14236 begin
14237 FVal1.Free;
14238 inherited Destroy;
14239 end;
14240
14241
14242 { TBinConstOperation }
14243
14244 destructor TBinConstOperation.Destroy;
14245 begin
14246 FVal1.Free;
14247 FVal2.Free;
14248 inherited Destroy;
14249 end;
14250
14251 { TConstData }
14252
14253 destructor TConstData.Destroy;
14254 begin
14255 DisposeVariant(FData);
14256 inherited Destroy;
14257 end;
14258
14259
14260 { TConstOperation }
14261
14262 procedure TConstOperation.SetPos(Parser: TPSPascalParser);
14263 begin
14264 FDeclPosition := Parser.CurrTokenPos;
14265 FDeclRow := Parser.Row;
14266 FDeclCol := Parser.Col;
14267 end;
14268
14269 { TPSValue }
14270
14271 procedure TPSValue.SetParserPos(P: TPSPascalParser);
14272 begin
14273 FPos := P.CurrTokenPos;
14274 FRow := P.Row;
14275 FCol := P.Col;
14276 end;
14277
14278 { TPSValueData }
14279
14280 destructor TPSValueData.Destroy;
14281 begin
14282 DisposeVariant(FData);
14283 inherited Destroy;
14284 end;
14285
14286
14287 { TPSValueReplace }
14288
14289 constructor TPSValueReplace.Create;
14290 begin
14291 FFreeNewValue := True;
14292 FReplaceTimes := 1;
14293 end;
14294
14295 destructor TPSValueReplace.Destroy;
14296 begin
14297 if FFreeOldValue then
14298 FOldValue.Free;
14299 if FFreeNewValue then
14300 FNewValue.Free;
14301 inherited Destroy;
14302 end;
14303
14304
14305
14306 { TPSUnValueOp }
14307
14308 destructor TPSUnValueOp.Destroy;
14309 begin
14310 FVal1.Free;
14311 inherited Destroy;
14312 end;
14313
14314 { TPSBinValueOp }
14315
14316 destructor TPSBinValueOp.Destroy;
14317 begin
14318 FVal1.Free;
14319 FVal2.Free;
14320 inherited Destroy;
14321 end;
14322
14323
14324
14325
14326 { TPSSubValue }
14327
14328 destructor TPSSubValue.Destroy;
14329 begin
14330 FSubNo.Free;
14331 inherited Destroy;
14332 end;
14333
14334 { TPSValueVar }
14335
14336 constructor TPSValueVar.Create;
14337 begin
14338 inherited Create;
14339 FRecItems := TPSList.Create;
14340 end;
14341
14342 destructor TPSValueVar.Destroy;
14343 var
14344 i: Longint;
14345 begin
14346 for i := 0 to FRecItems.Count -1 do
14347 begin
14348 TPSSubItem(FRecItems[I]).Free;
14349 end;
14350 FRecItems.Free;
14351 inherited Destroy;
14352 end;
14353
TPSValueVar.GetRecCountnull14354 function TPSValueVar.GetRecCount: Cardinal;
14355 begin
14356 Result := FRecItems.Count;
14357 end;
14358
TPSValueVar.GetRecItemnull14359 function TPSValueVar.GetRecItem(I: Cardinal): TPSSubItem;
14360 begin
14361 Result := FRecItems[I];
14362 end;
14363
TPSValueVar.RecAddnull14364 function TPSValueVar.RecAdd(Val: TPSSubItem): Cardinal;
14365 begin
14366 Result := FRecItems.Add(Val);
14367 end;
14368
14369 procedure TPSValueVar.RecDelete(I: Cardinal);
14370 var
14371 rr :TPSSubItem;
14372 begin
14373 rr := FRecItems[i];
14374 FRecItems.Delete(I);
14375 rr.Free;
14376 end;
14377
14378 { TPSValueProc }
14379
14380 destructor TPSValueProc.Destroy;
14381 begin
14382 FSelfPtr.Free;
14383 FParameters.Free;
14384 end;
14385 { TPSParameter }
14386
14387 destructor TPSParameter.Destroy;
14388 begin
14389 FTempVar.Free;
14390 FValue.Free;
14391 inherited Destroy;
14392 end;
14393
14394
14395 { TPSParameters }
14396
Addnull14397 function TPSParameters.Add: TPSParameter;
14398 begin
14399 Result := TPSParameter.Create;
14400 FItems.Add(Result);
14401 end;
14402
14403 constructor TPSParameters.Create;
14404 begin
14405 inherited Create;
14406 FItems := TPSList.Create;
14407 end;
14408
14409 procedure TPSParameters.Delete(I: Cardinal);
14410 var
14411 p: TPSParameter;
14412 begin
14413 p := FItems[I];
14414 FItems.Delete(i);
14415 p.Free;
14416 end;
14417
14418 destructor TPSParameters.Destroy;
14419 var
14420 i: Longint;
14421 begin
14422 for i := FItems.Count -1 downto 0 do
14423 begin
14424 TPSParameter(FItems[I]).Free;
14425 end;
14426 FItems.Free;
14427 inherited Destroy;
14428 end;
14429
GetCountnull14430 function TPSParameters.GetCount: Cardinal;
14431 begin
14432 Result := FItems.Count;
14433 end;
14434
GetItemnull14435 function TPSParameters.GetItem(I: Longint): TPSParameter;
14436 begin
14437 Result := FItems[I];
14438 end;
14439
14440
14441 { TPSValueArray }
14442
Addnull14443 function TPSValueArray.Add(Item: TPSValue): Cardinal;
14444 begin
14445 Result := FItems.Add(Item);
14446 end;
14447
14448 constructor TPSValueArray.Create;
14449 begin
14450 inherited Create;
14451 FItems := TPSList.Create;
14452 end;
14453
14454 procedure TPSValueArray.Delete(I: Cardinal);
14455 begin
14456 FItems.Delete(i);
14457 end;
14458
14459 destructor TPSValueArray.Destroy;
14460 var
14461 i: Longint;
14462 begin
14463 for i := FItems.Count -1 downto 0 do
14464 TPSValue(FItems[I]).Free;
14465 FItems.Free;
14466
14467 inherited Destroy;
14468 end;
14469
TPSValueArray.GetCountnull14470 function TPSValueArray.GetCount: Cardinal;
14471 begin
14472 Result := FItems.Count;
14473 end;
14474
GetItemnull14475 function TPSValueArray.GetItem(I: Cardinal): TPSValue;
14476 begin
14477 Result := FItems[I];
14478 end;
14479
14480
14481 { TPSValueAllocatedStackVar }
14482
14483 destructor TPSValueAllocatedStackVar.Destroy;
14484 var
14485 pv: TPSProcVar;
14486 begin
14487 {$IFDEF DEBUG}
14488 if Cardinal(LocalVarNo +1) <> proc.ProcVars.Count then
14489 begin
14490 Abort;
14491 exit;
14492 end;
14493 {$ENDIF}
14494 if Proc <> nil then
14495 begin
14496 pv := Proc.ProcVars[Proc.ProcVars.Count -1];
14497 Proc.ProcVars.Delete(Proc.ProcVars.Count -1);
14498 pv.Free;
14499 Proc.Data := Proc.Data + tbtChar(CM_PO);
14500 end;
14501 inherited Destroy;
14502 end;
14503
14504
14505
14506
AddImportedClassVariablenull14507 function AddImportedClassVariable(Sender: TPSPascalCompiler; const VarName, VarType: tbtString): Boolean;
14508 var
14509 P: TPSVar;
14510 begin
14511 P := Sender.AddVariableN(VarName, VarType);
14512 if p = nil then
14513 begin
14514 Result := False;
14515 Exit;
14516 end;
14517 SetVarExportName(P, FastUppercase(VarName));
14518 p.Use;
14519 Result := True;
14520 end;
14521
14522
14523 {'class:'+CLASSNAME+'|'+FUNCNAME+'|'+chr(CallingConv)+chr(hasresult)+params
14524
14525 For property write functions there is an '@' after the funcname.
14526 }
14527
14528 const
14529 ProcHDR = 'procedure a;';
14530
14531
14532
14533 { TPSCompileTimeClass }
14534
TPSCompileTimeClass.CastToTypenull14535 function TPSCompileTimeClass.CastToType(IntoType: TPSType;
14536 var ProcNo: Cardinal): Boolean;
14537 var
14538 P: TPSExternalProcedure;
14539 begin
14540 if (IntoType <> nil) and (IntoType.BaseType <> btClass) and (IntoType.BaseType <> btInterface) then
14541 begin
14542 Result := False;
14543 exit;
14544 end;
14545 if FCastProc <> InvalidVal then
14546 begin
14547 Procno := FCastProc;
14548 Result := True;
14549 exit;
14550 end;
14551 ProcNo := FOwner. AddUsedFunction2(P);
rocHDRnull14552 P.RegProc := FOwner.AddFunction(ProcHDR);
14553 P.RegProc.Name := '';
14554
14555 with P.RegProc.Decl.AddParam do
14556 begin
14557 OrgName := 'Org';
14558 aType := Self.FType;
14559 end;
14560 with P.RegProc.Decl.AddParam do
14561 begin
14562 OrgName := 'TypeNo';
14563 aType := FOwner.at2ut(FOwner.FindBaseType(btU32));
14564 end;
14565 P.RegProc.Decl.Result := IntoType;
14566 P.RegProc.ImportDecl := 'class:+';
14567 FCastProc := ProcNo;
14568 Result := True;
14569 end;
14570
14571
ClassFunc_Callnull14572 function TPSCompileTimeClass.ClassFunc_Call(Index: IPointer;
14573 var ProcNo: Cardinal): Boolean;
14574 var
14575 C: TPSDelphiClassItemConstructor;
14576 P: TPSExternalProcedure;
14577 s: tbtString;
14578 i: Longint;
14579
14580 begin
14581 if FIsAbstract then
14582 FOwner.MakeWarning('', ewAbstractClass, '');
14583 C := Pointer(Index);
14584 if c.MethodNo = InvalidVal then
14585 begin
14586 ProcNo := FOwner.AddUsedFunction2(P);
rocHDRnull14587 P.RegProc := FOwner.AddFunction(ProcHDR);
14588 P.RegProc.Name := '';
14589 P.RegProc.Decl.Assign(c.Decl);
14590 s := 'class:' + C.Owner.FClassName + '|' + C.Name + '|'+ chr(0);
14591 if c.Decl.Result = nil then
14592 s := s + #0
14593 else
14594 s := s + #1;
14595 for i := 0 to C.Decl.ParamCount -1 do
14596 begin
14597 if c.Decl.Params[i].Mode <> pmIn then
14598 s := s + #1
14599 else
14600 s := s + #0;
14601 end;
14602 P.RegProc.ImportDecl := s;
14603 C.MethodNo := ProcNo;
14604 end else begin
14605 ProcNo := c.MethodNo;
14606 end;
14607 Result := True;
14608 end;
14609
TPSCompileTimeClass.ClassFunc_Findnull14610 function TPSCompileTimeClass.ClassFunc_Find(const Name: tbtString;
14611 var Index: IPointer): Boolean;
14612 var
14613 H: Longint;
14614 I: Longint;
14615 CurrClass: TPSCompileTimeClass;
14616 C: TPSDelphiClassItem;
14617 begin
14618 H := MakeHash(Name);
14619 CurrClass := Self;
14620 while CurrClass <> nil do
14621 begin
14622 for i := CurrClass.FClassItems.Count -1 downto 0 do
14623 begin
14624 C := CurrClass.FClassItems[I];
14625 if (c is TPSDelphiClassItemConstructor) and (C.NameHash = H) and (C.Name = Name) then
14626 begin
14627 Index := IPointer(C);
14628 Result := True;
14629 exit;
14630 end;
14631 end;
14632 CurrClass := CurrClass.FInheritsFrom;
14633 end;
14634 Result := False;
14635 end;
14636
14637
TPSCompileTimeClass.CreateCnull14638 class function TPSCompileTimeClass.CreateC(FClass: TClass; aOwner: TPSPascalCompiler; aType: TPSType): TPSCompileTimeClass;
14639 begin
14640 Result := TPSCompileTimeClass.Create(FastUpperCase(tbtstring(FClass.ClassName)), aOwner, aType);
14641 Result.FClass := FClass;
14642 end;
14643
14644 constructor TPSCompileTimeClass.Create(ClassName: tbtString; aOwner: TPSPascalCompiler; aType: TPSType);
14645 begin
14646 inherited Create;
14647 FType := aType;
14648 FCastProc := InvalidVal;
14649 FNilProc := InvalidVal;
14650
14651 FDefaultProperty := InvalidVal;
14652 FClassName := Classname;
14653 FClassNameHash := MakeHash(FClassName);
14654 FClassItems := TPSList.Create;
14655 FOwner := aOwner;
14656 end;
14657
14658 destructor TPSCompileTimeClass.Destroy;
14659 var
14660 I: Longint;
14661 begin
14662 for i := FClassItems.Count -1 downto 0 do
14663 TPSDelphiClassItem(FClassItems[I]).Free;
14664 FClassItems.Free;
14665 inherited Destroy;
14666 end;
14667
14668
TPSCompileTimeClass.Func_Callnull14669 function TPSCompileTimeClass.Func_Call(Index: TPSDelphiClassItem;
14670 var ProcNo: Cardinal): Boolean;
14671 var
14672 C: TPSDelphiClassItemMethod;
14673 P: TPSExternalProcedure;
14674 i: Longint;
14675 s: tbtString;
14676
14677 begin
14678 C := Index as TPSDelphiClassItemMethod;
14679 if c.MethodNo = InvalidVal then
14680 begin
14681 ProcNo := FOwner.AddUsedFunction2(P);
rocHDRnull14682 P.RegProc := FOwner.AddFunction(ProcHDR);
14683 P.RegProc.Name := '';
14684 p.RegProc.Decl.Assign(c.Decl);
14685 s := 'class:' + C.Owner.FClassName + '|' + C.Name + '|'+ chr(0);
14686 if c.Decl.Result = nil then
14687 s := s + #0
14688 else
14689 s := s + #1;
14690 for i := 0 to c.Decl.ParamCount -1 do
14691 begin
14692 if c.Decl.Params[i].Mode <> pmIn then
14693 s := s + #1
14694 else
14695 s := s + #0;
14696 end;
14697 P.RegProc.ImportDecl := s;
14698 C.MethodNo := ProcNo;
14699 end else begin
14700 ProcNo := c.MethodNo;
14701 end;
14702 Result := True;
14703 end;
14704
TPSCompileTimeClass.Func_Findnull14705 function TPSCompileTimeClass.Func_Find(const Name: tbtString;
14706 var Index: TPSDelphiClassItem): Boolean;
14707 var
14708 H: Longint;
14709 I: Longint;
14710 CurrClass: TPSCompileTimeClass;
14711 C: TPSDelphiClassItem;
14712 begin
14713 H := MakeHash(Name);
14714 CurrClass := Self;
14715 while CurrClass <> nil do
14716 begin
14717 for i := CurrClass.FClassItems.Count -1 downto 0 do
14718 begin
14719 C := CurrClass.FClassItems[I];
14720 if (c is TPSDelphiClassItemMethod) and (C.NameHash = H) and (C.Name = Name) then
14721 begin
14722 Index := C;
14723 Result := True;
14724 exit;
14725 end;
14726 end;
14727 CurrClass := CurrClass.FInheritsFrom;
14728 end;
14729 Result := False;
14730 end;
14731
TPSCompileTimeClass.GetCountnull14732 function TPSCompileTimeClass.GetCount: Longint;
14733 begin
14734 Result := FClassItems.Count;
14735 end;
14736
GetItemnull14737 function TPSCompileTimeClass.GetItem(i: Longint): TPSDelphiClassItem;
14738 begin
14739 Result := FClassItems[i];
14740 end;
14741
TPSCompileTimeClass.IsCompatibleWithnull14742 function TPSCompileTimeClass.IsCompatibleWith(aType: TPSType): Boolean;
14743 var
14744 Temp: TPSCompileTimeClass;
14745 begin
14746 if (atype.BaseType <> btClass) then
14747 begin
14748 Result := False;
14749 exit;
14750 end;
14751 temp := TPSClassType(aType).Cl;
14752 while Temp <> nil do
14753 begin
14754 if Temp = Self then
14755 begin
14756 Result := True;
14757 exit;
14758 end;
14759 Temp := Temp.FInheritsFrom;
14760 end;
14761 Result := False;
14762 end;
14763
TPSCompileTimeClass.Property_Findnull14764 function TPSCompileTimeClass.Property_Find(const Name: tbtString;
14765 var Index: TPSDelphiClassItem): Boolean;
14766 var
14767 H: Longint;
14768 I: Longint;
14769 CurrClass: TPSCompileTimeClass;
14770 C: TPSDelphiClassItem;
14771 begin
14772 if Name = '' then
14773 begin
14774 CurrClass := Self;
14775 while CurrClass <> nil do
14776 begin
14777 if CurrClass.FDefaultProperty <> InvalidVal then
14778 begin
14779 Index := TPSDelphiClassItem(CurrClass.FClassItems[Currclass.FDefaultProperty]);
14780 result := True;
14781 exit;
14782 end;
14783 CurrClass := CurrClass.FInheritsFrom;
14784 end;
14785 Result := False;
14786 exit;
14787 end;
14788 H := MakeHash(Name);
14789 CurrClass := Self;
14790 while CurrClass <> nil do
14791 begin
14792 for i := CurrClass.FClassItems.Count -1 downto 0 do
14793 begin
14794 C := CurrClass.FClassItems[I];
14795 if (c is TPSDelphiClassItemProperty) and (C.NameHash = H) and (C.Name = Name) then
14796 begin
14797 Index := C;
14798 Result := True;
14799 exit;
14800 end;
14801 end;
14802 CurrClass := CurrClass.FInheritsFrom;
14803 end;
14804 Result := False;
14805 end;
14806
Property_Getnull14807 function TPSCompileTimeClass.Property_Get(Index: TPSDelphiClassItem;
14808 var ProcNo: Cardinal): Boolean;
14809 var
14810 C: TPSDelphiClassItemProperty;
14811 P: TPSExternalProcedure;
14812 s: tbtString;
14813
14814 begin
14815 C := Index as TPSDelphiClassItemProperty;
14816 if c.AccessType = iptW then
14817 begin
14818 Result := False;
14819 exit;
14820 end;
14821 if c.ReadProcNo = InvalidVal then
14822 begin
14823 ProcNo := FOwner.AddUsedFunction2(P);
rocHDRnull14824 P.RegProc := FOwner.AddFunction(ProcHDR);
14825 P.RegProc.Name := '';
14826 P.RegProc.Decl.Result := C.Decl.Result;
14827 s := 'class:' + C.Owner.FClassName + '|' + C.Name + '|'+#0#0#0#0;
14828 Longint((@(s[length(s)-3]))^) := c.Decl.ParamCount +1;
14829 P.RegProc.ImportDecl := s;
14830 C.ReadProcNo := ProcNo;
14831 end else begin
14832 ProcNo := c.ReadProcNo;
14833 end;
14834 Result := True;
14835 end;
14836
Property_GetHeadernull14837 function TPSCompileTimeClass.Property_GetHeader(Index: TPSDelphiClassItem;
14838 Dest: TPSParametersDecl): Boolean;
14839 var
14840 c: TPSDelphiClassItemProperty;
14841 begin
14842 C := Index as TPSDelphiClassItemProperty;
14843 FOwner.UseProc(c.Decl);
14844 Dest.Assign(c.Decl);
14845 Result := True;
14846 end;
14847
Property_Setnull14848 function TPSCompileTimeClass.Property_Set(Index: TPSDelphiClassItem;
14849 var ProcNo: Cardinal): Boolean;
14850 var
14851 C: TPSDelphiClassItemProperty;
14852 P: TPSExternalProcedure;
14853 s: tbtString;
14854
14855 begin
14856 C := Index as TPSDelphiClassItemProperty;
14857 if c.AccessType = iptR then
14858 begin
14859 Result := False;
14860 exit;
14861 end;
14862 if c.WriteProcNo = InvalidVal then
14863 begin
14864 ProcNo := FOwner.AddUsedFunction2(P);
rocHDRnull14865 P.RegProc := FOwner.AddFunction(ProcHDR);
14866 P.RegProc.Name := '';
14867 s := 'class:' + C.Owner.FClassName + '|' + C.Name + '@|'#0#0#0#0;
14868 Longint((@(s[length(s)-3]))^) := C.Decl.ParamCount+1;
14869 P.RegProc.ImportDecl := s;
14870 C.WriteProcNo := ProcNo;
14871 end else begin
14872 ProcNo := c.WriteProcNo;
14873 end;
14874 Result := True;
14875 end;
14876
TPSCompileTimeClass.RegisterMethodnull14877 function TPSCompileTimeClass.RegisterMethod(const Decl: tbtString): Boolean;
14878 var
14879 DOrgName: tbtString;
14880 DDecl: TPSParametersDecl;
14881 FT: TPMFuncType;
14882 p: TPSDelphiClassItemMethod;
14883 begin
14884 DDecl := TPSParametersDecl.Create;
14885 try
14886 if not ParseMethod(FOwner, FClassName, Decl, DOrgName, DDecl, FT) then
14887 begin
14888 Result := False;
14889 {$IFDEF DEBUG} raise EPSCompilerException.CreateFmt(RPS_UnableToRegister, [Decl]); {$ENDIF}
14890 exit;
14891 end;
14892 if ft = mftConstructor then
14893 p := TPSDelphiClassItemConstructor.Create(Self)
14894 else
14895 p := TPSDelphiClassItemMethod.Create(self);
14896 p.OrgName := DOrgName;
14897 p.Decl.Assign(DDecl);
14898 p.MethodNo := InvalidVal;
14899 FClassItems.Add(p);
14900 Result := True;
14901 finally
14902 DDecl.Free;
14903 end;
14904 end;
14905
14906 procedure TPSCompileTimeClass.RegisterProperty(const PropertyName,
14907 PropertyType: tbtString; PropAC: TPSPropType);
14908 var
14909 FType: TPSType;
14910 Param: TPSParameterDecl;
14911 p: TPSDelphiClassItemProperty;
14912 PT: tbtString;
14913 begin
14914 pt := PropertyType;
14915 p := TPSDelphiClassItemProperty.Create(Self);
14916 p.AccessType := PropAC;
14917 p.ReadProcNo := InvalidVal;
14918 p.WriteProcNo := InvalidVal;
14919 p.OrgName := PropertyName;
14920 repeat
14921 FType := FOwner.FindType(FastUpperCase(grfw(pt)));
14922 if FType = nil then
14923 begin
14924 p.Free;
14925 Exit;
14926 end;
14927 if p.Decl.Result = nil then p.Decl.Result := FType else
14928 begin
14929 param := p.Decl.AddParam;
14930 Param.OrgName := 'param'+IntToStr(p.Decl.ParamCount);
14931 Param.aType := FType;
14932 end;
14933 until pt = '';
14934 FClassItems.Add(p);
14935 end;
14936
14937
14938 procedure TPSCompileTimeClass.RegisterPublishedProperties;
14939 var
14940 p: PPropList;
14941 i, Count: Longint;
14942 a: TPSPropType;
14943 begin
14944 if (Fclass = nil) or (Fclass.ClassInfo = nil) then exit;
14945 Count := GetTypeData(fclass.ClassInfo)^.PropCount;
14946 GetMem(p, Count * SizeOf(Pointer));
14947 GetPropInfos(fclass.ClassInfo, p);
14948 for i := Count -1 downto 0 do
14949 begin
14950 if p^[i]^.PropType^.Kind in [tkLString, tkInteger, tkChar, tkEnumeration, tkFloat, tkString, tkSet, tkClass, tkMethod{$IFNDEF PS_NOWIDESTRING}, tkWString{$ENDIF}{$IFDEF DELPHI2009UP}, tkUString{$ENDIF}] then
14951 begin
14952 if (p^[i]^.GetProc <> nil) then
14953 begin
14954 if p^[i]^.SetProc = nil then
14955 a := iptr
14956 else
14957 a := iptrw;
14958 end else
14959 begin
14960 a := iptW;
14961 if p^[i]^.SetProc = nil then continue;
14962 end;
14963 RegisterProperty(p^[i]^.Name, p^[i]^.PropType^.Name, a);
14964 end;
14965 end;
14966 FreeMem(p);
14967 end;
14968
TPSCompileTimeClass.RegisterPublishedPropertynull14969 function TPSCompileTimeClass.RegisterPublishedProperty(const Name: tbtString): Boolean;
14970 var
14971 p: PPropInfo;
14972 a: TPSPropType;
14973 begin
14974 if (Fclass = nil) or (Fclass.ClassInfo = nil) then begin Result := False; exit; end;
14975 p := GetPropInfo(fclass.ClassInfo, string(Name));
14976 if p = nil then begin Result := False; exit; end;
14977 if (p^.GetProc <> nil) then
14978 begin
14979 if p^.SetProc = nil then
14980 a := iptr
14981 else
14982 a := iptrw;
14983 end else
14984 begin
14985 a := iptW;
14986 if p^.SetProc = nil then begin result := False; exit; end;
14987 end;
14988 RegisterProperty(p^.Name, p^.PropType^.Name, a);
14989 Result := True;
14990 end;
14991
14992
14993 procedure TPSCompileTimeClass.SetDefaultPropery(const Name: tbtString);
14994 var
14995 i,h: Longint;
14996 p: TPSDelphiClassItem;
14997 s: tbtString;
14998
14999 begin
15000 s := FastUppercase(name);
15001 h := MakeHash(s);
15002 for i := FClassItems.Count -1 downto 0 do
15003 begin
15004 p := FClassItems[i];
15005 if (p.NameHash = h) and (p.Name = s) then
15006 begin
15007 if p is TPSDelphiClassItemProperty then
15008 begin
15009 if p.Decl.ParamCount = 0 then
15010 raise EPSCompilerException.CreateFmt(RPS_NotArrayProperty, [Name]);
15011 FDefaultProperty := I;
15012 exit;
15013 end else raise EPSCompilerException.CreateFmt(RPS_NotProperty, [Name]);
15014 end;
15015 end;
15016 raise EPSCompilerException.CreateFmt(RPS_UnknownProperty, [Name]);
15017 end;
15018
SetNilnull15019 function TPSCompileTimeClass.SetNil(var ProcNo: Cardinal): Boolean;
15020 var
15021 P: TPSExternalProcedure;
15022
15023 begin
15024 if FNilProc <> InvalidVal then
15025 begin
15026 Procno := FNilProc;
15027 Result := True;
15028 exit;
15029 end;
15030 ProcNo := FOwner.AddUsedFunction2(P);
rocHDRnull15031 P.RegProc := FOwner.AddFunction(ProcHDR);
15032 P.RegProc.Name := '';
15033 with P.RegProc.Decl.AddParam do
15034 begin
15035 OrgName := 'VarNo';
15036 aType := FOwner.at2ut(FType);
15037 end;
15038 P.RegProc.ImportDecl := 'class:-';
15039 FNilProc := Procno;
15040 Result := True;
15041 end;
15042
15043 { TPSSetType }
15044
GetBitSizenull15045 function TPSSetType.GetBitSize: Longint;
15046 begin
15047 case SetType.BaseType of
15048 btEnum: begin Result := TPSEnumType(setType).HighValue+1; end;
15049 btChar, btU8: Result := 256;
15050 else
15051 Result := 0;
15052 end;
15053 end;
15054
TPSSetType.GetByteSizenull15055 function TPSSetType.GetByteSize: Longint;
15056 var
15057 r: Longint;
15058 begin
15059 r := BitSize;
15060 if r mod 8 <> 0 then inc(r, 7);
15061 Result := r div 8;
15062 end;
15063
15064
15065 { TPSBlockInfo }
15066
15067 procedure TPSBlockInfo.Clear;
15068 var
15069 i: Longint;
15070 begin
15071 for i := WithList.Count -1 downto 0 do
15072 begin
15073 TPSValue(WithList[i]).Free;
15074 WithList.Delete(i);
15075 end;
15076 end;
15077
15078 constructor TPSBlockInfo.Create(Owner: TPSBlockInfo);
15079 begin
15080 inherited Create;
15081 FOwner := Owner;
15082 FWithList := TPSList.Create;
15083 if FOwner <> nil then
15084 begin
15085 FProcNo := FOwner.ProcNo;
15086 FProc := FOwner.Proc;
15087 end;
15088 end;
15089
15090 destructor TPSBlockInfo.Destroy;
15091 begin
15092 Clear;
15093 FWithList.Free;
15094 inherited Destroy;
15095 end;
15096
15097 { TPSAttributeTypeField }
15098 procedure TPSAttributeTypeField.SetFieldOrgName(const Value: tbtString);
15099 begin
15100 FFieldOrgName := Value;
15101 FFieldName := FastUpperCase(Value);
15102 FFieldNameHash := MakeHash(FFieldName);
15103 end;
15104
15105 constructor TPSAttributeTypeField.Create(AOwner: TPSAttributeType);
15106 begin
15107 inherited Create;
15108 FOwner := AOwner;
15109 end;
15110
15111 { TPSAttributeType }
15112
GetFieldnull15113 function TPSAttributeType.GetField(I: Longint): TPSAttributeTypeField;
15114 begin
15115 Result := TPSAttributeTypeField(FFields[i]);
15116 end;
15117
TPSAttributeType.GetFieldCountnull15118 function TPSAttributeType.GetFieldCount: Longint;
15119 begin
15120 Result := FFields.Count;
15121 end;
15122
15123 procedure TPSAttributeType.SetName(const s: tbtString);
15124 begin
15125 FOrgname := s;
15126 FName := FastUppercase(s);
15127 FNameHash := MakeHash(FName);
15128 end;
15129
15130 constructor TPSAttributeType.Create;
15131 begin
15132 inherited Create;
15133 FFields := TPSList.Create;
15134 end;
15135
15136 destructor TPSAttributeType.Destroy;
15137 var
15138 i: Longint;
15139 begin
15140 for i := FFields.Count -1 downto 0 do
15141 begin
15142 TPSAttributeTypeField(FFields[i]).Free;
15143 end;
15144 FFields.Free;
15145 inherited Destroy;
15146 end;
15147
AddFieldnull15148 function TPSAttributeType.AddField: TPSAttributeTypeField;
15149 begin
15150 Result := TPSAttributeTypeField.Create(self);
15151 FFields.Add(Result);
15152 end;
15153
15154 procedure TPSAttributeType.DeleteField(I: Longint);
15155 var
15156 Fld: TPSAttributeTypeField;
15157 begin
15158 Fld := FFields[i];
15159 FFields.Delete(i);
15160 Fld.Free;
15161 end;
15162
15163 { TPSAttribute }
TPSAttribute.GetValueCountnull15164 function TPSAttribute.GetValueCount: Longint;
15165 begin
15166 Result := FValues.Count;
15167 end;
15168
TPSAttribute.GetValuenull15169 function TPSAttribute.GetValue(I: Longint): PIfRVariant;
15170 begin
15171 Result := FValues[i];
15172 end;
15173
15174 constructor TPSAttribute.Create(AttribType: TPSAttributeType);
15175 begin
15176 inherited Create;
15177 FValues := TPSList.Create;
15178 FAttribType := AttribType;
15179 end;
15180
15181 procedure TPSAttribute.DeleteValue(i: Longint);
15182 var
15183 Val: PIfRVariant;
15184 begin
15185 Val := FValues[i];
15186 FValues.Delete(i);
15187 DisposeVariant(Val);
15188 end;
15189
AddValuenull15190 function TPSAttribute.AddValue(v: PIFRVariant): Longint;
15191 begin
15192 Result := FValues.Add(v);
15193 end;
15194
15195
15196 destructor TPSAttribute.Destroy;
15197 var
15198 i: Longint;
15199 begin
15200 for i := FValues.Count -1 downto 0 do
15201 begin
15202 DisposeVariant(FValues[i]);
15203 end;
15204 FValues.Free;
15205 inherited Destroy;
15206 end;
15207
15208
15209 procedure TPSAttribute.Assign(Item: TPSAttribute);
15210 var
15211 i: Longint;
15212 p: PIfRVariant;
15213 begin
15214 for i := FValues.Count -1 downto 0 do
15215 begin
15216 DisposeVariant(FValues[i]);
15217 end;
15218 FValues.Clear;
15219 FAttribType := Item.FAttribType;
15220 for i := 0 to Item.FValues.Count -1 do
15221 begin
15222 p := DuplicateVariant(Item.FValues[i]);
15223 FValues.Add(p);
15224 end;
15225 end;
15226
15227 { TPSAttributes }
15228
TPSAttributes.GetCountnull15229 function TPSAttributes.GetCount: Longint;
15230 begin
15231 Result := FItems.Count;
15232 end;
15233
GetItemnull15234 function TPSAttributes.GetItem(I: Longint): TPSAttribute;
15235 begin
15236 Result := TPSAttribute(FItems[i]);
15237 end;
15238
15239 procedure TPSAttributes.Delete(i: Longint);
15240 var
15241 item: TPSAttribute;
15242 begin
15243 item := TPSAttribute(FItems[i]);
15244 FItems.Delete(i);
15245 Item.Free;
15246 end;
15247
Addnull15248 function TPSAttributes.Add(AttribType: TPSAttributeType): TPSAttribute;
15249 begin
15250 Result := TPSAttribute.Create(AttribType);
15251 FItems.Add(Result);
15252 end;
15253
15254 constructor TPSAttributes.Create;
15255 begin
15256 inherited Create;
15257 FItems := TPSList.Create;
15258 end;
15259
15260 destructor TPSAttributes.Destroy;
15261 var
15262 i: Longint;
15263 begin
15264 for i := FItems.Count -1 downto 0 do
15265 begin
15266 TPSAttribute(FItems[i]).Free;
15267 end;
15268 FItems.Free;
15269 inherited Destroy;
15270 end;
15271
15272 procedure TPSAttributes.Assign(attr: TPSAttributes; Move: Boolean);
15273 var
15274 newitem, item: TPSAttribute;
15275 i: Longint;
15276 begin
15277 for i := ATtr.FItems.Count -1 downto 0 do
15278 begin
15279 Item := Attr.Fitems[i];
15280 if Move then
15281 begin
15282 FItems.Add(Item);
15283 Attr.FItems.Delete(i);
15284 end else
15285 begin
15286 newitem := TPSAttribute.Create(Item.FAttribType );
15287 newitem.Assign(item);
15288 FItems.Add(NewItem);
15289 end;
15290 end;
15291
15292 end;
15293
15294
TPSAttributes.FindAttributenull15295 function TPSAttributes.FindAttribute(
15296 const Name: tbtString): TPSAttribute;
15297 var
15298 h, i: Longint;
15299
15300 begin
15301 h := MakeHash(name);
15302 for i := FItems.Count -1 downto 0 do
15303 begin
15304 Result := FItems[i];
15305 if (Result.FAttribType.NameHash = h) and (Result.FAttribType.Name = Name) then
15306 exit;
15307 end;
15308 result := nil;
15309 end;
15310
15311 { TPSParameterDecl }
15312 procedure TPSParameterDecl.SetName(const s: tbtString);
15313 begin
15314 FOrgName := s;
15315 FName := FastUppercase(s);
15316 end;
15317
15318
15319 { TPSParametersDecl }
15320
15321 procedure TPSParametersDecl.Assign(Params: TPSParametersDecl);
15322 var
15323 i: Longint;
15324 np, orgp: TPSParameterDecl;
15325 begin
15326 for i := FParams.Count -1 downto 0 do
15327 begin
15328 TPSParameterDecl(Fparams[i]).Free;
15329 end;
15330 FParams.Clear;
15331 FResult := Params.Result;
15332
15333 for i := 0 to Params.FParams.count -1 do
15334 begin
15335 orgp := Params.FParams[i];
15336 np := AddParam;
15337 np.OrgName := orgp.OrgName;
15338 np.Mode := orgp.Mode;
15339 np.aType := orgp.aType;
15340 np.DeclarePos:=orgp.DeclarePos;
15341 np.DeclareRow:=orgp.DeclareRow;
15342 np.DeclareCol:=orgp.DeclareCol;
15343 end;
15344 end;
15345
15346
GetParamnull15347 function TPSParametersDecl.GetParam(I: Longint): TPSParameterDecl;
15348 begin
15349 Result := FParams[i];
15350 end;
15351
TPSParametersDecl.GetParamCountnull15352 function TPSParametersDecl.GetParamCount: Longint;
15353 begin
15354 Result := FParams.Count;
15355 end;
15356
TPSParametersDecl.AddParamnull15357 function TPSParametersDecl.AddParam: TPSParameterDecl;
15358 begin
15359 Result := TPSParameterDecl.Create;
15360 FParams.Add(Result);
15361 end;
15362
15363 procedure TPSParametersDecl.DeleteParam(I: Longint);
15364 var
15365 param: TPSParameterDecl;
15366 begin
15367 param := FParams[i];
15368 FParams.Delete(i);
15369 Param.Free;
15370 end;
15371
15372 constructor TPSParametersDecl.Create;
15373 begin
15374 inherited Create;
15375 FParams := TPSList.Create;
15376 end;
15377
15378 destructor TPSParametersDecl.Destroy;
15379 var
15380 i: Longint;
15381 begin
15382 for i := FParams.Count -1 downto 0 do
15383 begin
15384 TPSParameterDecl(Fparams[i]).Free;
15385 end;
15386 FParams.Free;
15387 inherited Destroy;
15388 end;
15389
Samenull15390 function TPSParametersDecl.Same(d: TPSParametersDecl): boolean;
15391 var
15392 i: Longint;
15393 begin
15394 if (d = nil) or (d.ParamCount <> ParamCount) or (d.Result <> Self.Result) then
15395 Result := False
15396 else begin
15397 for i := 0 to d.ParamCount -1 do
15398 begin
15399 if (d.Params[i].Mode <> Params[i].Mode) or (d.Params[i].aType <> Params[i].aType) then
15400 begin
15401 Result := False;
15402 exit;
15403 end;
15404 end;
15405 Result := True;
15406 end;
15407 end;
15408
15409 { TPSProceduralType }
15410
15411 constructor TPSProceduralType.Create;
15412 begin
15413 inherited Create;
15414 FProcDef := TPSParametersDecl.Create;
15415
15416 end;
15417
15418 destructor TPSProceduralType.Destroy;
15419 begin
15420 FProcDef.Free;
15421 inherited Destroy;
15422 end;
15423
15424 { TPSDelphiClassItem }
15425
15426 procedure TPSDelphiClassItem.SetName(const s: tbtString);
15427 begin
15428 FOrgName := s;
15429 FName := FastUpperCase(s);
15430 FNameHash := MakeHash(FName);
15431 end;
15432
15433 constructor TPSDelphiClassItem.Create(Owner: TPSCompileTimeClass);
15434 begin
15435 inherited Create;
15436 FOwner := Owner;
15437 FDecl := TPSParametersDecl.Create;
15438 end;
15439
15440 destructor TPSDelphiClassItem.Destroy;
15441 begin
15442 FDecl.Free;
15443 inherited Destroy;
15444 end;
15445
15446 {$IFNDEF PS_NOINTERFACES}
15447 { TPSInterface }
15448
TPSInterface.CastToTypenull15449 function TPSInterface.CastToType(IntoType: TPSType;
15450 var ProcNo: Cardinal): Boolean;
15451 var
15452 P: TPSExternalProcedure;
15453 begin
15454 if (IntoType <> nil) and (IntoType.BaseType <> btInterface) then
15455 begin
15456 Result := False;
15457 exit;
15458 end;
15459 if FCastProc <> InvalidVal then
15460 begin
15461 ProcNo := FCastProc;
15462 Result := True;
15463 exit;
15464 end;
15465 ProcNo := FOwner.AddUsedFunction2(P);
rocHDRnull15466 P.RegProc := FOwner.AddFunction(ProcHDR);
15467 P.RegProc.Name := '';
15468 with P.RegProc.Decl.AddParam do
15469 begin
15470 OrgName := 'Org';
15471 aType := Self.FType;
15472 end;
15473 with P.RegProc.Decl.AddParam do
15474 begin
15475 OrgName := 'TypeNo';
15476 aType := FOwner.at2ut(FOwner.FindBaseType(btU32));
15477 end;
15478 P.RegProc.Decl.Result := FOwner.at2ut(IntoType);
15479
15480 P.RegProc.ImportDecl := 'class:+';
15481 FCastProc := ProcNo;
15482 Result := True;
15483 end;
15484
15485 constructor TPSInterface.Create(Owner: TPSPascalCompiler; InheritedFrom: TPSInterface; Guid: TGuid; const Name: tbtString; aType: TPSType);
15486 begin
15487 inherited Create;
15488 FCastProc := InvalidVal;
15489 FNilProc := InvalidVal;
15490
15491 FType := aType;
15492 FOWner := Owner;
15493 FGuid := GUID;
15494 Self.InheritedFrom := InheritedFrom;
15495
15496 FItems := TPSList.Create;
15497 FName := Name;
15498 FNameHash := MakeHash(Name);
15499 end;
15500
15501 procedure TPSInterface.SetInheritedFrom(p: TPSInterface);
15502 begin
15503 FInheritedFrom := p;
15504 end;
15505
15506 destructor TPSInterface.Destroy;
15507 var
15508 i: Longint;
15509 begin
15510 for i := FItems.Count -1 downto 0 do
15511 begin
15512 TPSInterfaceMethod(FItems[i]).Free;
15513 end;
15514 FItems.Free;
15515 inherited Destroy;
15516 end;
15517
TPSInterface.Func_Callnull15518 function TPSInterface.Func_Call(Index: TPSInterfaceMethod;
15519 var ProcNo: Cardinal): Boolean;
15520 var
15521 c: TPSInterfaceMethod;
15522 P: TPSExternalProcedure;
15523 s: tbtString;
15524 i: Longint;
15525 begin
15526 c := TPSInterfaceMethod(Index);
15527 if c.FScriptProcNo <> InvalidVal then
15528 begin
15529 Procno := c.FScriptProcNo;
15530 Result := True;
15531 exit;
15532 end;
15533 ProcNo := FOwner.AddUsedFunction2(P);
rocHDRnull15534 P.RegProc := FOwner.AddFunction(ProcHDR);
15535 P.RegProc.Name := '';
15536 FOwner.UseProc(C.Decl);
15537 P.RegProc.Decl.Assign(c.Decl);
15538 s := tbtstring('intf:.') + PS_mi2s(c.AbsoluteProcOffset) + tbtchar(ord(c.CC));
15539 if c.Decl.Result = nil then
15540 s := s + #0
15541 else
15542 s := s + #1;
15543 for i := 0 to C.Decl.ParamCount -1 do
15544 begin
15545 if c.Decl.Params[i].Mode <> pmIn then
15546 s := s + #1
15547 else
15548 s := s + #0;
15549 end;
15550 P.RegProc.ImportDecl := s;
15551 C.FScriptProcNo := ProcNo;
15552 Result := True;
15553 end;
15554
TPSInterface.Func_Findnull15555 function TPSInterface.Func_Find(const Name: tbtString;
15556 var Index: TPSInterfaceMethod): Boolean;
15557 var
15558 H: Longint;
15559 I: Longint;
15560 CurrClass: TPSInterface;
15561 C: TPSInterfaceMethod;
15562 begin
15563 H := MakeHash(Name);
15564 CurrClass := Self;
15565 while CurrClass <> nil do
15566 begin
15567 for i := CurrClass.FItems.Count -1 downto 0 do
15568 begin
15569 C := CurrClass.FItems[I];
15570 if (C.NameHash = H) and (C.Name = Name) then
15571 begin
15572 Index := c;
15573 Result := True;
15574 exit;
15575 end;
15576 end;
15577 CurrClass := CurrClass.FInheritedFrom;
15578 end;
15579 Result := False;
15580 end;
15581
TPSInterface.IsCompatibleWithnull15582 function TPSInterface.IsCompatibleWith(aType: TPSType): Boolean;
15583 var
15584 Temp: TPSInterface;
15585 begin
15586 if (atype.BaseType = btClass) then // just support it, we'll see what happens
15587 begin
15588 Result := true;
15589 exit;
15590 end;
15591 if atype.BaseType <> btInterface then
15592 begin
15593 Result := False;
15594 exit;
15595 end;
15596 temp := TPSInterfaceType(atype).FIntf;
15597 while Temp <> nil do
15598 begin
15599 if Temp = Self then
15600 begin
15601 Result := True;
15602 exit;
15603 end;
15604 Temp := Temp.FInheritedFrom;
15605 end;
15606 Result := False;
15607 end;
15608
15609 procedure TPSInterface.RegisterDummyMethod;
15610 begin
15611 FItems.Add(TPSInterfaceMethod.Create(self));
15612 end;
15613
RegisterMethodnull15614 function TPSInterface.RegisterMethod(const Declaration: tbtString;
15615 const cc: TPSCallingConvention): Boolean;
15616 begin
15617 Result := RegisterMethodEx(Declaration, cc, nil);
15618 end;
15619
RegisterMethodExnull15620 function TPSInterface.RegisterMethodEx(const Declaration: tbtString;
15621 const cc: TPSCallingConvention; const CustomParser: TPSPascalParser): Boolean;
15622 var
15623 M: TPSInterfaceMethod;
15624 DOrgName: tbtString;
15625 Func: TPMFuncType;
15626 begin
15627 M := TPSInterfaceMethod.Create(Self);
15628 if not ParseMethodEx(FOwner, '', Declaration, DOrgname, m.Decl, Func, CustomParser) then
15629 begin
15630 FItems.Add(m); // in any case, add a dummy item
15631 Result := False;
15632 exit;
15633 end;
15634 m.FName := FastUppercase(DOrgName);
15635 m.FOrgName := DOrgName;
15636 m.FNameHash := MakeHash(m.FName);
15637 m.FCC := CC;
15638 m.FScriptProcNo := InvalidVal;
15639 FItems.Add(M);
15640 Result := True;
15641 end;
15642
15643
SetNilnull15644 function TPSInterface.SetNil(var ProcNo: Cardinal): Boolean;
15645 var
15646 P: TPSExternalProcedure;
15647
15648 begin
15649 if FNilProc <> InvalidVal then
15650 begin
15651 Procno := FNilProc;
15652 Result := True;
15653 exit;
15654 end;
15655 ProcNo := FOwner.AddUsedFunction2(P);
15656 P.RegProc := FOwner.AddFunction(ProcHDR);
15657 P.RegProc.Name := '';
15658 with p.RegProc.Decl.AddParam do
15659 begin
15660 Mode := pmInOut;
15661 OrgName := 'VarNo';
15662 aType := FOwner.at2ut(Self.FType);
15663 end;
15664 P.RegProc.ImportDecl := 'class:-';
15665 FNilProc := Procno;
15666 Result := True;
15667 end;
15668
15669 { TPSInterfaceMethod }
15670
15671 constructor TPSInterfaceMethod.Create(Owner: TPSInterface);
15672 begin
15673 inherited Create;
15674 FDecl := TPSParametersDecl.Create;
15675 FOwner := Owner;
15676 FOffsetCache := InvalidVal;
15677 end;
15678
GetAbsoluteProcOffsetnull15679 function TPSInterfaceMethod.GetAbsoluteProcOffset: Cardinal;
15680 var
15681 ps: TPSInterface;
15682 begin
15683 if FOffsetCache = InvalidVal then
15684 begin
15685 FOffsetCache := FOwner.FItems.IndexOf(Self);
15686 ps := FOwner.FInheritedFrom;
15687 while ps <> nil do
15688 begin
15689 FOffsetCache := FOffsetCache + ps.FItems.Count;
15690 ps := ps.FInheritedFrom;
15691 end;
15692 end;
15693 result := FOffsetCache;
15694 end;
15695
15696
15697 destructor TPSInterfaceMethod.Destroy;
15698 begin
15699 FDecl.Free;
15700 inherited Destroy;
15701 end;
15702 {$ENDIF}
15703
15704 { TPSVariantType }
15705
GetDynInvokeParamTypenull15706 function TPSVariantType.GetDynInvokeParamType(Owner: TPSPascalCompiler) : TPSType;
15707 begin
15708 Result := Owner.at2ut(FindAndAddType(owner, '!OPENARRAYOFVARIANT', 'array of Variant'));
15709 end;
15710
GetDynInvokeProcNonull15711 function TPSVariantType.GetDynInvokeProcNo(Owner: TPSPascalCompiler; const Name: tbtString;
15712 Params: TPSParameters): Cardinal;
15713 begin
15714 Result := Owner.FindProc('IdispatchInvoke');
15715 end;
15716
GetDynIvokeResulTypenull15717 function TPSVariantType.GetDynIvokeResulType(
15718 Owner: TPSPascalCompiler): TPSType;
15719 begin
15720 Result := Owner.FindType('VARIANT');
15721 end;
15722
GetDynIvokeSelfTypenull15723 function TPSVariantType.GetDynIvokeSelfType(Owner: TPSPascalCompiler): TPSType;
15724 begin
15725 Result := Owner.at2ut(Owner.FindType('IDISPATCH'));
15726 end;
15727
15728
15729 { TPSExternalClass }
SetNilnull15730 function TPSExternalClass.SetNil(var ProcNo: Cardinal): Boolean;
15731 begin
15732 Result := False;
15733 end;
15734
15735 constructor TPSExternalClass.Create(Se: TIFPSPascalCompiler; TypeNo: TPSType);
15736 begin
15737 inherited Create;
15738 Self.SE := se;
15739 Self.FTypeNo := TypeNo;
15740 end;
15741
Func_Callnull15742 function TPSExternalClass.Func_Call(Index: Cardinal;
15743 var ProcNo: Cardinal): Boolean;
15744 begin
15745 Result := False;
15746 end;
15747
Func_Findnull15748 function TPSExternalClass.Func_Find(const Name: tbtString;
15749 var Index: Cardinal): Boolean;
15750 begin
15751 Result := False;
15752 end;
15753
IsCompatibleWithnull15754 function TPSExternalClass.IsCompatibleWith(
15755 Cl: TPSExternalClass): Boolean;
15756 begin
15757 Result := False;
15758 end;
15759
SelfTypenull15760 function TPSExternalClass.SelfType: TPSType;
15761 begin
15762 Result := nil;
15763 end;
15764
CastToTypenull15765 function TPSExternalClass.CastToType(IntoType: TPSType;
15766 var ProcNo: Cardinal): Boolean;
15767 begin
15768 Result := False;
15769 end;
15770
CompareClassnull15771 function TPSExternalClass.CompareClass(OtherTypeNo: TPSType;
15772 var ProcNo: Cardinal): Boolean;
15773 begin
15774 Result := false;
15775 end;
15776
ClassFunc_Findnull15777 function TPSExternalClass.ClassFunc_Find(const Name: tbtString; var Index: Cardinal): Boolean;
15778 begin
15779 result := false;
15780 end;
15781
ClassFunc_Callnull15782 function TPSExternalClass.ClassFunc_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean;
15783 begin
15784 result := false;
15785 end;
15786
15787
15788 { TPSValueProcVal }
15789
15790 destructor TPSValueProcVal.Destroy;
15791 begin
15792 FProcNo.Free;
15793 inherited;
15794 end;
15795
15796
15797 {
15798
15799 Internal error counter: 00020 (increase and then use)
15800
15801 }
15802 end.
15803