-
Notifications
You must be signed in to change notification settings - Fork 3
Expand file tree
/
Copy pathParser.pas
More file actions
3352 lines (3298 loc) · 141 KB
/
Parser.pas
File metadata and controls
3352 lines (3298 loc) · 141 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
// Based on XD Pascal (2020) original code by Vasiliy Tereshkov
// Refactoring and extensions by Wanderlan
{$I-,H-}
unit Parser;
interface
uses
SysUtils, Common, Scanner, CodeGen, Linker;
function Compile(const Name: TString): Integer;
implementation
type
TParserState = record
IsUnit, IsInterfaceSection: Boolean;
UnitStatus: TUnitStatus;
end;
var
ParserState: TParserState;
procedure CompileConstExpression(var ConstVal: TConst; var ConstValType: Integer); forward;
function CompileDesignator(var ValType: Integer; AllowConst: Boolean = True): Boolean; forward;
procedure CompileExpression(var ValType: Integer); forward;
procedure CompileStatement(LoopNesting: Integer); forward;
procedure CompileType(var DataType: Integer); forward;
procedure DeclareIdent(const IdentName: TString; IdentKind: TIdentKind; TotalParamDataSize: Integer; IdentIsInCStack: Boolean; IdentDataType: Integer;
IdentPassMethod: TPassMethod; IdentOrdConstValue: Longint; IdentRealConstValue: Double; const IdentStrConstValue: TString;
const IdentSetConstValue: TByteSet; IdentPredefProc: TPredefProc; const IdentReceiverName: TString; IdentReceiverType: Integer);
var
i, AdditionalStackItems, IdentTypeSize: Integer;
IdentScope: TScope;
begin
if BlockStack[BlockStackTop].Index = 1 then
IdentScope := GLOBAL
else
IdentScope := LOCAL;
i := GetIdentUnsafe(IdentName, False, IdentReceiverType);
if (i > 0) and (Ident[i].UnitIndex = ParserState.UnitStatus.Index) and (Ident[i].Block = BlockStack[BlockStackTop].Index) then
Error('Duplicate identifier ' + IdentName);
Inc(NumIdent);
if NumIdent > MAXIDENTS then
Error('Maximum number of identifiers exceeded');
with Ident[NumIdent] do begin
Kind := IdentKind;
Name := IdentName;
Address := 0;
Scope := IdentScope;
RelocType := UNINITDATARELOC;
DataType := IdentDataType;
UnitIndex := ParserState.UnitStatus.Index;
Block := BlockStack[BlockStackTop].Index;
NestingLevel := BlockStackTop;
ReceiverName := IdentReceiverName;
ReceiverType := IdentReceiverType;
Signature.NumParams := 0;
Signature.CallConv := DEFAULTCONV;
PassMethod := IdentPassMethod;
IsUsed := False;
IsUnresolvedForward := False;
IsExported := ParserState.IsInterfaceSection and (IdentScope = GLOBAL);
IsTypedConst := False;
IsInCStack := IdentIsInCStack;
ForLoopNesting := 0;
end;
case IdentKind of
PROC, FUNC: begin
Ident[NumIdent].Signature.ResultType := IdentDataType;
if IdentPredefProc = EMPTYPROC then begin
Ident[NumIdent].Address := GetCodeSize; // Routine entry point address
Ident[NumIdent].PredefProc := EMPTYPROC;
end
else begin
Ident[NumIdent].Address := 0;
Ident[NumIdent].PredefProc := IdentPredefProc; // Predefined routine index
end;
end;
VARIABLE: case IdentScope of
GLOBAL: begin
IdentTypeSize := TypeSize(IdentDataType);
if IdentTypeSize > MAXUNINITIALIZEDDATASIZE - UninitializedGlobalDataSize then
Error('Not enough memory for global variable');
Ident[NumIdent].Address := UninitializedGlobalDataSize; // Variable address (relocatable)
UninitializedGlobalDataSize := UninitializedGlobalDataSize + IdentTypeSize;
end;// else
LOCAL: if TotalParamDataSize > 0 then // Declare parameter (always 4 bytes, except structures in the C stack and doubles)
begin
if Ident[NumIdent].NestingLevel = 2 then // Inside a non-nested routine
AdditionalStackItems := 1 // Return address
else // Inside a nested routine
AdditionalStackItems := 2; // Return address, static link (hidden parameter)
with BlockStack[BlockStackTop] do begin
if (IdentIsInCStack or (Types[IdentDataType].Kind = REALTYPE)) and (IdentPassMethod = VALPASSING) then
IdentTypeSize := Align(TypeSize(IdentDataType), SizeOf(Longint))
else
IdentTypeSize := SizeOf(Longint);
if IdentTypeSize > MAXSTACKSIZE - ParamDataSize then
Error('Not enough memory for parameter');
Ident[NumIdent].Address := AdditionalStackItems * SizeOf(Longint) + TotalParamDataSize - ParamDataSize - (IdentTypeSize - SizeOf(Longint));
// Parameter offset from EBP (>0)
ParamDataSize := ParamDataSize + IdentTypeSize;
end;
end
else
with BlockStack[BlockStackTop] do // Declare local variable
begin
IdentTypeSize := TypeSize(IdentDataType);
if IdentTypeSize > MAXSTACKSIZE - LocalDataSize then
Error('Not enough memory for local variable');
Ident[NumIdent].Address := -LocalDataSize - IdentTypeSize; // Local variable offset from EBP (<0)
LocalDataSize := LocalDataSize + IdentTypeSize;
end;
end; // case
CONSTANT: if IdentPassMethod = EMPTYPASSING then // Untyped constant
case Types[IdentDataType].Kind of
SETTYPE: begin
Ident[NumIdent].ConstVal.SetValue := IdentSetConstValue;
DefineStaticSet(Ident[NumIdent].ConstVal.SetValue, Ident[NumIdent].Address);
end;
ARRAYTYPE: begin
Ident[NumIdent].ConstVal.StrValue := IdentStrConstValue;
DefineStaticString(Ident[NumIdent].ConstVal.StrValue, Ident[NumIdent].Address);
end;
REALTYPE: Ident[NumIdent].ConstVal.RealValue := IdentRealConstValue; // Real constant value
else Ident[NumIdent].ConstVal.OrdValue := IdentOrdConstValue; // Ordinal constant value
end
else // Typed constant (actually an initialized global variable)
begin
with Ident[NumIdent] do begin
Kind := VARIABLE;
Scope := GLOBAL;
RelocType := INITDATARELOC;
PassMethod := EMPTYPASSING;
IsTypedConst := True;
end;
IdentTypeSize := TypeSize(IdentDataType);
if IdentTypeSize > MAXINITIALIZEDDATASIZE - InitializedGlobalDataSize then
Error('Not enough memory for initialized global variable');
Ident[NumIdent].Address := InitializedGlobalDataSize; // Typed constant address (relocatable)
InitializedGlobalDataSize := InitializedGlobalDataSize + IdentTypeSize;
end;
GOTOLABEL: Ident[NumIdent].IsUnresolvedForward := True;
end;// case
end; // DeclareIdent
procedure DeclareType(TypeKind: TTypeKind);
begin
Inc(NumTypes);
if NumTypes > MAXTYPES then
Error('Maximum number of types exceeded');
with Types[NumTypes] do begin
Kind := TypeKind;
Block := BlockStack[BlockStackTop].Index;
end;
end; // DeclareType
procedure DeclarePredefinedIdents;
begin
// Constants
DeclareIdent('TRUE', CONSTANT, 0, False, BOOLEANTYPEINDEX, EMPTYPASSING, 1, 0.0, '', [], EMPTYPROC, '', 0);
DeclareIdent('FALSE', CONSTANT, 0, False, BOOLEANTYPEINDEX, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
// Types
DeclareIdent('INTEGER', USERTYPE, 0, False, INTEGERTYPEINDEX, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
DeclareIdent('SMALLINT', USERTYPE, 0, False, SMALLINTTYPEINDEX, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
DeclareIdent('SHORTINT', USERTYPE, 0, False, SHORTINTTYPEINDEX, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
DeclareIdent('WORD', USERTYPE, 0, False, WORDTYPEINDEX, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
DeclareIdent('BYTE', USERTYPE, 0, False, BYTETYPEINDEX, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
DeclareIdent('CHAR', USERTYPE, 0, False, CHARTYPEINDEX, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
DeclareIdent('BOOLEAN', USERTYPE, 0, False, BOOLEANTYPEINDEX, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
DeclareIdent('REAL', USERTYPE, 0, False, REALTYPEINDEX, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
DeclareIdent('SINGLE', USERTYPE, 0, False, SINGLETYPEINDEX, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
DeclareIdent('POINTER', USERTYPE, 0, False, POINTERTYPEINDEX, EMPTYPASSING, 0, 0.0, '', [], EMPTYPROC, '', 0);
// Procedures
DeclareIdent('INC', PROC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], INCPROC, '', 0);
DeclareIdent('DEC', PROC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], DECPROC, '', 0);
DeclareIdent('READ', PROC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], READPROC, '', 0);
DeclareIdent('WRITE', PROC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], WRITEPROC, '', 0);
DeclareIdent('READLN', PROC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], READLNPROC, '', 0);
DeclareIdent('WRITELN', PROC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], WRITELNPROC, '', 0);
DeclareIdent('NEW', PROC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], NEWPROC, '', 0);
DeclareIdent('DISPOSE', PROC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], DISPOSEPROC, '', 0);
DeclareIdent('BREAK', PROC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], BREAKPROC, '', 0);
DeclareIdent('CONTINUE', PROC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], CONTINUEPROC, '', 0);
DeclareIdent('EXIT', PROC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], EXITPROC, '', 0);
DeclareIdent('HALT', PROC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], HALTPROC, '', 0);
// Functions
DeclareIdent('SIZEOF', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], SIZEOFFUNC, '', 0);
DeclareIdent('ORD', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], ORDFUNC, '', 0);
DeclareIdent('CHR', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], CHRFUNC, '', 0);
DeclareIdent('LOW', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], LOWFUNC, '', 0);
DeclareIdent('HIGH', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], HIGHFUNC, '', 0);
DeclareIdent('PRED', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], PREDFUNC, '', 0);
DeclareIdent('SUCC', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], SUCCFUNC, '', 0);
DeclareIdent('ROUND', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], ROUNDFUNC, '', 0);
DeclareIdent('TRUNC', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], TRUNCFUNC, '', 0);
DeclareIdent('ABS', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], ABSFUNC, '', 0);
DeclareIdent('SQR', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], SQRFUNC, '', 0);
DeclareIdent('SIN', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], SINFUNC, '', 0);
DeclareIdent('COS', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], COSFUNC, '', 0);
DeclareIdent('ARCTAN', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], ARCTANFUNC, '', 0);
DeclareIdent('EXP', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], EXPFUNC, '', 0);
DeclareIdent('LN', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], LNFUNC, '', 0);
DeclareIdent('SQRT', FUNC, 0, False, 0, EMPTYPASSING, 0, 0.0, '', [], SQRTFUNC, '', 0);
end;// DeclarePredefinedIdents
procedure DeclarePredefinedTypes;
begin
NumTypes := STRINGTYPEINDEX;
Types[ANYTYPEINDEX].Kind := ANYTYPE;
Types[INTEGERTYPEINDEX].Kind := INTEGERTYPE;
Types[SMALLINTTYPEINDEX].Kind := SMALLINTTYPE;
Types[SHORTINTTYPEINDEX].Kind := SHORTINTTYPE;
Types[WORDTYPEINDEX].Kind := WORDTYPE;
Types[BYTETYPEINDEX].Kind := BYTETYPE;
Types[CHARTYPEINDEX].Kind := CHARTYPE;
Types[BOOLEANTYPEINDEX].Kind := BOOLEANTYPE;
Types[REALTYPEINDEX].Kind := REALTYPE;
Types[SINGLETYPEINDEX].Kind := SINGLETYPE;
Types[POINTERTYPEINDEX].Kind := POINTERTYPE;
Types[FILETYPEINDEX].Kind := FILETYPE;
Types[STRINGTYPEINDEX].Kind := ARRAYTYPE;
Types[POINTERTYPEINDEX].BaseType := ANYTYPEINDEX;
Types[FILETYPEINDEX].BaseType := ANYTYPEINDEX;
// Add new anonymous type: 1 .. MAXSTRLENGTH + 1
DeclareType(SUBRANGETYPE);
Types[NumTypes].BaseType := INTEGERTYPEINDEX;
Types[NumTypes].Low := 1;
Types[NumTypes].High := MAXSTRLENGTH + 1;
Types[STRINGTYPEINDEX].BaseType := CHARTYPEINDEX;
Types[STRINGTYPEINDEX].IndexType := NumTypes;
Types[STRINGTYPEINDEX].IsOpenArray := False;
end;// DeclarePredefinedTypes
function AllocateTempStorage(Size: Integer): Integer;
begin
with BlockStack[BlockStackTop] do begin
TempDataSize := TempDataSize + Size;
Result := -LocalDataSize - TempDataSize;
end;
end; // AllocateTempStorage
procedure PushTempStoragePtr(Addr: Integer);
begin
PushVarPtr(Addr, LOCAL, 0, UNINITDATARELOC);
end; // PushTempStoragePtr
procedure PushVarIdentPtr(IdentIndex: Integer);
begin
PushVarPtr(Ident[IdentIndex].Address, Ident[IdentIndex].Scope, BlockStackTop - Ident[IdentIndex].NestingLevel, Ident[IdentIndex].RelocType);
Ident[IdentIndex].IsUsed := True;
end; // PushVarIdentPtr
procedure ConvertConstIntegerToReal(DestType: Integer; var SrcType: Integer; var ConstVal: TConst);
begin
// Try to convert an integer (right-hand side) into a real
if (Types[DestType].Kind in [REALTYPE, SINGLETYPE]) and ((Types[SrcType].Kind in IntegerTypes) or ((Types[SrcType].Kind = SUBRANGETYPE) and
(Types[Types[SrcType].BaseType].Kind in IntegerTypes))) then begin
ConstVal.RealValue := ConstVal.OrdValue;
SrcType := REALTYPEINDEX;
end;
end; // ConvertConstIntegerToReal
procedure ConvertIntegerToReal(DestType: Integer; var SrcType: Integer; Depth: Integer);
begin
// Try to convert an integer (right-hand side) into a real
if (Types[DestType].Kind in [REALTYPE, SINGLETYPE]) and ((Types[SrcType].Kind in IntegerTypes) or ((Types[SrcType].Kind = SUBRANGETYPE) and
(Types[Types[SrcType].BaseType].Kind in IntegerTypes))) then begin
GenerateDoubleFromInteger(Depth);
SrcType := REALTYPEINDEX;
end;
end; // ConvertIntegerToReal
procedure ConvertConstRealToReal(DestType: Integer; var SrcType: Integer; var ConstVal: TConst);
begin
// Try to convert a single (right-hand side) into a double or vice versa
if (Types[DestType].Kind = REALTYPE) and (Types[SrcType].Kind = SINGLETYPE) then begin
ConstVal.RealValue := ConstVal.SingleValue;
SrcType := REALTYPEINDEX;
end
else
if (Types[DestType].Kind = SINGLETYPE) and (Types[SrcType].Kind = REALTYPE) then begin
ConstVal.SingleValue := ConstVal.RealValue;
SrcType := SINGLETYPEINDEX;
end;
end; // ConvertConstRealToReal
procedure ConvertRealToReal(DestType: Integer; var SrcType: Integer);
begin
// Try to convert a single (right-hand side) into a double or vice versa
if (Types[DestType].Kind = REALTYPE) and (Types[SrcType].Kind = SINGLETYPE) then begin
GenerateDoubleFromSingle;
SrcType := REALTYPEINDEX;
end
else
if (Types[DestType].Kind = SINGLETYPE) and (Types[SrcType].Kind = REALTYPE) then begin
GenerateSingleFromDouble;
SrcType := SINGLETYPEINDEX;
end;
end; // ConvertRealToReal
procedure ConvertConstCharToString(DestType: Integer; var SrcType: Integer; var ConstVal: TConst);
var
ch: TCharacter;
begin
if IsString(DestType) and ((Types[SrcType].Kind = CHARTYPE) or ((Types[SrcType].Kind = SUBRANGETYPE) and (Types[Types[SrcType].BaseType].Kind = CHARTYPE))) then begin
ch := Char(ConstVal.OrdValue);
ConstVal.StrValue := ch;
SrcType := STRINGTYPEINDEX;
end;
end; // ConvertConstCharToString
procedure ConvertCharToString(DestType: Integer; var SrcType: Integer; Depth: Integer);
var
TempStorageAddr: Longint;
begin
// Try to convert a character (right-hand side) into a 2-character temporary string
if IsString(DestType) and ((Types[SrcType].Kind = CHARTYPE) or ((Types[SrcType].Kind = SUBRANGETYPE) and (Types[Types[SrcType].BaseType].Kind = CHARTYPE))) then begin
TempStorageAddr := AllocateTempStorage(2 * SizeOf(TCharacter));
PushTempStoragePtr(TempStorageAddr);
GetCharAsTempString(Depth);
SrcType := STRINGTYPEINDEX;
end;
end; // ConvertCharToString
procedure ConvertStringToPChar(DestType: Integer; var SrcType: Integer);
begin
// Try to convert a string (right-hand side) into a pointer to character
if (Types[DestType].Kind = POINTERTYPE) and (Types[Types[DestType].BaseType].Kind = CHARTYPE) and IsString(SrcType) then
SrcType := DestType;
end; // ConvertStringToPChar
procedure ConvertToInterface(DestType: Integer; var SrcType: Integer);
var
SrcField, DestField: PField;
TempStorageAddr: Longint;
FieldIndex, MethodIndex: Integer;
begin
// Try to convert a concrete or interface type to an interface type
if (Types[DestType].Kind = INTERFACETYPE) and (DestType <> SrcType) then begin
// Allocate new interface variable
TempStorageAddr := AllocateTempStorage(TypeSize(DestType));
// Set interface's Self pointer (offset 0) to the concrete/interface data
if Types[SrcType].Kind = INTERFACETYPE then begin
DuplicateStackTop;
DerefPtr(POINTERTYPEINDEX);
GenerateInterfaceFieldAssignment(TempStorageAddr, True, 0, UNINITDATARELOC);
DiscardStackTop(1);
end
else
GenerateInterfaceFieldAssignment(TempStorageAddr, True, 0, UNINITDATARELOC);
// Set interface's procedure pointers to the concrete/interface methods
for FieldIndex := 2 to Types[DestType].NumFields do begin
DestField := Types[DestType].Field[FieldIndex];
if Types[SrcType].Kind = INTERFACETYPE then // Interface to interface
begin
SrcField := Types[SrcType].Field[GetField(SrcType, DestField^.Name)];
CheckSignatures(Types[SrcField^.DataType].Signature, Types[DestField^.DataType].Signature, SrcField^.Name, False);
DuplicateStackTop;
GetFieldPtr(SrcField^.Offset);
DerefPtr(POINTERTYPEINDEX);
GenerateInterfaceFieldAssignment(TempStorageAddr + (FieldIndex - 1) * POINTER_SIZE, True, 0, CODERELOC);
DiscardStackTop(1);
end
else // Concrete to interface
begin
MethodIndex := GetMethod(SrcType, DestField^.Name);
CheckSignatures(Ident[MethodIndex].Signature, Types[DestField^.DataType].Signature, Ident[MethodIndex].Name, False);
GenerateInterfaceFieldAssignment(TempStorageAddr + (FieldIndex - 1) * POINTER_SIZE, False, Ident[MethodIndex].Address, CODERELOC);
end;
end; // for
DiscardStackTop(1); // Remove source pointer
PushTempStoragePtr(TempStorageAddr); // Push destination pointer
SrcType := DestType;
end;
end; // ConvertToInterface
procedure CompileConstPredefinedFunc(func: TPredefProc; var ConstVal: TConst; var ConstValType: Integer);
var
IdentIndex: Integer;
begin
NextTok;
EatTok(OPARTOK);
case func of
SIZEOFFUNC: begin
AssertIdent;
IdentIndex := GetIdentUnsafe(Tok.Name);
if (IdentIndex <> 0) and (Ident[IdentIndex].Kind = USERTYPE) then // Type name
begin
NextTok;
ConstVal.OrdValue := TypeSize(Ident[IdentIndex].DataType);
end
else // Variable name
Error('Type name expected');
ConstValType := INTEGERTYPEINDEX;
end;
ROUNDFUNC, TRUNCFUNC: begin
CompileConstExpression(ConstVal, ConstValType);
if not (Types[ConstValType].Kind in IntegerTypes) then begin
GetCompatibleType(ConstValType, REALTYPEINDEX);
if func = TRUNCFUNC then
ConstVal.OrdValue := Trunc(ConstVal.RealValue)
else
ConstVal.OrdValue := Round(ConstVal.RealValue);
end;
ConstValType := INTEGERTYPEINDEX;
end;
ORDFUNC: begin
CompileConstExpression(ConstVal, ConstValType);
if not (Types[ConstValType].Kind in OrdinalTypes) then
Error('Ordinal type expected');
ConstValType := INTEGERTYPEINDEX;
end;
CHRFUNC: begin
CompileConstExpression(ConstVal, ConstValType);
GetCompatibleType(ConstValType, INTEGERTYPEINDEX);
ConstValType := CHARTYPEINDEX;
end;
LOWFUNC, HIGHFUNC: begin
AssertIdent;
IdentIndex := GetIdentUnsafe(Tok.Name);
if (IdentIndex <> 0) and (Ident[IdentIndex].Kind = USERTYPE) then // Type name
begin
NextTok;
ConstValType := Ident[IdentIndex].DataType;
end
else // Variable name
Error('Type name expected');
if (Types[ConstValType].Kind = ARRAYTYPE) and not Types[ConstValType].IsOpenArray then
ConstValType := Types[ConstValType].IndexType;
if func = HIGHFUNC then
ConstVal.OrdValue := HighBound(ConstValType)
else
ConstVal.OrdValue := LowBound(ConstValType);
end;
PREDFUNC, SUCCFUNC: begin
CompileConstExpression(ConstVal, ConstValType);
if not (Types[ConstValType].Kind in OrdinalTypes) then
Error('Ordinal type expected');
if func = SUCCFUNC then
Inc(ConstVal.OrdValue)
else
Dec(ConstVal.OrdValue);
end;
ABSFUNC, SQRFUNC, SINFUNC, COSFUNC, ARCTANFUNC, EXPFUNC, LNFUNC, SQRTFUNC: begin
CompileConstExpression(ConstVal, ConstValType);
if (func = ABSFUNC) or (func = SQRFUNC) then // Abs and Sqr accept real or integer parameters
begin
if not ((Types[ConstValType].Kind in NumericTypes) or ((Types[ConstValType].Kind = SUBRANGETYPE) and
(Types[Types[ConstValType].BaseType].Kind in NumericTypes))) then
Error('Numeric type expected');
if Types[ConstValType].Kind = REALTYPE then
if func = ABSFUNC then
ConstVal.RealValue := abs(ConstVal.RealValue)
else
ConstVal.RealValue := sqr(ConstVal.RealValue)
else
if func = ABSFUNC then
ConstVal.OrdValue := abs(ConstVal.OrdValue)
else
ConstVal.OrdValue := sqr(ConstVal.OrdValue);
end
else
Error('Function is not allowed in constant expressions');
end;
end;
EatTok(CPARTOK);
end;
procedure CompileConstSetConstructor(var ConstVal: TConst; var ConstValType: Integer);
var
ElementVal, ElementVal2: TConst;
ElementValType: Integer;
ElementIndex: Integer;
begin
ConstVal.SetValue := [];
// Add new anonymous type
DeclareType(SETTYPE);
Types[NumTypes].BaseType := ANYTYPEINDEX;
ConstValType := NumTypes;
// Compile constructor
EatTok(OBRACKETTOK);
if Tok.Kind <> CBRACKETTOK then
repeat
CompileConstExpression(ElementVal, ElementValType);
if Types[ConstValType].BaseType = ANYTYPEINDEX then begin
if not (Types[ElementValType].Kind in OrdinalTypes) then
Error('Ordinal type expected');
Types[ConstValType].BaseType := ElementValType;
end
else
GetCompatibleType(ElementValType, Types[ConstValType].BaseType);
if Tok.Kind = RANGETOK then begin
NextTok;
CompileConstExpression(ElementVal2, ElementValType);
GetCompatibleType(ElementValType, Types[ConstValType].BaseType);
end
else
ElementVal2 := ElementVal;
if (ElementVal.OrdValue < 0) or (ElementVal.OrdValue >= MAXSETELEMENTS) or (ElementVal2.OrdValue < 0) or (ElementVal2.OrdValue >= MAXSETELEMENTS) then
Error('Set elements must be between 0 and ' + IntToStr(MAXSETELEMENTS - 1));
for ElementIndex := ElementVal.OrdValue to ElementVal2.OrdValue do
ConstVal.SetValue := ConstVal.SetValue + [ElementIndex];
if Tok.Kind <> COMMATOK then
Break;
NextTok;
until False;
EatTok(CBRACKETTOK);
end; // CompileConstSetConstructor
procedure CompileConstFactor(var ConstVal: TConst; var ConstValType: Integer);
var
NotOpTok: TToken;
IdentIndex: Integer;
begin
case Tok.Kind of
IDENTTOK: begin
IdentIndex := GetIdent(Tok.Name);
case Ident[IdentIndex].Kind of
GOTOLABEL: Error('Constant expression expected but label ' + Ident[IdentIndex].Name + ' found');
PROC: Error('Constant expression expected but procedure ' + Ident[IdentIndex].Name + ' found');
FUNC: if Ident[IdentIndex].PredefProc <> EMPTYPROC then
CompileConstPredefinedFunc(Ident[IdentIndex].PredefProc, ConstVal, ConstValType)
else
Error('Function ' + Ident[IdentIndex].Name + ' is not allowed in constant expressions');
VARIABLE: Error('Constant expression expected but variable ' + Ident[IdentIndex].Name + ' found');
CONSTANT: begin
ConstValType := Ident[IdentIndex].DataType;
case Types[ConstValType].Kind of
SETTYPE: ConstVal.SetValue := Ident[IdentIndex].ConstVal.SetValue;
ARRAYTYPE: ConstVal.StrValue := Ident[IdentIndex].ConstVal.StrValue;
REALTYPE: ConstVal.RealValue := Ident[IdentIndex].ConstVal.RealValue;
else ConstVal.OrdValue := Ident[IdentIndex].ConstVal.OrdValue;
end;
NextTok;
end;
USERTYPE: Error('Constant expression expected but type ' + Ident[IdentIndex].Name + ' found');
else Error('Internal fault: Illegal identifier');
end; // case Ident[IdentIndex].Kind
end;
INTNUMBERTOK: begin
ConstVal.OrdValue := Tok.OrdValue;
ConstValType := INTEGERTYPEINDEX;
NextTok;
end;
REALNUMBERTOK: begin
ConstVal.RealValue := Tok.RealValue;
ConstValType := REALTYPEINDEX;
NextTok;
end;
CHARLITERALTOK: begin
ConstVal.OrdValue := Tok.OrdValue;
ConstValType := CHARTYPEINDEX;
NextTok;
end;
STRINGLITERALTOK: begin
ConstVal.StrValue := Tok.Name;
ConstValType := STRINGTYPEINDEX;
NextTok;
end;
OPARTOK: begin
NextTok;
CompileConstExpression(ConstVal, ConstValType);
EatTok(CPARTOK);
end;
NOTTOK: begin
NotOpTok := Tok;
NextTok;
CompileConstFactor(ConstVal, ConstValType);
CheckOperator(NotOpTok, ConstValType);
ConstVal.OrdValue := not ConstVal.OrdValue;
if Types[ConstValType].Kind = BOOLEANTYPE then
ConstVal.OrdValue := ConstVal.OrdValue and 1;
end;
OBRACKETTOK: CompileConstSetConstructor(ConstVal, ConstValType);
else Error('Expression expected but ' + GetTokSpelling(Tok.Kind) + ' found');
end;// case
end; // CompileConstFactor
procedure CompileConstTerm(var ConstVal: TConst; var ConstValType: Integer);
var
OpTok: TToken;
RightConstVal: TConst;
RightConstValType: Integer;
begin
CompileConstFactor(ConstVal, ConstValType);
while Tok.Kind in MultiplicativeOperators do begin
OpTok := Tok;
NextTok;
CompileConstFactor(RightConstVal, RightConstValType);
// Try to convert integer to real
ConvertConstIntegerToReal(RightConstValType, ConstValType, ConstVal);
ConvertConstIntegerToReal(ConstValType, RightConstValType, RightConstVal);
// Special case: real division of two integers
if OpTok.Kind = DIVTOK then begin
ConvertConstIntegerToReal(REALTYPEINDEX, ConstValType, ConstVal);
ConvertConstIntegerToReal(REALTYPEINDEX, RightConstValType, RightConstVal);
end;
ConstValType := GetCompatibleType(ConstValType, RightConstValType);
// Special case: set intersection
if (OpTok.Kind = MULTOK) and (Types[ConstValType].Kind = SETTYPE) then
ConstVal.SetValue := ConstVal.SetValue * RightConstVal.SetValue
// General rule
else begin
CheckOperator(OpTok, ConstValType);
if Types[ConstValType].Kind = REALTYPE then // Real constants
case OpTok.Kind of
MULTOK: ConstVal.RealValue := ConstVal.RealValue * RightConstVal.RealValue;
DIVTOK: if RightConstVal.RealValue <> 0 then
ConstVal.RealValue := ConstVal.RealValue / RightConstVal.RealValue
else
Error('Constant division by zero')
end
else // Integer constants
begin
case OpTok.Kind of
MULTOK: ConstVal.OrdValue := ConstVal.OrdValue * RightConstVal.OrdValue;
IDIVTOK: if RightConstVal.OrdValue <> 0 then
ConstVal.OrdValue := ConstVal.OrdValue div RightConstVal.OrdValue
else
Error('Constant division by zero');
MODTOK: if RightConstVal.OrdValue <> 0 then
ConstVal.OrdValue := ConstVal.OrdValue mod RightConstVal.OrdValue
else
Error('Constant division by zero');
SHLTOK: ConstVal.OrdValue := ConstVal.OrdValue shl RightConstVal.OrdValue;
SHRTOK: ConstVal.OrdValue := ConstVal.OrdValue shr RightConstVal.OrdValue;
ANDTOK: ConstVal.OrdValue := ConstVal.OrdValue and RightConstVal.OrdValue;
end;
if Types[ConstValType].Kind = BOOLEANTYPE then
ConstVal.OrdValue := ConstVal.OrdValue and 1;
end; // else
end; // else
end;// while
end;// CompileConstTerm
procedure CompileSimpleConstExpression(var ConstVal: TConst; var ConstValType: Integer);
var
UnaryOpTok, OpTok: TToken;
RightConstVal: TConst;
RightConstValType: Integer;
begin
UnaryOpTok := Tok;
if UnaryOpTok.Kind in UnaryOperators then
NextTok;
CompileConstTerm(ConstVal, ConstValType);
if UnaryOpTok.Kind in UnaryOperators then
CheckOperator(UnaryOpTok, ConstValType);
if UnaryOpTok.Kind = MINUSTOK then // Unary minus
if Types[ConstValType].Kind = REALTYPE then
ConstVal.RealValue := -ConstVal.RealValue
else
ConstVal.OrdValue := -ConstVal.OrdValue;
while Tok.Kind in AdditiveOperators do begin
OpTok := Tok;
NextTok;
CompileConstTerm(RightConstVal, RightConstValType);
// Try to convert integer to real
ConvertConstIntegerToReal(RightConstValType, ConstValType, ConstVal);
ConvertConstIntegerToReal(ConstValType, RightConstValType, RightConstVal);
// Try to convert character to string
ConvertConstCharToString(RightConstValType, ConstValType, ConstVal);
ConvertConstCharToString(ConstValType, RightConstValType, RightConstVal);
ConstValType := GetCompatibleType(ConstValType, RightConstValType);
// Special case: string concatenation
if (OpTok.Kind = PLUSTOK) and IsString(ConstValType) and IsString(RightConstValType) then
ConstVal.StrValue := ConstVal.StrValue + RightConstVal.StrValue
// Special case: set union or difference
else
if (OpTok.Kind in [PLUSTOK, MINUSTOK]) and (Types[ConstValType].Kind = SETTYPE) then
ConstVal.SetValue := ConstVal.SetValue + RightConstVal.SetValue
// General rule
else begin
CheckOperator(OpTok, ConstValType);
if Types[ConstValType].Kind = REALTYPE then // Real constants
case OpTok.Kind of
PLUSTOK: ConstVal.RealValue := ConstVal.RealValue + RightConstVal.RealValue;
MINUSTOK: ConstVal.RealValue := ConstVal.RealValue - RightConstVal.RealValue;
end
else // Integer constants
begin
case OpTok.Kind of
PLUSTOK: ConstVal.OrdValue := ConstVal.OrdValue + RightConstVal.OrdValue;
MINUSTOK: ConstVal.OrdValue := ConstVal.OrdValue - RightConstVal.OrdValue;
ORTOK: ConstVal.OrdValue := ConstVal.OrdValue or RightConstVal.OrdValue;
XORTOK: ConstVal.OrdValue := ConstVal.OrdValue xor RightConstVal.OrdValue;
end;
if Types[ConstValType].Kind = BOOLEANTYPE then
ConstVal.OrdValue := ConstVal.OrdValue and 1;
end;
end;
end;// while
end; // CompileSimpleConstExpression
procedure CompileConstExpression(var ConstVal: TConst; var ConstValType: Integer);
var
OpTok: TToken;
RightConstVal: TConst;
RightConstValType: Integer;
Yes: Boolean;
begin
Yes := False;
CompileSimpleConstExpression(ConstVal, ConstValType);
if Tok.Kind in RelationOperators then begin
OpTok := Tok;
NextTok;
CompileSimpleConstExpression(RightConstVal, RightConstValType);
// Try to convert integer to real
ConvertConstIntegerToReal(RightConstValType, ConstValType, ConstVal);
ConvertConstIntegerToReal(ConstValType, RightConstValType, RightConstVal);
// Try to convert character to string
ConvertConstCharToString(RightConstValType, ConstValType, ConstVal);
ConvertConstCharToString(ConstValType, RightConstValType, RightConstVal);
GetCompatibleType(ConstValType, RightConstValType);
// Special case: string comparison
if IsString(ConstValType) and IsString(RightConstValType) then
case OpTok.Kind of
EQTOK: Yes := ConstVal.StrValue = RightConstVal.StrValue;
NETOK: Yes := ConstVal.StrValue <> RightConstVal.StrValue;
LTTOK: Yes := ConstVal.StrValue < RightConstVal.StrValue;
LETOK: Yes := ConstVal.StrValue <= RightConstVal.StrValue;
GTTOK: Yes := ConstVal.StrValue > RightConstVal.StrValue;
GETOK: Yes := ConstVal.StrValue >= RightConstVal.StrValue;
end
// Special case: set comparison
else
if (OpTok.Kind in [EQTOK, NETOK, GETOK, LETOK]) and (Types[ConstValType].Kind = SETTYPE) then
case OpTok.Kind of
EQTOK: Yes := ConstVal.SetValue = RightConstVal.SetValue;
NETOK: Yes := ConstVal.SetValue <> RightConstVal.SetValue;
LETOK: Yes := ConstVal.SetValue <= RightConstVal.SetValue;
GETOK: Yes := ConstVal.SetValue >= RightConstVal.SetValue;
end
// General rule
else begin
CheckOperator(OpTok, ConstValType);
if Types[ConstValType].Kind = REALTYPE then
case OpTok.Kind of
EQTOK: Yes := ConstVal.RealValue = RightConstVal.RealValue;
NETOK: Yes := ConstVal.RealValue <> RightConstVal.RealValue;
LTTOK: Yes := ConstVal.RealValue < RightConstVal.RealValue;
LETOK: Yes := ConstVal.RealValue <= RightConstVal.RealValue;
GTTOK: Yes := ConstVal.RealValue > RightConstVal.RealValue;
GETOK: Yes := ConstVal.RealValue >= RightConstVal.RealValue;
end
else
case OpTok.Kind of
EQTOK: Yes := ConstVal.OrdValue = RightConstVal.OrdValue;
NETOK: Yes := ConstVal.OrdValue <> RightConstVal.OrdValue;
LTTOK: Yes := ConstVal.OrdValue < RightConstVal.OrdValue;
LETOK: Yes := ConstVal.OrdValue <= RightConstVal.OrdValue;
GTTOK: Yes := ConstVal.OrdValue > RightConstVal.OrdValue;
GETOK: Yes := ConstVal.OrdValue >= RightConstVal.OrdValue;
end;
end;
if Yes then
ConstVal.OrdValue := 1
else
ConstVal.OrdValue := 0;
ConstValType := BOOLEANTYPEINDEX;
end;
end;// CompileConstExpression
procedure CompilePredefinedProc(proc: TPredefProc; LoopNesting: Integer);
function GetReadProcIdent(DataType: Integer): Integer;
begin
Result := 0;
with Types[DataType] do
if (Kind = INTEGERTYPE) or ((Kind = SUBRANGETYPE) and (Types[BaseType].Kind = INTEGERTYPE)) then
Result := GetIdent('READINT') // Integer argument
else
if (Kind = SMALLINTTYPE) or ((Kind = SUBRANGETYPE) and (Types[BaseType].Kind = SMALLINTTYPE)) then
Result := GetIdent('READSMALLINT') // Small integer argument
else
if (Kind = SHORTINTTYPE) or ((Kind = SUBRANGETYPE) and (Types[BaseType].Kind = SHORTINTTYPE)) then
Result := GetIdent('READSHORTINT') // Short integer argument
else
if (Kind = WORDTYPE) or ((Kind = SUBRANGETYPE) and (Types[BaseType].Kind = WORDTYPE)) then
Result := GetIdent('READWORD') // Word argument
else
if (Kind = BYTETYPE) or ((Kind = SUBRANGETYPE) and (Types[BaseType].Kind = BYTETYPE)) then
Result := GetIdent('READBYTE') // Byte argument
else
if (Kind = BOOLEANTYPE) or ((Kind = SUBRANGETYPE) and (Types[BaseType].Kind = BOOLEANTYPE)) then
Result := GetIdent('READBOOLEAN') // Boolean argument
else
if (Kind = CHARTYPE) or ((Kind = SUBRANGETYPE) and (Types[BaseType].Kind = CHARTYPE)) then
Result := GetIdent('READCH') // Character argument
else
if Kind = REALTYPE then
Result := GetIdent('READREAL') // Real argument
else
if Kind = SINGLETYPE then
Result := GetIdent('READSINGLE') // Single argument
else
if (Kind = ARRAYTYPE) and (BaseType = CHARTYPEINDEX) then
Result := GetIdent('READSTRING') // String argument
else
Error('Cannot read ' + GetTypeSpelling(DataType));
end; // GetReadProcIdent
function GetWriteProcIdent(DataType: Integer): Integer;
begin
Result := 0;
with Types[DataType] do
if (Kind in IntegerTypes) or ((Kind = SUBRANGETYPE) and (Types[BaseType].Kind in IntegerTypes)) then
Result := GetIdent('WRITEINTF') // Integer argument
else
if (Kind = BOOLEANTYPE) or ((Kind = SUBRANGETYPE) and (Types[BaseType].Kind = BOOLEANTYPE)) then
Result := GetIdent('WRITEBOOLEANF') // Boolean argument
else
if Kind = REALTYPE then
Result := GetIdent('WRITEREALF') // Real argument
else
if Kind = POINTERTYPE then
Result := GetIdent('WRITEPOINTERF') // Pointer argument
else
if (Kind = ARRAYTYPE) and (BaseType = CHARTYPEINDEX) then
Result := GetIdent('WRITESTRINGF') // String argument
else
Error('Cannot write ' + GetTypeSpelling(DataType));
end; // GetWriteProcIdentIndex
var
DesignatorType, FileVarType, ExpressionType, FormatterType: Integer;
LibProcIdentIndex, ConsoleIndex: Integer;
IsFirstParam: Boolean;
begin // CompilePredefinedProc
NextTok;
case proc of
INCPROC, DECPROC: begin
EatTok(OPARTOK);
CompileDesignator(DesignatorType, False);
if (Types[DesignatorType].Kind = POINTERTYPE) and (Types[DesignatorType].BaseType <> ANYTYPEINDEX) then // Special case: typed pointer
GenerateIncDec(proc, TypeSize(DesignatorType), TypeSize(Types[DesignatorType].BaseType))
else // General rule
begin
GetCompatibleType(DesignatorType, INTEGERTYPEINDEX);
GenerateIncDec(proc, TypeSize(DesignatorType));
end;
EatTok(CPARTOK);
end;
READPROC, READLNPROC: begin
ConsoleIndex := GetIdent('STDINPUTFILE');
FileVarType := ANYTYPEINDEX;
IsFirstParam := True;
if Tok.Kind = OPARTOK then begin
NextTok;
repeat
// 1st argument - file handle
if FileVarType <> ANYTYPEINDEX then
DuplicateStackTop
else
PushVarIdentPtr(ConsoleIndex);
// 2nd argument - stream handle
PushConst(0);
// 3rd argument - designator
CompileDesignator(DesignatorType, False);
if Types[DesignatorType].Kind = FILETYPE then // File handle
begin
if not IsFirstParam or ((proc = READLNPROC) and (Types[DesignatorType].BaseType <> ANYTYPEINDEX)) then
Error('Cannot read ' + GetTypeSpelling(DesignatorType));
FileVarType := DesignatorType;
end
else // Any input variable
begin
// Select input subroutine
if (Types[FileVarType].Kind = FILETYPE) and (Types[FileVarType].BaseType <> ANYTYPEINDEX) then // Read from typed file
begin
GetCompatibleRefType(Types[FileVarType].BaseType, DesignatorType);
// 4th argument - record length
PushConst(TypeSize(Types[FileVarType].BaseType));
LibProcIdentIndex := GetIdent('READREC');
end
else // Read from text file
LibProcIdentIndex := GetReadProcIdent(DesignatorType);
// Call selected input subroutine. Interface: FileHandle; StreamHandle; var Designator [; Length]
GenerateCall(Ident[LibProcIdentIndex].Address, BlockStackTop - 1, Ident[LibProcIdentIndex].NestingLevel);
end; // else
IsFirstParam := False;
if Tok.Kind <> COMMATOK then
Break;
NextTok;
until False;
EatTok(CPARTOK);
end; // if OPARTOR
// Add CR+LF, if necessary
if proc = READLNPROC then begin
// 1st argument - file handle
if FileVarType <> ANYTYPEINDEX then
DuplicateStackTop
else
PushVarIdentPtr(ConsoleIndex);
// 2nd argument - stream handle
PushConst(0);
LibProcIdentIndex := GetIdent('READNEWLINE');
GenerateCall(Ident[LibProcIdentIndex].Address, BlockStackTop - 1, Ident[LibProcIdentIndex].NestingLevel);
end;
// Remove first 3 arguments if they correspond to a file variable
if FileVarType <> ANYTYPEINDEX then
DiscardStackTop(3);
end;// READPROC, READLNPROC
WRITEPROC, WRITELNPROC: begin
ConsoleIndex := GetIdent('STDOUTPUTFILE');
FileVarType := ANYTYPEINDEX;
IsFirstParam := True;
if Tok.Kind = OPARTOK then begin
NextTok;
repeat
// 1st argument - file handle
if FileVarType <> ANYTYPEINDEX then
DuplicateStackTop
else
PushVarIdentPtr(ConsoleIndex);
// 2nd argument - stream handle
PushConst(0);
// 3rd argument - expression (for untyped/text files) or designator (for typed files)
if (Types[FileVarType].Kind = FILETYPE) and (Types[FileVarType].BaseType <> ANYTYPEINDEX) then
CompileDesignator(ExpressionType)
else begin
CompileExpression(ExpressionType);
// Try to convert single to double
ConvertRealToReal(REALTYPEINDEX, ExpressionType);
// Try to convert character to string
ConvertCharToString(STRINGTYPEINDEX, ExpressionType, 0);
end;
if Types[ExpressionType].Kind = FILETYPE then // File handle
begin
if not IsFirstParam or ((proc = WRITELNPROC) and (Types[ExpressionType].BaseType <> ANYTYPEINDEX)) then
Error('Cannot write ' + GetTypeSpelling(ExpressionType));
FileVarType := ExpressionType;
end
else // Any output expression
begin
// 4th argument - minimum width
if Tok.Kind = COLONTOK then begin
if (Types[FileVarType].Kind = FILETYPE) and (Types[FileVarType].BaseType <> ANYTYPEINDEX) then
Error('Format specifiers are not allowed for typed files');
NextTok;
CompileExpression(FormatterType);
GetCompatibleType(FormatterType, INTEGERTYPEINDEX);
// 5th argument - number of decimal places
if (Tok.Kind = COLONTOK) and (Types[ExpressionType].Kind = REALTYPE) then begin
NextTok;
CompileExpression(FormatterType);
GetCompatibleType(FormatterType, INTEGERTYPEINDEX);
end
else
PushConst(0);
end
else begin
PushConst(0);
PushConst(0);
end;
// Select output subroutine
if (Types[FileVarType].Kind = FILETYPE) and (Types[FileVarType].BaseType <> ANYTYPEINDEX) then // Write to typed file
begin
GetCompatibleRefType(Types[FileVarType].BaseType, ExpressionType);
// Discard 4th and 5th arguments - format specifiers
DiscardStackTop(2);
// 4th argument - record length
PushConst(TypeSize(Types[FileVarType].BaseType));
LibProcIdentIndex := GetIdent('WRITEREC');
end
else // Write to text file
LibProcIdentIndex := GetWriteProcIdent(ExpressionType);
// Call selected output subroutine. Interface: FileHandle; StreamHandle; (Designator | Expression); (Length; | MinWidth; DecPlaces)
GenerateCall(Ident[LibProcIdentIndex].Address, BlockStackTop - 1, Ident[LibProcIdentIndex].NestingLevel);
end; // else
IsFirstParam := False;
if Tok.Kind <> COMMATOK then
Break;
NextTok;
until False;
EatTok(CPARTOK);
end; // if OPARTOR
// Add CR+LF, if necessary
if proc = WRITELNPROC then begin
LibProcIdentIndex := GetIdent('WRITENEWLINE');
// 1st argument - file handle
if FileVarType <> ANYTYPEINDEX then
DuplicateStackTop
else
PushVarIdentPtr(ConsoleIndex);
// 2nd argument - stream handle
PushConst(0);
GenerateCall(Ident[LibProcIdentIndex].Address, BlockStackTop - 1, Ident[LibProcIdentIndex].NestingLevel);
end;
// Remove first 3 arguments if they correspond to a file variable
if FileVarType <> ANYTYPEINDEX then
DiscardStackTop(3);
end;// WRITEPROC, WRITELNPROC
NEWPROC, DISPOSEPROC: begin
EatTok(OPARTOK);
CompileDesignator(DesignatorType, False);
GetCompatibleType(DesignatorType, POINTERTYPEINDEX);
if proc = NEWPROC then begin
PushConst(TypeSize(Types[DesignatorType].BaseType));
LibProcIdentIndex := GetIdent('GETMEM');
end
else
LibProcIdentIndex := GetIdent('FREEMEM');
GenerateCall(Ident[LibProcIdentIndex].Address, BlockStackTop - 1, Ident[LibProcIdentIndex].NestingLevel);