]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/m2/gm2-compiler/M2Quads.mod
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
PR modula2/114745: const cast causes ICE
[thirdparty/gcc.git] / gcc / m2 / gm2-compiler / M2Quads.mod
CommitLineData
1eee94d3
GM		 1(* M2Quads.mod generates quadruples.
2
a945c346 3Copyright (C) 2001-2024 Free Software Foundation, Inc.
1eee94d3
GM		 4Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
5
6This file is part of GNU Modula-2.
7
8GNU Modula-2 is free software; you can redistribute it and/or modify
9it under the terms of the GNU General Public License as published by
10the Free Software Foundation; either version 3, or (at your option)
11any later version.
12
13GNU Modula-2 is distributed in the hope that it will be useful, but
14WITHOUT ANY WARRANTY; without even the implied warranty of
15MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16General Public License for more details.
17
18You should have received a copy of the GNU General Public License
19along with GNU Modula-2; see the file COPYING3. If not see
20<http://www.gnu.org/licenses/>. *)
21
22IMPLEMENTATION MODULE M2Quads ;
23
24
25FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
26FROM M2Debug IMPORT Assert, WriteDebug ;
27FROM NameKey IMPORT Name, NulName, MakeKey, GetKey, makekey, KeyToCharStar, WriteKey ;
28FROM FormatStrings IMPORT Sprintf0, Sprintf1, Sprintf2, Sprintf3 ;
29FROM M2DebugStack IMPORT DebugStack ;
48d49200 30FROM StrLib IMPORT StrLen ;
1eee94d3
GM		 31FROM M2Scaffold IMPORT DeclareScaffold, mainFunction, initFunction,
32 finiFunction, linkFunction, PopulateCtorArray,
33 ForeachModuleCallInit, ForeachModuleCallFinish ;
34
35FROM M2MetaError IMPORT MetaError0, MetaError1, MetaError2, MetaError3,
36 MetaErrors1, MetaErrors2, MetaErrors3,
37 MetaErrorT0, MetaErrorT1, MetaErrorT2,
5ededfa5 38 MetaErrorsT1, MetaErrorsT2, MetaErrorT3,
1eee94d3
GM		 39 MetaErrorStringT0, MetaErrorStringT1,
40 MetaErrorString1, MetaErrorString2,
41 MetaErrorN1, MetaErrorN2,
42 MetaErrorNT0, MetaErrorNT1, MetaErrorNT2 ;
43
44FROM DynamicStrings IMPORT String, string, InitString, KillString,
45 ConCat, InitStringCharStar, Dup, Mark,
46 PushAllocation, PopAllocationExemption,
47 InitStringDB, InitStringCharStarDB,
48 InitStringCharDB, MultDB, DupDB, SliceDB ;
49
50FROM SymbolTable IMPORT ModeOfAddr, GetMode, PutMode, GetSymName, IsUnknown,
51 MakeTemporary,
52 MakeTemporaryFromExpression,
53 MakeTemporaryFromExpressions,
78b72ee5
GM		 54 MakeConstLit,
55 MakeConstString, MakeConstant, MakeConstVar,
56 MakeConstStringM2nul, MakeConstStringCnul,
1eee94d3
GM		 57 Make2Tuple,
58 RequestSym, MakePointer, PutPointer,
59 SkipType,
60 GetDType, GetSType, GetLType,
61 GetScope, GetCurrentScope,
62 GetSubrange, SkipTypeAndSubrange,
63 GetModule, GetMainModule,
64 GetCurrentModule, GetFileModule, GetLocalSym,
65 GetStringLength, GetString,
66 GetArraySubscript, GetDimension,
67 GetParam,
68 GetNth, GetNthParam,
69 GetFirstUsed, GetDeclaredMod,
70 GetQuads, GetReadQuads, GetWriteQuads,
71 GetWriteLimitQuads, GetReadLimitQuads,
72 GetVarScope,
73 GetModuleQuads, GetProcedureQuads,
74 GetModuleCtors,
75 MakeProcedure,
78b72ee5 76 CopyConstString, PutConstStringKnown,
1eee94d3
GM		 77 PutModuleStartQuad, PutModuleEndQuad,
78 PutModuleFinallyStartQuad, PutModuleFinallyEndQuad,
79 PutProcedureStartQuad, PutProcedureEndQuad,
80 PutProcedureScopeQuad,
81 PutVar, PutConstSet,
82 GetVarPointerCheck, PutVarPointerCheck,
83 PutVarWritten,
84 PutReadQuad, RemoveReadQuad,
85 PutWriteQuad, RemoveWriteQuad,
86 PutPriority, GetPriority,
87 PutProcedureBegin, PutProcedureEnd,
88 PutVarConst, IsVarConst,
c1667b1e 89 PutConstLitInternal,
b80e3c46 90 PutVarHeap,
1eee94d3
GM		 91 IsVarParam, IsProcedure, IsPointer, IsParameter,
92 IsUnboundedParam, IsEnumeration, IsDefinitionForC,
93 IsVarAParam, IsVarient, IsLegal,
94 UsesVarArgs, UsesOptArg,
95 GetOptArgInit,
96 IsReturnOptional,
97 NoOfElements,
98 NoOfParam,
99 StartScope, EndScope,
990d10ab
GM		 100 IsGnuAsm, IsGnuAsmVolatile,
101 MakeRegInterface, PutRegInterface,
1eee94d3
GM		 102 HasExceptionBlock, PutExceptionBlock,
103 HasExceptionFinally, PutExceptionFinally,
104 GetParent, GetRecord, IsRecordField, IsFieldVarient, IsRecord,
105 IsFieldEnumeration,
106 IsVar, IsProcType, IsType, IsSubrange, IsExported,
107 IsConst, IsConstString, IsModule, IsDefImp,
108 IsArray, IsUnbounded, IsProcedureNested,
109 IsParameterUnbounded,
110 IsPartialUnbounded, IsProcedureBuiltin,
111 IsSet, IsConstSet, IsConstructor, PutConst,
112 PutConstructor, PutConstructorFrom,
113 PutDeclared,
114 MakeComponentRecord, MakeComponentRef,
78b72ee5 115 IsSubscript, IsComponent, IsConstStringKnown,
1eee94d3
GM		 116 IsTemporary,
117 IsAModula2Type,
118 PutLeftValueFrontBackType,
119 PushSize, PushValue, PopValue,
120 GetVariableAtAddress, IsVariableAtAddress,
121 MakeError, UnknownReported,
81d5ca0b 122 IsProcedureBuiltinAvailable,
1eee94d3
GM		 123 IsError,
124 IsInnerModule,
125 IsImportStatement, IsImport, GetImportModule, GetImportDeclared,
126 GetImportStatementList,
127 GetModuleDefImportStatementList, GetModuleModImportStatementList,
128 IsCtor, IsPublic, IsExtern, IsMonoName,
129
130 GetUnboundedRecordType,
131 GetUnboundedAddressOffset,
132 GetUnboundedHighOffset,
40b91158 133 PutVarArrayRef,
1eee94d3
GM		 134
135 ForeachFieldEnumerationDo, ForeachLocalSymDo,
05652ac4 136 GetExported, PutImported, GetSym, GetLibName,
64b0130b 137 GetTypeMode,
1eee94d3
GM		 138 IsUnused,
139 NulSym ;
140
141FROM M2Batch IMPORT MakeDefinitionSource ;
142FROM M2GCCDeclare IMPORT PutToBeSolvedByQuads ;
143
144FROM FifoQueue IMPORT GetConstFromFifoQueue,
145 PutConstructorIntoFifoQueue, GetConstructorFromFifoQueue ;
146
147FROM M2Comp IMPORT CompilingImplementationModule,
148 CompilingProgramModule ;
149
150FROM M2LexBuf IMPORT currenttoken, UnknownTokenNo, BuiltinTokenNo,
f065c582 151 GetToken, MakeVirtualTok, MakeVirtual2Tok,
1eee94d3
GM		 152 GetFileName, TokenToLineNo, GetTokenName,
153 GetTokenNo, GetLineNo, GetPreviousTokenLineNo, PrintTokenNo ;
154
155FROM M2Error IMPORT Error,
156 InternalError,
157 WriteFormat0, WriteFormat1, WriteFormat2, WriteFormat3,
158 NewError, NewWarning, ErrorFormat0, ErrorFormat1,
159 ErrorFormat2, ErrorFormat3, FlushErrors, ChainError,
160 ErrorString,
161 ErrorStringAt, ErrorStringAt2, ErrorStringsAt2,
162 WarnStringAt, WarnStringAt2, WarnStringsAt2 ;
163
48d49200
GM		 164FROM M2Printf IMPORT fprintf0, fprintf1, fprintf2, fprintf3, fprintf4,
165 printf0, printf1, printf2, printf3, printf4 ;
1eee94d3
GM		 166
167FROM M2Reserved IMPORT PlusTok, MinusTok, TimesTok, DivTok, ModTok,
168 DivideTok, RemTok,
169 OrTok, AndTok, AmbersandTok,
170 EqualTok, LessEqualTok, GreaterEqualTok,
171 LessTok, GreaterTok, HashTok, LessGreaterTok,
172 InTok,
173 UpArrowTok, RParaTok, LParaTok, CommaTok,
174 NulTok, ByTok,
175 SemiColonTok, toktype ;
176
177FROM M2Base IMPORT True, False, Boolean, Cardinal, Integer, Char,
178 Real, LongReal, ShortReal, Nil,
179 ZType, RType, CType,
180 Re, Im, Cmplx,
181 NegateType, ComplexToScalar, GetCmplxReturnType,
182 IsAssignmentCompatible, IsExpressionCompatible,
183 AssignmentRequiresWarning,
184 CannotCheckTypeInPass3, ScalarToComplex, MixTypes,
185 CheckAssignmentCompatible, CheckExpressionCompatible,
186 High, LengthS, New, Dispose, Inc, Dec, Incl, Excl,
187 Cap, Abs, Odd,
188 IsOrd, Chr, Convert, Val, IsFloat, IsTrunc,
189 IsInt, Min, Max,
190 IsPseudoBaseProcedure, IsPseudoBaseFunction,
191 IsMathType, IsOrdinalType, IsRealType,
192 IsBaseType, GetBaseTypeMinMax, ActivationPointer ;
193
194FROM M2System IMPORT IsPseudoSystemFunction, IsPseudoSystemProcedure,
195 IsSystemType, GetSystemTypeMinMax,
196 IsPseudoSystemFunctionConstExpression,
197 IsGenericSystemType,
198 Adr, TSize, TBitSize, AddAdr, SubAdr, DifAdr, Cast,
199 Shift, Rotate, MakeAdr, Address, Byte, Word, Loc, Throw ;
200
201FROM M2Size IMPORT Size ;
202FROM M2Bitset IMPORT Bitset ;
203
204FROM M2ALU IMPORT PushInt, Gre, Less, PushNulSet, AddBitRange, AddBit,
205 IsGenericNulSet, IsValueAndTreeKnown, AddField,
206 AddElements, ChangeToConstructor ;
207
208FROM Lists IMPORT List, InitList, GetItemFromList, NoOfItemsInList, PutItemIntoList,
209 IsItemInList, KillList, IncludeItemIntoList ;
210
211FROM M2Options IMPORT NilChecking,
212 WholeDivChecking, WholeValueChecking,
213 IndexChecking, RangeChecking,
214 CaseElseChecking, ReturnChecking,
215 UnusedVariableChecking, UnusedParameterChecking,
216 Iso, Pim, Pim2, Pim3, Pim4, PositiveModFloorDiv,
217 Pedantic, CompilerDebugging, GenerateDebugging,
218 GenerateLineDebug, Exceptions,
219 Profiling, Coding, Optimizing,
b0762d4c 220 UninitVariableChecking,
1eee94d3 221 ScaffoldDynamic, ScaffoldStatic, cflag,
573dbd51 222 ScaffoldMain, SharedFlag, WholeProgram,
48d49200 223 GetDumpDir, GetM2DumpFilter,
1bafa6a3 224 GetRuntimeModuleOverride, GetDebugTraceQuad,
eadd05d5 225 GetDumpQuad ;
1eee94d3 226
48d49200 227FROM M2LangDump IMPORT CreateDumpQuad, CloseDumpQuad, GetDumpFile ;
1eee94d3
GM		 228FROM M2Pass IMPORT IsPassCodeGeneration, IsNoPass ;
229
230FROM M2StackAddress IMPORT StackOfAddress, InitStackAddress, KillStackAddress,
231 PushAddress, PopAddress, PeepAddress,
232 IsEmptyAddress, NoOfItemsInStackAddress ;
233
234FROM M2StackWord IMPORT StackOfWord, InitStackWord, KillStackWord,
235 PushWord, PopWord, PeepWord, RemoveTop,
236 IsEmptyWord, NoOfItemsInStackWord ;
237
3cdaa649
GM		 238FROM Indexing IMPORT Index, InitIndex, GetIndice, PutIndice, InBounds, HighIndice,
239 IncludeIndiceIntoIndex, InitIndexTuned ;
1eee94d3
GM		 240
241FROM M2Range IMPORT InitAssignmentRangeCheck,
242 InitReturnRangeCheck,
243 InitSubrangeRangeCheck,
244 InitStaticArraySubscriptRangeCheck,
245 InitDynamicArraySubscriptRangeCheck,
246 InitIncRangeCheck,
247 InitDecRangeCheck,
248 InitInclCheck,
249 InitExclCheck,
250 InitRotateCheck,
251 InitShiftCheck,
252 InitTypesAssignmentCheck,
253 InitTypesExpressionCheck,
254 InitTypesParameterCheck,
255 InitForLoopBeginRangeCheck,
256 InitForLoopToRangeCheck,
257 InitForLoopEndRangeCheck,
258 InitPointerRangeCheck,
259 InitNoReturnRangeCheck,
260 InitNoElseRangeCheck,
261 InitCaseBounds,
262 InitWholeZeroDivisionCheck,
263 InitWholeZeroRemainderCheck,
264 InitParameterRangeCheck,
161a67b2 265 PutRangeForIncrement,
1eee94d3
GM		 266 WriteRangeCheck ;
267
268FROM M2CaseList IMPORT PushCase, PopCase, AddRange, BeginCaseList, EndCaseList, ElseCase ;
269FROM PCSymBuild IMPORT SkipConst ;
270FROM m2builtins IMPORT GetBuiltinTypeInfoType ;
48d49200 271FROM M2LangDump IMPORT IsDumpRequired ;
1eee94d3 272
48d49200 273IMPORT M2Error, FIO, SFIO, DynamicStrings, StdIO ;
1eee94d3
GM		 274
275
276CONST
277 DebugStackOn = TRUE ;
278 DebugVarients = FALSE ;
eadd05d5 279 BreakAtQuad = 140 ;
1eee94d3
GM		 280 DebugTokPos = FALSE ;
281
282TYPE
b0762d4c
GM		 283 ConstructorFrame = POINTER TO RECORD
284 type : CARDINAL ;
285 index: CARDINAL ;
286 END ;
1eee94d3
GM		 287
288 BoolFrame = POINTER TO RECORD
289 TrueExit : CARDINAL ;
290 FalseExit : CARDINAL ;
291 Unbounded : CARDINAL ;
292 BooleanOp : BOOLEAN ;
293 Dimension : CARDINAL ;
294 ReadWrite : CARDINAL ;
295 name : CARDINAL ;
296 Annotation: String ;
297 tokenno : CARDINAL ;
298 END ;
299
300 QuadFrame = POINTER TO RECORD
301 Operator : QuadOperator ;
302 Operand1 : CARDINAL ;
303 Operand2 : CARDINAL ;
304 Operand3 : CARDINAL ;
b80e3c46 305 Trash : CARDINAL ;
ac7c9954
GM		 306 Next : CARDINAL ; (* Next quadruple. *)
307 LineNo : CARDINAL ; (* Line No of source text. *)
308 TokenNo : CARDINAL ; (* Token No of source text. *)
309 NoOfTimesReferenced: CARDINAL ; (* No of times quad is referenced. *)
4e3c8257
GM		 310 ConstExpr, (* Must backend resolve this at *)
311 (* compile time? *)
161a67b2 312 CheckType,
ac7c9954 313 CheckOverflow : BOOLEAN ; (* should backend check overflow *)
1eee94d3
GM		 314 op1pos,
315 op2pos,
ac7c9954 316 op3pos : CARDINAL ; (* Token position of operands. *)
1eee94d3
GM		 317 END ;
318
319 WithFrame = POINTER TO RECORD
320 RecordSym : CARDINAL ;
321 RecordType : CARDINAL ;
322 RecordRef : CARDINAL ;
c787f593
GM		 323 rw : CARDINAL ; (* The record variable. *)
324 RecordTokPos: CARDINAL ; (* Token of the record. *)
1eee94d3
GM		 325 END ;
326
327 ForLoopInfo = POINTER TO RECORD
328 IncrementQuad,
ac7c9954
GM		 329 StartOfForLoop, (* We keep a list of all for *)
330 EndOfForLoop, (* loops so we can check index. *)
1eee94d3 331 ForLoopIndex,
ac7c9954
GM		 332 IndexTok : CARDINAL ; (* Used to ensure iterators are not *)
333 (* user modified. *)
1eee94d3
GM		 334 END ;
335
336 LineNote = POINTER TO RECORD
337 Line: CARDINAL ;
338 File: Name ;
339 Next: LineNote ;
340 END ;
341VAR
342 ConstructorStack,
343 LineStack,
344 BoolStack,
345 WithStack : StackOfAddress ;
346 TryStack,
347 CatchStack,
348 ExceptStack,
4e3c8257
GM		 349 ConstExprStack,
350 ConstParamStack,
1eee94d3
GM		 351 AutoStack,
352 RepeatStack,
353 WhileStack,
354 ForStack,
355 ExitStack,
c787f593
GM		 356 ReturnStack : StackOfWord ; (* Return quadruple of the procedure. *)
357 PriorityStack : StackOfWord ; (* Temporary variable holding old *)
358 (* priority. *)
1eee94d3
GM		 359 SuppressWith : BOOLEAN ;
360 QuadArray : Index ;
361 NextQuad : CARDINAL ; (* Next quadruple number to be created. *)
362 FreeList : CARDINAL ; (* FreeList of quadruples. *)
363 CurrentProc : CARDINAL ; (* Current procedure being compiled, used *)
ac7c9954 364 (* to determine which procedure a RETURN. *)
1eee94d3
GM		 365 (* ReturnValueOp must have as its 3rd op. *)
366 InitQuad : CARDINAL ; (* Initial Quad BackPatch that starts the *)
367 (* suit of Modules. *)
368 LastQuadNo : CARDINAL ; (* Last Quadruple accessed by GetQuad. *)
ac7c9954 369 ArithPlusTok, (* Internal + token for arithmetic only. *)
1eee94d3
GM		 370 LogicalOrTok, (* Internal _LOR token. *)
371 LogicalAndTok, (* Internal _LAND token. *)
372 LogicalXorTok, (* Internal _LXOR token. *)
373 LogicalDifferenceTok : Name ; (* Internal _LDIFF token. *)
374 InConstExpression,
4e3c8257 375 InConstParameters,
ac7c9954
GM		 376 IsAutoOn, (* Should parser automatically push *)
377 (* idents? *)
1eee94d3 378 MustNotCheckBounds : BOOLEAN ;
ac7c9954
GM		 379 ForInfo : Index ; (* Start and end of all FOR loops. *)
380 GrowInitialization : CARDINAL ; (* Upper limit of where the initialized *)
1eee94d3
GM		 381 (* quadruples. *)
382 BuildingHigh,
383 BuildingSize,
ac7c9954
GM		 384 QuadrupleGeneration : BOOLEAN ; (* Should we be generating quadruples? *)
385 FreeLineList : LineNote ; (* Free list of line notes. *)
386 VarientFields : List ; (* The list of all varient fields created. *)
387 VarientFieldNo : CARDINAL ; (* Used to retrieve the VarientFields *)
1eee94d3
GM		 388 (* in order. *)
389 NoOfQuads : CARDINAL ; (* Number of used quadruples. *)
ac7c9954 390 Head : CARDINAL ; (* Head of the list of quadruples. *)
1eee94d3
GM		 391
392
393(*
394 Rules for file and initialization quadruples:
395
396 StartModFileOp - indicates that this file (module) has produced the
397 following code
398 StartDefFileOp - indicates that this definition module has produced
399 this code.
400 EndFileOp - indicates that a module has finished
401 InitStartOp - the start of the initialization code of a module
402 InitEndOp - the end of the above
403 FinallyStartOp - the start of the finalization code of a module
404 FinallyEndOp - the end of the above
405*)
406
407
408(*
409#define InitString(X) InitStringDB(X, __FILE__, __LINE__)
410#define InitStringCharStar(X) InitStringCharStarDB(X, __FILE__, __LINE__)
411#define InitStringChar(X) InitStringCharDB(X, __FILE__, __LINE__)
412#define Mult(X,Y) MultDB(X, Y, __FILE__, __LINE__)
413#define Dup(X) DupDB(X, __FILE__, __LINE__)
414#define Slice(X,Y,Z) SliceDB(X, Y, Z, __FILE__, __LINE__)
415*)
416
417
418(*
419 doDSdbEnter -
420*)
421
422(*
423PROCEDURE doDSdbEnter ;
424BEGIN
425 PushAllocation
426END doDSdbEnter ;
427*)
428
429(*
430 doDSdbExit -
431*)
432
433(*
434PROCEDURE doDSdbExit (s: String) ;
435BEGIN
436 s := PopAllocationExemption(TRUE, s)
437END doDSdbExit ;
438*)
439
440(*
441 DSdbEnter -
442*)
443
444PROCEDURE DSdbEnter ;
445BEGIN
446END DSdbEnter ;
447
448
449(*
450 DSdbExit -
451*)
452
453PROCEDURE DSdbExit ;
454BEGIN
455END DSdbExit ;
456
457
458(*
459#define DBsbEnter doDBsbEnter
460#define DBsbExit doDBsbExit
461*)
462
463
464(*
465 SetOptionProfiling - builds a profile quadruple if the profiling
466 option was given to the compiler.
467*)
468
469PROCEDURE SetOptionProfiling (b: BOOLEAN) ;
470BEGIN
471 IF b#Profiling
472 THEN
473 IF b
474 THEN
475 BuildProfileOn
476 ELSE
477 BuildProfileOff
478 END ;
479 Profiling := b
480 END
481END SetOptionProfiling ;
482
483
484(*
485 SetOptionCoding - builds a code quadruple if the profiling
486 option was given to the compiler.
487*)
488
489PROCEDURE SetOptionCoding (b: BOOLEAN) ;
490BEGIN
491 IF b#Coding
492 THEN
493 IF b
494 THEN
495 BuildCodeOn
496 ELSE
497 BuildCodeOff
498 END ;
499 Coding := b
500 END
501END SetOptionCoding ;
502
503
504(*
505 SetOptionOptimizing - builds a quadruple to say that the optimization option
506 has been found in a comment.
507*)
508
509PROCEDURE SetOptionOptimizing (b: BOOLEAN) ;
510BEGIN
511 IF b
512 THEN
513 BuildOptimizeOn
514 ELSE
515 BuildOptimizeOff
516 END
517END SetOptionOptimizing ;
518
519
520(*
521 GetQF - returns the QuadFrame associated with, q.
522*)
523
524PROCEDURE GetQF (q: CARDINAL) : QuadFrame ;
525BEGIN
526 RETURN QuadFrame (GetIndice (QuadArray, q))
527END GetQF ;
528
529
530(*
531 Opposite - returns the opposite comparison operator.
532*)
533
534PROCEDURE Opposite (Operator: QuadOperator) : QuadOperator ;
535VAR
536 Op: QuadOperator ;
537BEGIN
538 CASE Operator OF
539
540 IfNotEquOp : Op := IfEquOp |
541 IfEquOp : Op := IfNotEquOp |
542 IfLessEquOp: Op := IfGreOp |
543 IfGreOp : Op := IfLessEquOp |
544 IfGreEquOp : Op := IfLessOp |
545 IfLessOp : Op := IfGreEquOp |
546 IfInOp : Op := IfNotInOp |
547 IfNotInOp : Op := IfInOp
548
549 ELSE
550 InternalError ('unexpected operator')
551 END ;
552 RETURN Op
553END Opposite ;
554
555
556(*
557 IsReferenced - returns true if QuadNo is referenced by another quadruple.
558*)
559
560PROCEDURE IsReferenced (QuadNo: CARDINAL) : BOOLEAN ;
561VAR
562 f: QuadFrame ;
563BEGIN
564 f := GetQF(QuadNo) ;
565 WITH f^ DO
566 RETURN( (Operator=ProcedureScopeOp) OR (Operator=NewLocalVarOp) OR
567 (NoOfTimesReferenced>0) )
568 END
569END IsReferenced ;
570
571
572(*
573 IsBackReference - returns TRUE if quadruple, q, is referenced from a quad further on.
574*)
575
576PROCEDURE IsBackReference (q: CARDINAL) : BOOLEAN ;
577VAR
578 i : CARDINAL ;
579 op : QuadOperator ;
580 op1, op2, op3: CARDINAL ;
581BEGIN
582 i := q ;
583 WHILE i#0 DO
584 GetQuad (i, op, op1, op2, op3) ;
585 CASE op OF
586
587 NewLocalVarOp,
588 KillLocalVarOp,
589 FinallyStartOp,
590 FinallyEndOp,
591 InitEndOp,
592 InitStartOp,
593 EndFileOp,
594 StartDefFileOp,
595 StartModFileOp: RETURN( FALSE ) | (* run into end of procedure or module *)
596
597 GotoOp,
598 IfEquOp,
599 IfLessEquOp,
600 IfGreEquOp,
601 IfGreOp,
602 IfLessOp,
603 IfNotEquOp,
604 IfInOp,
605 IfNotInOp : IF op3=q
606 THEN
607 RETURN( TRUE )
608 END
609
40b91158 610 ELSE
1eee94d3 611 END ;
a1afdc6e 612 i := GetNextQuad (i)
1eee94d3
GM		 613 END ;
614 InternalError ('fix this for the sake of efficiency..')
615END IsBackReference ;
616
617
618(*
619 IsUnConditional - returns true if QuadNo is an unconditional jump.
620*)
621
622PROCEDURE IsUnConditional (QuadNo: CARDINAL) : BOOLEAN ;
623VAR
624 f: QuadFrame ;
625BEGIN
626 f := GetQF(QuadNo) ;
627 WITH f^ DO
628 CASE Operator OF
629
630 ThrowOp,
631 RetryOp,
632 CallOp,
633 ReturnOp,
634 GotoOp : RETURN( TRUE )
635
636 ELSE
637 RETURN( FALSE )
638 END
639 END
640END IsUnConditional ;
641
642
643(*
644 IsConditional - returns true if QuadNo is a conditional jump.
645*)
646
647PROCEDURE IsConditional (QuadNo: CARDINAL) : BOOLEAN ;
648VAR
649 f: QuadFrame ;
650BEGIN
651 f := GetQF(QuadNo) ;
652 WITH f^ DO
653 CASE Operator OF
654
655 IfInOp,
656 IfNotInOp,
657 IfEquOp,
658 IfNotEquOp,
659 IfLessOp,
660 IfLessEquOp,
661 IfGreOp,
662 IfGreEquOp : RETURN( TRUE )
663
664 ELSE
665 RETURN( FALSE )
666 END ;
667 END
668END IsConditional ;
669
670
671(*
672 IsBackReferenceConditional - returns TRUE if quadruple, q, is referenced from
673 a conditional quad further on.
674*)
675
676PROCEDURE IsBackReferenceConditional (q: CARDINAL) : BOOLEAN ;
677VAR
678 i : CARDINAL ;
679 op : QuadOperator ;
680 op1, op2, op3: CARDINAL ;
681BEGIN
682 i := q ;
683 WHILE i#0 DO
684 GetQuad (i, op, op1, op2, op3) ;
685 CASE op OF
686
687 NewLocalVarOp,
688 KillLocalVarOp,
689 FinallyStartOp,
690 FinallyEndOp,
691 InitEndOp,
692 InitStartOp,
693 EndFileOp,
694 StartDefFileOp,
695 StartModFileOp: RETURN( FALSE ) | (* run into end of procedure or module *)
696
697 TryOp,
698 RetryOp,
699 GotoOp,
700 IfEquOp,
701 IfLessEquOp,
702 IfGreEquOp,
703 IfGreOp,
704 IfLessOp,
705 IfNotEquOp,
706 IfInOp,
707 IfNotInOp : IF (op3=q) AND IsConditional(q)
708 THEN
709 RETURN( TRUE )
710 END
711
89b58667
GM		 712 ELSE
713 RETURN FALSE
1eee94d3 714 END ;
a1afdc6e 715 i := GetNextQuad (i)
1eee94d3
GM		 716 END ;
717 InternalError ('fix this for the sake of efficiency..')
718END IsBackReferenceConditional ;
719
720
721(*
722 IsQuadA - returns true if QuadNo is a op.
723*)
724
725PROCEDURE IsQuadA (QuadNo: CARDINAL; op: QuadOperator) : BOOLEAN ;
726VAR
727 f: QuadFrame ;
728BEGIN
729 f := GetQF(QuadNo) ;
730 WITH f^ DO
731 RETURN( Operator=op )
732 END
733END IsQuadA ;
734
735
40b91158
GM		 736(*
737 IsGoto - returns true if QuadNo is a goto operation.
738*)
739
740PROCEDURE IsGoto (QuadNo: CARDINAL) : BOOLEAN ;
741BEGIN
742 RETURN( IsQuadA (QuadNo, GotoOp) )
743END IsGoto ;
744
745
1eee94d3
GM		 746(*
747 IsCall - returns true if QuadNo is a call operation.
748*)
749
750PROCEDURE IsCall (QuadNo: CARDINAL) : BOOLEAN ;
751BEGIN
752 RETURN( IsQuadA(QuadNo, CallOp) )
753END IsCall ;
754
755
756(*
757 IsReturn - returns true if QuadNo is a return operation.
758*)
759
760PROCEDURE IsReturn (QuadNo: CARDINAL) : BOOLEAN ;
761BEGIN
762 RETURN( IsQuadA(QuadNo, ReturnOp) )
763END IsReturn ;
764
765
766(*
767 IsNewLocalVar - returns true if QuadNo is a NewLocalVar operation.
768*)
769
770PROCEDURE IsNewLocalVar (QuadNo: CARDINAL) : BOOLEAN ;
771BEGIN
772 RETURN( IsQuadA(QuadNo, NewLocalVarOp) )
773END IsNewLocalVar ;
774
775
776(*
777 IsKillLocalVar - returns true if QuadNo is a KillLocalVar operation.
778*)
779
780PROCEDURE IsKillLocalVar (QuadNo: CARDINAL) : BOOLEAN ;
781BEGIN
782 RETURN( IsQuadA(QuadNo, KillLocalVarOp) )
783END IsKillLocalVar ;
784
785
786(*
787 IsProcedureScope - returns true if QuadNo is a ProcedureScope operation.
788*)
789
790PROCEDURE IsProcedureScope (QuadNo: CARDINAL) : BOOLEAN ;
791BEGIN
792 RETURN( IsQuadA(QuadNo, ProcedureScopeOp) )
793END IsProcedureScope ;
794
795
796(*
797 IsCatchBegin - returns true if QuadNo is a catch begin quad.
798*)
799
800PROCEDURE IsCatchBegin (QuadNo: CARDINAL) : BOOLEAN ;
801BEGIN
802 RETURN( IsQuadA(QuadNo, CatchBeginOp) )
803END IsCatchBegin ;
804
805
806(*
807 IsCatchEnd - returns true if QuadNo is a catch end quad.
808*)
809
810PROCEDURE IsCatchEnd (QuadNo: CARDINAL) : BOOLEAN ;
811BEGIN
812 RETURN( IsQuadA(QuadNo, CatchEndOp) )
813END IsCatchEnd ;
814
815
816(*
817 IsInitStart - returns true if QuadNo is a init start quad.
818*)
819
820PROCEDURE IsInitStart (QuadNo: CARDINAL) : BOOLEAN ;
821BEGIN
822 RETURN( IsQuadA(QuadNo, InitStartOp) )
823END IsInitStart ;
824
825
826(*
827 IsInitEnd - returns true if QuadNo is a init end quad.
828*)
829
830PROCEDURE IsInitEnd (QuadNo: CARDINAL) : BOOLEAN ;
831BEGIN
832 RETURN( IsQuadA(QuadNo, InitEndOp) )
833END IsInitEnd ;
834
835
836(*
837 IsFinallyStart - returns true if QuadNo is a finally start quad.
838*)
839
840PROCEDURE IsFinallyStart (QuadNo: CARDINAL) : BOOLEAN ;
841BEGIN
842 RETURN( IsQuadA(QuadNo, FinallyStartOp) )
843END IsFinallyStart ;
844
845
846(*
847 IsFinallyEnd - returns true if QuadNo is a finally end quad.
848*)
849
850PROCEDURE IsFinallyEnd (QuadNo: CARDINAL) : BOOLEAN ;
851BEGIN
852 RETURN( IsQuadA(QuadNo, FinallyEndOp) )
853END IsFinallyEnd ;
854
855
4e3c8257
GM		 856(*
857 IsBecomes - return TRUE if QuadNo is a BecomesOp.
858*)
859
860PROCEDURE IsBecomes (QuadNo: CARDINAL) : BOOLEAN ;
861BEGIN
862 RETURN IsQuadA (QuadNo, BecomesOp)
863END IsBecomes ;
864
865
866(*
867 IsDummy - return TRUE if QuadNo is a DummyOp.
868*)
869
870PROCEDURE IsDummy (QuadNo: CARDINAL) : BOOLEAN ;
871BEGIN
872 RETURN IsQuadA (QuadNo, DummyOp)
873END IsDummy ;
874
875
876(*
877 IsQuadConstExpr - returns TRUE if QuadNo is part of a constant expression.
878*)
879
880PROCEDURE IsQuadConstExpr (QuadNo: CARDINAL) : BOOLEAN ;
881VAR
882 f: QuadFrame ;
883BEGIN
884 f := GetQF (QuadNo) ;
885 RETURN f^.ConstExpr
886END IsQuadConstExpr ;
887
888
889(*
890 SetQuadConstExpr - sets the constexpr field to value.
891*)
892
893PROCEDURE SetQuadConstExpr (QuadNo: CARDINAL; value: BOOLEAN) ;
894VAR
895 f: QuadFrame ;
896BEGIN
897 f := GetQF (QuadNo) ;
898 f^.ConstExpr := value
899END SetQuadConstExpr ;
900
901
902(*
903 GetQuadDest - returns the jump destination associated with quad.
904*)
905
906PROCEDURE GetQuadDest (QuadNo: CARDINAL) : CARDINAL ;
907BEGIN
908 RETURN GetQuadOp3 (QuadNo)
909END GetQuadDest ;
910
911
912(*
913 GetQuadOp1 - returns the 1st operand associated with quad.
914*)
915
916PROCEDURE GetQuadOp1 (QuadNo: CARDINAL) : CARDINAL ;
917VAR
918 f: QuadFrame ;
919BEGIN
920 f := GetQF (QuadNo) ;
921 RETURN f^.Operand1
922END GetQuadOp1 ;
923
924
925(*
926 GetQuadOp2 - returns the 2nd operand associated with quad.
927*)
928
929PROCEDURE GetQuadOp2 (QuadNo: CARDINAL) : CARDINAL ;
930VAR
931 f: QuadFrame ;
932BEGIN
933 f := GetQF (QuadNo) ;
934 RETURN f^.Operand2
935END GetQuadOp2 ;
936
937
938(*
939 GetQuadOp3 - returns the 3rd operand associated with quad.
940*)
941
942PROCEDURE GetQuadOp3 (QuadNo: CARDINAL) : CARDINAL ;
943VAR
944 f: QuadFrame ;
945BEGIN
946 f := GetQF (QuadNo) ;
947 RETURN f^.Operand3
948END GetQuadOp3 ;
949
950
1eee94d3
GM		 951(*
952 IsInitialisingConst - returns TRUE if the quadruple is setting
953 a const (op1) with a value.
954*)
955
956PROCEDURE IsInitialisingConst (QuadNo: CARDINAL) : BOOLEAN ;
957VAR
958 op : QuadOperator ;
959 op1, op2, op3: CARDINAL ;
960BEGIN
961 GetQuad (QuadNo, op, op1, op2, op3) ;
962 CASE op OF
963
78b72ee5
GM		 964 StringConvertCnulOp,
965 StringConvertM2nulOp,
966 StringLengthOp,
1eee94d3
GM		 967 InclOp,
968 ExclOp,
969 UnboundedOp,
970 FunctValueOp,
971 NegateOp,
972 BecomesOp,
973 HighOp,
974 SizeOp,
975 AddrOp,
976 RecordFieldOp,
977 ArrayOp,
978 LogicalShiftOp,
979 LogicalRotateOp,
980 LogicalOrOp,
981 LogicalAndOp,
982 LogicalXorOp,
983 CoerceOp,
984 ConvertOp,
985 CastOp,
986 AddOp,
987 SubOp,
988 MultOp,
989 ModFloorOp,
990 DivCeilOp,
991 ModCeilOp,
992 DivFloorOp,
993 ModTruncOp,
994 DivTruncOp,
995 DivM2Op,
996 ModM2Op,
997 XIndrOp,
998 IndrXOp,
999 SaveExceptionOp,
1000 RestoreExceptionOp: RETURN( IsConst(op1) )
1001
1002 ELSE
1003 RETURN( FALSE )
1004 END
1005END IsInitialisingConst ;
1006
1007
1008(*
1009 IsOptimizeOn - returns true if the Optimize flag was true at QuadNo.
1010*)
1011
1012PROCEDURE IsOptimizeOn (QuadNo: CARDINAL) : BOOLEAN ;
1013VAR
1014 f : QuadFrame ;
1015 n,
1016 q : CARDINAL ;
1017 On: BOOLEAN ;
1018BEGIN
1019 On := Optimizing ;
1020 q := Head ;
1021 WHILE (q#0) AND (q#QuadNo) DO
1022 f := GetQF(q) ;
1023 WITH f^ DO
1024 IF Operator=OptimizeOnOp
1025 THEN
1026 On := TRUE
1027 ELSIF Operator=OptimizeOffOp
1028 THEN
1029 On := FALSE
1030 END ;
1031 n := Next
1032 END ;
1033 q := n
1034 END ;
1035 RETURN( On )
1036END IsOptimizeOn ;
1037
1038
1039(*
1040 IsProfileOn - returns true if the Profile flag was true at QuadNo.
1041*)
1042
1043PROCEDURE IsProfileOn (QuadNo: CARDINAL) : BOOLEAN ;
1044VAR
1045 f : QuadFrame ;
1046 n,
1047 q : CARDINAL ;
1048 On: BOOLEAN ;
1049BEGIN
1050 On := Profiling ;
1051 q := Head ;
1052 WHILE (q#0) AND (q#QuadNo) DO
1053 f := GetQF(q) ;
1054 WITH f^ DO
1055 IF Operator=ProfileOnOp
1056 THEN
1057 On := TRUE
1058 ELSIF Operator=ProfileOffOp
1059 THEN
1060 On := FALSE
1061 END ;
1062 n := Next
1063 END ;
1064 q := n
1065 END ;
1066 RETURN( On )
1067END IsProfileOn ;
1068
1069
1070(*
1071 IsCodeOn - returns true if the Code flag was true at QuadNo.
1072*)
1073
1074PROCEDURE IsCodeOn (QuadNo: CARDINAL) : BOOLEAN ;
1075VAR
1076 f : QuadFrame ;
1077 n,
1078 q : CARDINAL ;
1079 On: BOOLEAN ;
1080BEGIN
1081 On := Coding ;
1082 q := Head ;
1083 WHILE (q#0) AND (q#QuadNo) DO
1084 f := GetQF(q) ;
1085 WITH f^ DO
1086 IF Operator=CodeOnOp
1087 THEN
1088 On := TRUE
1089 ELSIF Operator=CodeOffOp
1090 THEN
1091 On := FALSE
1092 END ;
1093 n := Next
1094 END ;
1095 q := n
1096 END ;
1097 RETURN( On )
1098END IsCodeOn ;
1099
1100
1101(*
1102 IsDefOrModFile - returns TRUE if QuadNo is a start of Module or Def file
1103 directive.
1104*)
1105
1106PROCEDURE IsDefOrModFile (QuadNo: CARDINAL) : BOOLEAN ;
1107VAR
1108 f: QuadFrame ;
1109BEGIN
1110 f := GetQF(QuadNo) ;
1111 WITH f^ DO
1112 RETURN( (Operator=StartDefFileOp) OR (Operator=StartModFileOp) )
1113 END
1114END IsDefOrModFile ;
1115
1116
1117(*
1118 IsPseudoQuad - returns true if QuadNo is a compiler directive.
1119 ie code, profile and optimize.
1120 StartFile, EndFile,
1121*)
1122
1123PROCEDURE IsPseudoQuad (QuadNo: CARDINAL) : BOOLEAN ;
1124VAR
1125 f: QuadFrame ;
1126BEGIN
1127 f := GetQF(QuadNo) ;
1128 WITH f^ DO
1129 RETURN( (Operator=CodeOnOp) OR (Operator=CodeOffOp) OR
1130 (Operator=ProfileOnOp) OR (Operator=ProfileOffOp) OR
1131 (Operator=OptimizeOnOp) OR (Operator=OptimizeOffOp) OR
1132 (Operator=EndFileOp) OR
1133 (Operator=StartDefFileOp) OR (Operator=StartModFileOp)
1134 )
1135 END
1136END IsPseudoQuad ;
1137
1138
1139(*
1140 GetLastFileQuad - returns the Quadruple number of the last StartDefFile or
1141 StartModFile quadruple.
1142*)
1143
1144PROCEDURE GetLastFileQuad (QuadNo: CARDINAL) : CARDINAL ;
1145VAR
1146 f : QuadFrame ;
1147 q, i,
1148 FileQuad: CARDINAL ;
1149BEGIN
1150 q := Head ;
1151 FileQuad := 0 ;
1152 REPEAT
1153 f := GetQF(q) ;
1154 WITH f^ DO
1155 IF (Operator=StartModFileOp) OR (Operator=StartDefFileOp)
1156 THEN
1157 FileQuad := q
1158 END ;
1159 i := Next
1160 END ;
1161 q := i
1162 UNTIL (i=QuadNo) OR (i=0) ;
1163 Assert(i#0) ;
1164 Assert(FileQuad#0) ;
1165 RETURN( FileQuad )
1166END GetLastFileQuad ;
1167
1168
1169(*
1170 GetLastQuadNo - returns the last quadruple number referenced
1171 by a GetQuad.
1172*)
1173
1174PROCEDURE GetLastQuadNo () : CARDINAL ;
1175BEGIN
1176 RETURN( LastQuadNo )
1177END GetLastQuadNo ;
1178
1179
1180(*
1181 QuadToLineNo - Converts a QuadNo into the approprate line number of the
1182 source file, the line number is returned.
1183
1184 This may be used to yield an idea where abouts in the
1185 source file the code generetion is
1186 processing.
1187*)
1188
1189PROCEDURE QuadToLineNo (QuadNo: CARDINAL) : CARDINAL ;
1190VAR
1191 f: QuadFrame ;
1192BEGIN
1193 IF ((LastQuadNo=0) AND (NOT IsNoPass()) AND (NOT IsPassCodeGeneration())) OR
1194 (NOT InBounds(QuadArray, QuadNo))
1195 THEN
1196 RETURN( 0 )
1197 ELSE
1198 f := GetQF(QuadNo) ;
1199 RETURN( f^.LineNo )
1200 END
1201END QuadToLineNo ;
1202
1203
1204(*
1205 QuadToTokenNo - Converts a QuadNo into the approprate token number of the
1206 source file, the line number is returned.
1207
1208 This may be used to yield an idea where abouts in the
1209 source file the code generetion is
1210 processing.
1211*)
1212
1213PROCEDURE QuadToTokenNo (QuadNo: CARDINAL) : CARDINAL ;
1214VAR
1215 f: QuadFrame ;
1216BEGIN
1217 IF ((LastQuadNo=0) AND (NOT IsNoPass()) AND (NOT IsPassCodeGeneration())) OR
1218 (NOT InBounds(QuadArray, QuadNo))
1219 THEN
1220 RETURN( 0 )
1221 ELSE
1222 f := GetQF(QuadNo) ;
1223 RETURN( f^.TokenNo )
1224 END
1225END QuadToTokenNo ;
1226
1227
1228(*
1229 GetQuad - returns the Quadruple QuadNo.
1230*)
1231
1232PROCEDURE GetQuad (QuadNo: CARDINAL;
1233 VAR Op: QuadOperator;
1234 VAR Oper1, Oper2, Oper3: CARDINAL) ;
1235VAR
1236 f: QuadFrame ;
1237BEGIN
1238 f := GetQF(QuadNo) ;
1239 LastQuadNo := QuadNo ;
1240 WITH f^ DO
1241 Op := Operator ;
1242 Oper1 := Operand1 ;
1243 Oper2 := Operand2 ;
1244 Oper3 := Operand3
1245 END
1246END GetQuad ;
1247
1248
1249(*
1250 GetQuadtok - returns the Quadruple QuadNo.
1251*)
1252
1253PROCEDURE GetQuadtok (QuadNo: CARDINAL;
1254 VAR Op: QuadOperator;
1255 VAR Oper1, Oper2, Oper3: CARDINAL;
1256 VAR Op1Pos, Op2Pos, Op3Pos: CARDINAL) ;
1257VAR
1258 f: QuadFrame ;
1259BEGIN
b0762d4c 1260 f := GetQF (QuadNo) ;
1eee94d3
GM		 1261 LastQuadNo := QuadNo ;
1262 WITH f^ DO
1263 Op := Operator ;
1264 Oper1 := Operand1 ;
1265 Oper2 := Operand2 ;
1266 Oper3 := Operand3 ;
1267 Op1Pos := op1pos ;
1268 Op2Pos := op2pos ;
1269 Op3Pos := op3pos
1270 END
1271END GetQuadtok ;
1272
1273
1274(*
1275 GetQuadOtok - returns the Quadruple QuadNo.
1276*)
1277
1278PROCEDURE GetQuadOtok (QuadNo: CARDINAL;
1279 VAR tok: CARDINAL;
1280 VAR Op: QuadOperator;
1281 VAR Oper1, Oper2, Oper3: CARDINAL;
4e3c8257 1282 VAR overflowChecking, constExpr: BOOLEAN ;
1eee94d3
GM		 1283 VAR Op1Pos, Op2Pos, Op3Pos: CARDINAL) ;
1284VAR
1285 f: QuadFrame ;
1286BEGIN
b0762d4c 1287 f := GetQF (QuadNo) ;
1eee94d3
GM		 1288 LastQuadNo := QuadNo ;
1289 WITH f^ DO
1290 Op := Operator ;
1291 Oper1 := Operand1 ;
1292 Oper2 := Operand2 ;
1293 Oper3 := Operand3 ;
1294 Op1Pos := op1pos ;
1295 Op2Pos := op2pos ;
1296 Op3Pos := op3pos ;
b0762d4c 1297 tok := TokenNo ;
4e3c8257
GM		 1298 overflowChecking := CheckOverflow ;
1299 constExpr := ConstExpr
1eee94d3
GM		 1300 END
1301END GetQuadOtok ;
1302
1303
b0762d4c
GM		 1304(*
1305 PutQuadOtok - alters a quadruple QuadNo with Op, Oper1, Oper2, Oper3, and
1306 sets a boolean to determinine whether overflow should be checked.
1307*)
1308
1309PROCEDURE PutQuadOtok (QuadNo: CARDINAL;
1310 tok: CARDINAL;
1311 Op: QuadOperator;
1312 Oper1, Oper2, Oper3: CARDINAL;
4e3c8257 1313 overflowChecking, constExpr: BOOLEAN ;
b0762d4c
GM		 1314 Op1Pos, Op2Pos, Op3Pos: CARDINAL) ;
1315VAR
1316 f: QuadFrame ;
1317BEGIN
1318 IF QuadNo = BreakAtQuad
1319 THEN
1320 stop
1321 END ;
1322 IF QuadrupleGeneration
1323 THEN
1324 EraseQuad (QuadNo) ;
1325 AddQuadInformation (QuadNo, Op, Oper1, Oper2, Oper3) ;
1326 f := GetQF (QuadNo) ;
1327 WITH f^ DO
1328 Operator := Op ;
1329 Operand1 := Oper1 ;
1330 Operand2 := Oper2 ;
1331 Operand3 := Oper3 ;
1332 CheckOverflow := overflowChecking ;
1333 op1pos := Op1Pos ;
1334 op2pos := Op2Pos ;
1335 op3pos := Op3Pos ;
4e3c8257
GM		 1336 TokenNo := tok ;
1337 ConstExpr := constExpr
b0762d4c
GM		 1338 END
1339 END
1340END PutQuadOtok ;
1341
1342
1eee94d3
GM		 1343(*
1344 AddQuadInformation - adds variable analysis and jump analysis to the new quadruple.
1345*)
1346
1347PROCEDURE AddQuadInformation (QuadNo: CARDINAL;
1348 Op: QuadOperator;
1349 Oper1, Oper2, Oper3: CARDINAL) ;
1350BEGIN
1351 CASE Op OF
1352
1353 IfInOp,
1354 IfNotInOp,
1355 IfEquOp,
1356 IfNotEquOp,
1357 IfLessOp,
1358 IfLessEquOp,
1359 IfGreOp,
1360 IfGreEquOp : ManipulateReference(QuadNo, Oper3) ;
1361 CheckAddVariableRead(Oper1, FALSE, QuadNo) ;
1362 CheckAddVariableRead(Oper2, FALSE, QuadNo) |
1363
1364 TryOp,
1365 RetryOp,
1366 GotoOp : ManipulateReference(QuadNo, Oper3) |
1367
1368 (* variable references *)
1369
1370 InclOp,
1371 ExclOp : CheckConst(Oper1) ;
1372 CheckAddVariableRead(Oper3, FALSE, QuadNo) ;
1373 CheckAddVariableWrite(Oper1, TRUE, QuadNo) |
1374 UnboundedOp,
1375 FunctValueOp,
1376 NegateOp,
1377 BecomesOp,
1378 HighOp,
1379 SizeOp : CheckConst(Oper1) ;
1380 CheckAddVariableWrite(Oper1, FALSE, QuadNo) ;
1381 CheckAddVariableRead(Oper3, FALSE, QuadNo) |
1382 AddrOp : CheckConst(Oper1) ;
1383 CheckAddVariableWrite(Oper1, FALSE, QuadNo) ;
1384 (* CheckAddVariableReadLeftValue(Oper3, QuadNo) *)
1385 (* the next line is a kludge and assumes we _will_
1386 write to the variable as we have taken its address *)
1387 CheckRemoveVariableWrite(Oper1, TRUE, QuadNo) |
1388 ReturnValueOp : CheckAddVariableRead(Oper1, FALSE, QuadNo) |
1389 ReturnOp,
1390 NewLocalVarOp,
1391 KillLocalVarOp : |
1392 CallOp : CheckAddVariableRead(Oper3, TRUE, QuadNo) |
1393
1394 ParamOp : CheckAddVariableRead(Oper2, FALSE, QuadNo) ;
1395 CheckAddVariableRead(Oper3, FALSE, QuadNo) ;
1396 IF (Oper1>0) AND (Oper1<=NoOfParam(Oper2)) AND
1397 IsVarParam(Oper2, Oper1)
1398 THEN
1399 (* _may_ also write to a var parameter, although we dont know *)
1400 CheckAddVariableWrite(Oper3, TRUE, QuadNo)
1401 END |
1402 RecordFieldOp,
1403 ArrayOp,
1404 LogicalShiftOp,
1405 LogicalRotateOp,
1406 LogicalOrOp,
1407 LogicalAndOp,
1408 LogicalXorOp,
1409 CoerceOp,
1410 ConvertOp,
1411 CastOp,
1412 AddOp,
1413 SubOp,
1414 MultOp,
1415 DivM2Op,
1416 ModM2Op,
1417 ModFloorOp,
1418 DivCeilOp,
1419 ModCeilOp,
1420 DivFloorOp,
1421 ModTruncOp,
1422 DivTruncOp : CheckConst(Oper1) ;
1423 CheckAddVariableWrite(Oper1, FALSE, QuadNo) ;
1424 CheckAddVariableRead(Oper2, FALSE, QuadNo) ;
1425 CheckAddVariableRead(Oper3, FALSE, QuadNo) |
1426
1427 XIndrOp : CheckConst(Oper1) ;
1428 CheckAddVariableWrite(Oper1, TRUE, QuadNo) ;
1429 CheckAddVariableRead(Oper3, FALSE, QuadNo) |
1430
1431 IndrXOp : CheckConst(Oper1) ;
1432 CheckAddVariableWrite(Oper1, FALSE, QuadNo) ;
1433 CheckAddVariableRead(Oper3, TRUE, QuadNo) |
1434
1435(* RangeCheckOp : CheckRangeAddVariableRead(Oper3, QuadNo) | *)
1436 SaveExceptionOp : CheckConst(Oper1) ;
1437 CheckAddVariableWrite(Oper1, FALSE, QuadNo) |
1438 RestoreExceptionOp: CheckAddVariableRead(Oper1, FALSE, QuadNo)
1439
1440 ELSE
1441 END
1442END AddQuadInformation ;
1443
1444
1445PROCEDURE stop ; BEGIN END stop ;
1446
1447
1448(*
1449 PutQuadO - alters a quadruple QuadNo with Op, Oper1, Oper2, Oper3, and
1450 sets a boolean to determinine whether overflow should be checked.
1451*)
1452
1453PROCEDURE PutQuadO (QuadNo: CARDINAL;
1454 Op: QuadOperator;
1455 Oper1, Oper2, Oper3: CARDINAL;
1456 overflow: BOOLEAN) ;
161a67b2
GM		 1457BEGIN
1458 PutQuadOType (QuadNo, Op, Oper1, Oper2, Oper3, overflow, TRUE)
1459END PutQuadO ;
1460
1461
1462(*
1463 PutQuadOType -
1464*)
1465
1466PROCEDURE PutQuadOType (QuadNo: CARDINAL;
1467 Op: QuadOperator;
1468 Oper1, Oper2, Oper3: CARDINAL;
1469 overflow, checktype: BOOLEAN) ;
1eee94d3
GM		 1470VAR
1471 f: QuadFrame ;
1472BEGIN
1473 IF QuadNo = BreakAtQuad
1474 THEN
1475 stop
1476 END ;
1477 IF QuadrupleGeneration
1478 THEN
1479 EraseQuad (QuadNo) ;
1480 AddQuadInformation (QuadNo, Op, Oper1, Oper2, Oper3) ;
1481 f := GetQF (QuadNo) ;
1482 WITH f^ DO
1483 Operator := Op ;
1484 Operand1 := Oper1 ;
1485 Operand2 := Oper2 ;
1486 Operand3 := Oper3 ;
161a67b2 1487 CheckOverflow := overflow ;
4e3c8257
GM		 1488 CheckType := checktype ;
1489 ConstExpr := IsInConstExpression ()
1eee94d3
GM		 1490 END
1491 END
161a67b2 1492END PutQuadOType ;
1eee94d3
GM		 1493
1494
1495(*
1496 PutQuad - overwrites a quadruple QuadNo with Op, Oper1, Oper2, Oper3
1497*)
1498
1499PROCEDURE PutQuad (QuadNo: CARDINAL;
1500 Op: QuadOperator;
1501 Oper1, Oper2, Oper3: CARDINAL) ;
1502BEGIN
1503 PutQuadO (QuadNo, Op, Oper1, Oper2, Oper3, TRUE)
1504END PutQuad ;
1505
1506
161a67b2 1507(*
4e3c8257 1508 GetQuadOTypetok - returns the fields associated with quadruple QuadNo.
161a67b2
GM		 1509*)
1510
1511PROCEDURE GetQuadOTypetok (QuadNo: CARDINAL;
1512 VAR tok: CARDINAL;
1513 VAR Op: QuadOperator;
1514 VAR Oper1, Oper2, Oper3: CARDINAL;
4e3c8257 1515 VAR overflowChecking, typeChecking, constExpr: BOOLEAN ;
161a67b2
GM		 1516 VAR Op1Pos, Op2Pos, Op3Pos: CARDINAL) ;
1517VAR
1518 f: QuadFrame ;
1519BEGIN
1520 f := GetQF (QuadNo) ;
1521 LastQuadNo := QuadNo ;
1522 WITH f^ DO
1523 Op := Operator ;
1524 Oper1 := Operand1 ;
1525 Oper2 := Operand2 ;
1526 Oper3 := Operand3 ;
1527 Op1Pos := op1pos ;
1528 Op2Pos := op2pos ;
1529 Op3Pos := op3pos ;
1530 tok := TokenNo ;
1531 overflowChecking := CheckOverflow ;
4e3c8257
GM		 1532 typeChecking := CheckType ;
1533 constExpr := ConstExpr
161a67b2
GM		 1534 END
1535END GetQuadOTypetok ;
1536
1537
1eee94d3
GM		 1538(*
1539 UndoReadWriteInfo -
1540*)
1541
1542PROCEDURE UndoReadWriteInfo (QuadNo: CARDINAL;
1543 Op: QuadOperator;
1544 Oper1, Oper2, Oper3: CARDINAL) ;
1545BEGIN
1546 CASE Op OF
1547
1548 (* jumps, calls and branches *)
1549 IfInOp,
1550 IfNotInOp,
1551 IfEquOp,
1552 IfNotEquOp,
1553 IfLessOp,
1554 IfLessEquOp,
1555 IfGreOp,
1556 IfGreEquOp : RemoveReference(QuadNo) ;
1557 CheckRemoveVariableRead(Oper1, FALSE, QuadNo) ;
1558 CheckRemoveVariableRead(Oper2, FALSE, QuadNo) |
1559
1560 TryOp,
1561 RetryOp,
1562 GotoOp : RemoveReference(QuadNo) |
1563
1564 (* variable references *)
1565
1566 InclOp,
1567 ExclOp : CheckRemoveVariableRead(Oper1, FALSE, QuadNo) ;
1568 CheckRemoveVariableWrite(Oper1, TRUE, QuadNo) |
1569
1570 UnboundedOp,
1571 FunctValueOp,
1572 NegateOp,
1573 BecomesOp,
1574 HighOp,
1575 SizeOp : CheckRemoveVariableWrite(Oper1, FALSE, QuadNo) ;
1576 CheckRemoveVariableRead(Oper3, FALSE, QuadNo) |
1577 AddrOp : CheckRemoveVariableWrite(Oper1, FALSE, QuadNo) ;
1578 (* CheckRemoveVariableReadLeftValue(Oper3, QuadNo) ; *)
1579 (* the next line is a kludge and assumes we _will_
1580 write to the variable as we have taken its address *)
1581 CheckRemoveVariableWrite(Oper1, TRUE, QuadNo) |
1582 ReturnValueOp : CheckRemoveVariableRead(Oper1, FALSE, QuadNo) |
1583 ReturnOp,
1584 CallOp,
1585 NewLocalVarOp,
1586 KillLocalVarOp : |
1587 ParamOp : CheckRemoveVariableRead(Oper2, FALSE, QuadNo) ;
1588 CheckRemoveVariableRead(Oper3, FALSE, QuadNo) ;
1589 IF (Oper1>0) AND (Oper1<=NoOfParam(Oper2)) AND
1590 IsVarParam(Oper2, Oper1)
1591 THEN
1592 (* _may_ also write to a var parameter, although we dont know *)
1593 CheckRemoveVariableWrite(Oper3, TRUE, QuadNo)
1594 END |
1595 RecordFieldOp,
1596 ArrayOp,
1597 LogicalShiftOp,
1598 LogicalRotateOp,
1599 LogicalOrOp,
1600 LogicalAndOp,
1601 LogicalXorOp,
1602 CoerceOp,
1603 ConvertOp,
1604 CastOp,
1605 AddOp,
1606 SubOp,
1607 MultOp,
1608 DivM2Op,
1609 ModM2Op,
1610 ModFloorOp,
1611 DivCeilOp,
1612 ModCeilOp,
1613 DivFloorOp,
1614 ModTruncOp,
1615 DivTruncOp : CheckRemoveVariableWrite(Oper1, FALSE, QuadNo) ;
1616 CheckRemoveVariableRead(Oper2, FALSE, QuadNo) ;
1617 CheckRemoveVariableRead(Oper3, FALSE, QuadNo) |
1618
1619 XIndrOp : CheckRemoveVariableWrite(Oper1, TRUE, QuadNo) ;
1620 CheckRemoveVariableRead(Oper3, FALSE, QuadNo) |
1621
1622 IndrXOp : CheckRemoveVariableWrite(Oper1, FALSE, QuadNo) ;
1623 CheckRemoveVariableRead(Oper3, TRUE, QuadNo) |
1624
1625(* RangeCheckOp : CheckRangeRemoveVariableRead(Oper3, QuadNo) | *)
1626 SaveExceptionOp : CheckRemoveVariableWrite(Oper1, FALSE, QuadNo) |
1627 RestoreExceptionOp: CheckRemoveVariableRead(Oper1, FALSE, QuadNo)
1628
1629 ELSE
1630 END
1631END UndoReadWriteInfo ;
1632
1633
1634(*
1635 EraseQuad - erases a quadruple QuadNo, the quadruple is still in the list
1636 but wiped clean.
1637*)
1638
1639PROCEDURE EraseQuad (QuadNo: CARDINAL) ;
1640VAR
1641 f: QuadFrame ;
1642BEGIN
1643 f := GetQF(QuadNo) ;
1644 WITH f^ DO
1645 UndoReadWriteInfo(QuadNo, Operator, Operand1, Operand2, Operand3) ;
1646 Operator := DummyOp ; (* finally blank it out *)
1647 Operand1 := 0 ;
1648 Operand2 := 0 ;
1649 Operand3 := 0 ;
b80e3c46 1650 Trash := 0 ;
1eee94d3
GM		 1651 op1pos := UnknownTokenNo ;
1652 op2pos := UnknownTokenNo ;
4e3c8257
GM		 1653 op3pos := UnknownTokenNo ;
1654 ConstExpr := FALSE
1eee94d3
GM		 1655 END
1656END EraseQuad ;
1657
1658
1659(*
1660 CheckAddVariableReadLeftValue -
1661*)
1662
1663(*
1664PROCEDURE CheckAddVariableReadLeftValue (sym: CARDINAL; q: CARDINAL) ;
1665BEGIN
1666 IF IsVar(sym)
1667 THEN
1668 PutReadQuad(sym, LeftValue, q)
1669 END
1670END CheckAddVariableReadLeftValue ;
1671*)
1672
1673
1674(*
1675 CheckRemoveVariableReadLeftValue -
1676*)
1677
1678(*
1679PROCEDURE CheckRemoveVariableReadLeftValue (sym: CARDINAL; q: CARDINAL) ;
1680BEGIN
1681 IF IsVar(sym)
1682 THEN
1683 RemoveReadQuad(sym, LeftValue, q)
1684 END
1685END CheckRemoveVariableReadLeftValue ;
1686*)
1687
1688
1689(*
1690 CheckAddVariableRead - checks to see whether symbol, Sym, is a variable or
1691 a parameter and if so it then adds this quadruple
1692 to the variable list.
1693*)
1694
1695PROCEDURE CheckAddVariableRead (Sym: CARDINAL; canDereference: BOOLEAN; Quad: CARDINAL) ;
1696BEGIN
1697 IF IsVar(Sym)
1698 THEN
1699 PutReadQuad(Sym, GetMode(Sym), Quad) ;
1700 IF (GetMode(Sym)=LeftValue) AND canDereference
1701 THEN
1702 PutReadQuad(Sym, RightValue, Quad)
1703 END
1704 END
1705END CheckAddVariableRead ;
1706
1707
1708(*
1709 CheckRemoveVariableRead - checks to see whether, Sym, is a variable or
1710 a parameter and if so then it removes the
1711 quadruple from the variable list.
1712*)
1713
1714PROCEDURE CheckRemoveVariableRead (Sym: CARDINAL; canDereference: BOOLEAN; Quad: CARDINAL) ;
1715BEGIN
1716 IF IsVar(Sym)
1717 THEN
1718 RemoveReadQuad(Sym, GetMode(Sym), Quad) ;
1719 IF (GetMode(Sym)=LeftValue) AND canDereference
1720 THEN
1721 RemoveReadQuad(Sym, RightValue, Quad)
1722 END
1723 END
1724END CheckRemoveVariableRead ;
1725
1726
1727(*
1728 CheckAddVariableWrite - checks to see whether symbol, Sym, is a variable and
1729 if so it then adds this quadruple to the variable list.
1730*)
1731
1732PROCEDURE CheckAddVariableWrite (Sym: CARDINAL; canDereference: BOOLEAN; Quad: CARDINAL) ;
1733BEGIN
1734 IF IsVar(Sym)
1735 THEN
1736 IF (GetMode(Sym)=LeftValue) AND canDereference
1737 THEN
1738 PutReadQuad(Sym, LeftValue, Quad) ;
1739 PutWriteQuad(Sym, RightValue, Quad)
1740 ELSE
1741 PutWriteQuad(Sym, GetMode(Sym), Quad)
1742 END
1743 END
1744END CheckAddVariableWrite ;
1745
1746
1747(*
1748 CheckRemoveVariableWrite - checks to see whether, Sym, is a variable and
1749 if so then it removes the quadruple from the
1750 variable list.
1751*)
1752
1753PROCEDURE CheckRemoveVariableWrite (Sym: CARDINAL; canDereference: BOOLEAN; Quad: CARDINAL) ;
1754BEGIN
1755 IF IsVar(Sym)
1756 THEN
1757 IF (GetMode(Sym)=LeftValue) AND canDereference
1758 THEN
1759 RemoveReadQuad(Sym, LeftValue, Quad) ;
1760 RemoveWriteQuad(Sym, RightValue, Quad)
1761 ELSE
1762 RemoveWriteQuad(Sym, GetMode(Sym), Quad)
1763 END
1764 END
1765END CheckRemoveVariableWrite ;
1766
1767
1768(*
1769 CheckConst -
1770*)
1771
1772PROCEDURE CheckConst (sym: CARDINAL) ;
1773BEGIN
1774 IF IsConst(sym)
1775 THEN
1776 PutToBeSolvedByQuads(sym)
1777 END
1778END CheckConst ;
1779
1780
1781(*
1782 GetFirstQuad - returns the first quadruple.
1783*)
1784
1785PROCEDURE GetFirstQuad () : CARDINAL ;
1786BEGIN
1787 RETURN( Head )
1788END GetFirstQuad ;
1789
1790
1791(*
1792 GetNextQuad - returns the Quadruple number following QuadNo.
1793*)
1794
1795PROCEDURE GetNextQuad (QuadNo: CARDINAL) : CARDINAL ;
1796VAR
1797 f: QuadFrame ;
1798BEGIN
1799 f := GetQF(QuadNo) ;
1800 RETURN( f^.Next )
1801END GetNextQuad ;
1802
1803
1804(*
1805 SubQuad - subtracts a quadruple QuadNo from a list Head.
1806*)
1807
1808PROCEDURE SubQuad (QuadNo: CARDINAL) ;
1809VAR
1810 i : CARDINAL ;
1811 f, g: QuadFrame ;
1812BEGIN
1813 f := GetQF(QuadNo) ;
1814 WITH f^ DO
1815 AlterReference(Head, QuadNo, f^.Next) ;
1816 UndoReadWriteInfo(QuadNo, Operator, Operand1, Operand2, Operand3)
1817 END ;
1818 IF Head=QuadNo
1819 THEN
1820 Head := f^.Next
1821 ELSE
1822 i := Head ;
1823 g := GetQF(i) ;
1824 WHILE g^.Next#QuadNo DO
1825 i := g^.Next ;
1826 g := GetQF(i)
1827 END ;
1828 g^.Next := f^.Next
1829 END ;
1830 f^.Operator := DummyOp ;
1831 DEC(NoOfQuads)
1832END SubQuad ;
1833
1834
1835(*
1836 GetRealQuad - returns the Quadruple number of the real quadruple
1837 at QuadNo or beyond.
1838*)
1839
1840PROCEDURE GetRealQuad (QuadNo: CARDINAL) : CARDINAL ;
1841VAR
1842 f: QuadFrame ;
1843BEGIN
1844 WHILE QuadNo#0 DO
1845 IF InBounds(QuadArray, QuadNo)
1846 THEN
1847 f := GetQF(QuadNo) ;
1848 WITH f^ DO
1849 IF (NOT IsPseudoQuad(QuadNo)) AND
1850 (Operator#DummyOp) AND (Operator#LineNumberOp) AND (Operator#StatementNoteOp)
1851 THEN
1852 RETURN( QuadNo )
1853 END
1854 END ;
1855 INC(QuadNo)
1856 ELSE
1857 RETURN( 0 )
1858 END
1859 END ;
1860 RETURN( 0 )
1861END GetRealQuad ;
1862
1863
1864(*
1865 AlterReference - alters all references from OldQuad, to NewQuad in a
1866 quadruple list Head.
1867*)
1868
1869PROCEDURE AlterReference (Head, OldQuad, NewQuad: CARDINAL) ;
1870VAR
1871 f, g: QuadFrame ;
1872 i : CARDINAL ;
1873BEGIN
1874 f := GetQF(OldQuad) ;
1875 WHILE (f^.NoOfTimesReferenced>0) AND (Head#0) DO
1876 g := GetQF(Head) ;
1877 WITH g^ DO
1878 CASE Operator OF
1879
1880 IfInOp,
1881 IfNotInOp,
1882 IfEquOp,
1883 IfNotEquOp,
1884 IfLessOp,
1885 IfLessEquOp,
1886 IfGreOp,
1887 IfGreEquOp,
1888 TryOp,
1889 RetryOp,
1890 GotoOp : IF Operand3=OldQuad
1891 THEN
1892 ManipulateReference(Head, NewQuad)
1893 END
1894
1895 ELSE
1896 END ;
1897 i := Next
1898 END ;
1899 Head := i
1900 END
1901END AlterReference ;
1902
1903
1904(*
1905 GrowQuads - grows the list of quadruples to the quadruple, to.
1906*)
1907
1908PROCEDURE GrowQuads (to: CARDINAL) ;
1909VAR
1910 i: CARDINAL ;
1911 f: QuadFrame ;
1912BEGIN
1913 IF (to#0) AND (to>GrowInitialization)
1914 THEN
1915 i := GrowInitialization+1 ;
1916 WHILE i<=to DO
1917 IF InBounds(QuadArray, i)
1918 THEN
1919 Assert(GetIndice(QuadArray, i)#NIL)
1920 ELSE
1921 NEW(f) ;
1922 IF f=NIL
1923 THEN
1924 InternalError ('out of memory error when trying to allocate a quadruple')
1925 END ;
1926 PutIndice(QuadArray, i, f) ;
1927 f^.NoOfTimesReferenced := 0
1928 END ;
1929 INC(i)
1930 END ;
1931 GrowInitialization := to
1932 END
1933END GrowQuads ;
1934
1935
1936(*
1937 ManipulateReference - manipulates the quadruple, q, so that it now points to quad, to.
1938*)
1939
1940PROCEDURE ManipulateReference (q: CARDINAL; to: CARDINAL) ;
1941VAR
1942 f: QuadFrame ;
1943BEGIN
1944 Assert((GrowInitialization>=q) OR (to=0)) ;
1945 GrowQuads(to) ;
1946 RemoveReference(q) ;
1947 f := GetQF(q) ;
1948 f^.Operand3 := to ;
1949 IF to#0
1950 THEN
1951 f := GetQF(to) ;
1952 INC(f^.NoOfTimesReferenced)
1953 END
1954END ManipulateReference ;
1955
1956
1957(*
1958 RemoveReference - remove the reference by quadruple, q, to wherever
1959 it was pointing to.
1960*)
1961
1962PROCEDURE RemoveReference (q: CARDINAL) ;
1963VAR
1964 f, g: QuadFrame ;
1965BEGIN
1966 f := GetQF(q) ;
1967 IF (f^.Operand3#0) AND (f^.Operand3<NextQuad)
1968 THEN
1969 g := GetQF(f^.Operand3) ;
1970 Assert(g^.NoOfTimesReferenced#0) ;
1971 DEC(g^.NoOfTimesReferenced)
1972 END
1973END RemoveReference ;
1974
1975
1976(*
1977 CountQuads - returns the number of quadruples.
1978*)
1979
1980PROCEDURE CountQuads () : CARDINAL ;
1981BEGIN
1982 RETURN( NoOfQuads )
1983END CountQuads ;
1984
1985
1986(*
1987 NewQuad - sets QuadNo to a new quadruple.
1988*)
1989
1990PROCEDURE NewQuad (VAR QuadNo: CARDINAL) ;
1991VAR
1992 f: QuadFrame ;
1993BEGIN
1994 QuadNo := FreeList ;
1995 IF InBounds (QuadArray, QuadNo) AND (GetIndice (QuadArray, QuadNo) # NIL)
1996 THEN
1997 f := GetIndice (QuadArray, QuadNo)
1998 ELSE
1999 NEW (f) ;
2000 IF f=NIL
2001 THEN
2002 InternalError ('out of memory error trying to allocate a quadruple')
2003 ELSE
2004 INC (NoOfQuads) ;
2005 PutIndice (QuadArray, QuadNo, f) ;
2006 f^.NoOfTimesReferenced := 0
2007 END
2008 END ;
2009 WITH f^ DO
2010 Operator := DummyOp ;
2011 Operand3 := 0 ;
2012 Next := 0
2013 END ;
2014 INC (FreeList) ;
2015 IF GrowInitialization < FreeList
2016 THEN
2017 GrowInitialization := FreeList
2018 END
2019END NewQuad ;
2020
2021
2022(*
2023 CheckVariableAt - checks to see whether, sym, was declared at a particular address.
2024*)
2025
2026PROCEDURE CheckVariableAt (sym: CARDINAL) ;
2027BEGIN
2028 IF IsVar (sym) AND IsVariableAtAddress (sym)
2029 THEN
2030 IF GetMode (sym) = LeftValue
2031 THEN
2032 GenQuad (InitAddressOp, sym, NulSym, GetVariableAtAddress (sym))
2033 ELSE
2034 InternalError ('expecting lvalue for this variable which is declared at an explicit address')
2035 END
2036 END
2037END CheckVariableAt ;
2038
2039
2040(*
2041 CheckVariablesAt - checks to see whether we need to initialize any pointers
2042 which point to variable declared at addresses.
2043*)
2044
2045PROCEDURE CheckVariablesAt (scope: CARDINAL) ;
2046BEGIN
2047 ForeachLocalSymDo (scope, CheckVariableAt)
2048END CheckVariablesAt ;
2049
2050
2051(*
2052 GetTurnInterrupts - returns the TurnInterrupts procedure function.
2053*)
2054
2055PROCEDURE GetTurnInterrupts (tok: CARDINAL) : CARDINAL ;
2056BEGIN
2057 IF Iso
2058 THEN
2059 RETURN GetQualidentImport (tok,
2060 MakeKey ('TurnInterrupts'), MakeKey ('COROUTINES'))
2061 ELSE
2062 RETURN GetQualidentImport (tok,
2063 MakeKey ('TurnInterrupts'), MakeKey ('SYSTEM'))
2064 END
2065END GetTurnInterrupts ;
2066
2067
2068(*
2069 GetProtection - returns the PROTECTION data type.
2070*)
2071
2072PROCEDURE GetProtection (tok: CARDINAL) : CARDINAL ;
2073BEGIN
2074 IF Iso
2075 THEN
2076 RETURN GetQualidentImport (tok,
2077 MakeKey ('PROTECTION'), MakeKey ('COROUTINES'))
2078 ELSE
2079 RETURN GetQualidentImport (tok,
2080 MakeKey ('PROTECTION'), MakeKey ('SYSTEM'))
2081 END
2082END GetProtection ;
2083
2084
2085(*
2086 CheckNeedPriorityBegin - checks to see whether we need to save the old
2087 module priority and change to another module
2088 priority.
2089 The current module initialization or procedure
2090 being built is defined by, scope. The module whose
2091 priority will be used is defined by, module.
2092*)
2093
2094PROCEDURE CheckNeedPriorityBegin (tok: CARDINAL; scope, module: CARDINAL) ;
2095VAR
2096 ProcSym, old: CARDINAL ;
2097BEGIN
2098 IF GetPriority (module) # NulSym
2099 THEN
2100 (* module has been given a priority *)
2101 ProcSym := GetTurnInterrupts (tok) ;
2102 IF ProcSym # NulSym
2103 THEN
2104 old := MakeTemporary (tok, RightValue) ;
2105 PutVar (old, GetProtection (tok)) ;
2106
2107 GenQuadO (tok, SavePriorityOp, old, scope, ProcSym, FALSE) ;
2108 PushWord (PriorityStack, old)
2109 END
2110 END
2111END CheckNeedPriorityBegin ;
2112
2113
2114(*
2115 CheckNeedPriorityEnd - checks to see whether we need to restore the old
2116 module priority.
2117 The current module initialization or procedure
2118 being built is defined by, scope.
2119*)
2120
2121PROCEDURE CheckNeedPriorityEnd (tok: CARDINAL;
2122 scope, module: CARDINAL) ;
2123VAR
2124 ProcSym, old: CARDINAL ;
2125BEGIN
2126 IF GetPriority (module) # NulSym
2127 THEN
2128 (* module has been given a priority *)
2129 ProcSym := GetTurnInterrupts (tok) ;
2130 IF ProcSym # NulSym
2131 THEN
2132 old := PopWord (PriorityStack) ;
2133 GenQuad (RestorePriorityOp, old, scope, ProcSym)
2134 END
2135 END
2136END CheckNeedPriorityEnd ;
2137
2138
2139(*
2140 StartBuildDefFile - generates a StartFileDefOp quadruple indicating the file
2141 that has produced the subsequent quadruples.
2142 The code generator uses the StartDefFileOp quadruples
2143 to relate any error to the appropriate file.
2144
2145
2146 Entry Exit
2147 ===== ====
2148
2149
2150 Ptr -> <- Ptr
2151 +------------+ +------------+
2152 | ModuleName | | ModuleName |
2153 |------------| |------------|
2154
2155
2156 Quadruples Produced
2157
2158 q StartDefFileOp _ _ ModuleSym
2159*)
2160
2161PROCEDURE StartBuildDefFile (tok: CARDINAL) ;
2162VAR
2163 ModuleName: Name ;
2164BEGIN
2165 PopT (ModuleName) ;
2166 PushT (ModuleName) ;
2167 GenQuadO (tok, StartDefFileOp, tok, NulSym, GetModule (ModuleName), FALSE)
2168END StartBuildDefFile ;
2169
2170
2171(*
2172 StartBuildModFile - generates a StartModFileOp quadruple indicating the file
2173 that has produced the subsequent quadruples.
2174 The code generator uses the StartModFileOp quadruples
2175 to relate any error to the appropriate file.
2176
2177
2178 Entry Exit
2179 ===== ====
2180
2181
2182 Ptr -> <- Ptr
2183 +------------+ +------------+
2184 | ModuleName | | ModuleName |
2185 |------------| |------------|
2186
2187
2188 Quadruples Produced
2189
2190 q StartModFileOp lineno filename ModuleSym
2191*)
2192
2193PROCEDURE StartBuildModFile (tok: CARDINAL) ;
2194BEGIN
2195 GenQuadO (tok, StartModFileOp, tok,
2196 WORD (makekey (string (GetFileName ()))),
2197 GetFileModule (), FALSE)
2198END StartBuildModFile ;
2199
2200
2201(*
2202 EndBuildFile - generates an EndFileOp quadruple indicating the file
2203 that has produced the previous quadruples has ended.
2204
2205 Entry Exit
2206 ===== ====
2207
2208
2209 Ptr -> <- Ptr
2210 +------------+ +------------+
2211 | ModuleName | | ModuleName |
2212 |------------| |------------|
2213
2214
2215 Quadruples Produced
2216
2217 q EndFileOp _ _ ModuleSym
2218*)
2219
2220PROCEDURE EndBuildFile (tok: CARDINAL) ;
2221VAR
2222 ModuleName: Name ;
2223BEGIN
2224 ModuleName := OperandT (1) ;
2225 GenQuadO (tok, EndFileOp, NulSym, NulSym, GetModule (ModuleName), FALSE)
2226END EndBuildFile ;
2227
2228
2229(*
2230 StartBuildInit - Sets the start of initialization code of the
2231 current module to the next quadruple.
2232*)
2233
2234PROCEDURE StartBuildInit (tok: CARDINAL) ;
2235VAR
2236 name : Name ;
2237 ModuleSym: CARDINAL ;
2238BEGIN
2239 PopT(name) ;
2240 ModuleSym := GetCurrentModule() ;
2241 Assert(IsModule(ModuleSym) OR IsDefImp(ModuleSym)) ;
2242 Assert(GetSymName(ModuleSym)=name) ;
2243 PutModuleStartQuad(ModuleSym, NextQuad) ;
2244 GenQuad(InitStartOp, tok, GetFileModule(), ModuleSym) ;
2245 PushWord(ReturnStack, 0) ;
2246 PushT(name) ;
2247 CheckVariablesAt(ModuleSym) ;
2248 CheckNeedPriorityBegin(tok, ModuleSym, ModuleSym) ;
2249 PushWord(TryStack, NextQuad) ;
2250 PushWord(CatchStack, 0) ;
2251 IF HasExceptionBlock(ModuleSym)
2252 THEN
2253 GenQuad(TryOp, NulSym, NulSym, 0)
2254 END
2255END StartBuildInit ;
2256
2257
2258(*
2259 EndBuildInit - Sets the end initialization code of a module.
2260*)
2261
2262PROCEDURE EndBuildInit (tok: CARDINAL) ;
2263BEGIN
2264 IF HasExceptionBlock(GetCurrentModule())
2265 THEN
2266 BuildRTExceptLeave (tok, TRUE) ;
2267 GenQuadO (tok, CatchEndOp, NulSym, NulSym, NulSym, FALSE)
2268 END ;
2269 BackPatch (PopWord (ReturnStack), NextQuad) ;
2270 CheckNeedPriorityEnd (tok, GetCurrentModule(), GetCurrentModule()) ;
2271 PutModuleEndQuad (GetCurrentModule(), NextQuad) ;
2272 CheckVariablesInBlock (GetCurrentModule()) ;
2273 GenQuadO (tok, InitEndOp, tok, GetFileModule(), GetCurrentModule(), FALSE)
2274END EndBuildInit ;
2275
2276
2277(*
2278 StartBuildFinally - Sets the start of finalization code of the
2279 current module to the next quadruple.
2280*)
2281
2282PROCEDURE StartBuildFinally (tok: CARDINAL) ;
2283VAR
2284 name : Name ;
2285 ModuleSym: CARDINAL ;
2286BEGIN
2287 PopT(name) ;
2288 ModuleSym := GetCurrentModule() ;
2289 Assert(IsModule(ModuleSym) OR IsDefImp(ModuleSym)) ;
2290 Assert(GetSymName(ModuleSym)=name) ;
2291 PutModuleFinallyStartQuad(ModuleSym, NextQuad) ;
2292 GenQuadO (tok, FinallyStartOp, tok, GetFileModule(), ModuleSym, FALSE) ;
2293 PushWord (ReturnStack, 0) ;
2294 PushT (name) ;
2295 (* CheckVariablesAt(ModuleSym) ; *)
2296 CheckNeedPriorityBegin (tok, ModuleSym, ModuleSym) ;
2297 PushWord (TryStack, NextQuad) ;
2298 PushWord (CatchStack, 0) ;
2299 IF HasExceptionFinally (ModuleSym)
2300 THEN
2301 GenQuadO (tok, TryOp, NulSym, NulSym, 0, FALSE)
2302 END
2303END StartBuildFinally ;
2304
2305
2306(*
2307 EndBuildFinally - Sets the end finalization code of a module.
2308*)
2309
2310PROCEDURE EndBuildFinally (tok: CARDINAL) ;
2311BEGIN
2312 IF HasExceptionFinally(GetCurrentModule())
2313 THEN
2314 BuildRTExceptLeave (tok, TRUE) ;
2315 GenQuadO (tok, CatchEndOp, NulSym, NulSym, NulSym, FALSE)
2316 END ;
2317 BackPatch (PopWord (ReturnStack), NextQuad) ;
2318 CheckNeedPriorityEnd (tok, GetCurrentModule (), GetCurrentModule ()) ;
2319 PutModuleFinallyEndQuad(GetCurrentModule (), NextQuad) ;
2320 CheckVariablesInBlock (GetCurrentModule ()) ;
2321 GenQuadO (tok, FinallyEndOp, tok, GetFileModule (),
2322 GetCurrentModule(), FALSE)
2323END EndBuildFinally ;
2324
2325
2326(*
2327 BuildRTExceptEnter - informs RTExceptions that we are about to enter the except state.
2328*)
2329
2330PROCEDURE BuildRTExceptEnter (tok: CARDINAL) ;
2331VAR
2332 old,
2333 ProcSym: CARDINAL ;
2334BEGIN
2335 IF Exceptions
2336 THEN
2337 (* now inform the Modula-2 runtime we are in the exception state *)
2338 ProcSym := GetQualidentImport (tok,
2339 MakeKey('SetExceptionState'), MakeKey('RTExceptions')) ;
2340 IF ProcSym=NulSym
2341 THEN
2342 MetaErrorT0 (tok,
2343 '{%W}no procedure SetExceptionState found in RTExceptions which is needed to implement exception handling')
2344 ELSE
2345 old := MakeTemporary (tok, RightValue) ;
2346 PutVar (old, Boolean) ;
2347 GenQuadO (tok, SaveExceptionOp, old, NulSym, ProcSym, FALSE) ;
2348 PushWord (ExceptStack, old)
2349 END
2350 ELSE
2351 MetaErrorT0 (tok,
2352 '{%E}cannot use {%kEXCEPT} blocks with the -fno-exceptions flag')
2353 END
2354END BuildRTExceptEnter ;
2355
2356
2357(*
2358 BuildRTExceptLeave - informs RTExceptions that we are about to leave the except state.
2359 If, destroy, is TRUE then pop the ExceptStack.
2360*)
2361
2362PROCEDURE BuildRTExceptLeave (tok: CARDINAL; destroy: BOOLEAN) ;
2363VAR
2364 old,
2365 ProcSym: CARDINAL ;
2366BEGIN
2367 IF Exceptions
2368 THEN
2369 (* now inform the Modula-2 runtime we are in the exception state *)
2370 ProcSym := GetQualidentImport (tok,
2371 MakeKey('SetExceptionState'), MakeKey('RTExceptions')) ;
2372 IF ProcSym#NulSym
2373 THEN
2374 IF destroy
2375 THEN
2376 old := PopWord (ExceptStack)
2377 ELSE
2378 old := PeepWord (ExceptStack, 1)
2379 END ;
2380 GenQuadO (tok, RestoreExceptionOp, old, NulSym, ProcSym, FALSE)
2381 END
2382 ELSE
2383 (* no need for an error message here as it will be generated in the Enter procedure above *)
2384 END
2385END BuildRTExceptLeave ;
2386
2387
2388(*
2389 BuildExceptInitial - adds an CatchBeginOp, CatchEndOp quadruple
2390 in the current block.
2391*)
2392
2393PROCEDURE BuildExceptInitial (tok: CARDINAL) ;
2394VAR
2395 previous: CARDINAL ;
2396BEGIN
2397 (* we have finished the 'try' block, so now goto the return
2398 section which will tidy up (any) priorities before returning.
2399 *)
2400 GenQuadO (tok, GotoOp, NulSym, NulSym, PopWord(ReturnStack), FALSE) ;
2401 PushWord (ReturnStack, NextQuad-1) ;
2402 (*
2403 this is the 'catch' block.
2404 *)
2405 BackPatch (PeepWord (TryStack, 1), NextQuad) ;
2406 GenQuadO (tok, CatchBeginOp, NulSym, NulSym, NulSym, FALSE) ;
2407 previous := PopWord (CatchStack) ;
2408 IF previous # 0
2409 THEN
2410 MetaErrorT0 (tok,
2411 '{%E}only allowed one EXCEPT statement in a procedure or module')
2412 END ;
2413 PushWord (CatchStack, NextQuad-1) ;
2414 BuildRTExceptEnter (tok)
2415END BuildExceptInitial ;
2416
2417
2418(*
2419 BuildExceptFinally - adds an ExceptOp quadruple in a modules
2420 finally block.
2421*)
2422
2423PROCEDURE BuildExceptFinally (tok: CARDINAL) ;
2424BEGIN
2425 BuildExceptInitial (tok)
2426END BuildExceptFinally ;
2427
2428
2429(*
2430 BuildExceptProcedure - adds an ExceptOp quadruple in a procedure
2431 block.
2432*)
2433
2434PROCEDURE BuildExceptProcedure (tok: CARDINAL) ;
2435BEGIN
2436 BuildExceptInitial (tok)
2437END BuildExceptProcedure ;
2438
2439
2440(*
2441 BuildRetry - adds an RetryOp quadruple.
2442*)
2443
2444PROCEDURE BuildRetry (tok: CARDINAL);
2445BEGIN
2446 IF PeepWord (CatchStack, 1) = 0
2447 THEN
2448 MetaErrorT0 (tok,
2449 '{%E}the {%kRETRY} statement must occur after an {%kEXCEPT} statement in the same module or procedure block')
2450 ELSE
2451 BuildRTExceptLeave (tok, FALSE) ;
2452 GenQuadO (tok, RetryOp, NulSym, NulSym, PeepWord (TryStack, 1), FALSE)
2453 END
2454END BuildRetry ;
2455
2456
2457(*
2458 SafeRequestSym - only used during scaffold to get argc, argv, envp.
2459 It attempts to get symbol name from the current scope(s) and if
2460 it fails then it falls back onto default constants.
2461*)
2462
2463PROCEDURE SafeRequestSym (tok: CARDINAL; name: Name) : CARDINAL ;
2464VAR
2465 sym: CARDINAL ;
2466BEGIN
2467 sym := GetSym (name) ;
2468 IF sym = NulSym
2469 THEN
2470 IF name = MakeKey ('argc')
2471 THEN
2472 RETURN MakeConstLit (tok, MakeKey ('0'), ZType)
2473 ELSIF (name = MakeKey ('argv')) OR (name = MakeKey ('envp'))
2474 THEN
2475 RETURN Nil
2476 ELSE
2477 InternalError ('not expecting this parameter name') ;
2478 RETURN Nil
2479 END
2480 END ;
2481 RETURN sym
2482END SafeRequestSym ;
2483
2484
2485(*
2486 callRequestDependant - create a call:
05652ac4
GM		 2487 RequestDependant (GetSymName (modulesym), GetLibName (modulesym),
2488 GetSymName (depModuleSym), GetLibName (depModuleSym));
1eee94d3
GM		 2489*)
2490
2491PROCEDURE callRequestDependant (tokno: CARDINAL;
2492 moduleSym, depModuleSym: CARDINAL;
2493 requestDep: CARDINAL) ;
2494BEGIN
2495 Assert (requestDep # NulSym) ;
2496 PushTtok (requestDep, tokno) ;
84104022 2497 PushTFtok (Adr, Address, tokno) ;
78b72ee5 2498 PushTtok (MakeConstString (tokno, GetSymName (moduleSym)), tokno) ;
1eee94d3
GM		 2499 PushT (1) ;
2500 BuildAdrFunction ;
2501
84104022 2502 PushTFtok (Adr, Address, tokno) ;
78b72ee5 2503 PushTtok (MakeConstString (tokno, GetLibName (moduleSym)), tokno) ;
05652ac4
GM		 2504 PushT (1) ;
2505 BuildAdrFunction ;
2506
1eee94d3
GM		 2507 IF depModuleSym = NulSym
2508 THEN
05652ac4 2509 PushTF (Nil, Address) ;
1eee94d3
GM		 2510 PushTF (Nil, Address)
2511 ELSE
84104022 2512 PushTFtok (Adr, Address, tokno) ;
78b72ee5 2513 PushTtok (MakeConstString (tokno, GetSymName (depModuleSym)), tokno) ;
1eee94d3 2514 PushT (1) ;
05652ac4
GM		 2515 BuildAdrFunction ;
2516
84104022 2517 PushTFtok (Adr, Address, tokno) ;
78b72ee5 2518 PushTtok (MakeConstString (tokno, GetLibName (depModuleSym)), tokno) ;
05652ac4 2519 PushT (1) ;
1eee94d3
GM		 2520 BuildAdrFunction
2521 END ;
2522
05652ac4 2523 PushT (4) ;
1eee94d3
GM		 2524 BuildProcedureCall (tokno)
2525END callRequestDependant ;
2526
2527
2528(*
2529 ForeachImportInDepDo -
2530*)
2531
2532PROCEDURE ForeachImportInDepDo (importStatements: List; moduleSym, requestDep: CARDINAL) ;
2533VAR
2534 i, j,
2535 m, n : CARDINAL ;
2536 imported,
2537 stmt : CARDINAL ;
2538 l : List ;
2539BEGIN
2540 IF importStatements # NIL
2541 THEN
2542 i := 1 ;
2543 n := NoOfItemsInList (importStatements) ;
2544 WHILE i <= n DO
2545 stmt := GetItemFromList (importStatements, i) ;
2546 Assert (IsImportStatement (stmt)) ;
2547 l := GetImportStatementList (stmt) ;
2548 j := 1 ;
2549 m := NoOfItemsInList (l) ;
2550 WHILE j <= m DO
2551 imported := GetItemFromList (l, j) ;
2552 Assert (IsImport (imported)) ;
2553 callRequestDependant (GetImportDeclared (imported),
2554 moduleSym, GetImportModule (imported),
2555 requestDep) ;
2556 INC (j) ;
2557 END ;
2558 INC (i)
2559 END
2560 END
2561END ForeachImportInDepDo ;
2562
2563
2564(*
2565 ForeachImportedModuleDo -
2566*)
2567
2568PROCEDURE ForeachImportedModuleDo (moduleSym, requestDep: CARDINAL) ;
2569VAR
2570 importStatements: List ;
2571BEGIN
2572 importStatements := GetModuleModImportStatementList (moduleSym) ;
2573 ForeachImportInDepDo (importStatements, moduleSym, requestDep) ;
2574 importStatements := GetModuleDefImportStatementList (moduleSym) ;
2575 ForeachImportInDepDo (importStatements, moduleSym, requestDep)
2576END ForeachImportedModuleDo ;
2577
2578
2579(*
2580 BuildM2DepFunction - creates the dependency graph procedure using IR:
2581 static void
2582 dependencies (void)
2583 {
05652ac4
GM		 2584 M2RTS_RequestDependant (module_name, libname, "b", "b libname");
2585 M2RTS_RequestDependant (module_name, libname, NULL, NULL);
1eee94d3
GM		 2586 }
2587*)
2588
2589PROCEDURE BuildM2DepFunction (tokno: CARDINAL; moduleSym: CARDINAL) ;
2590VAR
2591 requestDep,
2592 ctor, init, fini, dep: CARDINAL ;
2593BEGIN
2594 IF ScaffoldDynamic
2595 THEN
2596 (* Scaffold required and dynamic dependency graph should be produced. *)
2597 GetModuleCtors (moduleSym, ctor, init, fini, dep) ;
2598 PushT (dep) ;
2599 BuildProcedureStart ;
2600 BuildProcedureBegin ;
2601 StartScope (dep) ;
2602 requestDep := GetQualidentImport (tokno,
2603 MakeKey ("RequestDependant"),
2604 MakeKey ("M2RTS")) ;
2605 IF requestDep # NulSym
2606 THEN
2607 ForeachImportedModuleDo (moduleSym, requestDep) ;
2608 callRequestDependant (tokno, moduleSym, NulSym, requestDep)
2609 END ;
2610 EndScope ;
2611 BuildProcedureEnd ;
2612 PopN (1)
2613 END
2614END BuildM2DepFunction ;
2615
2616
2617(*
2618 BuildM2LinkFunction - creates the _M2_link procedure which will
2619 cause the linker to pull in all the module ctors.
2620*)
2621
2622PROCEDURE BuildM2LinkFunction (tokno: CARDINAL) ;
2623BEGIN
2624 IF ScaffoldDynamic
2625 THEN
2626 IF linkFunction # NulSym
2627 THEN
2628 (* void
2629 _M2_link (void)
2630 {
2631 for each module in uselist do
2632 PROC foo_%d = _M2_module_ctor
2633 done
2634 }. *)
2635 PushT (linkFunction) ;
2636 BuildProcedureStart ;
2637 BuildProcedureBegin ;
2638 StartScope (linkFunction) ;
2639 PopulateCtorArray (tokno) ;
2640 EndScope ;
2641 BuildProcedureEnd ;
2642 PopN (1)
2643 END
2644 END
2645END BuildM2LinkFunction ;
2646
2647
2648(*
2649 BuildTry - build the try statement for main.
2650*)
2651
2652PROCEDURE BuildTry (tokno: CARDINAL) ;
2653BEGIN
2654 IF Exceptions
2655 THEN
2656 PushWord (TryStack, NextQuad) ;
2657 PushWord (CatchStack, 0) ;
2658 GenQuadO (tokno, TryOp, NulSym, NulSym, 0, FALSE)
2659 END
2660END BuildTry ;
2661
2662
2663(*
2664 BuildExcept - build the except block for main.
2665*)
2666
2667PROCEDURE BuildExcept (tokno: CARDINAL) ;
2668VAR
2669 catchProcedure: CARDINAL ;
2670BEGIN
2671 IF Exceptions
2672 THEN
2673 BuildExceptInitial (tokno) ;
2674 catchProcedure := GetQualidentImport (tokno,
2675 MakeKey ('DefaultErrorCatch'),
2676 MakeKey ('RTExceptions')) ;
2677 IF catchProcedure # NulSym
2678 THEN
2679 PushTtok (catchProcedure, tokno) ;
2680 PushT (0) ;
2681 BuildProcedureCall (tokno)
2682 END ;
2683 BuildRTExceptLeave (tokno, TRUE) ;
2684 GenQuadO (tokno, CatchEndOp, NulSym, NulSym, NulSym, FALSE)
2685 END
2686END BuildExcept ;
2687
2688
2689(*
2690 BuildM2MainFunction - creates the main function with appropriate calls to the scaffold.
2691*)
2692
2693PROCEDURE BuildM2MainFunction (tokno: CARDINAL) ;
2694BEGIN
2695 IF (ScaffoldDynamic OR ScaffoldStatic) AND (NOT SharedFlag)
2696 THEN
2697 (* Scaffold required and main should be produced. *)
2698 (*
2699 int
2700 main (int argc, char *argv[], char *envp[])
2701 {
2702 try {
2703 _M2_init (argc, argv, envp);
2704 _M2_fini (argc, argv, envp);
2705 return 0;
2706 }
2707 catch (...) {
2708 RTExceptions_DefaultErrorCatch ();
94673a12 2709 return 0;
1eee94d3
GM		 2710 }
2711 }
2712 *)
2713 PushT (mainFunction) ;
2714 BuildProcedureStart ;
2715 BuildProcedureBegin ;
2716 StartScope (mainFunction) ;
2717 BuildTry (tokno) ;
2718 (* _M2_init (argc, argv, envp); *)
2719 PushTtok (initFunction, tokno) ;
2720 PushTtok (RequestSym (tokno, MakeKey ("argc")), tokno) ;
2721 PushTtok (RequestSym (tokno, MakeKey ("argv")), tokno) ;
2722 PushTtok (RequestSym (tokno, MakeKey ("envp")), tokno) ;
2723 PushT (3) ;
2724 BuildProcedureCall (tokno) ;
2725
2726 (* _M2_fini (argc, argv, envp); *)
2727 PushTtok (finiFunction, tokno) ;
2728 PushTtok (RequestSym (tokno, MakeKey ("argc")), tokno) ;
2729 PushTtok (RequestSym (tokno, MakeKey ("argv")), tokno) ;
2730 PushTtok (RequestSym (tokno, MakeKey ("envp")), tokno) ;
2731 PushT (3) ;
2732 BuildProcedureCall (tokno) ;
1eee94d3
GM		 2733 PushZero (tokno, Integer) ;
2734 BuildReturn (tokno) ;
2735 BuildExcept (tokno) ;
94673a12
GM		 2736 PushZero (tokno, Integer) ;
2737 BuildReturn (tokno) ;
1eee94d3
GM		 2738 EndScope ;
2739 BuildProcedureEnd ;
2740 PopN (1)
2741 END
2742END BuildM2MainFunction ;
2743
2744
78b72ee5
GM		 2745(*
2746 DeferMakeConstStringCnul - return a C const string which will be nul terminated.
2747*)
2748
2749PROCEDURE DeferMakeConstStringCnul (tok: CARDINAL; sym: CARDINAL) : CARDINAL ;
2750VAR
2751 const: CARDINAL ;
2752BEGIN
2753 const := MakeConstStringCnul (tok, NulName, FALSE) ;
2754 GenQuadO (tok, StringConvertCnulOp, const, 0, sym, FALSE) ;
2755 RETURN const
2756END DeferMakeConstStringCnul ;
2757
2758
2759(*
2760 DeferMakeConstStringM2nul - return a const string which will be nul terminated.
2761*)
2762
2763PROCEDURE DeferMakeConstStringM2nul (tok: CARDINAL; sym: CARDINAL) : CARDINAL ;
2764VAR
2765 const: CARDINAL ;
2766BEGIN
2767 const := MakeConstStringM2nul (tok, NulName, FALSE) ;
2768 GenQuadO (tok, StringConvertM2nulOp, const, 0, sym, FALSE) ;
2769 RETURN const
2770END DeferMakeConstStringM2nul ;
2771
2772
53daf67f
GM		 2773(*
2774 BuildStringAdrParam - push the address of a nul terminated string onto the quad stack.
2775*)
2776
2777PROCEDURE BuildStringAdrParam (tok: CARDINAL; name: Name);
2778VAR
2779 str, m2strnul: CARDINAL ;
2780BEGIN
84104022 2781 PushTFtok (Adr, Address, tok) ;
78b72ee5
GM		 2782 str := MakeConstString (tok, name) ;
2783 PutConstStringKnown (tok, str, name, FALSE, TRUE) ;
2784 m2strnul := DeferMakeConstStringM2nul (tok, str) ;
53daf67f
GM		 2785 PushTtok (m2strnul, tok) ;
2786 PushT (1) ;
2787 BuildAdrFunction
2b783fe2 2788END BuildStringAdrParam ;
53daf67f
GM		 2789
2790
1eee94d3
GM		 2791(*
2792 BuildM2InitFunction -
2793*)
2794
2795PROCEDURE BuildM2InitFunction (tok: CARDINAL; moduleSym: CARDINAL) ;
2796VAR
2797 constructModules: CARDINAL ;
2798BEGIN
2799 IF ScaffoldDynamic OR ScaffoldStatic
2800 THEN
2801 (* Scaffold required and main should be produced. *)
2802 (* int
2803 _M2_init (int argc, char *argv[], char *envp[])
2804 {
573dbd51
GM		 2805 M2RTS_ConstructModules (module_name, libname,
2806 overrideliborder, argc, argv, envp);
1eee94d3
GM		 2807 } *)
2808 PushT (initFunction) ;
2809 BuildProcedureStart ;
2810 BuildProcedureBegin ;
2811 StartScope (initFunction) ;
2812 IF ScaffoldDynamic
2813 THEN
2814 IF linkFunction # NulSym
2815 THEN
2816 (* _M2_link (); *)
2817 PushTtok (linkFunction, tok) ;
2818 PushT (0) ;
2819 BuildProcedureCall (tok)
2820 END ;
2821
2822 (* Lookup ConstructModules and call it. *)
2823 constructModules := GetQualidentImport (tok,
2824 MakeKey ("ConstructModules"),
2825 MakeKey ("M2RTS")) ;
2826 IF constructModules # NulSym
2827 THEN
2828 (* ConstructModules (module_name, argc, argv, envp); *)
2829 PushTtok (constructModules, tok) ;
2830
53daf67f
GM		 2831 BuildStringAdrParam (tok, GetSymName (moduleSym)) ;
2832 BuildStringAdrParam (tok, GetLibName (moduleSym)) ;
2833 BuildStringAdrParam (tok, makekey (GetRuntimeModuleOverride ())) ;
573dbd51 2834
1eee94d3
GM		 2835 PushTtok (SafeRequestSym (tok, MakeKey ("argc")), tok) ;
2836 PushTtok (SafeRequestSym (tok, MakeKey ("argv")), tok) ;
2837 PushTtok (SafeRequestSym (tok, MakeKey ("envp")), tok) ;
573dbd51 2838 PushT (6) ;
1eee94d3
GM		 2839 BuildProcedureCall (tok) ;
2840 END
2841 ELSIF ScaffoldStatic
2842 THEN
2843 ForeachModuleCallInit (tok,
2844 SafeRequestSym (tok, MakeKey ("argc")),
2845 SafeRequestSym (tok, MakeKey ("argv")),
2846 SafeRequestSym (tok, MakeKey ("envp")))
2847 END ;
2848 EndScope ;
2849 BuildProcedureEnd ;
2850 PopN (1)
2851 END
2852END BuildM2InitFunction ;
2853
2854
2855(*
2856 BuildM2FiniFunction -
2857*)
2858
2859PROCEDURE BuildM2FiniFunction (tok: CARDINAL; moduleSym: CARDINAL) ;
2860VAR
2861 deconstructModules: CARDINAL ;
2862BEGIN
2863 IF ScaffoldDynamic OR ScaffoldStatic
2864 THEN
2865 (* Scaffold required and main should be produced. *)
2866 PushT (finiFunction) ;
2867 BuildProcedureStart ;
2868 BuildProcedureBegin ;
2869 StartScope (finiFunction) ;
2870 IF ScaffoldDynamic
2871 THEN
2872 (* static void
2873 _M2_finish (int argc, char *argv[], char *envp[])
2874 {
2875 M2RTS_DeconstructModules (module_name, argc, argv, envp);
2876 } *)
2877 deconstructModules := GetQualidentImport (tok,
2878 MakeKey ("DeconstructModules"),
2879 MakeKey ("M2RTS")) ;
2880 IF deconstructModules # NulSym
2881 THEN
2882 (* DeconstructModules (module_name, argc, argv, envp); *)
2883 PushTtok (deconstructModules, tok) ;
2884
84104022 2885 PushTFtok (Adr, Address, tok) ;
78b72ee5 2886 PushTtok (MakeConstString (tok, GetSymName (moduleSym)), tok) ;
1eee94d3
GM		 2887 PushT(1) ;
2888 BuildAdrFunction ;
2889
84104022 2890 PushTFtok (Adr, Address, tok) ;
78b72ee5 2891 PushTtok (MakeConstString (tok, GetLibName (moduleSym)), tok) ;
05652ac4
GM		 2892 PushT(1) ;
2893 BuildAdrFunction ;
2894
1eee94d3
GM		 2895 PushTtok (SafeRequestSym (tok, MakeKey ("argc")), tok) ;
2896 PushTtok (SafeRequestSym (tok, MakeKey ("argv")), tok) ;
2897 PushTtok (SafeRequestSym (tok, MakeKey ("envp")), tok) ;
05652ac4 2898 PushT (5) ;
1eee94d3
GM		 2899 BuildProcedureCall (tok)
2900 END
2901 ELSIF ScaffoldStatic
2902 THEN
2903 ForeachModuleCallFinish (tok,
2904 SafeRequestSym (tok, MakeKey ("argc")),
2905 SafeRequestSym (tok, MakeKey ("argv")),
2906 SafeRequestSym (tok, MakeKey ("envp")))
2907 END ;
2908 EndScope ;
2909 BuildProcedureEnd ;
2910 PopN (1)
2911 END
2912END BuildM2FiniFunction ;
2913
2914
2915(*
2916 BuildM2CtorFunction - create a constructor function associated with moduleSym.
2917
2918 void
2919 ctorFunction ()
2920 {
05652ac4 2921 M2RTS_RegisterModule (GetSymName (moduleSym), GetLibName (moduleSym),
1eee94d3
GM		 2922 init, fini, dependencies);
2923 }
2924*)
2925
2926PROCEDURE BuildM2CtorFunction (tok: CARDINAL; moduleSym: CARDINAL) ;
2927VAR
2928 RegisterModule : CARDINAL ;
2929 ctor, init, fini, dep: CARDINAL ;
2930BEGIN
2931 IF ScaffoldDynamic
2932 THEN
2933 GetModuleCtors (moduleSym, ctor, init, fini, dep) ;
2934 IF ctor # NulSym
2935 THEN
2936 Assert (IsProcedure (ctor)) ;
2937 PushT (ctor) ;
2938 BuildProcedureStart ;
2939 BuildProcedureBegin ;
2940 StartScope (ctor) ;
2941 RegisterModule := GetQualidentImport (tok,
2942 MakeKey ("RegisterModule"),
2943 MakeKey ("M2RTS")) ;
2944 IF RegisterModule # NulSym
2945 THEN
2946 (* RegisterModule (module_name, init, fini, dependencies); *)
2947 PushTtok (RegisterModule, tok) ;
2948
84104022 2949 PushTFtok (Adr, Address, tok) ;
78b72ee5 2950 PushTtok (MakeConstString (tok, GetSymName (moduleSym)), tok) ;
1eee94d3
GM		 2951 PushT (1) ;
2952 BuildAdrFunction ;
2953
84104022 2954 PushTFtok (Adr, Address, tok) ;
78b72ee5 2955 PushTtok (MakeConstString (tok, GetLibName (moduleSym)), tok) ;
05652ac4
GM		 2956 PushT (1) ;
2957 BuildAdrFunction ;
2958
1eee94d3
GM		 2959 PushTtok (init, tok) ;
2960 PushTtok (fini, tok) ;
2961 PushTtok (dep, tok) ;
05652ac4 2962 PushT (5) ;
1eee94d3
GM		 2963 BuildProcedureCall (tok)
2964 END ;
2965 EndScope ;
2966 BuildProcedureEnd ;
2967 PopN (1)
2968 END
2969 END
2970END BuildM2CtorFunction ;
2971
2972
2973(*
2974 BuildScaffold - generate the main, init, finish functions if
2975 no -c and this is the application module.
2976*)
2977
2978PROCEDURE BuildScaffold (tok: CARDINAL; moduleSym: CARDINAL) ;
2979BEGIN
2980 IF GetMainModule () = moduleSym
2981 THEN
2982 DeclareScaffold (tok) ;
2983 IF (ScaffoldMain OR (NOT cflag))
2984 THEN
2985 (* There are module init/fini functions and
2986 application init/fini functions.
2987 Here we create the application pair. *)
2988 BuildM2LinkFunction (tok) ;
2989 BuildM2MainFunction (tok) ;
2990 BuildM2InitFunction (tok, moduleSym) ; (* Application init. *)
2991 BuildM2FiniFunction (tok, moduleSym) ; (* Application fini. *)
2992 END ;
2993 BuildM2DepFunction (tok, moduleSym) ; (* Per module dependency. *)
2994 (* Each module needs a ctor to register the module
2995 init/finish/dep with M2RTS. *)
2996 BuildM2CtorFunction (tok, moduleSym)
2997 ELSIF WholeProgram
2998 THEN
2999 DeclareScaffold (tok) ;
3000 BuildM2DepFunction (tok, moduleSym) ; (* Per module dependency. *)
3001 (* Each module needs a ctor to register the module
3002 init/finish/dep with M2RTS. *)
3003 BuildM2CtorFunction (tok, moduleSym)
3004 END
3005END BuildScaffold ;
3006
3007
3008(*
3009 BuildModuleStart - starts current module scope.
3010*)
3011
3012PROCEDURE BuildModuleStart (tok: CARDINAL) ;
3013BEGIN
3014 GenQuadO (tok,
3015 ModuleScopeOp, tok,
3016 WORD (makekey (string (GetFileName ()))), GetCurrentModule (), FALSE)
3017END BuildModuleStart ;
3018
3019
3020(*
3021 StartBuildInnerInit - Sets the start of initialization code of the
3022 inner module to the next quadruple.
3023*)
3024
3025PROCEDURE StartBuildInnerInit (tok: CARDINAL) ;
3026BEGIN
3027 PutModuleStartQuad (GetCurrentModule(), NextQuad) ;
3028 GenQuadO (tok, InitStartOp, tok, NulSym, GetCurrentModule(), FALSE) ;
3029 PushWord (ReturnStack, 0) ;
3030 CheckNeedPriorityBegin (tok, GetCurrentModule(), GetCurrentModule()) ;
3031 PushWord (TryStack, NextQuad) ;
3032 PushWord (CatchStack, 0) ;
3033 IF HasExceptionFinally (GetCurrentModule())
3034 THEN
3035 GenQuadO (tok, TryOp, NulSym, NulSym, 0, FALSE)
3036 END
3037END StartBuildInnerInit ;
3038
3039
3040(*
3041 EndBuildInnerInit - Sets the end initialization code of a module.
3042*)
3043
3044PROCEDURE EndBuildInnerInit (tok: CARDINAL) ;
3045BEGIN
3046 IF HasExceptionBlock (GetCurrentModule())
3047 THEN
3048 BuildRTExceptLeave (tok, TRUE) ;
3049 GenQuadO (tok, CatchEndOp, NulSym, NulSym, NulSym, FALSE)
3050 END ;
3051 PutModuleEndQuad (GetCurrentModule(), NextQuad) ;
3052 CheckVariablesInBlock (GetCurrentModule ()) ;
3053 BackPatch (PopWord (ReturnStack), NextQuad) ;
3054 CheckNeedPriorityEnd (tok, GetCurrentModule (), GetCurrentModule ()) ;
3055 GenQuadO (tok, InitEndOp, tok, NulSym, GetCurrentModule (), FALSE)
3056END EndBuildInnerInit ;
3057
3058
3059(*
3060 BuildModulePriority - assigns the current module with a priority
3061 from the top of stack.
3062
3063 Entry Exit
3064 ===== ====
3065
3066
3067 Ptr -> Empty
3068 +------------+
3069 | Priority |
3070 |------------|
3071*)
3072
3073PROCEDURE BuildModulePriority ;
3074VAR
3075 Priority: CARDINAL ;
3076BEGIN
3077 PopT (Priority) ;
3078 PutPriority (GetCurrentModule (), Priority)
3079END BuildModulePriority ;
3080
3081
3082(*
3083 ForLoopAnalysis - checks all the FOR loops for index variable manipulation
3084 and dangerous usage outside the loop.
3085*)
3086
3087PROCEDURE ForLoopAnalysis ;
3088VAR
3089 i, n : CARDINAL ;
3090 forDesc: ForLoopInfo ;
3091BEGIN
3092 IF Pedantic
3093 THEN
3094 n := HighIndice (ForInfo) ;
3095 i := 1 ;
3096 WHILE i <= n DO
3097 forDesc := GetIndice (ForInfo, i) ;
3098 CheckForIndex (forDesc) ;
3099 INC (i)
3100 END
3101 END
3102END ForLoopAnalysis ;
3103
3104
3105(*
3106 AddForInfo - adds the description of the FOR loop into the record list.
3107 This is used if -pedantic is turned on to check index variable
3108 usage.
3109*)
3110
3111PROCEDURE AddForInfo (Start, End, IncQuad: CARDINAL; Sym: CARDINAL; idtok: CARDINAL) ;
3112VAR
3113 forDesc: ForLoopInfo ;
3114BEGIN
3115 IF Pedantic
3116 THEN
3117 NEW (forDesc) ;
3118 WITH forDesc^ DO
3119 IncrementQuad := IncQuad ;
3120 StartOfForLoop := Start ;
3121 EndOfForLoop := End ;
3122 ForLoopIndex := Sym ;
3123 IndexTok := idtok
3124 END ;
3125 IncludeIndiceIntoIndex (ForInfo, forDesc)
3126 END
3127END AddForInfo ;
3128
3129
3130(*
3131 CheckForIndex - checks the quadruples: Start..End to see whether a
3132 for loop index is manipulated by the programmer.
3133 It generates a warning if this is the case.
3134 It also checks to see whether the IndexSym is read
3135 immediately outside the loop in which case a warning
3136 is issued.
3137*)
3138
3139PROCEDURE CheckForIndex (forDesc: ForLoopInfo) ;
3140VAR
3141 ReadStart, ReadEnd,
3142 WriteStart, WriteEnd: CARDINAL ;
3143BEGIN
3144 GetWriteLimitQuads (forDesc^.ForLoopIndex, RightValue, forDesc^.StartOfForLoop, forDesc^.EndOfForLoop, WriteStart, WriteEnd) ;
3145 IF (WriteStart < forDesc^.IncrementQuad) AND (WriteStart > forDesc^.StartOfForLoop)
3146 THEN
3147 MetaErrorT1 (forDesc^.IndexTok,
3148 '{%kFOR} loop index variable {%1Wad} is being manipulated inside the loop',
3149 forDesc^.ForLoopIndex) ;
3150 MetaErrorT1 (QuadToTokenNo (WriteStart),
3151 '{%kFOR} loop index variable {%1Wad} is being manipulated, this is considered bad practice and may cause unknown program behaviour',
3152 forDesc^.ForLoopIndex)
3153 END ;
3154 GetWriteLimitQuads (forDesc^.ForLoopIndex, RightValue, forDesc^.EndOfForLoop, 0, WriteStart, WriteEnd) ;
3155 GetReadLimitQuads (forDesc^.ForLoopIndex, RightValue, forDesc^.EndOfForLoop, 0, ReadStart, ReadEnd) ;
3156 IF (ReadStart#0) AND ((ReadStart < WriteStart) OR (WriteStart = 0))
3157 THEN
3158 MetaErrorT1 (forDesc^.IndexTok,
3159 '{%kFOR} loop index variable {%1Wad} is being read outside the FOR loop (without being reset)',
3160 forDesc^.ForLoopIndex) ;
3161 MetaErrorT1 (QuadToTokenNo (ReadStart),
3162 '{%kFOR} loop index variable {%1Wad} is being read outside the FOR loop (without being reset), this is considered extremely bad practice and may cause unknown program behaviour',
3163 forDesc^.ForLoopIndex)
3164 END
3165END CheckForIndex ;
3166
3167
3168(*
3169 GetCurrentFunctionName - returns the name for the current __FUNCTION__
3170*)
3171
3172(*
3173PROCEDURE GetCurrentFunctionName () : Name ;
3174VAR
3175 s: String ;
3176 n: Name ;
3177BEGIN
3178 IF CurrentProc=NulSym
3179 THEN
3180 s := InitStringCharStar(KeyToCharStar(GetSymName(GetCurrentModule()))) ;
3181 s := Sprintf1(Mark(InitString('module %s initialization')), s) ;
3182 n := makekey(string(s)) ;
3183 s := KillString(s) ;
3184 RETURN( n )
3185 ELSE
3186 RETURN( GetSymName(CurrentProc) )
3187 END
3188END GetCurrentFunctionName ;
3189*)
3190
3191
3192(*
3193 BuildRange - generates a RangeCheckOp quad with, r, as its operand.
3194*)
3195
3196PROCEDURE BuildRange (r: CARDINAL) ;
3197BEGIN
3198 GenQuad (RangeCheckOp, WORD (GetLineNo ()), NulSym, r)
3199END BuildRange ;
3200
3201
3202(*
3203 BuildError - generates a ErrorOp quad, indicating that if this
3204 quadruple is reachable, then a runtime error would
3205 occur.
3206*)
3207
3208PROCEDURE BuildError (r: CARDINAL) ;
3209BEGIN
3210 GenQuad (ErrorOp, WORD (GetLineNo ()), NulSym, r)
3211END BuildError ;
3212
3213
3214(*
3215 CheckPointerThroughNil - builds a range quadruple, providing, sym, is
3216 a candidate for checking against NIL.
3217 This range quadruple is only expanded into
3218 code during the code generation phase
3219 thus allowing limited compile time checking.
3220*)
3221
3222PROCEDURE CheckPointerThroughNil (tokpos: CARDINAL; sym: CARDINAL) ;
3223BEGIN
3224 IF IsVar (sym) AND GetVarPointerCheck (sym)
3225 THEN
3226 (* PutVarPointerCheck(sym, FALSE) ; (* so we do not detect this again *) *)
3227 BuildRange (InitPointerRangeCheck (tokpos, sym, GetMode (sym) = LeftValue))
3228 END
3229END CheckPointerThroughNil ;
3230
3231
3232(*
3233 CollectLow - returns the low of the subrange value.
3234*)
3235
3236PROCEDURE CollectLow (sym: CARDINAL) : CARDINAL ;
3237VAR
3238 low, high: CARDINAL ;
3239BEGIN
3240 IF IsSubrange (sym)
3241 THEN
3242 GetSubrange (sym, high, low) ;
3243 RETURN low
3244 ELSE
3245 InternalError ('expecting Subrange symbol')
3246 END
3247END CollectLow ;
3248
3249
3250(*
3251 CollectHigh - returns the high of the subrange value, sym.
3252*)
3253
3254PROCEDURE CollectHigh (sym: CARDINAL) : CARDINAL ;
3255VAR
3256 low, high: CARDINAL ;
3257BEGIN
3258 IF IsSubrange (sym)
3259 THEN
3260 GetSubrange (sym, high, low) ;
3261 RETURN high
3262 ELSE
3263 InternalError ('expecting Subrange symbol')
3264 END
3265END CollectHigh ;
3266
3267
3268(*
3269 BackPatchSubrangesAndOptParam - runs through all the quadruples and finds SubrangeLow or SubrangeHigh
3270 quadruples and replaces it by an assignment to the Low or High component
3271 of the subrange type.
3272
3273 Input:
3274 SubrangeLow op1 op3 (* op3 is a subrange *)
3275
3276 Output:
3277 Becomes op1 low
3278
3279 Input:
3280 SubrangeHigh op1 op3 (* op3 is a subrange *)
3281
3282 Output:
3283 Becomes op1 high
3284
3285 Input:
3286 OptParam op1 op2 op3
3287
3288 Output:
3289 Param op1 op2 GetOptArgInit(op3)
3290*)
3291
3292PROCEDURE BackPatchSubrangesAndOptParam ;
3293VAR
3294 f: QuadFrame ;
3295 q: CARDINAL ;
3296BEGIN
3297 q := GetFirstQuad () ;
3298 IF q # 0
3299 THEN
3300 REPEAT
3301 f := GetQF (q) ;
3302 WITH f^ DO
3303 CASE Operator OF
3304
3305 SubrangeLowOp : Operand3 := CollectLow (Operand3) ;
4e3c8257
GM		 3306 Operator := BecomesOp ;
3307 ConstExpr := FALSE |
1eee94d3 3308 SubrangeHighOp: Operand3 := CollectHigh (Operand3) ;
4e3c8257
GM		 3309 Operator := BecomesOp ;
3310 ConstExpr := FALSE |
1eee94d3
GM		 3311 OptParamOp : Operand3 := GetOptArgInit (Operand3) ;
3312 Operator := ParamOp
3313
3314 ELSE
3315 END ;
3316 q := Next
3317 END
3318 UNTIL q = 0
3319 END
3320END BackPatchSubrangesAndOptParam ;
3321
3322
3323(*
3324 CheckCompatibleWithBecomes - checks to see that symbol, sym, is
3325 compatible with the := operator.
3326*)
3327
3328PROCEDURE CheckCompatibleWithBecomes (des, expr,
3329 destok, exprtok: CARDINAL) ;
3330BEGIN
3331 IF IsType (des)
3332 THEN
3333 MetaErrorT1 (destok,
3334 'an assignment cannot assign a value to a type {%1a}', des)
3335 ELSIF IsProcedure (des)
3336 THEN
3337 MetaErrorT1 (destok,
3338 'an assignment cannot assign a value to a procedure {%1a}', des)
3339 ELSIF IsFieldEnumeration (des)
3340 THEN
3341 MetaErrorT1 (destok,
3342 'an assignment cannot assign a value to an enumeration field {%1a}', des)
3343 END ;
3344 IF IsPseudoBaseProcedure (expr) OR IsPseudoBaseFunction (expr)
3345 THEN
3346 MetaErrorT1 (exprtok,
3347 'an assignment cannot assign a {%1d} {%1a}', expr)
3348 END
3349END CheckCompatibleWithBecomes ;
3350
3351
3352(*
3353 BuildAssignmentWithoutBounds - calls BuildAssignment but makes sure we do not
3354 check bounds.
3355*)
3356
3357PROCEDURE BuildAssignmentWithoutBounds (tok: CARDINAL; checkTypes, checkOverflow: BOOLEAN) ;
3358VAR
3359 old: BOOLEAN ;
3360BEGIN
3361 old := MustNotCheckBounds ;
3362 MustNotCheckBounds := TRUE ;
3363 doBuildAssignment (tok, checkTypes, checkOverflow) ;
3364 MustNotCheckBounds := old
3365END BuildAssignmentWithoutBounds ;
3366
3367
3368(*
3369 MarkArrayWritten - marks, Array, as being written.
3370*)
3371
3372PROCEDURE MarkArrayWritten (Array: CARDINAL) ;
3373BEGIN
3374 IF (Array#NulSym) AND IsVarAParam(Array)
3375 THEN
b0762d4c 3376 PutVarWritten (Array, TRUE)
1eee94d3
GM		 3377 END
3378END MarkArrayWritten ;
3379
3380
3381(*
3382 MarkAsReadWrite - marks the variable or parameter as being
3383 read/write.
3384*)
3385
3386PROCEDURE MarkAsReadWrite (sym: CARDINAL) ;
3387BEGIN
3388 IF (sym#NulSym) AND IsVar(sym)
3389 THEN
3390 PutReadQuad (sym, RightValue, NextQuad) ;
3391 PutWriteQuad (sym, RightValue, NextQuad)
3392 END
3393END MarkAsReadWrite ;
3394
3395
3396(*
3397 MarkAsRead - marks the variable or parameter as being read.
3398*)
3399
3400PROCEDURE MarkAsRead (sym: CARDINAL) ;
3401BEGIN
3402 IF (sym#NulSym) AND IsVar(sym)
3403 THEN
3404 PutReadQuad (sym, RightValue, NextQuad)
3405 END
3406END MarkAsRead ;
3407
3408
3409(*
3410 MarkAsWrite - marks the variable or parameter as being written.
3411*)
3412
3413PROCEDURE MarkAsWrite (sym: CARDINAL) ;
3414BEGIN
b0762d4c 3415 IF (sym # NulSym) AND IsVar (sym)
1eee94d3 3416 THEN
b0762d4c 3417 PutWriteQuad (sym, RightValue, NextQuad)
1eee94d3
GM		 3418 END
3419END MarkAsWrite ;
3420
3421
3422(*
3423 doVal - return an expression which is VAL(type, expr). If
3424 expr is a constant then return expr.
3425*)
3426
3427PROCEDURE doVal (type, expr: CARDINAL) : CARDINAL ;
3428BEGIN
b0762d4c 3429 IF (NOT IsConst (expr)) AND (SkipType (type) # GetDType (expr))
1eee94d3 3430 THEN
b0762d4c
GM		 3431 PushTF (Convert, NulSym) ;
3432 PushT (SkipType(type)) ;
3433 PushT (expr) ;
3434 PushT (2) ; (* Two parameters *)
4bd2f59a 3435 BuildConvertFunction (Convert, FALSE) ;
b0762d4c 3436 PopT (expr)
1eee94d3
GM		 3437 END ;
3438 RETURN( expr )
3439END doVal ;
3440
3441
3442(*
3443 MoveWithMode -
3444*)
3445
3446PROCEDURE MoveWithMode (tokno: CARDINAL;
3447 Des, Exp, Array: CARDINAL;
3448 destok, exptok: CARDINAL;
3449 checkOverflow: BOOLEAN) ;
3450VAR
3451 t: CARDINAL ;
3452BEGIN
3453 IF IsConstString(Exp) AND IsConst(Des)
3454 THEN
3455 GenQuadOtok (tokno, BecomesOp, Des, NulSym, Exp, TRUE,
c787f593 3456 destok, UnknownTokenNo, exptok) ;
78b72ee5 3457 CopyConstString (tokno, Des, Exp)
1eee94d3
GM		 3458 ELSE
3459 IF GetMode(Des)=RightValue
3460 THEN
3461 IF GetMode(Exp)=LeftValue
3462 THEN
3463 CheckPointerThroughNil (tokno, Exp) ; (* Des = *Exp *)
3464 doIndrX (tokno, Des, Exp)
3465 ELSE
3466 GenQuadOtok (tokno, BecomesOp, Des, NulSym, Exp, TRUE,
c787f593 3467 destok, UnknownTokenNo, exptok)
1eee94d3
GM		 3468 END
3469 ELSIF GetMode(Des)=LeftValue
3470 THEN
3471 MarkArrayWritten (Array) ;
3472 IF GetMode(Exp) = LeftValue
3473 THEN
3474 t := MakeTemporary (tokno, RightValue) ;
3475 PutVar(t, GetSType(Exp)) ;
3476 CheckPointerThroughNil (tokno, Exp) ;
3477 doIndrX (tokno, t, Exp) ;
3478 CheckPointerThroughNil (tokno, Des) ; (* *Des = Exp *)
3479 GenQuadO (tokno, XIndrOp, Des, GetSType (Des), doVal (GetSType (Des), t),
3480 checkOverflow)
3481 ELSE
3482 CheckPointerThroughNil (tokno, Des) ; (* *Des = Exp *)
3483 GenQuadO (tokno, XIndrOp, Des, GetSType (Des), doVal (GetSType (Des), Exp),
3484 checkOverflow)
3485 END
3486 ELSE
3487 GenQuadOtok (tokno, BecomesOp, Des, NulSym, Exp, TRUE,
c787f593 3488 destok, UnknownTokenNo, exptok)
1eee94d3
GM		 3489 END
3490 END
3491END MoveWithMode ;
3492
3493
3494(*
3495 BuildBuiltinConst - makes reference to a builtin constant within gm2.
3496
3497 Entry Exit
3498
3499 Ptr ->
3500 +------------+ +------------+
3501 | Ident | | Sym |
3502 |------------| |------------|
3503
3504 Quadruple produced:
3505
3506 q Sym BuiltinConstOp Ident
3507*)
3508
3509PROCEDURE BuildBuiltinConst ;
3510VAR
3511 idtok: CARDINAL ;
3512 Id : CARDINAL ;
3513 Sym : CARDINAL ;
3514BEGIN
3515 PopTtok (Id, idtok) ;
3516 Sym := MakeTemporary (idtok, ImmediateValue) ;
3517 PutVar (Sym, Integer) ;
3518(*
3519 CASE GetBuiltinConstType(KeyToCharStar(Name(Id))) OF
3520
3521 0: ErrorFormat1(NewError(GetTokenNo()),
3522 '%a unrecognised builtin constant', Id) |
3523 1: PutVar(Sym, Integer) |
3524 2: PutVar(Sym, Real)
3525
3526 ELSE
3527 InternalError ('unrecognised value')
3528 END ;
3529*)
3530 GenQuadO (idtok, BuiltinConstOp, Sym, NulSym, Id, FALSE) ;
3531 PushTtok (Sym, idtok)
3532END BuildBuiltinConst ;
3533
3534
3535(*
3536 BuildBuiltinTypeInfo - make reference to a builtin typeinfo function
3537 within gm2.
3538
3539 Entry Exit
3540
3541 Ptr ->
3542 +-------------+
3543 | Type |
3544 |-------------| +------------+
3545 | Ident | | Sym |
3546 |-------------| |------------|
3547
3548 Quadruple produced:
3549
3550 q Sym BuiltinTypeInfoOp Type Ident
3551*)
3552
3553PROCEDURE BuildBuiltinTypeInfo ;
3554VAR
3555 idtok: CARDINAL ;
3556 Ident,
3557 Type,
3558 Sym : CARDINAL ;
3559BEGIN
3560 PopTtok (Ident, idtok) ;
3561 PopT (Type) ;
3562 Sym := MakeTemporary (BuiltinTokenNo, ImmediateValue) ;
3563 CASE GetBuiltinTypeInfoType (KeyToCharStar (Name (Ident))) OF
3564
3565 0: ErrorFormat1 (NewError(idtok),
3566 '%a unrecognised builtin constant', Ident) |
3567 1: PutVar (Sym, Boolean) |
3568 2: PutVar (Sym, ZType) |
3569 3: PutVar (Sym, RType)
3570
3571 ELSE
3572 InternalError ('unrecognised value')
3573 END ;
3574 GenQuadO (idtok, BuiltinTypeInfoOp, Sym, Type, Ident, FALSE) ;
3575 PushTtok (Sym, idtok)
3576END BuildBuiltinTypeInfo ;
3577
3578
3579(*
3580 CheckBecomesMeta - checks to make sure that we are not
3581 assigning a variable to a constant.
3582 Also check we are not assigning to an
3583 unbounded array.
3584*)
3585
3586PROCEDURE CheckBecomesMeta (Des, Exp: CARDINAL; combinedtok, destok, exprtok: CARDINAL) ;
3587BEGIN
3588 IF IsConst (Des) AND IsVar (Exp)
3589 THEN
3590 MetaErrorsT2 (combinedtok,
3591 'in assignment, cannot assign a variable {%2a} to a constant {%1a}',
3592 'designator {%1Da} is declared as a {%kCONST}', Des, Exp)
3593 END ;
3594 IF (GetDType(Des) # NulSym) AND IsVar (Des) AND IsUnbounded (GetDType (Des))
3595 THEN
3596 MetaErrorT1 (destok,
3597 'in assignment, cannot assign to an unbounded array {%1ad}', Des)
3598 END ;
3599 IF (GetDType(Exp) # NulSym) AND IsVar (Exp) AND IsUnbounded (GetDType (Exp))
3600 THEN
3601 MetaErrorT1 (exprtok,
3602 'in assignment, cannot assign from an unbounded array {%1ad}', Exp)
3603 END
3604END CheckBecomesMeta ;
3605
3606
3607(*
3608 BuildAssignment - Builds an assignment from the values given on the
3609 quad stack. Either an assignment to an
3610 arithmetic expression or an assignment to a
3611 boolean expression. This procedure should not
3612 be called in CONST declarations.
3613 The Stack is expected to contain:
3614
3615
3616 Either
3617
3618 Entry Exit
3619 ===== ====
3620
3621 Ptr ->
3622 +------------+
3623 | Expression |
3624 |------------|
3625 | Designator |
3626 |------------| +------------+
3627 | | | | <- Ptr
3628 |------------| |------------|
3629
3630
3631 Quadruples Produced
3632
3633 q BecomesOp Designator _ Expression
3634
3635 OR
3636
3637 Entry Exit
3638 ===== ====
3639
3640 Ptr ->
3641 +------------+
3642 | True |False|
3643 |------------|
3644 | Designator |
3645 |------------| +------------+
3646 | | | | <- Ptr
3647 |------------| |------------|
3648
3649
3650 Quadruples Produced
3651
3652 q BecomesOp Designator _ TRUE
3653 q+1 GotoOp q+3
3654 q+2 BecomesOp Designator _ FALSE
3655
3656*)
3657
3658PROCEDURE BuildAssignment (becomesTokNo: CARDINAL) ;
3659VAR
3660 des, exp : CARDINAL ;
3661 destok,
3662 exptok,
3663 combinedtok: CARDINAL ;
3664BEGIN
3665 des := OperandT (2) ;
3666 IF IsReadOnly (des)
3667 THEN
3668 destok := OperandTok (2) ;
3669 exptok := OperandTok (1) ;
3670 exp := OperandT (1) ;
3671 IF DebugTokPos
3672 THEN
3673 MetaErrorT1 (destok, 'destok {%1Ead}', des) ;
3674 MetaErrorT1 (exptok, 'exptok {%1Ead}', exp)
3675 END ;
3676 combinedtok := MakeVirtualTok (becomesTokNo, destok, exptok) ;
3677 IF DebugTokPos
3678 THEN
3679 MetaErrorT1 (combinedtok, 'combined {%1Ead}', des)
3680 END ;
3681 IF IsBoolean (1)
3682 THEN
3683 MetaErrorT1 (combinedtok,
3684 'cannot assign expression to a constant designator {%1Ead}', des)
3685 ELSE
3686 exp := OperandT (1) ;
3687 MetaErrorT2 (combinedtok,
3688 'cannot assign a constant designator {%1Ead} with an expression {%2Ead}',
3689 des, exp)
3690 END ;
3691 PopN (2) (* Remove both parameters. *)
3692 ELSIF IsError (des)
3693 THEN
3694 PopN (2) (* Remove both parameters. *)
3695 ELSE
3696 doBuildAssignment (becomesTokNo, TRUE, TRUE)
3697 END
3698END BuildAssignment ;
3699
3700
3701(*
3702 BuildAssignConstant - used to create constant in the CONST declaration.
3703 The stack is expected to contain:
3704
3705 Either
3706
3707 Entry Exit
3708 ===== ====
3709
3710 Ptr ->
3711 +------------+
3712 | Expression |
3713 |------------|
3714 | Designator |
3715 |------------| +------------+
3716 | | | | <- Ptr
3717 |------------| |------------|
3718
3719
3720 Quadruples Produced
3721
3722 q BecomesOp Designator _ Expression
3723
3724 OR
3725
3726 Entry Exit
3727 ===== ====
3728
3729 Ptr ->
3730 +------------+
3731 | True |False|
3732 |------------|
3733 | Designator |
3734 |------------| +------------+
3735 | | | | <- Ptr
3736 |------------| |------------|
3737
3738
3739 Quadruples Produced
3740
3741 q BecomesOp Designator _ TRUE
3742 q+1 GotoOp q+3
3743 q+2 BecomesOp Designator _ FALSE
3744*)
3745
3746PROCEDURE BuildAssignConstant (equalsTokNo: CARDINAL) ;
3747BEGIN
3748 doBuildAssignment (equalsTokNo, TRUE, TRUE)
3749END BuildAssignConstant ;
3750
3751
3752(*
3753 doBuildAssignment - subsiduary procedure of BuildAssignment.
3754 It builds the assignment and optionally
3755 checks the types are compatible.
3756*)
3757
3758PROCEDURE doBuildAssignment (becomesTokNo: CARDINAL; checkTypes, checkOverflow: BOOLEAN) ;
3759VAR
3760 r, w,
3761 t, f,
3762 Array,
3763 Des, Exp : CARDINAL ;
3764 combinedtok,
3765 destok, exptok: CARDINAL ;
3766BEGIN
3767 DisplayStack ;
3768 IF IsBoolean (1)
3769 THEN
3770 PopBool (t, f) ;
3771 PopTtok (Des, destok) ;
3772 (* Conditional Boolean Assignment. *)
3773 BackPatch (t, NextQuad) ;
4e3c8257 3774 IF GetMode (Des) = LeftValue
1eee94d3 3775 THEN
1eee94d3
GM		 3776 CheckPointerThroughNil (destok, Des) ;
3777 GenQuadO (destok, XIndrOp, Des, Boolean, True, checkOverflow)
4e3c8257
GM		 3778 ELSE
3779 GenQuadO (becomesTokNo, BecomesOp, Des, NulSym, True, checkOverflow)
1eee94d3
GM		 3780 END ;
3781 GenQuadO (destok, GotoOp, NulSym, NulSym, NextQuad+2, checkOverflow) ;
3782 BackPatch (f, NextQuad) ;
4e3c8257 3783 IF GetMode (Des) = LeftValue
1eee94d3 3784 THEN
1eee94d3
GM		 3785 CheckPointerThroughNil (destok, Des) ;
3786 GenQuadO (destok, XIndrOp, Des, Boolean, False, checkOverflow)
4e3c8257
GM		 3787 ELSE
3788 GenQuadO (becomesTokNo, BecomesOp, Des, NulSym, False, checkOverflow)
1eee94d3
GM		 3789 END
3790 ELSE
3791 PopTrwtok (Exp, r, exptok) ;
3792 MarkAsRead (r) ;
3793 IF Exp = NulSym
3794 THEN
3795 MetaError0 ('{%E}unknown expression found during assignment') ;
3796 FlushErrors
3797 END ;
3798 Array := OperandA (1) ;
3799 PopTrwtok (Des, w, destok) ;
3800 MarkAsWrite (w) ;
3801 CheckCompatibleWithBecomes (Des, Exp, destok, exptok) ;
c787f593
GM		 3802 IF DebugTokPos
3803 THEN
3804 MetaErrorT1 (becomesTokNo, 'becomestok {%1Oad}', Des) ;
3805 MetaErrorT1 (destok, 'destok {%1Oad}', Des) ;
3806 MetaErrorT1 (exptok, 'exptok {%1Oad}', Exp)
3807 END ;
3808 combinedtok := MakeVirtualTok (becomesTokNo, destok, exptok) ;
3809 IF DebugTokPos
3810 THEN
3811 MetaErrorT1 (combinedtok, 'combined {%1Oad}', Des)
3812 END ;
1eee94d3
GM		 3813 IF (GetSType (Des) # NulSym) AND (NOT IsSet (GetDType (Des)))
3814 THEN
3815 (* Tell code generator to test runtime values of assignment so ensure we
3816 catch overflow and underflow. *)
f065c582 3817 BuildRange (InitAssignmentRangeCheck (combinedtok, Des, Exp, destok, exptok))
1eee94d3
GM		 3818 END ;
3819 IF checkTypes
3820 THEN
3821 CheckBecomesMeta (Des, Exp, combinedtok, destok, exptok)
3822 END ;
c787f593 3823 (* Simple assignment. *)
eb619490 3824 MoveWithMode (combinedtok, Des, Exp, Array, destok, exptok, checkOverflow) ;
1eee94d3
GM		 3825 IF checkTypes
3826 THEN
3827 (*
3828 IF (CannotCheckTypeInPass3 (Des) OR CannotCheckTypeInPass3 (Exp))
3829 THEN
3830 (* We must do this after the assignment to allow the Designator to be
3831 resolved (if it is a constant) before the type checking is done. *)
3832 (* Prompt post pass 3 to check the assignment once all types are resolved. *)
3833 BuildRange (InitTypesAssignmentCheck (combinedtok, Des, Exp))
3834 END ;
3835 *)
3836 (* BuildRange (InitTypesAssignmentCheck (combinedtok, Des, Exp)) ; *)
3837 CheckAssignCompatible (Des, Exp, combinedtok, destok, exptok)
3838 END
3839 END ;
3840 DisplayStack
3841END doBuildAssignment ;
3842
3843
3844(*
3845 CheckAssignCompatible - checks to see that an assignment is compatible.
3846 It performs limited checking - thorough checking
3847 is done in pass 3. But we do what we can here
3848 given knowledge so far.
3849*)
3850
3851PROCEDURE CheckAssignCompatible (Des, Exp: CARDINAL; combinedtok, destok, exprtok: CARDINAL) ;
3852VAR
3853 DesT, ExpT, DesL: CARDINAL ;
3854BEGIN
3855 DesT := GetSType(Des) ;
3856 ExpT := GetSType(Exp) ;
3857 DesL := GetLType(Des) ;
3858 IF IsProcedure(Exp) AND
3859 ((DesT#NulSym) AND (NOT IsProcType(DesT))) AND
3860 ((DesL#NulSym) AND (NOT IsProcType(DesL)))
3861 THEN
3862 MetaErrorT1 (destok,
3863 'incorrectly assigning a procedure to a designator {%1Ead} (designator is not a procedure type, {%1ast})', Des)
3864 ELSIF IsProcedure (Exp) AND IsProcedureNested (Exp)
3865 THEN
3866 MetaErrorT1 (exprtok,
3867 'cannot call nested procedure {%1Ead} indirectly as the outer scope will not be known', Exp)
3868 ELSIF IsConstString(Exp)
3869 THEN
3870 ELSIF (DesT#NulSym) AND (IsUnbounded(DesT))
3871 THEN
3872 ELSIF (ExpT#NulSym) AND (IsUnbounded(ExpT))
3873 THEN
3874 ELSIF (DesL#NulSym) AND IsArray(DesL)
3875 THEN
3876 ELSIF IsConstructor(Exp)
3877 THEN
3878 IF ExpT=NulSym
3879 THEN
3880 (* ignore type checking *)
3881 ELSIF (DesT=NulSym) AND IsConst(Des) AND (IsConstructor(Des) OR IsConstSet(Des))
3882 THEN
3883 PutConst(Des, ExpT)
3884 ELSIF NOT IsAssignmentCompatible(DesT, ExpT)
3885 THEN
3886 MetaErrorT1 (combinedtok,
3887 'constructor expression is not compatible during assignment to {%1Ead}', Des)
3888 END
3889 ELSIF (DesT#NulSym) AND IsSet(DesT) AND IsConst(Exp)
3890 THEN
3891 (* We ignore checking of these types in pass 3 - but we do check them thoroughly post pass 3 *)
3892 ELSIF IsConst(Exp) AND (ExpT#Address) AND (NOT IsConst(Des)) AND
3893 (DesL#NulSym) AND ((DesL=Cardinal) OR (NOT IsSubrange(DesL))) AND
3894 (NOT IsEnumeration(DesL))
3895 THEN
3896 IF (IsBaseType(DesL) OR IsSystemType(DesL))
3897 THEN
3898 CheckAssignmentCompatible (combinedtok, ExpT, DesT)
3899 ELSE
3900 MetaErrorT2 (combinedtok,
3901 'assignment of a constant {%1Ead} can only be made to a variable whose type is equivalent to a Modula-2 base type {%2tsa}', Exp, Des)
3902 END
3903 ELSE
3904 IF (DesT#NulSym) AND IsProcType(DesT) AND IsProcedure(Exp)
3905 THEN
3906 DesT := GetSType(DesT) ; (* we can at least check RETURN values of procedure variables *)
3907 (* remember that thorough assignment checking is done post pass 3 *)
3908 CheckAssignmentCompatible (combinedtok, ExpT, DesT)
3909 END
3910 END
3911END CheckAssignCompatible ;
3912
3913
3914(*
3915 CheckBooleanId - Checks to see if the top operand is a boolean.
3916 If the operand is not a boolean then it is tested
3917 with true and a boolean is generated.
3918 The Stack:
3919
3920
3921 Entry Exit
3922 Ptr -> <- Ptr
3923 +------------+ +------------+
3924 | Sym | | t | f |
3925 |------------| |------------|
3926
3927 Quadruples
3928
3929 q If= Sym True _
3930 q+1 GotoOp _ _ _
3931*)
3932
3933PROCEDURE CheckBooleanId ;
3934VAR
3935 tok: CARDINAL ;
3936BEGIN
3937 IF NOT IsBoolean (1)
3938 THEN
3939 tok := OperandTok (1) ;
3940 IF IsVar (OperandT (1))
3941 THEN
3942 IF GetSType (OperandT (1)) # Boolean
3943 THEN
3944 MetaError1 ('{%1Ua:is not a boolean expression}' +
3945 '{!%1Ua:boolean expression expected}', OperandT (1))
3946 END
3947 END ;
3948 PushT (EqualTok) ;
3949 PushT (True) ;
3950 BuildRelOp (tok)
3951 END
3952END CheckBooleanId ;
3953
3954
3955(*
3956 BuildAlignment - builds an assignment to an alignment constant.
3957
3958 The Stack is expected to contain:
3959
3960
3961 Entry Exit
3962 ===== ====
3963
3964 Ptr ->
3965 +---------------+
3966 | Expression |
3967 |---------------|
3968 | bytealignment |
3969 |---------------| empty
3970*)
3971
3972PROCEDURE BuildAlignment (tokno: CARDINAL) ;
3973VAR
3974 name : Name ;
3975 expr,
3976 align: CARDINAL ;
3977BEGIN
3978 PopT (expr) ;
3979 PopT (name) ;
3980 IF name # MakeKey ('bytealignment')
3981 THEN
3982 MetaError1 ('expecting bytealignment identifier, rather than {%1Ea}',
3983 MakeError (tokno, name))
3984 END ;
3985 GetConstFromFifoQueue (align) ;
3986 PushT (align) ;
3987 PushT (expr) ;
3988 BuildAssignConstant (tokno)
3989END BuildAlignment ;
3990
3991
3992(*
3993 BuildBitLength - builds an assignment to a bit length constant.
3994
3995 The Stack is expected to contain:
3996
3997
3998 Entry Exit
3999 ===== ====
4000
4001 Ptr ->
4002 +------------+
4003 | Expression |
4004 |------------| empty
4005*)
4006
4007PROCEDURE BuildBitLength (tokno: CARDINAL) ;
4008VAR
4009 expr,
4010 length: CARDINAL ;
4011BEGIN
4012 PopT (expr) ;
4013 GetConstFromFifoQueue (length) ;
4014 PushT (length) ;
4015 PushT (expr) ;
4016 BuildAssignConstant (tokno)
4017END BuildBitLength ;
4018
4019
4020(*
4021 BuildDefaultFieldAlignment - builds an assignment to an alignment constant.
4022
4023 The Stack is expected to contain:
4024
4025
4026 Entry Exit
4027 ===== ====
4028
4029 Ptr ->
4030 +------------+
4031 | Expression |
4032 |------------| empty
4033*)
4034
4035PROCEDURE BuildDefaultFieldAlignment ;
4036VAR
4037 expr,
4038 align: CARDINAL ;
4039 name : Name ;
4040BEGIN
4041 PopT (expr) ;
4042 PopT (name) ;
4043 IF name # MakeKey ('bytealignment')
4044 THEN
4045 MetaError0 ('{%E}only allowed to use the attribute {%kbytealignment} in the default record field alignment pragma')
4046 END ;
4047 GetConstFromFifoQueue (align) ;
4048 PushT (align) ;
4049 PushT (expr) ;
4050 BuildAssignConstant (GetTokenNo ())
4051END BuildDefaultFieldAlignment ;
4052
4053
4054(*
4055 BuildPragmaField - builds an assignment to an alignment constant.
4056
4057 The Stack is expected to contain:
4058
4059
4060 Entry Exit
4061 ===== ====
4062
4063 Ptr ->
4064 +------------+
4065 | Expression |
4066 |------------| empty
4067*)
4068
4069PROCEDURE BuildPragmaField ;
4070VAR
4071 expr,
4072 const: CARDINAL ;
4073 name : Name ;
4074BEGIN
4075 PopT (expr) ;
4076 PopT (name) ;
4077 IF (name # MakeKey ('unused')) AND (name # MakeKey ('bytealignment'))
4078 THEN
4079 MetaError0 ('only allowed to use the attribute {%Ekbytealignment} in the default record field alignment pragma')
4080 END ;
4081 IF expr # NulSym
4082 THEN
4083 GetConstFromFifoQueue (const) ;
4084 PushT (const) ;
4085 PushT (expr) ;
4086 BuildAssignConstant (GetTokenNo ())
4087 END
4088END BuildPragmaField ;
4089
4090
4091(*
4092 BuildRepeat - Builds the repeat statement from the quad stack.
4093 The Stack is expected to contain:
4094
4095
4096 Entry Exit
4097 ===== ====
4098
4099
4100 Empty
4101 <- Ptr
4102 +------------+
4103 | RepeatQuad |
4104 |------------|
4105
4106*)
4107
4108PROCEDURE BuildRepeat ;
4109BEGIN
4110 PushT(NextQuad)
4111END BuildRepeat ;
4112
4113
4114(*
4115 BuildUntil - Builds the until part of the repeat statement
4116 from the quad stack.
4117 The Stack is expected to contain:
4118
4119
4120 Entry Exit
4121 ===== ====
4122
4123 Ptr ->
4124 +------------+
4125 | t | f |
4126 |------------|
4127 | RepeatQuad | Empty
4128 |------------|
4129*)
4130
4131PROCEDURE BuildUntil ;
4132VAR
4133 t, f,
4134 Repeat: CARDINAL ;
4135BEGIN
4136 CheckBooleanId ;
4137 PopBool(t, f) ;
4138 PopT(Repeat) ;
4139 BackPatch(f, Repeat) ; (* If False then keep on repeating *)
4140 BackPatch(t, NextQuad) ; (* If True then exit repeat *)
4141END BuildUntil ;
4142
4143
4144(*
4145 BuildWhile - Builds the While part of the While statement
4146 from the quad stack.
4147 The Stack is expected to contain:
4148
4149
4150 Entry Exit
4151 ===== ====
4152
4153 <- Ptr
4154 |------------|
4155 Empty | WhileQuad |
4156 |------------|
4157*)
4158
4159PROCEDURE BuildWhile ;
4160BEGIN
4161 PushT(NextQuad)
4162END BuildWhile ;
4163
4164
4165(*
4166 BuildDoWhile - Builds the Do part of the while statement
4167 from the quad stack.
4168 The Stack is expected to contain:
4169
4170
4171 Entry Exit
4172 ===== ====
4173
4174 Ptr ->
4175 +------------+ +------------+
4176 | t | f | | 0 | f |
4177 |------------| |------------|
4178 | WhileQuad | | WhileQuad |
4179 |------------| |------------|
4180
4181 Quadruples
4182
4183 BackPatch t exit to the NextQuad
4184*)
4185
4186PROCEDURE BuildDoWhile ;
4187VAR
4188 t, f: CARDINAL ;
4189BEGIN
4190 CheckBooleanId ;
4191 PopBool(t, f) ;
4192 BackPatch(t, NextQuad) ;
4193 PushBool(0, f)
4194END BuildDoWhile ;
4195
4196
4197(*
4198 BuildEndWhile - Builds the end part of the while statement
4199 from the quad stack.
4200 The Stack is expected to contain:
4201
4202
4203 Entry Exit
4204 ===== ====
4205
4206 Ptr ->
4207 +------------+
4208 | t | f |
4209 |------------|
4210 | WhileQuad | Empty
4211 |------------|
4212
4213 Quadruples
4214
4215 q GotoOp WhileQuad
4216 False exit is backpatched with q+1
4217*)
4218
4219PROCEDURE BuildEndWhile ;
4220VAR
4221 While,
4222 t, f : CARDINAL ;
4223BEGIN
4224 PopBool(t, f) ;
4225 Assert(t=0) ;
4226 PopT(While) ;
4227 GenQuad(GotoOp, NulSym, NulSym, While) ;
4228 BackPatch(f, NextQuad)
4229END BuildEndWhile ;
4230
4231
4232(*
4233 BuildLoop - Builds the Loop part of the Loop statement
4234 from the quad stack.
4235 The Stack is expected to contain:
4236
4237
4238 Entry Exit
4239 ===== ====
4240
4241 <- Ptr
4242 Empty +------------+
4243 | LoopQuad |
4244 |------------|
4245*)
4246
4247PROCEDURE BuildLoop ;
4248BEGIN
4249 PushT(NextQuad) ;
4250 PushExit(0) (* Seperate Exit Stack for loop end *)
4251END BuildLoop ;
4252
4253
4254(*
4255 BuildExit - Builds the Exit part of the Loop statement.
4256*)
4257
4258PROCEDURE BuildExit ;
4259BEGIN
4260 IF IsEmptyWord(ExitStack)
4261 THEN
4262 MetaError0 ('{%EkEXIT} is only allowed in a {%kLOOP} statement')
4263 ELSE
4264 GenQuad(GotoOp, NulSym, NulSym, 0) ;
4265 PushExit(Merge(PopExit(), NextQuad-1))
4266 END
4267END BuildExit ;
4268
4269
4270(*
4271 BuildEndLoop - Builds the End part of the Loop statement
4272 from the quad stack.
4273 The Stack is expected to contain:
4274
4275
4276 Entry Exit
4277 ===== ====
4278
4279 Ptr ->
4280 +------------+
4281 | LoopQuad | Empty
4282 |------------|
4283
4284 Quadruples
4285
4286 Goto _ _ LoopQuad
4287*)
4288
4289PROCEDURE BuildEndLoop ;
4290VAR
4291 Loop: CARDINAL ;
4292BEGIN
4293 PopT(Loop) ;
4294 GenQuad(GotoOp, NulSym, NulSym, Loop) ;
4295 BackPatch(PopExit(), NextQuad)
4296END BuildEndLoop ;
4297
4298
4299(*
4300 BuildThenIf - Builds the Then part of the If statement
4301 from the quad stack.
4302 The Stack is expected to contain:
4303
4304
4305 Entry Exit
4306 ===== ====
4307
4308 Ptr -> <- Ptr
4309 +------------+ +------------+
4310 | t | f | | 0 | f |
4311 |------------| |------------|
4312
4313 Quadruples
4314
4315 The true exit is BackPatched to point to
4316 the NextQuad.
4317*)
4318
4319PROCEDURE BuildThenIf ;
4320VAR
4321 t, f: CARDINAL ;
4322BEGIN
4323 CheckBooleanId ;
4324 PopBool(t, f) ;
4325 BackPatch(t, NextQuad) ;
4326 PushBool(0, f)
4327END BuildThenIf ;
4328
4329
4330(*
4331 BuildElse - Builds the Else part of the If statement
4332 from the quad stack.
4333 The Stack is expected to contain:
4334
4335
4336 Entry Exit
4337 ===== ====
4338
4339 Ptr ->
4340 +------------+ +------------+
4341 | t | f | | t+q | 0 |
4342 |------------| |------------|
4343
4344 Quadruples
4345
4346 q GotoOp _ _ 0
4347 q+1 <- BackPatched from f
4348*)
4349
4350PROCEDURE BuildElse ;
4351VAR
4352 t, f: CARDINAL ;
4353BEGIN
4354 GenQuad(GotoOp, NulSym, NulSym, 0) ;
4355 PopBool(t, f) ;
4356 BackPatch(f, NextQuad) ;
4357 PushBool(Merge(t, NextQuad-1), 0) (* NextQuad-1 = Goto Quad *)
4358END BuildElse ;
4359
4360
4361(*
4362 BuildEndIf - Builds the End part of the If statement
4363 from the quad stack.
4364 The Stack is expected to contain:
4365
4366
4367 Entry Exit
4368 ===== ====
4369
4370 Ptr ->
4371 +------------+
4372 | t | f | Empty
4373 |------------|
4374
4375 Quadruples
4376
4377 Both t and f are backpatched to point to the NextQuad
4378*)
4379
4380PROCEDURE BuildEndIf ;
4381VAR
4382 t, f: CARDINAL ;
4383BEGIN
4384 PopBool(t, f) ;
4385 BackPatch(t, NextQuad) ;
4386 BackPatch(f, NextQuad)
4387END BuildEndIf ;
4388
4389
4390(*
4391 BuildElsif1 - Builds the Elsif part of the If statement
4392 from the quad stack.
4393 The Stack is expected to contain:
4394
4395
4396 Entry Exit
4397 ===== ====
4398
4399 Ptr ->
4400 +------------+ +------------+
4401 | t | f | | t+q | 0 |
4402 |------------| |------------|
4403
4404 Quadruples
4405
4406 q GotoOp _ _ 0
4407 q+1 <- BackPatched from f
4408*)
4409
4410PROCEDURE BuildElsif1 ;
4411VAR
4412 t, f: CARDINAL ;
4413BEGIN
4414 GenQuad(GotoOp, NulSym, NulSym, 0) ;
4415 PopBool(t, f) ;
4416 BackPatch(f, NextQuad) ;
4417 PushBool(Merge(t, NextQuad-1), 0) (* NextQuad-1 = Goto Quad *)
4418END BuildElsif1 ;
4419
4420
4421(*
4422 BuildElsif2 - Builds the Elsif until part of the If statement
4423 from the quad stack.
4424 The Stack is expected to contain:
4425
4426
4427 Entry Exit
4428 ===== ====
4429
4430 Ptr ->
4431 +--------------+
4432 | 0 | f1 | <- Ptr
4433 |--------------| +---------------+
4434 | t2 | f2 | | t2 | f1+f2 |
4435 |--------------| |---------------|
4436*)
4437
4438PROCEDURE BuildElsif2 ;
4439VAR
4440 t1, f1,
4441 t2, f2: CARDINAL ;
4442BEGIN
4443 PopBool(t1, f1) ;
4444 Assert(t1=0) ;
4445 PopBool(t2, f2) ;
4446 PushBool(t2, Merge(f1, f2))
4447END BuildElsif2 ;
4448
4449
4450(*
4451 PushOne - pushes the value one to the stack.
4452 The Stack is changed:
4453
4454
4455 Entry Exit
4456 ===== ====
4457
4458 <- Ptr
4459 +------------+
4460 Ptr -> | 1 | type |
4461 |------------|
4462*)
4463
c1667b1e 4464PROCEDURE PushOne (tok: CARDINAL; type: CARDINAL;
4bd2f59a 4465 message: ARRAY OF CHAR) ;
c1667b1e
GM		 4466VAR
4467 const: CARDINAL ;
1eee94d3
GM		 4468BEGIN
4469 IF type = NulSym
4470 THEN
c1667b1e
GM		 4471 const := MakeConstLit (tok, MakeKey('1'), NulSym) ;
4472 PutConstLitInternal (const, TRUE) ;
4473 PushTFtok (const, NulSym, tok)
1eee94d3
GM		 4474 ELSIF IsEnumeration (type)
4475 THEN
4476 IF NoOfElements (type) = 0
4477 THEN
4478 MetaErrorString1 (ConCat (InitString ('enumeration type only has one element {%1Dad} and therefore '),
4479 Mark (InitString (message))),
4480 type) ;
4481 PushZero (tok, type)
4482 ELSE
c1667b1e 4483 PushTFtok (Convert, NulSym, tok) ;
1eee94d3 4484 PushT (type) ;
c1667b1e 4485 PushTFtok (MakeConstLit (tok, MakeKey ('1'), ZType), ZType, tok) ;
1eee94d3 4486 PushT (2) ; (* Two parameters *)
4bd2f59a 4487 BuildConvertFunction (Convert, TRUE)
1eee94d3
GM		 4488 END
4489 ELSE
c1667b1e
GM		 4490 const := MakeConstLit (tok, MakeKey ('1'), type) ;
4491 PutConstLitInternal (const, TRUE) ;
4492 PushTFtok (const, type, tok)
1eee94d3
GM		 4493 END
4494END PushOne ;
4495
4496
4497(*
4498 PushZero - pushes the value zero to the stack.
4499 The Stack is changed:
4500
4501
4502 Entry Exit
4503 ===== ====
4504
4505 <- Ptr
4506 +------------+
4507 Ptr -> | 0 | type |
4508 |------------|
4509*)
4510
4511PROCEDURE PushZero (tok: CARDINAL; type: CARDINAL) ;
4512BEGIN
4513 IF type = NulSym
4514 THEN
4515 PushTFtok (MakeConstLit (tok, MakeKey ('0'), NulSym), NulSym, tok)
4516 ELSIF IsEnumeration (type)
4517 THEN
4518 PushTFtok (Convert, NulSym, tok) ;
4519 PushTtok (type, tok) ;
4520 PushTtok (MakeConstLit (tok, MakeKey ('0'), ZType), tok) ;
4521 PushT (2) ; (* Two parameters *)
4bd2f59a 4522 BuildConvertFunction (Convert, TRUE)
1eee94d3
GM		 4523 ELSE
4524 PushTFtok (MakeConstLit (tok, MakeKey ('0'), type), type, tok)
4525 END
4526END PushZero ;
4527
4528
4529(*
4530 BuildPseudoBy - Builds the Non existant part of the By
4531 clause of the For statement
4532 from the quad stack.
4533 The Stack is expected to contain:
4534
4535
4536 Entry Exit
4537 ===== ====
4538
4539 <- Ptr
4540 +------------+
4541 Ptr -> | BySym | t |
4542 +------------+ |------------|
4543 | e | t | | e | t |
4544 |------------| |------------|
4545*)
4546
4547PROCEDURE BuildPseudoBy ;
4548VAR
161a67b2 4549 expr, type, dotok: CARDINAL ;
1eee94d3 4550BEGIN
161a67b2
GM		 4551 (* As there is no BY token this position is the DO at the end of the last expression. *)
4552 PopTFtok (expr, type, dotok) ;
4553 PushTFtok (expr, type, dotok) ;
4554 IF type = NulSym
4555 THEN
4556 (* type := ZType *)
4557 ELSIF IsEnumeration (SkipType (type)) OR (SkipType (type) = Char)
1eee94d3 4558 THEN
161a67b2
GM		 4559 (* Use type. *)
4560 ELSIF IsOrdinalType (SkipType (type))
4561 THEN
4562 type := ZType
1eee94d3 4563 END ;
c1667b1e 4564 PushOne (dotok, type,
4bd2f59a 4565 'the implied {%kFOR} loop increment will cause an overflow {%1ad}')
1eee94d3
GM		 4566END BuildPseudoBy ;
4567
4568
4569(*
4570 BuildForLoopToRangeCheck - builds the range check to ensure that the id
4571 does not exceed the limits of its type.
4572*)
4573
4574PROCEDURE BuildForLoopToRangeCheck ;
4575VAR
4576 d, dt,
4577 e, et: CARDINAL ;
4578BEGIN
4579 PopTF (e, et) ;
4580 PopTF (d, dt) ;
4581 BuildRange (InitForLoopToRangeCheck (d, e)) ;
4582 PushTF (d, dt) ;
4583 PushTF (e, et)
4584END BuildForLoopToRangeCheck ;
4585
4586
4587(*
4588 BuildForToByDo - Builds the For To By Do part of the For statement
4589 from the quad stack.
4590 The Stack is expected to contain:
4591
4592
4593 Entry Exit
4594 ===== ====
4595
161a67b2
GM		 4596 <- Ptr
4597 +----------------+
4598 Ptr -> | RangeId |
1eee94d3
GM		 4599 +----------------+ |----------------|
4600 | BySym | ByType | | ForQuad |
4601 |----------------| |----------------|
4602 | e2 | | LastValue |
4603 |----------------| |----------------|
4604 | e1 | | BySym | ByType |
4605 |----------------| |----------------|
4606 | Ident | | IdentSym |
4607 |----------------| |----------------|
4608
4609
4610 x := e1 ;
4611 LASTVALUE := ((e2-e1) DIV BySym) * BySym + e1
4612 IF BySym<0
4613 THEN
4614 IF e1<e2
4615 THEN
4616 goto exit
4617 END
4618 ELSE
4619 IF e1>e2
4620 THEN
4621 goto exit
4622 END
4623 END ;
4624 LOOP
4625 body
4626 IF x=LASTVALUE
4627 THEN
4628 goto exit
4629 END ;
4630 INC(x, BySym)
4631 END
4632
4633 Quadruples:
4634
4635 q BecomesOp IdentSym _ e1
4636 q+ LastValue := ((e1-e2) DIV by) * by + e1
4637 q+1 if >= by 0 q+..2
4638 q+2 GotoOp q+3
4639 q+3 If >= e1 e2 q+5
4640 q+4 GotoOp exit
4641 q+5 ..
4642 q+..1 Goto q+..5
4643 q+..2 If >= e2 e1 q+..4
4644 q+..3 GotoOp exit
4645 q+..4 ..
4646
4647 The For Loop is regarded:
4648
4649 For ident := e1 To e2 By by Do
4650
4651 End
4652*)
4653
4654PROCEDURE BuildForToByDo ;
4655VAR
4656 l1, l2 : LineNote ;
4657 e1, e2,
4658 Id : Name ;
4659 e1tok,
4660 e2tok,
4661 idtok,
4662 bytok : CARDINAL ;
4663 FinalValue,
4664 exit1,
4665 IdSym,
4666 BySym,
4667 ByType,
4668 ForLoop,
161a67b2 4669 RangeId,
1eee94d3
GM		 4670 t, f : CARDINAL ;
4671 etype,
4672 t1 : CARDINAL ;
4673BEGIN
4674 l2 := PopLineNo() ;
4675 l1 := PopLineNo() ;
4676 UseLineNote(l1) ;
4677 PushFor (0) ;
4678 PopTFtok (BySym, ByType, bytok) ;
4679 PopTtok (e2, e2tok) ;
4680 PopTtok (e1, e1tok) ;
4681 PopTtok (Id, idtok) ;
4682 IdSym := RequestSym (idtok, Id) ;
161a67b2
GM		 4683 RangeId := InitForLoopBeginRangeCheck (IdSym, idtok, e1, e1tok, e2, e2tok, BySym, bytok) ;
4684 BuildRange (RangeId) ;
1eee94d3
GM		 4685 PushTtok (IdSym, idtok) ;
4686 PushTtok (e1, e1tok) ;
4687 BuildAssignmentWithoutBounds (idtok, TRUE, TRUE) ;
4688
4689 UseLineNote (l2) ;
4690 FinalValue := MakeTemporary (e2tok,
4691 AreConstant (IsConst (e1) AND IsConst (e2) AND
4692 IsConst (BySym))) ;
4693 PutVar (FinalValue, GetSType (IdSym)) ;
4694 etype := MixTypes (GetSType (e1), GetSType (e2), e2tok) ;
4695 e1 := doConvert (etype, e1) ;
4696 e2 := doConvert (etype, e2) ;
4697
4698 PushTF (FinalValue, GetSType(FinalValue)) ;
4699 PushTFtok (e2, GetSType(e2), e2tok) ; (* FinalValue := ((e1-e2) DIV By) * By + e1 *)
4700 PushT (MinusTok) ;
4701 PushTFtok (e1, GetSType(e1), e1tok) ;
4702 doBuildBinaryOp (TRUE, FALSE) ;
4703 PushT (DivideTok) ;
4704 PushTFtok (BySym, ByType, bytok) ;
4705 doBuildBinaryOp (FALSE, FALSE) ;
4706 PushT (TimesTok) ;
4707 PushTFtok (BySym, ByType, bytok) ;
4708 doBuildBinaryOp (FALSE, FALSE) ;
ac7c9954 4709 PushT (ArithPlusTok) ;
1eee94d3
GM		 4710 PushTFtok (e1, GetSType (e1), e1tok) ;
4711 doBuildBinaryOp (FALSE, FALSE) ;
4712 BuildForLoopToRangeCheck ;
4713 BuildAssignmentWithoutBounds (e1tok, FALSE, FALSE) ;
4714
4715 (* q+1 if >= by 0 q+..2 *)
4716 (* q+2 GotoOp q+3 *)
4717 PushTFtok (BySym, ByType, bytok) ; (* BuildRelOp 1st parameter *)
4718 PushT (GreaterEqualTok) ; (* 2nd parameter *)
4719 (* 3rd parameter *)
4720 PushZero (bytok, ByType) ;
4721
4722 BuildRelOp (e2tok) ; (* choose final expression position. *)
4723 PopBool(t, f) ;
4724 BackPatch(f, NextQuad) ;
4725 (* q+3 If >= e1 e2 q+5 *)
4726 (* q+4 GotoOp Exit *)
4727 PushTFtok (e1, GetSType (e1), e1tok) ; (* BuildRelOp 1st parameter *)
4728 PushT (GreaterEqualTok) ; (* 2nd parameter *)
4729 PushTFtok (e2, GetSType (e2), e2tok) ; (* 3rd parameter *)
4730 BuildRelOp (e2tok) ; (* choose final expression position. *)
4731 PopBool (t1, exit1) ;
4732 BackPatch (t1, NextQuad) ;
4733 PushFor (Merge (PopFor(), exit1)) ; (* merge exit1 *)
4734
4735 GenQuad (GotoOp, NulSym, NulSym, 0) ;
4736 ForLoop := NextQuad-1 ;
4737
4738 (* ELSE *)
4739
4740 BackPatch (t, NextQuad) ;
4741 PushTFtok (e2, GetSType(e2), e2tok) ; (* BuildRelOp 1st parameter *)
4742 PushT (GreaterEqualTok) ; (* 2nd parameter *)
4743 PushTFtok (e1, GetSType(e1), e1tok) ; (* 3rd parameter *)
4744 BuildRelOp (e2tok) ;
4745 PopBool (t1, exit1) ;
4746 BackPatch (t1, NextQuad) ;
4747 PushFor (Merge (PopFor (), exit1)) ; (* merge exit1 *)
4748
4749 BackPatch(ForLoop, NextQuad) ; (* fixes the start of the for loop *)
4750 ForLoop := NextQuad ;
4751
4752 (* and set up the stack *)
4753
4754 PushTFtok (IdSym, GetSym (IdSym), idtok) ;
4755 PushTFtok (BySym, ByType, bytok) ;
4756 PushTFtok (FinalValue, GetSType (FinalValue), e2tok) ;
161a67b2
GM		 4757 PushT (ForLoop) ;
4758 PushT (RangeId)
1eee94d3
GM		 4759END BuildForToByDo ;
4760
4761
4762(*
4763 BuildEndFor - Builds the End part of the For statement
4764 from the quad stack.
4765 The Stack is expected to contain:
4766
4767
4768 Entry Exit
4769 ===== ====
4770
4771 Ptr ->
4772 +----------------+
c1667b1e
GM		 4773 | RangeId |
4774 |----------------|
1eee94d3
GM		 4775 | ForQuad |
4776 |----------------|
4777 | LastValue |
4778 |----------------|
4779 | BySym | ByType |
4780 |----------------|
4781 | IdSym | Empty
4782 |----------------|
4783*)
4784
4785PROCEDURE BuildEndFor (endpostok: CARDINAL) ;
4786VAR
4787 t, f,
4788 tsym,
161a67b2 4789 RangeId,
1eee94d3
GM		 4790 IncQuad,
4791 ForQuad: CARDINAL ;
4792 LastSym,
4793 ByType,
4794 BySym,
4795 bytok,
4796 IdSym,
4797 idtok : CARDINAL ;
4798BEGIN
161a67b2 4799 PopT (RangeId) ;
1eee94d3
GM		 4800 PopT (ForQuad) ;
4801 PopT (LastSym) ;
4802 PopTFtok (BySym, ByType, bytok) ;
4803 PopTtok (IdSym, idtok) ;
4804
4805 (* IF IdSym=LastSym THEN exit END *)
4806 PushTF(IdSym, GetSType (IdSym)) ;
4807 PushT (EqualTok) ;
4808 PushTF (LastSym, GetSType (LastSym)) ;
4809 BuildRelOp (endpostok) ;
4810 PopBool (t, f) ;
4811
4812 BackPatch (t, NextQuad) ;
4813 GenQuad (GotoOp, NulSym, NulSym, 0) ;
4814 PushFor (Merge (PopFor (), NextQuad-1)) ;
4815 BackPatch (f, NextQuad) ;
4816 IF GetMode (IdSym) = LeftValue
4817 THEN
4818 (* index variable is a LeftValue, therefore we must dereference it *)
4819 tsym := MakeTemporary (idtok, RightValue) ;
4820 PutVar (tsym, GetSType (IdSym)) ;
4821 CheckPointerThroughNil (idtok, IdSym) ;
4822 doIndrX (endpostok, tsym, IdSym) ;
4823 BuildRange (InitForLoopEndRangeCheck (tsym, BySym)) ; (* --fixme-- pass endpostok. *)
4824 IncQuad := NextQuad ;
4825 (* we have explicitly checked using the above and also
5f240871 4826 this addition can legitimately overflow if a cardinal type
1eee94d3
GM		 4827 is counting down. The above test will generate a more
4828 precise error message, so we suppress overflow detection
4829 here. *)
161a67b2
GM		 4830 GenQuadOTypetok (bytok, AddOp, tsym, tsym, BySym, FALSE, FALSE,
4831 idtok, idtok, bytok) ;
1eee94d3 4832 CheckPointerThroughNil (idtok, IdSym) ;
161a67b2
GM		 4833 GenQuadOtok (idtok, XIndrOp, IdSym, GetSType (IdSym),
4834 tsym, FALSE,
64b0130b 4835 idtok, idtok, idtok)
1eee94d3
GM		 4836 ELSE
4837 BuildRange (InitForLoopEndRangeCheck (IdSym, BySym)) ;
4838 IncQuad := NextQuad ;
4839 (* we have explicitly checked using the above and also
5f240871 4840 this addition can legitimately overflow if a cardinal type
1eee94d3
GM		 4841 is counting down. The above test will generate a more
4842 precise error message, so we suppress overflow detection
161a67b2
GM		 4843 here.
4844
4845 This quadruple suppresses the generic binary op type
4846 check (performed in M2GenGCC.mod) as there
4847 will be a more informative/exhaustive check performed by the
4848 InitForLoopBeginRangeCheck setup in BuildForToByDo and
4849 performed by M2Range.mod. *)
4850 GenQuadOTypetok (idtok, AddOp, IdSym, IdSym, BySym, FALSE, FALSE,
4851 idtok, idtok, bytok)
1eee94d3
GM		 4852 END ;
4853 GenQuadO (endpostok, GotoOp, NulSym, NulSym, ForQuad, FALSE) ;
4854 BackPatch (PopFor (), NextQuad) ;
161a67b2
GM		 4855 AddForInfo (ForQuad, NextQuad-1, IncQuad, IdSym, idtok) ;
4856 PutRangeForIncrement (RangeId, IncQuad)
1eee94d3
GM		 4857END BuildEndFor ;
4858
4859
4860(*
4861 BuildCaseStart - starts the case statement.
4862 It initializes a backpatch list on the compile
4863 time stack, the list is used to contain all
4864 case break points. The list is later backpatched
4865 and contains all positions of the case statement
4866 which jump to the end of the case statement.
4867 The stack also contains room for a boolean
4868 expression, this is needed to allow , operator
4869 in the CaseField alternatives.
4870
4871 The Stack is expected to contain:
4872
4873
4874 Entry Exit
4875 ===== ====
4876
4877 <- Ptr
4878 +------------+
1eee94d3
GM		 4879 | 0 | 0 |
4880 |------------|
89b58667
GM		 4881 | 0 | 0 |
4882 +-------------+ |------------|
4883 | Expr | | | Expr | |
4884 |-------------| |------------|
1eee94d3
GM		 4885*)
4886
4887PROCEDURE BuildCaseStart ;
4888BEGIN
89b58667 4889 BuildRange (InitCaseBounds (PushCase (NulSym, NulSym, OperandT (1)))) ;
1eee94d3
GM		 4890 PushBool (0, 0) ; (* BackPatch list initialized *)
4891 PushBool (0, 0) (* Room for a boolean expression *)
4892END BuildCaseStart ;
4893
4894
4895(*
4896 BuildCaseStartStatementSequence - starts the statement sequence
4897 inside a case clause.
4898 BackPatches the true exit to the
4899 NextQuad.
4900 The Stack:
4901
4902 Entry Exit
4903
4904 Ptr -> <- Ptr
4905 +-----------+ +------------+
4906 | t | f | | 0 | f |
4907 |-----------| |------------|
4908*)
4909
4910PROCEDURE BuildCaseStartStatementSequence ;
4911VAR
4912 t, f: CARDINAL ;
4913BEGIN
4914 PopBool (t, f) ;
4915 BackPatch (t, NextQuad) ;
4916 PushBool (0, f)
4917END BuildCaseStartStatementSequence ;
4918
4919
4920(*
4921 BuildCaseEndStatementSequence - ends the statement sequence
4922 inside a case clause.
4923 BackPatches the false exit f1 to the
4924 NextQuad.
4925 Asserts that t1 and f2 is 0
4926 Pushes t2+q and 0
4927
4928 Quadruples:
4929
4930 q GotoOp _ _ 0
4931
4932 The Stack:
4933
4934 Entry Exit
4935
4936 Ptr -> <- Ptr
4937 +-----------+ +------------+
4938 | t1 | f1 | | 0 | 0 |
4939 |-----------| |------------|
4940 | t2 | f2 | | t2+q | 0 |
4941 |-----------| |------------|
4942*)
4943
4944PROCEDURE BuildCaseEndStatementSequence ;
4945VAR
4946 t1, f1,
4947 t2, f2: CARDINAL ;
4948BEGIN
4949 GenQuad (GotoOp, NulSym, NulSym, 0) ;
4950 PopBool (t1, f1) ;
4951 PopBool (t2, f2) ; (* t2 contains the break list for the case *)
4952 BackPatch (f1, NextQuad) ; (* f1 no longer needed *)
4953 Assert (t1=0) ;
4954 Assert (f2=0) ;
4955 PushBool (Merge (t2, NextQuad-1), 0) ; (* NextQuad-1 = Goto Quad *)
4956 PushBool (0, 0) (* Room for boolean expression *)
4957END BuildCaseEndStatementSequence ;
4958
4959
4960(*
4961 BuildCaseRange - builds the range testing quaruples for
4962 a case clause.
4963
4964 IF (e1>=ce1) AND (e1<=ce2)
4965 THEN
4966
4967 ELS..
4968
4969 The Stack:
4970
4971 Entry Exit
4972
4973 Ptr ->
4974 +-----------+
4975 | ce2 | <- Ptr
4976 |-----------| +-----------+
4977 | ce1 | | t | f |
4978 |-----------| |-----------|
4979 | t1 | f1 | | t1 | f1 |
4980 |-----------| |-----------|
4981 | t2 | f2 | | t2 | f2 |
4982 |-----------| |-----------|
4983 | e1 | | e1 |
4984 |-----------| |-----------|
4985*)
4986
4987PROCEDURE BuildCaseRange ;
4988VAR
4989 ce1, ce2,
4990 combinedtok,
4991 ce1tok,
4992 ce2tok,
4993 e1tok,
4994 e1,
4995 t2, f2,
4996 t1, f1 : CARDINAL ;
4997BEGIN
4998 PopTtok (ce2, ce2tok) ;
4999 PopTtok (ce1, ce1tok) ;
5000 combinedtok := MakeVirtualTok (ce2tok, ce2tok, ce1tok) ;
5001 AddRange (ce1, ce2, combinedtok) ;
5002 PopBool (t1, f1) ;
5003 PopBool (t2, f2) ;
5004 PopTtok (e1, e1tok) ;
5005 PushTtok (e1, e1tok) ; (* leave e1 on bottom of stack when exit procedure *)
5006 PushBool (t2, f2) ;
5007 PushBool (t1, f1) ; (* also leave t1 and f1 on the bottom of the stack *)
5008 PushTtok (e1, e1tok) ;
5009 PushT (GreaterEqualTok) ;
5010 PushTtok (ce1, ce1tok) ;
5011 BuildRelOp (combinedtok) ;
5012 PushT (AndTok) ;
5013 RecordOp ;
5014 PushTtok (e1, e1tok) ;
5015 PushT (LessEqualTok) ;
5016 PushTtok (ce2, ce2tok) ;
5017 BuildRelOp (combinedtok) ;
5018 BuildBinaryOp
5019END BuildCaseRange ;
5020
5021
5022(*
5023 BuildCaseEquality - builds the range testing quadruples for
5024 a case clause.
5025
5026 IF e1=ce1
5027 THEN
5028
5029 ELS..
5030
5031 The Stack:
5032
5033 Entry Exit
5034
5035 Ptr ->
5036 +-----------+ +-----------+
5037 | ce1 | | t | f |
5038 |-----------| |-----------|
5039 | t1 | f1 | | t1 | f1 |
5040 |-----------| |-----------|
5041 | t2 | f2 | | t2 | f2 |
5042 |-----------| |-----------|
5043 | e1 | | e1 |
5044 |-----------| |-----------|
5045*)
5046
5047PROCEDURE BuildCaseEquality ;
5048VAR
5049 ce1tok,
5050 e1tok,
5051 ce1, e1,
5052 t2, f2,
5053 t1, f1 : CARDINAL ;
5054BEGIN
5055 PopTtok (ce1, ce1tok) ;
5056 AddRange (ce1, NulSym, ce1tok) ;
5057 PopBool (t1, f1) ;
5058 PopBool (t2, f2) ;
5059 PopTtok (e1, e1tok) ;
5060 PushTtok (e1, e1tok) ; (* leave e1 on bottom of stack when exit procedure *)
5061 PushBool (t2, f2) ; (* also leave t2 and f2 on the bottom of the stack *)
5062 PushBool (t1, f1) ;
5063 PushTtok (e1, e1tok) ;
5064 PushT (EqualTok) ;
5065 PushTtok (ce1, ce1tok) ;
5066 BuildRelOp (ce1tok)
5067END BuildCaseEquality ;
5068
5069
5070(*
5071 BuildCaseList - merges two case tests into one
5072
5073 The Stack:
5074
5075 Entry Exit
5076
5077 Ptr ->
5078 +-----------+
5079 | t2 | f2 |
5080 |-----------| +-------------+
5081 | t1 | f1 | | t1+t2| f1+f2|
5082 |-----------| |-------------|
5083*)
5084
5085PROCEDURE BuildCaseList ;
5086VAR
5087 t2, f2,
5088 t1, f1: CARDINAL ;
5089BEGIN
5090 PopBool (t2, f2) ;
5091 PopBool (t1, f1) ;
5092 PushBool (Merge (t1, t2), Merge (f1, f2))
5093END BuildCaseList ;
5094
5095
5096(*
5097 BuildCaseOr - builds the , in the case clause.
5098
5099 The Stack:
5100
5101 Entry Exit
5102
5103 Ptr -> <- Ptr
5104 +-----------+ +------------+
5105 | t | f | | t | 0 |
5106 |-----------| |------------|
5107*)
5108
5109PROCEDURE BuildCaseOr ;
5110VAR
5111 t, f: CARDINAL ;
5112BEGIN
5113 PopBool (t, f) ;
5114 BackPatch (f, NextQuad) ;
5115 PushBool (t, 0)
5116END BuildCaseOr ;
5117
5118
5119(*
5120 BuildCaseElse - builds the else of case clause.
5121
5122 The Stack:
5123
5124 Entry Exit
5125
5126 Ptr -> <- Ptr
5127 +-----------+ +------------+
5128 | t | f | | t | 0 |
5129 |-----------| |------------|
5130*)
5131
5132PROCEDURE BuildCaseElse ;
5133VAR
5134 t, f: CARDINAL ;
5135BEGIN
5136 PopBool (t, f) ;
5137 BackPatch (f, NextQuad) ;
5138 PushBool (t, 0)
5139END BuildCaseElse ;
5140
5141
5142(*
5143 BuildCaseEnd - builds the end of case clause.
5144
5145 The Stack:
5146
5147 Entry Exit
5148
5149 Ptr ->
5150 +-----------+
5151 | t1 | f1 |
5152 |-----------|
5153 | t2 | f2 |
5154 |-----------|
5155 | e1 |
5156 |-----------| Empty
5157*)
5158
5159PROCEDURE BuildCaseEnd ;
5160VAR
5161 e1,
5162 t, f: CARDINAL ;
5163BEGIN
5164 PopBool (t, f) ;
5165 BackPatch (f, NextQuad) ;
5166 BackPatch (t, NextQuad) ;
5167 PopBool (t, f) ;
5168 BackPatch (f, NextQuad) ;
5169 BackPatch (t, NextQuad) ;
5170 PopT (e1) ;
5171 PopCase
5172END BuildCaseEnd ;
5173
5174
5175(*
5176 BuildCaseCheck - builds the case checking code to ensure that
5177 the program does not need an else clause at runtime.
5178 The stack is unaltered.
5179*)
5180
5181PROCEDURE BuildCaseCheck ;
5182BEGIN
5183 BuildError (InitNoElseRangeCheck ())
5184END BuildCaseCheck ;
5185
5186
5187(*
5188 BuildNulParam - Builds a nul parameter on the stack.
5189 The Stack:
5190
5191 Entry Exit
5192
5193 <- Ptr
5194 Empty +------------+
5195 | 0 |
5196 |------------|
5197*)
5198
5199PROCEDURE BuildNulParam ;
5200BEGIN
5201 PushT (0)
5202END BuildNulParam ;
5203
5204
5205(*
5206 BuildSizeCheckStart - switches off all quadruple generation if the function SIZE or HIGH
5207 is being "called". This should be done as SIZE only requires the
5208 actual type of the expression, not its value. Consider the problem of
5209 SIZE(UninitializedPointer^) which is quite legal and it must
5210 also be safe!
5211 ISO Modula-2 also allows HIGH(a[0]) for a two dimensional array
5212 and there is no need to compute a[0], we just need to follow the
5213 type and count dimensions. However if SIZE(a) or HIGH(a) occurs
5214 and, a, is an unbounded array then we turn on quadruple generation.
5215
5216 The Stack is expected to contain:
5217
5218
5219 Entry Exit
5220 ===== ====
5221
5222 Ptr -> <- Ptr
5223 +----------------------+ +----------------------+
5224 | ProcSym | Type | tok | | ProcSym | Type | tok |
5225 |----------------------| |----------------------|
5226*)
5227
5228PROCEDURE BuildSizeCheckStart ;
5229VAR
5230 ProcSym, Type, tok: CARDINAL ;
5231BEGIN
5232 PopTFtok (ProcSym, Type, tok) ;
5233 IF (ProcSym=Size) OR (ProcSym=TSize) OR (ProcSym=TBitSize)
5234 THEN
5235 QuadrupleGeneration := FALSE ;
5236 BuildingSize := TRUE
5237 ELSIF ProcSym=High
5238 THEN
5239 QuadrupleGeneration := FALSE ;
5240 BuildingHigh := TRUE
5241 END ;
5242 PushTFtok (ProcSym, Type, tok)
5243END BuildSizeCheckStart ;
5244
5245
5246(*
5247 BuildSizeCheckEnd - checks to see whether the function "called" was in fact SIZE.
5248 If so then we restore quadruple generation.
5249*)
5250
5251PROCEDURE BuildSizeCheckEnd (ProcSym: CARDINAL) ;
5252BEGIN
5253 IF (ProcSym=Size) OR (ProcSym=TSize) OR (ProcSym=TBitSize)
5254 THEN
5255 QuadrupleGeneration := TRUE ;
5256 BuildingSize := FALSE
5257 ELSIF ProcSym=High
5258 THEN
5259 QuadrupleGeneration := TRUE ;
5260 BuildingHigh := FALSE
5261 END ;
5262END BuildSizeCheckEnd ;
5263
5264
5265(*
5266 BuildProcedureCall - builds a procedure call.
5267 Although this procedure does not directly
5268 destroy the procedure parameters, it calls
5269 routine which will manipulate the stack and
5270 so the entry and exit states of the stack are shown.
5271
5272 The Stack:
5273
5274
5275 Entry Exit
5276
5277 Ptr ->
5278 +----------------+
5279 | NoOfParam |
5280 |----------------|
5281 | Param 1 |
5282 |----------------|
5283 | Param 2 |
5284 |----------------|
5285 . .
5286 . .
5287 . .
5288 |----------------|
5289 | Param # |
5290 |----------------|
5291 | ProcSym | Type | Empty
5292 |----------------|
5293*)
5294
5295PROCEDURE BuildProcedureCall (tokno: CARDINAL) ;
5296VAR
5297 NoOfParam,
5298 ProcSym : CARDINAL ;
5299BEGIN
5300 PopT(NoOfParam) ;
5301 ProcSym := OperandT (NoOfParam+1) ;
5302 PushT (NoOfParam) ; (* Compile time stack restored to entry state *)
5303 IF IsPseudoBaseProcedure (ProcSym) OR IsPseudoSystemProcedure (ProcSym)
5304 THEN
5305 DisplayStack ;
5306 ManipulatePseudoCallParameters ;
5307 DisplayStack ;
5308 BuildPseudoProcedureCall (tokno) ;
5309 DisplayStack
5310 ELSIF IsUnknown (ProcSym)
5311 THEN
5312 MetaError1 ('{%1Ua} is not recognised as a procedure, check declaration or import', ProcSym) ;
5313 PopN (NoOfParam + 2)
5314 ELSE
5315 DisplayStack ;
5316 BuildRealProcedureCall (tokno) ;
5317 DisplayStack ;
5318 END
5319END BuildProcedureCall ;
5320
5321
5322(*
5323 BuildRealProcedureCall - builds a real procedure call.
5324 The Stack:
5325
5326
5327 Entry Exit
5328
5329 Ptr ->
5330 +----------------+
5331 | NoOfParam |
5332 |----------------|
5333 | Param 1 |
5334 |----------------|
5335 | Param 2 |
5336 |----------------|
5337 . .
5338 . .
5339 . .
5340 |----------------|
5341 | Param # |
5342 |----------------|
5343 | ProcSym | Type | Empty
5344 |----------------|
5345*)
5346
5347PROCEDURE BuildRealProcedureCall (tokno: CARDINAL) ;
5348VAR
5349 NoOfParam: CARDINAL ;
5350 ProcSym : CARDINAL ;
5351BEGIN
5352 PopT (NoOfParam) ;
5353 PushT (NoOfParam) ;
5354 ProcSym := OperandT (NoOfParam+2) ;
5355 ProcSym := SkipConst (ProcSym) ;
5356 (* tokno := OperandTtok (NoOfParam+2) ; *) (* --checkme-- *)
5357 IF IsVar (ProcSym)
5358 THEN
5359 (* Procedure Variable ? *)
5360 ProcSym := SkipType (OperandF (NoOfParam+2))
5361 END ;
5362 IF IsDefImp (GetScope (ProcSym)) AND IsDefinitionForC (GetScope (ProcSym))
5363 THEN
81d5ca0b 5364 BuildRealFuncProcCall (tokno, FALSE, TRUE, FALSE)
1eee94d3 5365 ELSE
81d5ca0b 5366 BuildRealFuncProcCall (tokno, FALSE, FALSE, FALSE)
1eee94d3
GM		 5367 END
5368END BuildRealProcedureCall ;
5369
5370
5371(*
5372 BuildRealFuncProcCall - builds a real procedure or function call.
5373 The Stack:
5374
5375
5376 Entry Exit
5377
5378 Ptr ->
5379 +----------------+
5380 | NoOfParam |
5381 |----------------|
5382 | Param 1 |
5383 |----------------|
5384 | Param 2 |
5385 |----------------|
5386 . .
5387 . .
5388 . .
5389 |----------------|
5390 | Param # |
5391 |----------------|
5392 | ProcSym | Type | Empty
5393 |----------------|
5394*)
5395
81d5ca0b 5396PROCEDURE BuildRealFuncProcCall (tokno: CARDINAL; IsFunc, IsForC, ConstExpr: BOOLEAN) ;
1eee94d3 5397VAR
b80e3c46
GM		 5398 AllocateProc,
5399 DeallocateProc,
1eee94d3
GM		 5400 ForcedFunc,
5401 ParamConstant : BOOLEAN ;
b80e3c46 5402 trash,
1eee94d3
GM		 5403 resulttok,
5404 paramtok,
5405 proctok,
5406 NoOfParameters,
5407 i, pi,
b80e3c46
GM		 5408 ParamType,
5409 Param1, (* Used to remember first param for allocate/deallocate. *)
1eee94d3
GM		 5410 ReturnVar,
5411 ProcSym,
5412 Proc : CARDINAL ;
5413BEGIN
b80e3c46
GM		 5414 Param1 := NulSym ;
5415 ParamType := NulSym ;
1eee94d3
GM		 5416 CheckProcedureParameters (IsForC) ;
5417 PopT (NoOfParameters) ;
5418 PushT (NoOfParameters) ; (* Restore stack to original state. *)
5419 ProcSym := OperandT (NoOfParameters+2) ;
5420 proctok := tokno ; (* OperandTtok (NoOfParameters+2) ; *)
5421 IF proctok = UnknownTokenNo
5422 THEN
5423 proctok := GetTokenNo ()
5424 END ;
5425 paramtok := proctok ;
5426 ProcSym := SkipConst (ProcSym) ;
5427 ForcedFunc := FALSE ;
b80e3c46
GM		 5428 AllocateProc := FALSE ;
5429 DeallocateProc := FALSE ;
1eee94d3
GM		 5430 IF IsVar (ProcSym)
5431 THEN
5432 (* Procedure Variable ? *)
5433 Proc := SkipType (OperandF (NoOfParameters+2)) ;
5434 ParamConstant := FALSE
5435 ELSE
5436 Proc := ProcSym ;
81d5ca0b 5437 ParamConstant := TRUE ;
b80e3c46
GM		 5438 AllocateProc := GetSymName (Proc) = MakeKey('ALLOCATE') ;
5439 DeallocateProc := GetSymName (Proc) = MakeKey('DEALLOCATE')
1eee94d3
GM		 5440 END ;
5441 IF IsFunc
5442 THEN
5443 IF GetSType (Proc) = NulSym
5444 THEN
5445 MetaErrors1 ('procedure {%1a} cannot be used as a function',
5446 'procedure {%1Da} does not have a return type',
5447 Proc)
5448 END
5449 ELSE
5450 (* is being called as a procedure *)
5451 IF GetSType (Proc) # NulSym
5452 THEN
5453 (* however it was declared as a procedure function *)
5454 IF NOT IsReturnOptional (Proc)
5455 THEN
5456 MetaErrors1 ('function {%1a} is being called but its return value is ignored',
5457 'function {%1Da} return a type {%1ta:of {%1ta}}',
5458 Proc)
5459 END ;
5460 IsFunc := TRUE ;
5461 ForcedFunc := TRUE
5462 END
5463 END ;
b80e3c46
GM		 5464 IF AllocateProc OR DeallocateProc
5465 THEN
5466 Param1 := OperandT (NoOfParameters+1) (* Remember this before manipulating. *)
5467 END ;
1eee94d3
GM		 5468 ManipulateParameters (IsForC) ;
5469 CheckParameterOrdinals ;
5470 PopT(NoOfParameters) ;
5471 IF IsFunc
5472 THEN
5473 GenQuad (ParamOp, 0, Proc, ProcSym) (* Space for return value *)
5474 END ;
5475 IF (NoOfParameters+1=NoOfParam(Proc)) AND UsesOptArg(Proc)
5476 THEN
5477 GenQuad (OptParamOp, NoOfParam(Proc), Proc, Proc)
5478 END ;
5479 i := NoOfParameters ;
5480 pi := 1 ; (* stack index referencing stacked parameter, i *)
5481 WHILE i>0 DO
5482 paramtok := OperandTtok (pi) ;
b80e3c46
GM		 5483 IF (AllocateProc OR DeallocateProc) AND (i = 1) AND (Param1 # NulSym)
5484 THEN
5485 ParamType := GetItemPointedTo (Param1) ;
5486 IF ParamType = NulSym
5487 THEN
5488 GenQuadO (paramtok, ParamOp, i, Proc, OperandT (pi), TRUE)
5489 ELSE
e029635c
GM		 5490 IF AllocateProc
5491 THEN
5492 trash := MakeTemporary (paramtok, RightValue) ;
5493 PutVar (trash, ParamType) ;
5494 PutVarHeap (trash, TRUE)
5495 ELSE
5496 Assert (DeallocateProc) ;
5497 trash := Nil
5498 END ;
b80e3c46
GM		 5499 GenQuadOTrash (paramtok, ParamOp, i, Proc, OperandT (pi), TRUE, trash)
5500 END
5501 ELSE
5502 GenQuadO (paramtok, ParamOp, i, Proc, OperandT (pi), TRUE)
5503 END ;
1eee94d3
GM		 5504 IF NOT IsConst (OperandT (pi))
5505 THEN
5506 ParamConstant := FALSE
5507 END ;
5508 DEC (i) ;
5509 INC (pi)
5510 END ;
5511 GenQuadO (proctok, CallOp, NulSym, NulSym, ProcSym, TRUE) ;
81d5ca0b 5512 PopN (NoOfParameters+1) ; (* Destroy arguments and procedure call *)
1eee94d3
GM		 5513 IF IsFunc
5514 THEN
81d5ca0b 5515 (* ReturnVar has the type of the procedure. *)
1eee94d3 5516 resulttok := MakeVirtualTok (proctok, proctok, paramtok) ;
81d5ca0b
GM		 5517 IF ConstExpr AND (NOT IsProcedureBuiltinAvailable (Proc))
5518 THEN
5519 MetaError1('{%1d} {%1ad} cannot be used in a constant expression', Proc) ;
5520 ParamConstant := FALSE
5521 END ;
5522 ReturnVar := MakeTemporary (resulttok, AreConstant (ParamConstant AND ConstExpr)) ;
5523 PutVar (ReturnVar, GetSType (Proc)) ;
1eee94d3
GM		 5524 GenQuadO (resulttok, FunctValueOp, ReturnVar, NulSym, Proc, TRUE) ;
5525 IF NOT ForcedFunc
5526 THEN
5527 PushTFtok (ReturnVar, GetSType (Proc), resulttok)
5528 END
5529 END
5530END BuildRealFuncProcCall ;
5531
5532
5533(*
5534 CheckProcedureParameters - Checks the parameters which are being passed to
5535 procedure ProcSym.
5536
5537 The Stack:
5538
5539
5540 Entry Exit
5541
5542 Ptr -> <- Ptr
5543 +----------------+ +----------------+
5544 | NoOfParam | | NoOfParam |
5545 |----------------| |----------------|
5546 | Param 1 | | Param 1 |
5547 |----------------| |----------------|
5548 | Param 2 | | Param 2 |
5549 |----------------| |----------------|
5550 . . . .
5551 . . . .
5552 . . . .
5553 |----------------| |----------------|
5554 | Param # | | Param # |
5555 |----------------| |----------------|
5556 | ProcSym | Type | | ProcSym | Type |
5557 |----------------| |----------------|
5558
5559*)
5560
5561PROCEDURE CheckProcedureParameters (IsForC: BOOLEAN) ;
5562VAR
5563 proctok,
5564 paramtok : CARDINAL ;
5565 n1, n2 : Name ;
5566 Dim,
5567 Actual,
5568 FormalI,
5569 ParamTotal,
5570 pi,
5571 Proc,
5572 ProcSym,
5573 i : CARDINAL ;
5574 s : String ;
5575BEGIN
5576 PopT(ParamTotal) ;
5577 PushT(ParamTotal) ; (* Restore stack to origional state *)
5578 ProcSym := OperandT(ParamTotal+1+1) ;
5579 proctok := OperandTtok(ParamTotal+1+1) ;
5580 IF IsVar(ProcSym) AND IsProcType(GetDType(ProcSym))
5581 THEN
5582 (* Procedure Variable ? *)
5583 Proc := SkipType(OperandF(ParamTotal+1+1))
5584 ELSE
5585 Proc := SkipConst(ProcSym)
5586 END ;
5587 IF NOT (IsProcedure(Proc) OR IsProcType(Proc))
5588 THEN
5589 IF IsUnknown(Proc)
5590 THEN
5591 MetaError1('{%1Ua} is not recognised as a procedure, check declaration or import', Proc)
5592 ELSE
5593 MetaErrors1('{%1a} is not recognised as a procedure, check declaration or import',
5594 '{%1Ua} is not recognised as a procedure, check declaration or import',
5595 Proc)
5596 END
5597 END ;
5598 IF CompilerDebugging
5599 THEN
5600 n1 := GetSymName(Proc) ;
5601 printf1(' %a ( ', n1)
5602 END ;
5603 IF DebugTokPos
5604 THEN
5605 s := InitString ('procedure') ;
5606 WarnStringAt (s, proctok)
5607 END ;
5608
5609 i := 1 ;
5610 pi := ParamTotal+1 ; (* stack index referencing stacked parameter, i *)
5611 WHILE i<=ParamTotal DO
5612 IF i<=NoOfParam(Proc)
5613 THEN
5614 FormalI := GetParam(Proc, i) ;
5615 IF CompilerDebugging
5616 THEN
5617 n1 := GetSymName(FormalI) ;
5618 n2 := GetSymName(GetSType(FormalI)) ;
5619 printf2('%a: %a', n1, n2)
5620 END ;
5621 Actual := OperandT(pi) ;
5622 Dim := OperandD(pi) ;
5623 paramtok := OperandTtok(pi) ;
5624 IF DebugTokPos
5625 THEN
5626 s := InitString ('actual') ;
5627 WarnStringAt (s, paramtok)
5628 END ;
5629
f8c8aebc 5630 BuildRange (InitTypesParameterCheck (paramtok, Proc, i, FormalI, Actual)) ;
1eee94d3
GM		 5631 IF IsConst(Actual)
5632 THEN
5633 IF IsVarParam(Proc, i)
5634 THEN
5635 FailParameter (paramtok,
5636 'trying to pass a constant to a VAR parameter',
5637 Actual, FormalI, Proc, i)
5638 ELSIF IsConstString (Actual)
5639 THEN
78b72ee5 5640 IF (NOT IsConstStringKnown (Actual))
1eee94d3 5641 THEN
eb619490
GM		 5642 (* We dont check this yet, it is checked in M2GenGCC.mod:CodeParam
5643 after the string has been created. *)
1eee94d3
GM		 5644 ELSIF IsArray(GetDType(FormalI)) AND (GetSType(GetDType(FormalI))=Char)
5645 THEN
eb619490 5646 (* Allow string literals to be passed to ARRAY [0..n] OF CHAR. *)
78b72ee5 5647 ELSIF (GetStringLength(paramtok, Actual) = 1) (* If = 1 then it maybe treated as a char. *)
1eee94d3
GM		 5648 THEN
5649 CheckParameter (paramtok, Actual, Dim, FormalI, Proc, i, NIL)
5650 ELSIF NOT IsUnboundedParam(Proc, i)
5651 THEN
5652 IF IsForC AND (GetSType(FormalI)=Address)
5653 THEN
5654 FailParameter (paramtok,
5655 'a string constant can either be passed to an ADDRESS parameter or an ARRAY OF CHAR',
5656 Actual, FormalI, Proc, i)
5657 ELSE
5658 FailParameter (paramtok,
5659 'cannot pass a string constant to a non unbounded array parameter',
5660 Actual, FormalI, Proc, i)
5661 END
5662 END
5663 END
5664 ELSE
5665 CheckParameter (paramtok, Actual, Dim, FormalI, Proc, i, NIL)
5666 END
5667 ELSE
5668 IF IsForC AND UsesVarArgs(Proc)
5669 THEN
5670 (* these are varargs, therefore we don't check them *)
5671 i := ParamTotal
5672 ELSE
5673 MetaErrorT2 (proctok, 'too many parameters, {%2n} passed to {%1a} ', Proc, i)
5674 END
5675 END ;
5676 INC(i) ;
5677 DEC(pi) ;
5678 IF CompilerDebugging
5679 THEN
5680 IF i<=ParamTotal
5681 THEN
48d49200 5682 printf0 ('; ')
1eee94d3 5683 ELSE
48d49200 5684 printf0 (' ) ; \n')
1eee94d3
GM		 5685 END
5686 END
5687 END
5688END CheckProcedureParameters ;
5689
5690
5691(*
5692 CheckProcTypeAndProcedure - checks the ProcType with the call.
5693*)
5694
f8c8aebc 5695PROCEDURE CheckProcTypeAndProcedure (tokno: CARDINAL; ProcType: CARDINAL; call: CARDINAL) ;
1eee94d3
GM		 5696VAR
5697 n1, n2 : Name ;
5698 i, n, t : CARDINAL ;
5699 CheckedProcedure: CARDINAL ;
5700 e : Error ;
5701BEGIN
5702 n := NoOfParam(ProcType) ;
5703 IF IsVar(call) OR IsTemporary(call) OR IsParameter(call)
5704 THEN
5705 CheckedProcedure := GetDType(call)
5706 ELSE
5707 CheckedProcedure := call
5708 END ;
5709 IF n#NoOfParam(CheckedProcedure)
5710 THEN
5711 e := NewError(GetDeclaredMod(ProcType)) ;
5712 n1 := GetSymName(call) ;
5713 n2 := GetSymName(ProcType) ;
5714 ErrorFormat2(e, 'procedure (%a) is a parameter being passed as variable (%a) but they are declared with different number of parameters',
5715 n1, n2) ;
5716 e := ChainError(GetDeclaredMod(call), e) ;
5717 t := NoOfParam(CheckedProcedure) ;
5718 IF n<2
5719 THEN
5720 ErrorFormat3(e, 'procedure (%a) is being called incorrectly with (%d) parameter, declared with (%d)',
5721 n1, n, t)
5722 ELSE
5723 ErrorFormat3(e, 'procedure (%a) is being called incorrectly with (%d) parameters, declared with (%d)',
5724 n1, n, t)
5725 END
5726 ELSE
5727 i := 1 ;
5728 WHILE i<=n DO
f8c8aebc 5729 IF IsVarParam (ProcType, i) # IsVarParam (CheckedProcedure, i)
1eee94d3 5730 THEN
f8c8aebc
GM		 5731 MetaError3 ('parameter {%3n} in {%1dD} causes a mismatch it was declared as a {%2d}', ProcType, GetNth (ProcType, i), i) ;
5732 MetaError3 ('parameter {%3n} in {%1dD} causes a mismatch it was declared as a {%2d}', call, GetNth (call, i), i)
1eee94d3 5733 END ;
f8c8aebc
GM		 5734 BuildRange (InitTypesParameterCheck (tokno, CheckedProcedure, i,
5735 GetParam (CheckedProcedure, i),
5736 GetParam (ProcType, i))) ;
1eee94d3
GM		 5737 (* CheckParameter(tokpos, GetParam(CheckedProcedure, i), 0, GetParam(ProcType, i), call, i, TypeList) ; *)
5738 INC(i)
5739 END
5740 END
5741END CheckProcTypeAndProcedure ;
5742
5743
5744(*
5745 IsReallyPointer - returns TRUE is sym is a pointer, address or a type declared
5746 as a pointer or address.
5747*)
5748
5749PROCEDURE IsReallyPointer (Sym: CARDINAL) : BOOLEAN ;
5750BEGIN
5751 IF IsVar(Sym)
5752 THEN
5753 Sym := GetSType(Sym)
5754 END ;
5755 Sym := SkipType(Sym) ;
5756 RETURN( IsPointer(Sym) OR (Sym=Address) )
5757END IsReallyPointer ;
5758
5759
5760(*
5f240871 5761 LegalUnboundedParam - returns TRUE if the parameter, Actual, can legitimately be
1eee94d3
GM		 5762 passed to ProcSym, i, the, Formal, parameter.
5763*)
5764
5765PROCEDURE LegalUnboundedParam (tokpos: CARDINAL; ProcSym, i, ActualType, Actual, Dimension, Formal: CARDINAL) : BOOLEAN ;
5766VAR
5767 FormalType: CARDINAL ;
5768 n, m : CARDINAL ;
5769BEGIN
5770 ActualType := SkipType(ActualType) ;
5771 FormalType := GetDType(Formal) ;
5772 FormalType := GetSType(FormalType) ; (* type of the unbounded ARRAY *)
5773 IF IsArray(ActualType)
5774 THEN
5775 m := GetDimension(Formal) ;
5776 n := 0 ;
5777 WHILE IsArray(ActualType) DO
5778 INC(n) ;
5779 ActualType := GetDType(ActualType) ;
5780 IF (m=n) AND (ActualType=FormalType)
5781 THEN
5782 RETURN( TRUE )
5783 END
5784 END ;
5785 IF n=m
5786 THEN
5787 (* now we fall though and test ActualType against FormalType *)
5788 ELSE
5789 IF IsGenericSystemType(FormalType)
5790 THEN
5791 RETURN( TRUE )
5792 ELSE
5793 FailParameter(tokpos,
5794 'attempting to pass an array with the incorrect number dimenisons to an unbounded formal parameter of different dimensions',
5795 Actual, Formal, ProcSym, i) ;
5796 RETURN( FALSE )
5797 END
5798 END
5799 ELSIF IsUnbounded(ActualType)
5800 THEN
5801 IF (Dimension=0) AND (GetDimension(Formal)=GetDimension(Actual))
5802 THEN
5803 (* now we fall though and test ActualType against FormalType *)
5804 ActualType := GetSType(ActualType)
5805 ELSE
5806 IF IsGenericSystemType(FormalType)
5807 THEN
5808 RETURN( TRUE )
5809 ELSE
5810 IF GetDimension(Actual)-Dimension = GetDimension(Formal)
5811 THEN
5812 ActualType := GetSType(ActualType)
5813 ELSE
5814 FailParameter(tokpos,
5815 'attempting to pass an unbounded array with the incorrect number dimenisons to an unbounded formal parameter of different dimensions',
5816 Actual, Formal, ProcSym, i) ;
5817 RETURN( FALSE )
5818 END
5819 END
5820 END
5821 END ;
5822 IF IsGenericSystemType (FormalType) OR
5823 IsGenericSystemType (ActualType) OR
5824 IsAssignmentCompatible (FormalType, ActualType)
5825 THEN
5826 (* we think it is legal, but we ask post pass 3 to check as
5827 not all types are known at this point *)
5828 RETURN( TRUE )
5829 ELSE
5830 FailParameter(tokpos,
5831 'identifier with an incompatible type is being passed to this procedure',
5832 Actual, Formal, ProcSym, i) ;
5833 RETURN( FALSE )
5834 END
5835END LegalUnboundedParam ;
5836
5837
5838(*
5839 CheckParameter - checks that types ActualType and FormalType are compatible for parameter
5840 passing. ProcSym is the procedure and i is the parameter number.
5841
5842 We obey the following rules:
5843
5844 (1) we allow WORD, BYTE, LOC to be compitable with any like sized
5845 type.
5846 (2) we allow ADDRESS to be compatible with any pointer type.
5847 (3) we relax INTEGER and CARDINAL checking for Temporary variables.
5848
5849 Note that type sizes are checked during the code generation pass.
5850*)
5851
5852PROCEDURE CheckParameter (tokpos: CARDINAL;
5853 Actual, Dimension, Formal, ProcSym: CARDINAL;
5854 i: CARDINAL; TypeList: List) ;
5855VAR
5856 NewList : BOOLEAN ;
5857 ActualType, FormalType: CARDINAL ;
5858BEGIN
78b72ee5
GM		 5859 IF IsConstString(Actual) AND (NOT IsConstStringKnown (Actual))
5860 THEN
5861 (* Cannot check if the string content is not yet known. *)
5862 RETURN
5863 END ;
1eee94d3 5864 FormalType := GetDType(Formal) ;
78b72ee5 5865 IF IsConstString(Actual) AND (GetStringLength(tokpos, Actual) = 1) (* if = 1 then it maybe treated as a char *)
1eee94d3
GM		 5866 THEN
5867 ActualType := Char
5868 ELSIF Actual=Boolean
5869 THEN
5870 ActualType := Actual
5871 ELSE
5872 ActualType := GetDType(Actual)
5873 END ;
5874 IF TypeList=NIL
5875 THEN
5876 NewList := TRUE ;
5877 InitList(TypeList)
5878 ELSE
5879 NewList := FALSE
5880 END ;
5881 IF IsItemInList(TypeList, ActualType)
5882 THEN
5883 (* no need to check *)
5884 RETURN
5885 END ;
5886 IncludeItemIntoList(TypeList, ActualType) ;
5887 IF IsProcType(FormalType)
5888 THEN
5889 IF (NOT IsProcedure(Actual)) AND ((ActualType=NulSym) OR (NOT IsProcType(SkipType(ActualType))))
5890 THEN
5891 FailParameter(tokpos,
5892 'expecting a procedure or procedure variable as a parameter',
5893 Actual, Formal, ProcSym, i) ;
5894 RETURN
5895 END ;
5896 IF IsProcedure(Actual) AND IsProcedureNested(Actual)
5897 THEN
5898 MetaError2 ('cannot pass a nested procedure {%1Ea} seen in the {%2N} parameter as the outer scope will be unknown at runtime', Actual, i)
5899 END ;
5900 (* we can check the return type of both proc types *)
5901 IF (ActualType#NulSym) AND IsProcType(ActualType)
5902 THEN
5903 IF ((GetSType(ActualType)#NulSym) AND (GetSType(FormalType)=NulSym))
5904 THEN
5905 FailParameter(tokpos,
5906 'the item being passed is a function whereas the formal procedure parameter is a procedure',
5907 Actual, Formal, ProcSym, i) ;
5908 RETURN
5909 ELSIF ((GetSType(ActualType)=NulSym) AND (GetSType(FormalType)#NulSym))
5910 THEN
5911 FailParameter(tokpos,
5912 'the item being passed is a procedure whereas the formal procedure parameter is a function',
5913 Actual, Formal, ProcSym, i) ;
5914 RETURN
5915 ELSIF AssignmentRequiresWarning(GetSType(ActualType), GetSType(FormalType))
5916 THEN
5917 WarnParameter(tokpos,
5918 'the return result of the procedure variable parameter may not be compatible on other targets with the return result of the item being passed',
5919 Actual, Formal, ProcSym, i) ;
5920 RETURN
5921 ELSIF IsGenericSystemType (GetSType(FormalType)) OR
5922 IsGenericSystemType (GetSType(ActualType)) OR
5923 IsAssignmentCompatible(GetSType(ActualType), GetSType(FormalType))
5924 THEN
5925 (* pass *)
5926 ELSE
5927 FailParameter(tokpos,
5928 'the return result of the procedure variable parameter is not compatible with the return result of the item being passed',
5929 Actual, Formal, ProcSym, i) ;
5930 RETURN
5931 END
5932 END ;
5933 (* now to check each parameter of the proc type *)
f8c8aebc 5934 CheckProcTypeAndProcedure (tokpos, FormalType, Actual)
1eee94d3
GM		 5935 ELSIF (ActualType#FormalType) AND (ActualType#NulSym)
5936 THEN
5937 IF IsUnknown(FormalType)
5938 THEN
5939 FailParameter(tokpos,
5940 'procedure parameter type is undeclared',
5941 Actual, Formal, ProcSym, i) ;
5942 RETURN
5943 END ;
5944 IF IsUnbounded(ActualType) AND (NOT IsUnboundedParam(ProcSym, i))
5945 THEN
5946 FailParameter(tokpos,
5947 'attempting to pass an unbounded array to a NON unbounded parameter',
5948 Actual, Formal, ProcSym, i) ;
5949 RETURN
5950 ELSIF IsUnboundedParam(ProcSym, i)
5951 THEN
5952 IF NOT LegalUnboundedParam(tokpos, ProcSym, i, ActualType, Actual, Dimension, Formal)
5953 THEN
5954 RETURN
5955 END
5956 ELSIF ActualType#FormalType
5957 THEN
5958 IF AssignmentRequiresWarning(FormalType, ActualType)
5959 THEN
5960 WarnParameter (tokpos,
5961 'identifier being passed to this procedure may contain a possibly incompatible type when compiling for a different target',
5962 Actual, Formal, ProcSym, i)
5963 ELSIF IsGenericSystemType (FormalType) OR
5964 IsGenericSystemType (ActualType) OR
5965 IsAssignmentCompatible (ActualType, FormalType)
5966 THEN
5967 (* so far we know it is legal, but not all types have been resolved
5968 and so this is checked later on in another pass. *)
5969 ELSE
5970 FailParameter (tokpos,
5971 'identifier with an incompatible type is being passed to this procedure',
5972 Actual, Formal, ProcSym, i)
5973 END
5974 END
5975 END ;
5976 IF NewList
5977 THEN
5978 KillList(TypeList)
5979 END
5980END CheckParameter ;
5981
5982
5983(*
5984 DescribeType - returns a String describing a symbol, Sym, name and its type.
5985*)
5986
5987PROCEDURE DescribeType (Sym: CARDINAL) : String ;
5988VAR
5989 s, s1, s2: String ;
5990 Low, High,
5991 Subrange,
5992 Subscript,
5993 Type : CARDINAL ;
5994BEGIN
5995 s := NIL ;
5996 IF IsConstString(Sym)
5997 THEN
78b72ee5
GM		 5998 (* If = 1 then it maybe treated as a char. *)
5999 IF IsConstStringKnown (Sym) AND (GetStringLength (GetDeclaredMod (Sym), Sym) = 1)
1eee94d3
GM		 6000 THEN
6001 s := InitString('(constant string) or {%kCHAR}')
6002 ELSE
6003 s := InitString('(constant string)')
6004 END
6005 ELSIF IsConst(Sym)
6006 THEN
6007 s := InitString('(constant)')
6008 ELSIF IsUnknown(Sym)
6009 THEN
6010 s := InitString('(unknown)')
6011 ELSE
6012 Type := GetSType(Sym) ;
6013 IF Type=NulSym
6014 THEN
6015 s := InitString('(unknown)')
6016 ELSIF IsUnbounded(Type)
6017 THEN
6018 s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(GetSType(Type))))) ;
6019 s := Sprintf1(Mark(InitString('{%%kARRAY} {%%kOF} %s')), s1)
6020 ELSIF IsArray(Type)
6021 THEN
6022 s := InitString('{%kARRAY} [') ;
6023 Subscript := GetArraySubscript(Type) ;
6024 IF Subscript#NulSym
6025 THEN
6026 Assert(IsSubscript(Subscript)) ;
6027 Subrange := GetSType(Subscript) ;
6028 IF NOT IsSubrange(Subrange)
6029 THEN
6030 MetaError3 ('error in definition of array {%1Ead} in the {%2N} subscript which has no subrange, instead type given is {%3a}',
6031 Sym, Subscript, Subrange)
6032 END ;
6033 Assert(IsSubrange(Subrange)) ;
6034 GetSubrange(Subrange, High, Low) ;
6035 s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Low)))) ;
6036 s2 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(High)))) ;
6037 s := ConCat(s, Mark(Sprintf2(Mark(InitString('%s..%s')),
6038 s1, s2)))
6039 END ;
6040 s1 := Mark(DescribeType(Type)) ;
6041 s := ConCat(ConCat(s, Mark(InitString('] OF '))), s1)
6042 ELSE
6043 IF IsUnknown(Type)
6044 THEN
6045 s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Type)))) ;
6046 s := Sprintf1(Mark(InitString('%s (currently unknown, check declaration or import)')),
6047 s1)
6048 ELSE
6049 s := InitStringCharStar(KeyToCharStar(GetSymName(Type)))
6050 END
6051 END
6052 END ;
6053 RETURN( s )
6054END DescribeType ;
6055
6056
6057(*
6058 FailParameter - generates an error message indicating that a parameter
6059 declaration has failed.
6060
6061 The parameters are:
6062
6063 CurrentState - string describing the current failing state.
6064 Given - the token that the source code provided.
6065 Expecting - token or identifier that was expected.
6066 ParameterNo - parameter number that has failed.
6067 ProcedureSym - procedure symbol where parameter has failed.
6068
6069 If any parameter is Nul then it is ignored.
6070*)
6071
6072PROCEDURE FailParameter (tokpos : CARDINAL;
6073 CurrentState : ARRAY OF CHAR;
6074 Given : CARDINAL;
6075 Expecting : CARDINAL;
6076 ProcedureSym : CARDINAL;
6077 ParameterNo : CARDINAL) ;
6078VAR
6079 First,
6080 ExpectType: CARDINAL ;
6081 s, s1, s2 : String ;
6082BEGIN
eb619490
GM		 6083 MetaErrorT2 (tokpos,
6084 'parameter mismatch between the {%2N} parameter of procedure {%1Ead}',
6085 ProcedureSym, ParameterNo) ;
1eee94d3
GM		 6086 s := InitString ('{%kPROCEDURE} {%1Eau} (') ;
6087 IF NoOfParam(ProcedureSym)>=ParameterNo
6088 THEN
6089 IF ParameterNo>1
6090 THEN
6091 s := ConCat(s, Mark(InitString('.., ')))
6092 END ;
6093 IF IsVarParam(ProcedureSym, ParameterNo)
6094 THEN
6095 s := ConCat(s, Mark(InitString('{%kVAR} ')))
6096 END ;
6097
6098 First := GetDeclaredMod(GetNthParam(ProcedureSym, ParameterNo)) ;
6099 ExpectType := GetSType(Expecting) ;
6100 IF IsUnboundedParam(ProcedureSym, ParameterNo)
6101 THEN
6102 s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Expecting)))) ;
6103 s2 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(GetSType(ExpectType))))) ;
6104 s := ConCat(s, Mark(Sprintf2(Mark(InitString('%s: {%%kARRAY} {%%kOF} %s')),
6105 s1, s2)))
6106 ELSE
6107 s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Expecting)))) ;
6108 s2 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(ExpectType)))) ;
6109 s := ConCat(s, Mark(Sprintf2(Mark(InitString('%s: %s')), s1, s2)))
6110 END ;
6111 IF ParameterNo<NoOfParam(ProcedureSym)
6112 THEN
6113 s := ConCat(s, Mark(InitString('; ... ')))
6114 END
6115 ELSE
6116 First := GetDeclaredMod(ProcedureSym) ;
6117 IF NoOfParam(ProcedureSym)>0
6118 THEN
6119 s := ConCat(s, Mark(InitString('..')))
6120 END
6121 END ;
6122 s := ConCat (s, Mark (InitString ('){%1Tau:% : {%1Tau}} ;'))) ;
6123 MetaErrorStringT1 (First, Dup (s), ProcedureSym) ;
6124 MetaErrorStringT1 (tokpos, s, ProcedureSym) ;
eb619490
GM		 6125 IF GetLType (Given) = NulSym
6126 THEN
6127 MetaError1 ('item being passed is {%1EDda} {%1Dad}', Given)
6128 ELSE
6129 MetaError1 ('item being passed is {%1EDda} {%1Dad} of type {%1Dts}',
6130 Given)
6131 END
1eee94d3
GM		 6132END FailParameter ;
6133
6134
6135(*
6136 WarnParameter - generates a warning message indicating that a parameter
6137 use might cause problems on another target.
6138
6139 The parameters are:
6140
6141 CurrentState - string describing the current failing state.
6142 Given - the token that the source code provided.
6143 Expecting - token or identifier that was expected.
6144 ParameterNo - parameter number that has failed.
6145 ProcedureSym - procedure symbol where parameter has failed.
6146
6147 If any parameter is Nul then it is ignored.
6148*)
6149
6150PROCEDURE WarnParameter (tokpos : CARDINAL;
6151 CurrentState : ARRAY OF CHAR;
6152 Given : CARDINAL;
6153 Expecting : CARDINAL;
6154 ProcedureSym : CARDINAL;
6155 ParameterNo : CARDINAL) ;
6156VAR
6157 First,
6158 ExpectType,
6159 ReturnType: CARDINAL ;
6160 s, s1, s2 : String ;
6161BEGIN
6162 s := InitString('{%W}') ;
6163 IF CompilingImplementationModule()
6164 THEN
6165 s := ConCat(s, Sprintf0(Mark(InitString('warning issued while compiling the implementation module\n'))))
6166 ELSIF CompilingProgramModule()
6167 THEN
6168 s := ConCat(s, Sprintf0(Mark(InitString('warning issued while compiling the program module\n'))))
6169 END ;
6170 s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(ProcedureSym)))) ;
6171 s := ConCat(s, Mark(Sprintf2(Mark(InitString('problem in parameter %d, PROCEDURE %s (')),
6172 ParameterNo,
6173 s1))) ;
6174 IF NoOfParam(ProcedureSym)>=ParameterNo
6175 THEN
6176 IF ParameterNo>1
6177 THEN
6178 s := ConCat(s, Mark(InitString('.., ')))
6179 END ;
6180 IF IsVarParam(ProcedureSym, ParameterNo)
6181 THEN
6182 s := ConCat(s, Mark(InitString('{%kVAR} ')))
6183 END ;
6184
6185 First := GetDeclaredMod(GetNthParam(ProcedureSym, ParameterNo)) ;
6186 ExpectType := GetSType(Expecting) ;
6187 IF IsUnboundedParam(ProcedureSym, ParameterNo)
6188 THEN
6189 s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Expecting)))) ;
6190 s2 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(GetSType(ExpectType))))) ;
6191 s := ConCat(s, Mark(Sprintf2(Mark(InitString('%s: {%%kARRAY} {%%kOF} %s')),
6192 s1, s2)))
6193 ELSE
6194 s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Expecting)))) ;
6195 s2 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(ExpectType)))) ;
6196 s := ConCat(s, Mark(Sprintf2(Mark(InitString('%s: %s')), s1, s2)))
6197 END ;
6198 IF ParameterNo<NoOfParam(ProcedureSym)
6199 THEN
6200 s := ConCat(s, Mark(InitString('; ... ')))
6201 END
6202 ELSE
6203 First := GetDeclaredMod(ProcedureSym) ;
6204 IF NoOfParam(ProcedureSym)>0
6205 THEN
6206 s := ConCat(s, Mark(InitString('..')))
6207 END
6208 END ;
6209 ReturnType := GetSType(ProcedureSym) ;
6210 IF ReturnType=NulSym
6211 THEN
6212 s := ConCat(s, Sprintf0(Mark(InitString(') ;\n'))))
6213 ELSE
6214 s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(ReturnType)))) ;
6215 s := ConCat(s, Mark(Sprintf1(Mark(InitString(') : %s ;\n')), s1)))
6216 END ;
6217 IF IsConstString(Given)
6218 THEN
6219 s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Given)))) ;
6220 s := ConCat(s, Mark(Sprintf1(Mark(InitString("item being passed is '%s'")),
6221 s1)))
6222 ELSIF IsTemporary(Given)
6223 THEN
6224 s := ConCat(s, Mark(InitString("item being passed has type")))
6225 ELSE
6226 s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Given)))) ;
6227 s := ConCat(s, Mark(Sprintf1(Mark(InitString("item being passed is '%s'")),
6228 s1)))
6229 END ;
6230 s1 := DescribeType(Given) ;
6231 s2 := Mark(InitString(CurrentState)) ;
6232 s := ConCat(s, Mark(Sprintf2(Mark(InitString(': %s\nparameter mismatch: %s')),
6233 s1, s2))) ;
6234 MetaErrorStringT0 (tokpos, Dup (s)) ;
6235 MetaErrorStringT0 (First, Dup (s))
6236END WarnParameter ;
6237
6238
6239(*
6240 ExpectVariable - checks to see whether, sym, is declared as a variable.
6241 If not then it generates an error message.
6242*)
6243
6244(*
6245PROCEDURE ExpectVariable (a: ARRAY OF CHAR; sym: CARDINAL) ;
6246VAR
6247 e : Error ;
6248 s1, s2, s3: String ;
6249BEGIN
6250 IF NOT IsVar(sym)
6251 THEN
6252 e := NewError(GetTokenNo()) ;
6253 IF IsUnknown(sym)
6254 THEN
6255 s1 := ConCat (InitString (a),
6256 Mark (InitString ('but was given an undeclared symbol {%E1a}'))) ;
6257
6258 ErrorString(e, Sprintf2(Mark(InitString('%s but was given an undeclared symbol %s')), s1, s2))
6259 ELSE
6260 s1 := Mark(InitString(a)) ;
6261 s2 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(sym)))) ;
6262 s3 := Mark(DescribeType(sym)) ;
6263 ErrorString(e, Sprintf3(Mark(InitString('%s but was given %s: %s')),
6264 s1, s2, s3))
6265 END
6266 END
6267END ExpectVariable ;
6268*)
6269
6270
6271(*
6272 doIndrX - perform des = *exp with a conversion if necessary.
6273*)
6274
6275PROCEDURE doIndrX (tok: CARDINAL;
6276 des, exp: CARDINAL) ;
6277VAR
6278 t: CARDINAL ;
6279BEGIN
6280 IF GetDType(des)=GetDType(exp)
6281 THEN
b0762d4c
GM		 6282 GenQuadOtok (tok, IndrXOp, des, GetSType (des), exp, TRUE,
6283 tok, tok, tok)
1eee94d3
GM		 6284 ELSE
6285 t := MakeTemporary (tok, RightValue) ;
6286 PutVar (t, GetSType (exp)) ;
b0762d4c
GM		 6287 GenQuadOtok (tok, IndrXOp, t, GetSType (exp), exp, TRUE,
6288 tok, tok, tok) ;
6289 GenQuadOtok (tok, BecomesOp, des, NulSym, doVal (GetSType(des), t), TRUE,
6290 tok, UnknownTokenNo, tok)
1eee94d3
GM		 6291 END
6292END doIndrX ;
6293
6294
6295(*
6296 MakeRightValue - returns a temporary which will have the RightValue of symbol, Sym.
6297 If Sym is a right value and has type, type, then no quadruples are
6298 generated and Sym is returned. Otherwise a new temporary is created
6299 and an IndrX quadruple is generated.
6300*)
6301
6302PROCEDURE MakeRightValue (tok: CARDINAL;
6303 Sym: CARDINAL; type: CARDINAL) : CARDINAL ;
6304VAR
6305 t: CARDINAL ;
6306BEGIN
6307 IF GetMode (Sym) = RightValue
6308 THEN
6309 IF GetSType(Sym) = type
6310 THEN
6311 RETURN Sym (* already a RightValue with desired type *)
6312 ELSE
6313 (*
6314 type change or mode change, type changes are a pain, but I've
6315 left them here as it is perhaps easier to remove them later.
6316 *)
6317 t := MakeTemporary (tok, RightValue) ;
6318 PutVar (t, type) ;
b0762d4c
GM		 6319 GenQuadOtok (tok, BecomesOp, t, NulSym, doVal (type, Sym), TRUE,
6320 tok, tok, tok) ;
1eee94d3
GM		 6321 RETURN t
6322 END
6323 ELSE
6324 t := MakeTemporary (tok, RightValue) ;
6325 PutVar (t, type) ;
6326 CheckPointerThroughNil (tok, Sym) ;
6327 doIndrX (tok, t, Sym) ;
6328 RETURN t
6329 END
6330END MakeRightValue ;
6331
6332
6333(*
6334 MakeLeftValue - returns a temporary coresponding to the LeftValue of
6335 symbol, Sym. No quadruple is generated if Sym is already
6336 a LeftValue and has the same type.
6337*)
6338
6339PROCEDURE MakeLeftValue (tok: CARDINAL;
6340 Sym: CARDINAL; with: ModeOfAddr; type: CARDINAL) : CARDINAL ;
6341VAR
6342 t: CARDINAL ;
6343BEGIN
6344 IF GetMode (Sym) = LeftValue
6345 THEN
6346 IF GetSType (Sym) = type
6347 THEN
6348 RETURN Sym
6349 ELSE
6350 (*
6351 type change or mode change, type changes are a pain, but I've
6352 left them here as it is perhaps easier to remove them later
6353 *)
6354 t := MakeTemporary (tok, with) ;
6355 PutVar (t, type) ;
b0762d4c
GM		 6356 GenQuadOtok (tok, BecomesOp, t, NulSym, Sym, TRUE,
6357 tok, UnknownTokenNo, tok) ;
1eee94d3
GM		 6358 RETURN t
6359 END
6360 ELSE
6361 t := MakeTemporary (tok, with) ;
6362 PutVar (t, type) ;
b0762d4c
GM		 6363 GenQuadOtok (tok, AddrOp, t, NulSym, Sym, TRUE,
6364 tok, UnknownTokenNo, tok) ;
1eee94d3
GM		 6365 RETURN t
6366 END
6367END MakeLeftValue ;
6368
6369
6370(*
6371 ManipulatePseudoCallParameters - manipulates the parameters to a pseudo function or
6372 procedure. It dereferences all LeftValue parameters
6373 and Boolean parameters.
6374 The Stack:
6375
6376
6377 Entry Exit
6378
6379 Ptr -> exactly the same
6380 +----------------+
6381 | NoOfParameters |
6382 |----------------|
6383 | Param 1 |
6384 |----------------|
6385 | Param 2 |
6386 |----------------|
6387 . .
6388 . .
6389 . .
6390 |----------------|
6391 | Param # |
6392 |----------------|
6393 | ProcSym | Type |
6394 |----------------|
6395
6396*)
6397
6398PROCEDURE ManipulatePseudoCallParameters ;
6399VAR
6400 NoOfParameters,
6401 ProcSym, Proc,
6402 i, pi : CARDINAL ;
6403 f : BoolFrame ;
6404BEGIN
6405 PopT(NoOfParameters) ;
6406 PushT(NoOfParameters) ; (* restored to original state *)
6407 (* Ptr points to the ProcSym *)
6408 ProcSym := OperandT(NoOfParameters+1+1) ;
6409 IF IsVar(ProcSym)
6410 THEN
6411 InternalError ('expecting a pseudo procedure or a type')
6412 ELSE
6413 Proc := ProcSym
6414 END ;
6415 i := 1 ;
6416 pi := NoOfParameters+1 ;
6417 WHILE i<=NoOfParameters DO
6418 IF (GetMode(OperandT(pi))=LeftValue) AND
6419 (Proc#Adr) AND (Proc#Size) AND (Proc#TSize) AND (Proc#High) AND
6420 (* procedures which have first parameter as a VAR param *)
6421 (((Proc#Inc) AND (Proc#Incl) AND (Proc#Dec) AND (Proc#Excl) AND (Proc#New) AND (Proc#Dispose)) OR (i>1))
6422 THEN
6423 (* must dereference LeftValue *)
6424 f := PeepAddress(BoolStack, pi) ;
6425 f^.TrueExit := MakeRightValue (GetTokenNo(), OperandT(pi), GetSType(OperandT(pi)))
6426 END ;
6427 INC(i) ;
6428 DEC(pi)
6429 END
6430END ManipulatePseudoCallParameters ;
6431
6432
6433(*
6434 ManipulateParameters - manipulates the procedure parameters in
6435 preparation for a procedure call.
6436 Prepares Boolean, Unbounded and VAR parameters.
6437 The Stack:
6438
6439
6440 Entry Exit
6441
6442 Ptr -> exactly the same
6443 +----------------+
6444 | NoOfParameters |
6445 |----------------|
6446 | Param 1 |
6447 |----------------|
6448 | Param 2 |
6449 |----------------|
6450 . .
6451 . .
6452 . .
6453 |----------------|
6454 | Param # |
6455 |----------------|
6456 | ProcSym | Type |
6457 |----------------|
6458*)
6459
6460PROCEDURE ManipulateParameters (IsForC: BOOLEAN) ;
6461VAR
6462 tokpos,
6463 np : CARDINAL ;
6464 s : String ;
6465 ArraySym,
6466 UnboundedType,
6467 ParamType,
6468 NoOfParameters,
6469 i, pi,
6470 ProcSym, rw,
6471 Proc,
6472 t : CARDINAL ;
6473 f : BoolFrame ;
6474BEGIN
6475 PopT(NoOfParameters) ;
6476 ProcSym := OperandT(NoOfParameters+1) ;
6477 tokpos := OperandTtok(NoOfParameters+1) ;
6478 IF IsVar(ProcSym)
6479 THEN
6480 (* Procedure Variable ? *)
6481 Proc := SkipType(OperandF(NoOfParameters+1))
6482 ELSE
6483 Proc := SkipConst(ProcSym)
6484 END ;
6485
6486 IF IsForC AND UsesVarArgs(Proc)
6487 THEN
6488 IF NoOfParameters<NoOfParam(Proc)
6489 THEN
6490 s := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Proc)))) ;
6491 np := NoOfParam(Proc) ;
6492 ErrorStringAt2(Sprintf3(Mark(InitString('attempting to pass (%d) parameters to procedure (%s) which was declared with varargs but contains at least (%d) parameters')),
6493 NoOfParameters, s, np),
6494 tokpos, GetDeclaredMod(ProcSym))
6495 END
6496 ELSIF UsesOptArg(Proc)
6497 THEN
6498 IF NOT ((NoOfParameters=NoOfParam(Proc)) OR (NoOfParameters+1=NoOfParam(Proc)))
6499 THEN
6500 s := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Proc)))) ;
6501 np := NoOfParam(Proc) ;
6502 ErrorStringAt2(Sprintf3(Mark(InitString('attempting to pass (%d) parameters to procedure (%s) which was declared with an optarg with a maximum of (%d) parameters')),
6503 NoOfParameters, s, np),
6504 tokpos, GetDeclaredMod(ProcSym))
6505 END
6506 ELSIF NoOfParameters#NoOfParam(Proc)
6507 THEN
6508 s := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Proc)))) ;
6509 np := NoOfParam(Proc) ;
6510 ErrorStringAt2(Sprintf3(Mark(InitString('attempting to pass (%d) parameters to procedure (%s) which was declared with (%d) parameters')),
6511 NoOfParameters, s, np),
6512 tokpos, GetDeclaredMod(ProcSym))
6513 END ;
6514 i := 1 ;
6515 pi := NoOfParameters ;
6516 WHILE i<=NoOfParameters DO
6517 f := PeepAddress(BoolStack, pi) ;
6518 rw := OperandMergeRW(pi) ;
6519 Assert(IsLegal(rw)) ;
6520 IF i>NoOfParam(Proc)
6521 THEN
6522 IF IsForC AND UsesVarArgs(Proc)
6523 THEN
6524 IF (GetSType(OperandT(pi))#NulSym) AND IsArray(GetDType(OperandT(pi)))
6525 THEN
6526 f^.TrueExit := MakeLeftValue(OperandTok(pi), OperandT(pi), RightValue, Address) ;
6527 MarkAsReadWrite(rw)
6528 ELSIF IsConstString (OperandT (pi))
6529 THEN
6530 f^.TrueExit := MakeLeftValue (OperandTok (pi),
78b72ee5 6531 DeferMakeConstStringCnul (OperandTok (pi), OperandT (pi)), RightValue, Address) ;
1eee94d3
GM		 6532 MarkAsReadWrite(rw)
6533 ELSIF (GetSType(OperandT(pi))#NulSym) AND IsUnbounded(GetSType(OperandT(pi)))
6534 THEN
6535 MarkAsReadWrite(rw) ;
6536 (* pass the address field of an unbounded variable *)
84104022 6537 PushTFtok (Adr, Address, OperandTok (pi)) ;
1eee94d3
GM		 6538 PushTFAD (f^.TrueExit, f^.FalseExit, f^.Unbounded, f^.Dimension) ;
6539 PushT(1) ;
6540 BuildAdrFunction ;
6541 PopT(f^.TrueExit)
6542 ELSIF GetMode(OperandT(pi))=LeftValue
6543 THEN
6544 MarkAsReadWrite(rw) ;
6545 (* must dereference LeftValue (even if we are passing variable as a vararg) *)
6546 t := MakeTemporary (OperandTok (pi), RightValue) ;
6547 PutVar(t, GetSType (OperandT (pi))) ;
6548 CheckPointerThroughNil (tokpos, OperandT (pi)) ;
6549 doIndrX (OperandTok(pi), t, OperandT (pi)) ;
6550 f^.TrueExit := t
6551 END
6552 ELSE
6553 MetaErrorT2 (tokpos,
6554 'attempting to pass too many parameters to procedure {%1a}, the {%2N} parameter does not exist',
6555 Proc, i)
6556 END
6557 ELSIF IsForC AND IsUnboundedParam(Proc, i) AND
6558 (GetSType(OperandT(pi))#NulSym) AND IsArray(GetDType(OperandT(pi)))
6559 THEN
6560 f^.TrueExit := MakeLeftValue(OperandTok(pi), OperandT(pi), RightValue, Address) ;
6561 MarkAsReadWrite(rw)
6562 ELSIF IsForC AND IsUnboundedParam(Proc, i) AND
6563 (GetSType(OperandT(pi))#NulSym) AND IsUnbounded(GetDType(OperandT(pi)))
6564 THEN
6565 MarkAsReadWrite(rw) ;
6566 (* pass the address field of an unbounded variable *)
84104022 6567 PushTFtok (Adr, Address, OperandTok (pi)) ;
1eee94d3
GM		 6568 PushTFAD (f^.TrueExit, f^.FalseExit, f^.Unbounded, f^.Dimension) ;
6569 PushT(1) ;
6570 BuildAdrFunction ;
6571 PopT(f^.TrueExit)
6572 ELSIF IsForC AND IsConstString(OperandT(pi)) AND
6573 (IsUnboundedParam(Proc, i) OR (GetDType(GetParam(Proc, i))=Address))
6574 THEN
6575 f^.TrueExit := MakeLeftValue (OperandTok (pi),
78b72ee5 6576 DeferMakeConstStringCnul (OperandTok (pi), OperandT (pi)),
1eee94d3
GM		 6577 RightValue, Address) ;
6578 MarkAsReadWrite (rw)
6579 ELSIF IsUnboundedParam(Proc, i)
6580 THEN
6581 (* always pass constant strings with a nul terminator, but leave the HIGH as before. *)
6582 IF IsConstString (OperandT(pi))
6583 THEN
6584 (* this is a Modula-2 string which must be nul terminated. *)
78b72ee5 6585 f^.TrueExit := DeferMakeConstStringM2nul (OperandTok (pi), OperandT (pi))
1eee94d3
GM		 6586 END ;
6587 t := MakeTemporary (OperandTok (pi), RightValue) ;
6588 UnboundedType := GetSType(GetParam(Proc, i)) ;
6589 PutVar(t, UnboundedType) ;
6590 ParamType := GetSType(UnboundedType) ;
6591 IF OperandD(pi)=0
6592 THEN
6593 ArraySym := OperandT(pi)
6594 ELSE
6595 ArraySym := OperandA(pi)
6596 END ;
6597 IF IsVarParam(Proc, i)
6598 THEN
6599 MarkArrayWritten (OperandT (pi)) ;
6600 MarkArrayWritten (OperandA (pi)) ;
6601 MarkAsReadWrite(rw) ;
6602 AssignUnboundedVar (OperandTtok (pi), OperandT (pi), ArraySym, t, ParamType, OperandD (pi))
6603 ELSE
6604 MarkAsRead(rw) ;
6605 AssignUnboundedNonVar (OperandTtok (pi), OperandT (pi), ArraySym, t, ParamType, OperandD (pi))
6606 END ;
6607 f^.TrueExit := t
6608 ELSIF IsVarParam(Proc, i)
6609 THEN
6610 (* must reference by address, but we contain the type of the referenced entity *)
6611 MarkArrayWritten(OperandT(pi)) ;
6612 MarkArrayWritten(OperandA(pi)) ;
6613 MarkAsReadWrite(rw) ;
6614 f^.TrueExit := MakeLeftValue(OperandTok(pi), OperandT(pi), LeftValue, GetSType(GetParam(Proc, i)))
6615 ELSIF (NOT IsVarParam(Proc, i)) AND (GetMode(OperandT(pi))=LeftValue)
6616 THEN
6617 (* must dereference LeftValue *)
6618 t := MakeTemporary (OperandTok (pi), RightValue) ;
6619 PutVar(t, GetSType(OperandT(pi))) ;
6620 CheckPointerThroughNil (tokpos, OperandT (pi)) ;
6621 doIndrX (OperandTok(pi), t, OperandT(pi)) ;
6622 f^.TrueExit := t ;
6623 MarkAsRead(rw)
6624 ELSE
6625 MarkAsRead(rw)
6626 END ;
6627 INC(i) ;
6628 DEC(pi)
6629 END ;
6630 PushT(NoOfParameters)
6631END ManipulateParameters ;
6632
6633
6634(*
6635 CheckParameterOrdinals - check that ordinal values are within type range.
6636*)
6637
6638PROCEDURE CheckParameterOrdinals ;
6639VAR
f8c8aebc 6640 tokno : CARDINAL ;
1eee94d3
GM		 6641 Proc,
6642 ProcSym : CARDINAL ;
6643 Actual,
6644 FormalI : CARDINAL ;
6645 ParamTotal,
6646 pi, i : CARDINAL ;
6647BEGIN
6648 PopT (ParamTotal) ;
6649 PushT (ParamTotal) ; (* Restore stack to origional state *)
6650 ProcSym := OperandT (ParamTotal+1+1) ;
6651 IF IsVar(ProcSym) AND IsProcType(GetDType(ProcSym))
6652 THEN
6653 (* Indirect procedure call. *)
6654 Proc := SkipType(OperandF(ParamTotal+1+1))
6655 ELSE
6656 Proc := SkipConst(ProcSym)
6657 END ;
6658 i := 1 ;
6659 pi := ParamTotal+1 ; (* stack index referencing stacked parameter, i *)
6660 WHILE i<=ParamTotal DO
6661 IF i<=NoOfParam(Proc)
6662 THEN
6663 FormalI := GetParam (Proc, i) ;
6664 Actual := OperandT (pi) ;
f8c8aebc 6665 tokno := OperandTok (pi) ;
1eee94d3
GM		 6666 IF IsOrdinalType (GetLType (FormalI))
6667 THEN
6668 IF NOT IsSet (GetDType (FormalI))
6669 THEN
6670 (* tell code generator to test runtime values of assignment so ensure we
6671 catch overflow and underflow *)
f8c8aebc 6672 BuildRange (InitParameterRangeCheck (tokno, Proc, i, FormalI, Actual))
1eee94d3
GM		 6673 END
6674 END
6675 END ;
6676 INC (i) ;
6677 DEC (pi)
6678 END
6679END CheckParameterOrdinals ;
6680
6681
6682(*
6683 IsSameUnbounded - returns TRUE if unbounded types, t1, and, t2,
6684 are compatible.
6685*)
6686
6687PROCEDURE IsSameUnbounded (t1, t2: CARDINAL) : BOOLEAN ;
6688BEGIN
6689 Assert(IsUnbounded(t1)) ;
6690 Assert(IsUnbounded(t2)) ;
6691 RETURN( GetDType(t1)=GetDType(t2) )
6692END IsSameUnbounded ;
6693
6694
6695(*
6696 AssignUnboundedVar - assigns an Unbounded symbol fields,
6697 ArrayAddress and ArrayHigh, from an array symbol.
6698 UnboundedSym is not a VAR parameter and therefore
6699 this procedure can complete both of the fields.
6700 Sym can be a Variable with type Unbounded.
6701 Sym can be a Variable with type Array.
6702 Sym can be a String Constant.
6703
6704 ParamType is the TYPE of the parameter
6705*)
6706
6707PROCEDURE AssignUnboundedVar (tok: CARDINAL;
6708 Sym, ArraySym, UnboundedSym, ParamType: CARDINAL; dim: CARDINAL) ;
6709VAR
6710 Type: CARDINAL ;
6711BEGIN
6712 IF IsConst(Sym)
6713 THEN
6714 MetaErrorT1 (tok, '{%1ad} cannot be passed to a VAR formal parameter', Sym)
6715 ELSIF IsVar(Sym)
6716 THEN
6717 Type := GetDType(Sym) ;
a0c59538
GM		 6718 IF Type = NulSym
6719 THEN
6720 MetaErrorT1 (tok, '{%1ad} has no type and cannot be passed to a VAR formal parameter', Sym)
6721 ELSIF IsUnbounded(Type)
1eee94d3
GM		 6722 THEN
6723 IF Type = GetSType (UnboundedSym)
6724 THEN
6725 (* Copy Unbounded Symbol ie. UnboundedSym := Sym *)
6726 PushT (UnboundedSym) ;
6727 PushT (Sym) ;
6728 BuildAssignmentWithoutBounds (tok, FALSE, TRUE)
6729 ELSIF IsSameUnbounded (Type, GetSType (UnboundedSym)) OR
6730 IsGenericSystemType (ParamType)
6731 THEN
6732 UnboundedVarLinkToArray (tok, Sym, ArraySym, UnboundedSym, ParamType, dim)
6733 ELSE
6734 MetaErrorT1 (tok, '{%1ad} cannot be passed to a VAR formal parameter', Sym)
6735 END
6736 ELSIF IsArray (Type) OR IsGenericSystemType (ParamType)
6737 THEN
6738 UnboundedVarLinkToArray (tok, Sym, ArraySym, UnboundedSym, ParamType, dim)
6739 ELSE
6740 MetaErrorT1 (tok, '{%1ad} cannot be passed to a VAR formal parameter', Sym)
6741 END
6742 ELSE
6743 MetaErrorT1 (tok, '{%1ad} cannot be passed to a VAR formal parameter', Sym)
6744 END
6745END AssignUnboundedVar ;
6746
6747
6748(*
6749 AssignUnboundedNonVar - assigns an Unbounded symbol fields,
6750 The difference between this procedure and
6751 AssignUnboundedVar is that this procedure cannot
6752 set the Unbounded.Address since the data from
6753 Sym will be copied because parameter is NOT a VAR
6754 parameter.
6755 UnboundedSym is not a VAR parameter and therefore
6756 this procedure can only complete the HIGH field
6757 and not the ADDRESS field.
6758 Sym can be a Variable with type Unbounded.
6759 Sym can be a Variable with type Array.
6760 Sym can be a String Constant.
6761
6762 ParamType is the TYPE of the paramater
6763*)
6764
6765PROCEDURE AssignUnboundedNonVar (tok: CARDINAL;
6766 Sym, ArraySym, UnboundedSym, ParamType: CARDINAL; dim: CARDINAL) ;
6767VAR
6768 Type: CARDINAL ;
6769BEGIN
6770 IF IsConst (Sym) (* was IsConstString(Sym) *)
6771 THEN
6772 UnboundedNonVarLinkToArray (tok, Sym, ArraySym, UnboundedSym, ParamType, dim)
6773 ELSIF IsVar (Sym)
6774 THEN
6775 Type := GetDType (Sym) ;
a0c59538
GM		 6776 IF Type = NulSym
6777 THEN
6778 MetaErrorT1 (tok, '{%1ad} has no type and cannot be passed to a non VAR formal parameter', Sym)
6779 ELSIF IsUnbounded (Type)
1eee94d3
GM		 6780 THEN
6781 UnboundedNonVarLinkToArray (tok, Sym, ArraySym, UnboundedSym, ParamType, dim)
6782 ELSIF IsArray (Type) OR IsGenericSystemType (ParamType)
6783 THEN
6784 UnboundedNonVarLinkToArray (tok, Sym, ArraySym, UnboundedSym, ParamType, dim)
6785 ELSE
6786 MetaErrorT1 (tok, 'illegal type parameter {%1Ead} expecting array or dynamic array', Sym)
6787 END
6788 ELSE
6789 MetaErrorT1 (tok, 'illegal parameter {%1Ead} which cannot be passed as {%kVAR} {%kARRAY} {%kOF} {%1tsad}', Sym)
6790 END
6791END AssignUnboundedNonVar ;
6792
6793
6794(*
6795 GenHigh - generates a HighOp but it checks if op3 is a
6796 L value and if so it dereferences it. This
6797 is inefficient, however it is clean and we let the gcc
6798 backend detect these as common subexpressions.
6799 It will also detect that a R value -> L value -> R value
6800 via indirection and eleminate these.
6801*)
6802
6803PROCEDURE GenHigh (tok: CARDINAL;
6804 op1, op2, op3: CARDINAL) ;
6805VAR
6806 sym: CARDINAL ;
6807BEGIN
6808 IF (GetMode(op3)=LeftValue) AND IsUnbounded(GetSType(op3))
6809 THEN
6810 sym := MakeTemporary (tok, RightValue) ;
6811 PutVar (sym, GetSType (op3)) ;
6812 doIndrX (tok, sym, op3) ;
6813 GenQuadO (tok, HighOp, op1, op2, sym, TRUE)
6814 ELSE
6815 GenQuadO (tok, HighOp, op1, op2, op3, TRUE)
6816 END
6817END GenHigh ;
6818
6819
6820(*
6821 AssignHighField -
6822*)
6823
6824PROCEDURE AssignHighField (tok: CARDINAL;
6825 Sym, ArraySym, UnboundedSym, ParamType: CARDINAL;
6826 actuali, formali: CARDINAL) ;
6827VAR
6828 ReturnVar,
6829 ArrayType,
6830 Field : CARDINAL ;
6831BEGIN
6832 (* Unbounded.ArrayHigh := HIGH(ArraySym) *)
6833 PushTFtok (UnboundedSym, GetSType (UnboundedSym), tok) ;
6834 Field := GetUnboundedHighOffset (GetSType (UnboundedSym), formali) ;
6835 PushTFtok (Field, GetSType (Field), tok) ;
6836 PushT (1) ;
6837 BuildDesignatorRecord (tok) ;
6838 IF IsGenericSystemType (ParamType)
6839 THEN
6840 IF IsConstString (Sym)
6841 THEN
78b72ee5 6842 PushTtok (DeferMakeLengthConst (tok, Sym), tok)
1eee94d3
GM		 6843 ELSE
6844 ArrayType := GetSType (Sym) ;
6845 IF IsUnbounded (ArrayType)
6846 THEN
6847 (*
6848 * SIZE(parameter) DIV TSIZE(ParamType)
6849 * however in this case parameter
6850 * is an unbounded symbol and therefore we must use
6851 * (HIGH(parameter)+1)*SIZE(unbounded type) DIV TSIZE(ParamType)
6852 *
6853 * we call upon the function SIZE(ArraySym)
6854 * remember SIZE doubles as
6855 * (HIGH(a)+1) * SIZE(ArrayType) for unbounded symbols
6856 *)
6857 PushTFtok (calculateMultipicand (tok, ArraySym, ArrayType, actuali-1), Cardinal, tok) ;
6858 PushT (DivideTok) ; (* Divide by *)
6859 PushTFtok (TSize, Cardinal, tok) ; (* TSIZE(ParamType) *)
6860 PushTtok (ParamType, tok) ;
6861 PushT (1) ; (* 1 parameter for TSIZE() *)
81d5ca0b 6862 BuildFunctionCall (FALSE) ;
1eee94d3
GM		 6863 BuildBinaryOp
6864 ELSE
6865 (* SIZE(parameter) DIV TSIZE(ParamType) *)
6866 PushTFtok (TSize, Cardinal, tok) ; (* TSIZE(ArrayType) *)
6867 PushTtok (ArrayType, tok) ;
6868 PushT (1) ; (* 1 parameter for TSIZE() *)
81d5ca0b 6869 BuildFunctionCall (TRUE) ;
1eee94d3
GM		 6870 PushT (DivideTok) ; (* Divide by *)
6871 PushTFtok (TSize, Cardinal, tok) ; (* TSIZE(ParamType) *)
6872 PushTtok (ParamType, tok) ;
6873 PushT (1) ; (* 1 parameter for TSIZE() *)
81d5ca0b 6874 BuildFunctionCall (TRUE) ;
1eee94d3
GM		 6875 BuildBinaryOp
6876 END ;
6877 (* now convert from no of elements into HIGH by subtracting 1 *)
6878 PushT (MinusTok) ; (* -1 *)
6879 PushTtok (MakeConstLit (tok, MakeKey('1'), Cardinal), tok) ;
6880 BuildBinaryOp
6881 END
6882 ELSE
6883 ReturnVar := MakeTemporary (tok, RightValue) ;
6884 PutVar (ReturnVar, Cardinal) ;
6885 IF (actuali # formali) AND (ArraySym # NulSym) AND IsUnbounded (GetSType (ArraySym))
6886 THEN
6887 GenHigh (tok, ReturnVar, actuali, ArraySym)
6888 ELSE
6889 GenHigh (tok, ReturnVar, formali, Sym)
6890 END ;
6891 PushTFtok (ReturnVar, GetSType(ReturnVar), tok)
6892 END ;
6893 BuildAssignmentWithoutBounds (tok, FALSE, TRUE)
6894END AssignHighField ;
6895
6896
6897(*
6898 AssignHighFields -
6899*)
6900
6901PROCEDURE AssignHighFields (tok: CARDINAL;
6902 Sym, ArraySym, UnboundedSym, ParamType: CARDINAL; dim: CARDINAL) ;
6903VAR
6904 type : CARDINAL ;
6905 actuali, formali,
6906 actualn, formaln: CARDINAL ;
6907BEGIN
6908 type := GetDType (Sym) ;
6909 actualn := 1 ;
6910 IF (type # NulSym) AND (IsUnbounded (type) OR IsArray (type))
6911 THEN
6912 actualn := GetDimension (type)
6913 END ;
6914 actuali := dim + 1 ;
6915 formali := 1 ;
6916 formaln := GetDimension (GetDType (UnboundedSym)) ;
6917 WHILE (actuali < actualn) AND (formali < formaln) DO
6918 AssignHighField (tok, Sym, ArraySym, UnboundedSym, NulSym, actuali, formali) ;
6919 INC (actuali) ;
6920 INC (formali)
6921 END ;
6922 AssignHighField (tok, Sym, ArraySym, UnboundedSym, ParamType, actuali, formali)
6923END AssignHighFields ;
6924
6925
6926(*
6927 UnboundedNonVarLinkToArray - links an array, ArraySym, to an unbounded
6928 array, UnboundedSym. The parameter is a
6929 NON VAR variety.
6930*)
6931
6932PROCEDURE UnboundedNonVarLinkToArray (tok: CARDINAL;
6933 Sym, ArraySym, UnboundedSym, ParamType: CARDINAL; dim: CARDINAL) ;
6934VAR
6935 Field,
6936 AddressField: CARDINAL ;
6937BEGIN
6938 (* Unbounded.ArrayAddress := to be assigned at runtime. *)
6939 PushTFtok (UnboundedSym, GetSType (UnboundedSym), tok) ;
6940
6941 Field := GetUnboundedAddressOffset(GetSType(UnboundedSym)) ;
6942 PushTFtok (Field, GetSType(Field), tok) ;
6943 PushT (1) ;
6944 BuildDesignatorRecord (tok) ;
6945 PopT (AddressField) ;
6946
6947 (* caller saves non var unbounded array contents. *)
6948 GenQuadO (tok, UnboundedOp, AddressField, NulSym, Sym, FALSE) ;
6949
6950 AssignHighFields (tok, Sym, ArraySym, UnboundedSym, ParamType, dim)
6951END UnboundedNonVarLinkToArray ;
6952
6953
6954(*
6955 UnboundedVarLinkToArray - links an array, ArraySym, to an unbounded array,
6956 UnboundedSym. The parameter is a VAR variety.
6957*)
6958
6959PROCEDURE UnboundedVarLinkToArray (tok: CARDINAL;
6960 Sym, ArraySym, UnboundedSym, ParamType: CARDINAL; dim: CARDINAL) ;
6961VAR
6962 SymType,
6963 Field : CARDINAL ;
6964BEGIN
6965 SymType := GetSType (Sym) ;
6966 (* Unbounded.ArrayAddress := ADR(Sym) *)
6967 PushTFtok (UnboundedSym, GetSType (UnboundedSym), tok) ;
6968 Field := GetUnboundedAddressOffset (GetSType (UnboundedSym)) ;
6969 PushTFtok (Field, GetSType (Field), tok) ;
6970 PushT (1) ;
6971 BuildDesignatorRecord (tok) ;
81d5ca0b 6972 PushTFtok (Adr, Address, tok) ; (* ADR (Sym). *)
1eee94d3
GM		 6973 IF IsUnbounded (SymType) AND (dim = 0)
6974 THEN
6975 PushTFADtok (Sym, SymType, UnboundedSym, dim, tok)
6976 ELSE
6977 PushTFADtok (Sym, SymType, ArraySym, dim, tok)
6978 END ;
81d5ca0b
GM		 6979 PushT (1) ; (* 1 parameter for ADR(). *)
6980 BuildFunctionCall (FALSE) ;
1eee94d3
GM		 6981 BuildAssignmentWithoutBounds (tok, FALSE, TRUE) ;
6982
6983 AssignHighFields (tok, Sym, ArraySym, UnboundedSym, ParamType, dim)
6984END UnboundedVarLinkToArray ;
6985
6986
6987(*
6988 BuildPseudoProcedureCall - builds a pseudo procedure call.
6989 This procedure does not directly alter the
6990 stack, but by calling routines the stack
6991 will change in the following way when this
6992 procedure returns.
6993
6994 The Stack:
6995
6996
6997 Entry Exit
6998
6999 Ptr ->
7000 +----------------+
7001 | NoOfParam |
7002 |----------------|
7003 | Param 1 |
7004 |----------------|
7005 | Param 2 |
7006 |----------------|
7007 . .
7008 . .
7009 . .
7010 |----------------|
7011 | Param # |
7012 |----------------|
7013 | ProcSym | Type | Empty
7014 |----------------|
7015*)
7016
7017PROCEDURE BuildPseudoProcedureCall (tokno: CARDINAL) ;
7018VAR
7019 NoOfParam,
7020 ProcSym : CARDINAL ;
7021BEGIN
7022 PopT (NoOfParam) ;
7023 ProcSym := OperandT (NoOfParam + 1) ;
7024 PushT (NoOfParam) ;
7025 (* Compile time stack restored to entry state *)
7026 IF ProcSym = New
7027 THEN
7028 BuildNewProcedure (tokno)
7029 ELSIF ProcSym = Dispose
7030 THEN
7031 BuildDisposeProcedure (tokno)
7032 ELSIF ProcSym = Inc
7033 THEN
7034 BuildIncProcedure
7035 ELSIF ProcSym = Dec
7036 THEN
7037 BuildDecProcedure
7038 ELSIF ProcSym = Incl
7039 THEN
7040 BuildInclProcedure
7041 ELSIF ProcSym = Excl
7042 THEN
7043 BuildExclProcedure
7044 ELSIF ProcSym = Throw
7045 THEN
7046 BuildThrowProcedure
7047 ELSE
7048 InternalError ('pseudo procedure not implemented yet')
7049 END
7050END BuildPseudoProcedureCall ;
7051
7052
7053(*
7054 GetItemPointedTo - returns the symbol type that is being pointed to
7055 by Sym.
7056*)
7057
7058PROCEDURE GetItemPointedTo (Sym: CARDINAL) : CARDINAL ;
7059BEGIN
7060 IF IsPointer (Sym)
7061 THEN
7062 RETURN GetSType (Sym)
7063 ELSIF IsVar (Sym) OR IsType (Sym)
7064 THEN
7065 RETURN GetItemPointedTo (GetSType (Sym))
9fadd8de 7066 ELSE
b80e3c46 7067 RETURN NulSym
1eee94d3
GM		 7068 END
7069END GetItemPointedTo ;
7070
7071
7072(*
7073 BuildThrowProcedure - builds the pseudo procedure call M2RTS.Throw.
7074 The Stack:
7075
7076
7077 Entry Exit
7078
7079 Ptr ->
7080 +----------------+
7081 | NoOfParam |
7082 |----------------|
7083 | Param 1 |
7084 |----------------|
7085 | Param 2 |
7086 |----------------|
7087 . .
7088 . .
7089 . .
7090 |----------------|
7091 | Param # |
7092 |----------------|
7093 | ProcSym | Type | Empty
7094 |----------------|
7095*)
7096
7097PROCEDURE BuildThrowProcedure ;
7098VAR
7099 functok : CARDINAL ;
7100 op : CARDINAL ;
7101 NoOfParam: CARDINAL ;
7102BEGIN
7103 PopT (NoOfParam) ;
7104 functok := OperandTtok (NoOfParam + 1) ;
7105 IF NoOfParam = 1
7106 THEN
7107 op := OperandT (NoOfParam) ;
7108 GenQuadO (functok, ThrowOp, NulSym, NulSym, op, FALSE)
7109 ELSE
7110 MetaErrorT1 (functok, 'the pseudo procedure %{1Ea} takes one INTEGER parameter', Throw)
7111 END ;
7112 PopN (NoOfParam+1)
7113END BuildThrowProcedure ;
7114
7115
7116(*
7117 BuildReThrow - creates a ThrowOp _ _ NulSym, indicating that
7118 the exception needs to be rethrown. The stack
7119 is unaltered.
7120*)
7121
7122PROCEDURE BuildReThrow (tokenno: CARDINAL) ;
7123BEGIN
7124 GenQuadO (tokenno, ThrowOp, NulSym, NulSym, NulSym, FALSE)
7125END BuildReThrow ;
7126
7127
7128(*
7129 BuildNewProcedure - builds the pseudo procedure call NEW.
7130 This procedure is traditionally a "macro" for
7131 NEW(x, ...) --> ALLOCATE(x, TSIZE(x^, ...))
7132 One method of implementation is to emulate a "macro"
7133 processor by pushing the relevant input tokens
7134 back onto the input stack.
7135 However this causes two problems:
7136
7137 (i) Unnecessary code is produced for x^
7138 (ii) SIZE must be imported from SYSTEM
7139 Therefore we chose an alternative method of
7140 implementation;
7141 generate quadruples for ALLOCATE(x, TSIZE(x^, ...))
7142 this, although slightly more efficient,
7143 is more complex and circumvents problems (i) and (ii).
7144
7145 The Stack:
7146
7147
7148 Entry Exit
7149
7150 Ptr ->
7151 +----------------+
7152 | NoOfParam |
7153 |----------------|
7154 | Param 1 |
7155 |----------------|
7156 | Param 2 |
7157 |----------------|
7158 . .
7159 . .
7160 . .
7161 |----------------|
7162 | Param # |
7163 |----------------|
7164 | ProcSym | Type | Empty
7165 |----------------|
7166*)
7167
7168PROCEDURE BuildNewProcedure (functok: CARDINAL) ;
7169VAR
7170 NoOfParam,
7171 SizeSym,
7172 PtrSym,
7173 ProcSym : CARDINAL ;
7174 paramtok,
7175 combinedtok: CARDINAL ;
7176BEGIN
7177 PopT(NoOfParam) ;
7178 IF NoOfParam>=1
7179 THEN
7180 ProcSym := RequestSym (functok, MakeKey('ALLOCATE')) ;
7181 IF (ProcSym#NulSym) AND IsProcedure(ProcSym)
7182 THEN
7183 PtrSym := OperandT (NoOfParam) ;
7184 paramtok := OperandTtok (1) ;
7185 IF IsReallyPointer(PtrSym)
7186 THEN
7187 combinedtok := MakeVirtualTok (functok, functok, paramtok) ;
7188 (*
7189 Build macro: ALLOCATE( PtrSym, SIZE(PtrSym^) )
7190 *)
7191 PushTFtok (TSize, Cardinal, paramtok) ;(* Procedure *)
7192 (* x^ *)
7193 PushTtok (GetItemPointedTo (PtrSym), paramtok) ;
7194 PushT (1) ; (* One parameter *)
81d5ca0b 7195 BuildFunctionCall (FALSE) ;
1eee94d3
GM		 7196 PopT (SizeSym) ;
7197
7198 PushTtok (ProcSym, combinedtok) ; (* ALLOCATE *)
7199 PushTtok (PtrSym, paramtok) ; (* x *)
7200 PushTtok (SizeSym, paramtok) ; (* TSIZE(x^) *)
7201 PushT (2) ; (* Two parameters *)
7202 BuildProcedureCall (combinedtok)
7203 ELSE
7204 MetaErrorT0 (paramtok, 'parameter to {%EkNEW} must be a pointer')
7205 END
7206 ELSE
7207 MetaErrorT0 (functok, '{%E}ALLOCATE procedure not found for NEW substitution')
7208 END
7209 ELSE
7210 MetaErrorT0 (functok, 'the pseudo procedure {%EkNEW} has one or more parameters')
7211 END ;
7212 PopN (NoOfParam+1)
7213END BuildNewProcedure ;
7214
7215
7216(*
7217 BuildDisposeProcedure - builds the pseudo procedure call DISPOSE.
7218 This procedure is traditionally a "macro" for
7219 DISPOSE(x) --> DEALLOCATE(x, TSIZE(x^))
7220 One method of implementation is to emulate a "macro"
7221 processor by pushing the relevant input tokens
7222 back onto the input stack.
7223 However this causes two problems:
7224
7225 (i) Unnecessary code is produced for x^
7226 (ii) TSIZE must be imported from SYSTEM
7227 Therefore we chose an alternative method of
7228 implementation;
7229 generate quadruples for DEALLOCATE(x, TSIZE(x^))
7230 this, although slightly more efficient,
7231 is more complex and circumvents problems (i)
7232 and (ii).
7233
7234 The Stack:
7235
7236
7237 Entry Exit
7238
7239 Ptr ->
7240 +----------------+
7241 | NoOfParam |
7242 |----------------|
7243 | Param 1 |
7244 |----------------|
7245 | Param 2 |
7246 |----------------|
7247 . .
7248 . .
7249 . .
7250 |----------------|
7251 | Param # |
7252 |----------------|
7253 | ProcSym | Type | Empty
7254 |----------------|
7255*)
7256
7257PROCEDURE BuildDisposeProcedure (functok: CARDINAL) ;
7258VAR
7259 NoOfParam,
7260 SizeSym,
7261 PtrSym,
7262 ProcSym : CARDINAL ;
7263 combinedtok,
7264 paramtok : CARDINAL ;
7265BEGIN
7266 PopT (NoOfParam) ;
7267 IF NoOfParam>=1
7268 THEN
7269 ProcSym := RequestSym (functok, MakeKey ('DEALLOCATE')) ;
7270 IF (ProcSym # NulSym) AND IsProcedure (ProcSym)
7271 THEN
7272 PtrSym := OperandT (NoOfParam) ;
7273 paramtok := OperandTtok (1) ;
7274 IF IsReallyPointer (PtrSym)
7275 THEN
7276 combinedtok := MakeVirtualTok (functok, functok, paramtok) ;
7277 (*
7278 Build macro: DEALLOCATE( PtrSym, TSIZE(PtrSym^) )
7279 *)
7280 PushTFtok (TSize, Cardinal, paramtok) ;(* Procedure *)
7281 (* x^ *)
7282 PushTtok (GetItemPointedTo(PtrSym), paramtok) ;
7283 PushT (1) ; (* One parameter *)
81d5ca0b 7284 BuildFunctionCall (FALSE) ;
1eee94d3
GM		 7285 PopT (SizeSym) ;
7286
7287 PushTtok (ProcSym, combinedtok) ; (* DEALLOCATE *)
7288 PushTtok (PtrSym, paramtok) ; (* x *)
7289 PushTtok (SizeSym, paramtok) ; (* TSIZE(x^) *)
7290 PushT (2) ; (* Two parameters *)
7291 BuildProcedureCall (combinedtok)
7292 ELSE
7293 MetaErrorT0 (paramtok, 'argument to {%EkDISPOSE} must be a pointer')
7294 END
7295 ELSE
7296 MetaErrorT0 (functok, '{%E}DEALLOCATE procedure not found for DISPOSE substitution')
7297 END
7298 ELSE
7299 MetaErrorT0 (functok, 'the pseudo procedure {%EkDISPOSE} has one or more parameters')
7300 END ;
7301 PopN (NoOfParam+1)
7302END BuildDisposeProcedure ;
7303
7304
7305(*
7306 CheckRangeIncDec - performs des := des <tok> expr
7307 with range checking (if enabled).
7308
7309 Stack
7310 Entry Exit
7311
7312 +------------+
7313 empty | des + expr |
7314 |------------|
7315*)
7316
7317PROCEDURE CheckRangeIncDec (tokenpos: CARDINAL; des, expr: CARDINAL; tok: Name) ;
7318VAR
7319 dtype, etype: CARDINAL ;
7320BEGIN
7321 dtype := GetDType(des) ;
7322 etype := GetDType(expr) ;
64b0130b
GM		 7323 IF (etype = NulSym) AND IsPointer (GetTypeMode (des))
7324 THEN
7325 expr := ConvertToAddress (tokenpos, expr) ;
7326 etype := Address
7327 END ;
1eee94d3
GM		 7328 IF WholeValueChecking AND (NOT MustNotCheckBounds)
7329 THEN
7330 IF tok=PlusTok
7331 THEN
7332 BuildRange (InitIncRangeCheck (des, expr))
7333 ELSE
7334 BuildRange (InitDecRangeCheck (des, expr))
7335 END
7336 END ;
7337
7338 IF IsExpressionCompatible (dtype, etype)
7339 THEN
7340 (* the easy case simulate a straightforward macro *)
b0762d4c
GM		 7341 PushTF (des, dtype) ;
7342 PushT (tok) ;
7343 PushTF (expr, etype) ;
7344 doBuildBinaryOp (FALSE, TRUE)
1eee94d3 7345 ELSE
b0762d4c
GM		 7346 IF (IsOrdinalType (dtype) OR (dtype = Address) OR IsPointer (dtype)) AND
7347 (IsOrdinalType (etype) OR (etype = Address) OR IsPointer (etype))
1eee94d3
GM		 7348 THEN
7349 PushTF (des, dtype) ;
7350 PushT (tok) ;
7351 PushTF (Convert, NulSym) ;
7352 PushT (dtype) ;
7353 PushT (expr) ;
7354 PushT (2) ; (* Two parameters *)
4bd2f59a 7355 BuildConvertFunction (Convert, FALSE) ;
1eee94d3
GM		 7356 doBuildBinaryOp (FALSE, TRUE)
7357 ELSE
7358 IF tok=PlusTok
7359 THEN
7360 MetaError0 ('cannot perform {%EkINC} using non ordinal types')
7361 ELSE
7362 MetaError0 ('cannot perform {%EkDEC} using non ordinal types')
7363 END ;
7364 PushTFtok (MakeConstLit (tokenpos, MakeKey ('0'), NulSym), NulSym, tokenpos)
7365 END
7366 END
7367END CheckRangeIncDec ;
7368
7369
7370(*
7371 BuildIncProcedure - builds the pseudo procedure call INC.
7372 INC is a procedure which increments a variable.
7373 It takes one or two parameters:
7374 INC(a, b) or INC(a)
7375 a := a+b or a := a+1
7376
7377 The Stack:
7378
7379
7380 Entry Exit
7381
7382 Ptr ->
7383 +----------------+
7384 | NoOfParam |
7385 |----------------|
7386 | Param 1 |
7387 |----------------|
7388 | Param 2 |
7389 |----------------|
7390 . .
7391 . .
7392 . .
7393 |----------------|
7394 | Param # |
7395 |----------------|
7396 | ProcSym | Type | Empty
7397 |----------------|
7398*)
7399
7400PROCEDURE BuildIncProcedure ;
7401VAR
7402 proctok : CARDINAL ;
7403 NoOfParam,
7404 dtype,
7405 OperandSym,
7406 VarSym,
7407 TempSym : CARDINAL ;
7408BEGIN
7409 PopT (NoOfParam) ;
7410 proctok := OperandTtok (NoOfParam + 1) ;
7411 IF (NoOfParam = 1) OR (NoOfParam = 2)
7412 THEN
7413 VarSym := OperandT (NoOfParam) ; (* bottom/first parameter *)
7414 IF IsVar (VarSym)
7415 THEN
7416 dtype := GetDType (VarSym) ;
7417 IF NoOfParam = 2
7418 THEN
7419 OperandSym := DereferenceLValue (OperandTok (1), OperandT (1))
7420 ELSE
c1667b1e 7421 PushOne (proctok, dtype,
4bd2f59a 7422 'the {%EkINC} will cause an overflow {%1ad}') ;
1eee94d3
GM		 7423 PopT (OperandSym)
7424 END ;
7425
7426 PushT (VarSym) ;
7427 TempSym := DereferenceLValue (OperandTok (NoOfParam), VarSym) ;
7428 CheckRangeIncDec (proctok, TempSym, OperandSym, PlusTok) ; (* TempSym + OperandSym *)
7429 BuildAssignmentWithoutBounds (proctok, FALSE, TRUE) (* VarSym := TempSym + OperandSym *)
7430 ELSE
7431 MetaErrorT1 (proctok,
7432 'base procedure {%EkINC} expects a variable as a parameter but was given {%1Ed}',
7433 VarSym)
7434 END
7435 ELSE
7436 MetaErrorT0 (proctok,
7437 'the base procedure {%EkINC} expects 1 or 2 parameters')
7438 END ;
7439 PopN (NoOfParam + 1)
7440END BuildIncProcedure ;
7441
7442
7443(*
7444 BuildDecProcedure - builds the pseudo procedure call DEC.
7445 DEC is a procedure which decrements a variable.
7446 It takes one or two parameters:
7447 DEC(a, b) or DEC(a)
7448 a := a-b or a := a-1
7449
7450 The Stack:
7451
7452
7453 Entry Exit
7454
7455 Ptr ->
7456 +----------------+
7457 | NoOfParam |
7458 |----------------|
7459 | Param 1 |
7460 |----------------|
7461 | Param 2 |
7462 |----------------|
7463 . .
7464 . .
7465 . .
7466 |----------------|
7467 | Param # |
7468 |----------------|
7469 | ProcSym | Type | Empty
7470 |----------------|
7471*)
7472
7473PROCEDURE BuildDecProcedure ;
7474VAR
7475 proctok,
7476 NoOfParam,
7477 dtype,
7478 OperandSym,
7479 VarSym,
7480 TempSym : CARDINAL ;
7481BEGIN
7482 PopT (NoOfParam) ;
7483 proctok := OperandTtok (NoOfParam + 1) ;
7484 IF (NoOfParam = 1) OR (NoOfParam = 2)
7485 THEN
7486 VarSym := OperandT (NoOfParam) ; (* bottom/first parameter *)
7487 IF IsVar (VarSym)
7488 THEN
7489 dtype := GetDType (VarSym) ;
7490 IF NoOfParam = 2
7491 THEN
7492 OperandSym := DereferenceLValue (OperandTok (1), OperandT (1))
7493 ELSE
c1667b1e 7494 PushOne (proctok, dtype,
4bd2f59a 7495 'the {%EkDEC} will cause an overflow {%1ad}') ;
1eee94d3
GM		 7496 PopT (OperandSym)
7497 END ;
7498
7499 PushT (VarSym) ;
7500 TempSym := DereferenceLValue (OperandTok (NoOfParam), VarSym) ;
7501 CheckRangeIncDec (proctok, TempSym, OperandSym, MinusTok) ; (* TempSym - OperandSym *)
7502 BuildAssignmentWithoutBounds (proctok, FALSE, TRUE) (* VarSym := TempSym - OperandSym *)
7503 ELSE
7504 MetaErrorT1 (proctok,
7505 'base procedure {%EkDEC} expects a variable as a parameter but was given {%1Ed}',
7506 VarSym)
7507 END
7508 ELSE
7509 MetaErrorT0 (proctok,
7510 'the base procedure {%EkDEC} expects 1 or 2 parameters')
7511 END ;
7512 PopN (NoOfParam + 1)
7513END BuildDecProcedure ;
7514
7515
7516(*
7517 DereferenceLValue - checks to see whether, operand, is declare as an LValue
7518 and if so it dereferences it.
7519*)
7520
7521PROCEDURE DereferenceLValue (tok: CARDINAL; operand: CARDINAL) : CARDINAL ;
7522VAR
7523 sym: CARDINAL ;
7524BEGIN
7525 IF GetMode (operand) = LeftValue
7526 THEN
7527 (* dereference the pointer *)
7528 sym := MakeTemporary (tok, AreConstant(IsConst(operand))) ;
7529 PutVar(sym, GetSType (operand)) ;
7530
7531 PushTtok (sym, tok) ;
7532 PushTtok (operand, tok) ;
7533 BuildAssignmentWithoutBounds (tok, FALSE, TRUE) ;
7534 RETURN sym
7535 ELSE
7536 RETURN operand
7537 END
7538END DereferenceLValue ;
7539
7540
7541(*
7542 BuildInclProcedure - builds the pseudo procedure call INCL.
7543 INCL is a procedure which adds bit b into a BITSET a.
7544 It takes two parameters:
7545 INCL(a, b)
7546
7547 a := a + {b}
7548
7549 The Stack:
7550
7551
7552 Entry Exit
7553
7554 Ptr ->
7555 +----------------+
7556 | NoOfParam |
7557 |----------------|
7558 | Param 1 |
7559 |----------------|
7560 | Param 2 |
7561 |----------------|
7562 | ProcSym | Type | Empty
7563 |----------------|
7564*)
7565
7566PROCEDURE BuildInclProcedure ;
7567VAR
7568 proctok,
7569 optok : CARDINAL ;
7570 NoOfParam,
7571 DerefSym,
7572 OperandSym,
7573 VarSym : CARDINAL ;
7574BEGIN
7575 PopT (NoOfParam) ;
7576 proctok := OperandTtok (NoOfParam + 1) ;
7577 IF NoOfParam = 2
7578 THEN
7579 VarSym := OperandT (2) ;
7580 MarkArrayWritten (OperandA (2)) ;
7581 OperandSym := OperandT (1) ;
7582 optok := OperandTok (1) ;
7583 IF IsVar (VarSym)
7584 THEN
7585 IF IsSet (GetDType (VarSym))
7586 THEN
7587 DerefSym := DereferenceLValue (optok, OperandSym) ;
7588 BuildRange (InitInclCheck (VarSym, DerefSym)) ;
7589 GenQuadO (proctok, InclOp, VarSym, NulSym, DerefSym, FALSE)
7590 ELSE
7591 MetaErrorT1 (proctok,
1bd13193 7592 'the first parameter to {%EkINCL} must be a set variable but is {%1Ed}',
1eee94d3
GM		 7593 VarSym)
7594 END
7595 ELSE
7596 MetaErrorT1 (proctok,
1bd13193 7597 'base procedure {%EkINCL} expects a variable as a parameter but is {%1Ed}',
1eee94d3
GM		 7598 VarSym)
7599 END
7600 ELSE
7601 MetaErrorT0 (proctok, 'the base procedure {%EkINCL} expects 1 or 2 parameters')
7602 END ;
7603 PopN (NoOfParam + 1)
7604END BuildInclProcedure ;
7605
7606
7607(*
7608 BuildExclProcedure - builds the pseudo procedure call EXCL.
7609 INCL is a procedure which removes bit b from SET a.
7610 It takes two parameters:
7611 EXCL(a, b)
7612
7613 a := a - {b}
7614
7615 The Stack:
7616
7617
7618 Entry Exit
7619
7620 Ptr ->
7621 +----------------+
7622 | NoOfParam |
7623 |----------------|
7624 | Param 1 |
7625 |----------------|
7626 | Param 2 |
7627 |----------------|
7628 | ProcSym | Type | Empty
7629 |----------------|
7630*)
7631
7632PROCEDURE BuildExclProcedure ;
7633VAR
7634 proctok,
7635 optok : CARDINAL ;
7636 NoOfParam,
7637 DerefSym,
7638 OperandSym,
7639 VarSym : CARDINAL ;
7640BEGIN
7641 PopT (NoOfParam) ;
7642 proctok := OperandTtok (NoOfParam + 1) ;
7643 IF NoOfParam=2
7644 THEN
7645 VarSym := OperandT (2) ;
7646 MarkArrayWritten (OperandA(2)) ;
7647 OperandSym := OperandT (1) ;
7648 optok := OperandTok (1) ;
7649 IF IsVar (VarSym)
7650 THEN
7651 IF IsSet (GetDType (VarSym))
7652 THEN
7653 DerefSym := DereferenceLValue (optok, OperandSym) ;
7654 BuildRange (InitExclCheck (VarSym, DerefSym)) ;
7655 GenQuadO (proctok, ExclOp, VarSym, NulSym, DerefSym, FALSE)
7656 ELSE
7657 MetaErrorT1 (proctok,
1bd13193 7658 'the first parameter to {%EkEXCL} must be a set variable but is {%1Ed}',
1eee94d3
GM		 7659 VarSym)
7660 END
7661 ELSE
7662 MetaErrorT1 (proctok,
1bd13193 7663 'base procedure {%EkEXCL} expects a variable as a parameter but is {%1Ed}',
1eee94d3
GM		 7664 VarSym)
7665 END
7666 ELSE
7667 MetaErrorT0 (proctok,
7668 'the base procedure {%EkEXCL} expects 1 or 2 parameters')
7669 END ;
7670 PopN (NoOfParam + 1)
7671END BuildExclProcedure ;
7672
7673
7674(*
7675 CheckBuildFunction - checks to see whether ProcSym is a function
7676 and if so it adds a TempSym value which will
7677 hold the return value once the function finishes.
7678 This procedure also generates an error message
7679 if the user is calling a function and ignoring
7680 the return result. The additional TempSym
7681 is not created if ProcSym is a procedure
7682 and the stack is unaltered.
7683
7684 The Stack:
7685
7686
7687 Entry Exit
7688
7689 Ptr ->
7690
7691 +----------------+
7692 | ProcSym | Type |
7693 +----------------+ |----------------|
7694 | ProcSym | Type | | TempSym | Type |
7695 |----------------| |----------------|
7696*)
7697
7698PROCEDURE CheckBuildFunction () : BOOLEAN ;
7699VAR
7700 n : Name ;
7701 tokpos,
7702 TempSym,
7703 ProcSym, Type: CARDINAL ;
7704BEGIN
7705 PopTFtok(ProcSym, Type, tokpos) ;
7706 IF IsVar(ProcSym) AND IsProcType(Type)
7707 THEN
7708 IF GetSType(Type)#NulSym
7709 THEN
7710 TempSym := MakeTemporary (tokpos, RightValue) ;
7711 PutVar(TempSym, GetSType(Type)) ;
7712 PushTFtok(TempSym, GetSType(Type), tokpos) ;
7713 PushTFtok(ProcSym, Type, tokpos) ;
7714 IF NOT IsReturnOptional(Type)
7715 THEN
7716 IF IsTemporary(ProcSym)
7717 THEN
7718 ErrorFormat0 (NewError (tokpos),
7719 'function is being called but its return value is ignored')
7720 ELSE
7721 n := GetSymName (ProcSym) ;
7722 ErrorFormat1 (NewError (tokpos),
7723 'function (%a) is being called but its return value is ignored', n)
7724 END
7725 END ;
7726 RETURN TRUE
7727 END
7728 ELSIF IsProcedure(ProcSym) AND (Type#NulSym)
7729 THEN
7730 TempSym := MakeTemporary (tokpos, RightValue) ;
7731 PutVar(TempSym, Type) ;
7732 PushTFtok(TempSym, Type, tokpos) ;
7733 PushTFtok(ProcSym, Type, tokpos) ;
7734 IF NOT IsReturnOptional(ProcSym)
7735 THEN
7736 n := GetSymName(ProcSym) ;
7737 ErrorFormat1(NewError(tokpos),
7738 'function (%a) is being called but its return value is ignored', n)
7739 END ;
7740 RETURN TRUE
7741 END ;
7742 PushTFtok (ProcSym, Type, tokpos) ;
7743 RETURN FALSE
7744END CheckBuildFunction ;
7745
7746
7747(*
7748 BuildFunctionCall - builds a function call.
7749 The Stack:
7750
7751
7752 Entry Exit
7753
7754 Ptr ->
7755 +----------------+
7756 | NoOfParam |
7757 |----------------|
7758 | Param 1 |
7759 |----------------|
7760 | Param 2 |
7761 |----------------|
7762 . .
7763 . .
7764 . .
7765 |----------------|
7766 | Param # | <- Ptr
7767 |----------------| +------------+
7768 | ProcSym | Type | | ReturnVar |
7769 |----------------| |------------|
7770*)
7771
81d5ca0b 7772PROCEDURE BuildFunctionCall (ConstExpr: BOOLEAN) ;
1eee94d3
GM		 7773VAR
7774 paramtok,
7775 combinedtok,
7776 functok,
7777 NoOfParam,
7778 ProcSym : CARDINAL ;
7779BEGIN
7780 PopT (NoOfParam) ;
7781 functok := OperandTtok (NoOfParam + 1) ;
7782 ProcSym := OperandT (NoOfParam + 1) ;
7783 ProcSym := SkipConst (ProcSym) ;
7784 PushT (NoOfParam) ;
81d5ca0b 7785 (* Compile time stack restored to entry state. *)
1eee94d3
GM		 7786 IF IsUnknown (ProcSym)
7787 THEN
7788 paramtok := OperandTtok (1) ;
4bd2f59a 7789 combinedtok := MakeVirtual2Tok (functok, paramtok) ;
1eee94d3
GM		 7790 MetaErrorT1 (functok, 'procedure function {%1Ea} is undefined', ProcSym) ;
7791 PopN (NoOfParam + 2) ;
81d5ca0b
GM		 7792 (* Fake return value to continue compiling. *)
7793 PushT (MakeConstLit (combinedtok, MakeKey ('0'), NulSym))
1eee94d3
GM		 7794 ELSIF IsAModula2Type (ProcSym)
7795 THEN
7796 ManipulatePseudoCallParameters ;
eadd05d5 7797 BuildTypeCoercion (ConstExpr)
1eee94d3
GM		 7798 ELSIF IsPseudoSystemFunction (ProcSym) OR
7799 IsPseudoBaseFunction (ProcSym)
7800 THEN
7801 ManipulatePseudoCallParameters ;
4bd2f59a 7802 BuildPseudoFunctionCall (ConstExpr)
1eee94d3 7803 ELSE
81d5ca0b 7804 BuildRealFunctionCall (functok, ConstExpr)
1eee94d3
GM		 7805 END
7806END BuildFunctionCall ;
7807
7808
7809(*
7810 BuildConstFunctionCall - builds a function call and checks that this function can be
7811 called inside a ConstExpression.
7812
7813 The Stack:
7814
7815
7816 Entry Exit
7817
7818 Ptr ->
7819 +----------------+
7820 | NoOfParam |
7821 |----------------|
7822 | Param 1 |
7823 |----------------|
7824 | Param 2 |
7825 |----------------|
7826 . .
7827 . .
7828 . .
7829 |----------------|
7830 | Param # | <- Ptr
7831 |----------------| +------------+
7832 | ProcSym | Type | | ReturnVar |
7833 |----------------| |------------|
7834
7835*)
7836
7837PROCEDURE BuildConstFunctionCall ;
7838VAR
7839 functok,
7840 combinedtok,
7841 paramtok,
7842 ConstExpression,
7843 NoOfParam,
7844 ProcSym : CARDINAL ;
7845BEGIN
7846 DisplayStack ;
7847 PopT(NoOfParam) ;
7848 ProcSym := OperandT (NoOfParam + 1) ;
7849 functok := OperandTtok (NoOfParam + 1) ;
7850 IF CompilerDebugging
7851 THEN
7852 printf2 ('procsym = %d token = %d\n', ProcSym, functok) ;
81d5ca0b 7853 (* ErrorStringAt (InitString ('constant function'), functok). *)
1eee94d3
GM		 7854 END ;
7855 PushT (NoOfParam) ;
7856 IF (ProcSym # Convert) AND
7857 (IsPseudoBaseFunction (ProcSym) OR
7858 IsPseudoSystemFunctionConstExpression (ProcSym) OR
7859 (IsProcedure (ProcSym) AND IsProcedureBuiltin (ProcSym)))
7860 THEN
81d5ca0b 7861 BuildFunctionCall (TRUE)
1eee94d3
GM		 7862 ELSE
7863 IF IsAModula2Type (ProcSym)
7864 THEN
81d5ca0b 7865 (* Type conversion. *)
1eee94d3
GM		 7866 IF NoOfParam = 1
7867 THEN
7868 ConstExpression := OperandT (NoOfParam + 1) ;
7869 paramtok := OperandTtok (NoOfParam + 1) ;
7870 PopN (NoOfParam + 2) ;
81d5ca0b 7871 (* Build macro: CONVERT( ProcSym, ConstExpression ). *)
1eee94d3
GM		 7872 PushTFtok (Convert, NulSym, functok) ;
7873 PushTtok (ProcSym, functok) ;
7874 PushTtok (ConstExpression, paramtok) ;
81d5ca0b 7875 PushT (2) ; (* Two parameters. *)
4bd2f59a 7876 BuildConvertFunction (Convert, TRUE)
1eee94d3
GM		 7877 ELSE
7878 MetaErrorT0 (functok, '{%E}a constant type conversion can only have one argument')
7879 END
7880 ELSE
81d5ca0b 7881 (* Error issue message and fake return stack. *)
1eee94d3
GM		 7882 IF Iso
7883 THEN
7884 MetaErrorT0 (functok, 'the only functions permissible in a constant expression are: {%kCAP}, {%kCHR}, {%kCMPLX}, {%kFLOAT}, {%kHIGH}, {%kIM}, {%kLENGTH}, {%kMAX}, {%kMIN}, {%kODD}, {%kORD}, {%kRE}, {%kSIZE}, {%kTSIZE}, {%kTRUNC}, {%kVAL} and gcc builtins')
7885 ELSE
7886 MetaErrorT0 (functok, 'the only functions permissible in a constant expression are: {%kCAP}, {%kCHR}, {%kFLOAT}, {%kHIGH}, {%kMAX}, {%kMIN}, {%kODD}, {%kORD}, {%kSIZE}, {%kTSIZE}, {%kTRUNC}, {%kVAL} and gcc builtins')
7887 END ;
7888 IF NoOfParam > 0
7889 THEN
7890 paramtok := OperandTtok (NoOfParam + 1) ;
7891 combinedtok := MakeVirtualTok (functok, functok, paramtok)
7892 ELSE
7893 combinedtok := functok
7894 END ;
7895 PopN (NoOfParam+2) ;
81d5ca0b 7896 PushT (MakeConstLit (combinedtok, MakeKey('0'), NulSym)) (* Fake return value to continue compiling. *)
1eee94d3
GM		 7897 END
7898 END
7899END BuildConstFunctionCall ;
7900
7901
7902(*
7903 BuildTypeCoercion - builds the type coersion.
78b72ee5 7904 Modula-2 allows types to be coersed with no runtime
1eee94d3
GM		 7905 penility.
7906 It insists that the TSIZE(t1)=TSIZE(t2) where
7907 t2 variable := t2(variable of type t1).
7908 The ReturnVar on the stack is of type t2.
7909
7910 The Stack:
7911
7912
7913 Entry Exit
7914
7915 Ptr ->
7916 +----------------+
7917 | NoOfParam |
7918 |----------------|
7919 | Param 1 |
7920 |----------------|
7921 | Param 2 |
7922 |----------------|
7923 . .
7924 . .
7925 . .
7926 |----------------|
7927 | Param # | <- Ptr
7928 |----------------| +------------+
7929 | ProcSym | Type | | ReturnVar |
7930 |----------------| |------------|
7931
7932 Quadruples:
7933
7934 CoerceOp ReturnVar Type Param1
7935
7936 A type coercion will only be legal if the different
7937 types have exactly the same size.
7938 Since we can only decide this after M2Eval has processed
7939 the symbol table then we create a quadruple explaining
7940 the coercion taking place, the code generator can test
7941 this assertion and report an error if the type sizes
7942 differ.
7943*)
7944
eadd05d5 7945PROCEDURE BuildTypeCoercion (ConstExpr: BOOLEAN) ;
1eee94d3
GM		 7946VAR
7947 resulttok,
7948 proctok,
7949 exptok : CARDINAL ;
7950 r,
7951 exp,
7952 NoOfParam,
7953 ReturnVar,
7954 ProcSym : CARDINAL ;
7955BEGIN
7956 PopT(NoOfParam) ;
7957 ProcSym := OperandT (NoOfParam+1) ;
7958 proctok := OperandTok (NoOfParam+1) ;
7959 IF NOT IsAModula2Type (ProcSym)
7960 THEN
7961 MetaError1 ('coersion expecting a type, seen {%1Ea} which is {%1Ed}', ProcSym)
7962 END ;
7963 IF NoOfParam = 1
7964 THEN
7965 PopTrwtok (exp, r, exptok) ;
7966 MarkAsRead (r) ;
eadd05d5 7967 resulttok := MakeVirtual2Tok (proctok, exptok) ;
81d5ca0b 7968 PopN (1) ; (* Pop procedure. *)
eadd05d5 7969 IF ConstExprError (ProcSym, exp, exptok, ConstExpr)
1eee94d3 7970 THEN
eadd05d5
GM		 7971 ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
7972 PutVar (ReturnVar, ProcSym) ; (* Set ReturnVar's TYPE. *)
7973 ELSIF IsConst (exp) OR IsVar (exp)
7974 THEN
7975 ReturnVar := MakeTemporary (resulttok, AreConstant (IsConst (exp))) ;
7976 PutVar (ReturnVar, ProcSym) ; (* Set ReturnVar's TYPE. *)
1eee94d3
GM		 7977 GenQuad (CoerceOp, ReturnVar, ProcSym, exp)
7978 ELSE
7979 MetaError2 ('trying to coerse {%1EMRad} which is not a variable or constant into {%2ad}',
7980 exp, ProcSym) ;
7981 MetaError2 ('trying to coerse {%1ECad} which is not a variable or constant into {%2ad}',
eadd05d5
GM		 7982 exp, ProcSym) ;
7983 ReturnVar := MakeTemporary (resulttok, RightValue) ;
7984 PutVar (ReturnVar, ProcSym) (* Set ReturnVar's TYPE. *)
1eee94d3
GM		 7985 END ;
7986 PushTFtok (ReturnVar, ProcSym, resulttok)
7987 ELSE
7988 MetaError0 ('{%E}only one parameter expected in a TYPE coersion')
7989 END
7990END BuildTypeCoercion ;
7991
7992
7993(*
7994 BuildRealFunctionCall - builds a function call.
7995 The Stack:
7996
7997
7998 Entry Exit
7999
8000 Ptr ->
8001 +----------------+
8002 | NoOfParam |
8003 |----------------|
8004 | Param 1 |
8005 |----------------|
8006 | Param 2 |
8007 |----------------|
8008 . .
8009 . .
8010 . .
8011 |----------------|
8012 | Param # | <- Ptr
8013 |----------------| +------------+
8014 | ProcSym | Type | | ReturnVar |
8015 |----------------| |------------|
8016*)
8017
81d5ca0b 8018PROCEDURE BuildRealFunctionCall (tokno: CARDINAL; ConstExpr: BOOLEAN) ;
1eee94d3
GM		 8019VAR
8020 NoOfParam,
8021 ProcSym : CARDINAL ;
8022BEGIN
8023 PopT(NoOfParam) ;
8024 PushT(NoOfParam) ;
8025 ProcSym := OperandT (NoOfParam+2) ;
8026 ProcSym := SkipConst (ProcSym) ;
8027 IF IsVar(ProcSym)
8028 THEN
81d5ca0b
GM		 8029 (* Procedure Variable therefore get its type to see if it is a FOR "C" call. *)
8030 ProcSym := SkipType (OperandF (NoOfParam+2))
1eee94d3 8031 END ;
81d5ca0b 8032 IF IsDefImp (GetScope (ProcSym)) AND IsDefinitionForC (GetScope (ProcSym))
1eee94d3 8033 THEN
81d5ca0b 8034 BuildRealFuncProcCall (tokno, TRUE, TRUE, ConstExpr)
1eee94d3 8035 ELSE
81d5ca0b 8036 BuildRealFuncProcCall (tokno, TRUE, FALSE, ConstExpr)
1eee94d3
GM		 8037 END
8038END BuildRealFunctionCall ;
8039
8040
8041(*
8042 BuildPseudoFunctionCall - builds the pseudo function
8043 The Stack:
8044
8045
8046 Entry Exit
8047
8048 Ptr ->
8049 +----------------+
8050 | NoOfParam |
8051 |----------------|
8052 | Param 1 |
8053 |----------------|
8054 | Param 2 |
8055 |----------------|
8056 . .
8057 . .
8058 . .
8059 |----------------|
8060 | Param # | <- Ptr
8061 |----------------| +------------+
8062 | ProcSym | Type | | ReturnVar |
8063 |----------------| |------------|
8064
8065*)
8066
4bd2f59a 8067PROCEDURE BuildPseudoFunctionCall (ConstExpr: BOOLEAN) ;
1eee94d3
GM		 8068VAR
8069 NoOfParam,
8070 ProcSym : CARDINAL ;
8071BEGIN
8072 PopT (NoOfParam) ;
8073 ProcSym := OperandT (NoOfParam+1) ;
8074 ProcSym := SkipConst (ProcSym) ;
8075 PushT (NoOfParam) ;
4bd2f59a 8076 (* Compile time stack restored to entry state. *)
1eee94d3
GM		 8077 IF ProcSym = High
8078 THEN
8079 BuildHighFunction
8080 ELSIF ProcSym = LengthS
8081 THEN
4bd2f59a 8082 BuildLengthFunction (ProcSym, ConstExpr)
1eee94d3
GM		 8083 ELSIF ProcSym = Adr
8084 THEN
8085 BuildAdrFunction
8086 ELSIF ProcSym = Size
8087 THEN
8088 BuildSizeFunction
8089 ELSIF ProcSym = TSize
8090 THEN
8091 BuildTSizeFunction
8092 ELSIF ProcSym = TBitSize
8093 THEN
8094 BuildTBitSizeFunction
8095 ELSIF ProcSym = Convert
8096 THEN
4bd2f59a 8097 BuildConvertFunction (ProcSym, ConstExpr)
1eee94d3
GM		 8098 ELSIF ProcSym = Odd
8099 THEN
4bd2f59a 8100 BuildOddFunction (ProcSym, ConstExpr)
1eee94d3
GM		 8101 ELSIF ProcSym = Abs
8102 THEN
4bd2f59a 8103 BuildAbsFunction (ProcSym, ConstExpr)
1eee94d3
GM		 8104 ELSIF ProcSym = Cap
8105 THEN
4bd2f59a 8106 BuildCapFunction (ProcSym, ConstExpr)
1eee94d3
GM		 8107 ELSIF ProcSym = Val
8108 THEN
4bd2f59a 8109 BuildValFunction (ProcSym, ConstExpr)
1eee94d3
GM		 8110 ELSIF ProcSym = Chr
8111 THEN
4bd2f59a 8112 BuildChrFunction (ProcSym, ConstExpr)
1eee94d3
GM		 8113 ELSIF IsOrd (ProcSym)
8114 THEN
4bd2f59a 8115 BuildOrdFunction (ProcSym, ConstExpr)
1eee94d3
GM		 8116 ELSIF IsInt (ProcSym)
8117 THEN
4bd2f59a 8118 BuildIntFunction (ProcSym, ConstExpr)
1eee94d3
GM		 8119 ELSIF IsTrunc (ProcSym)
8120 THEN
4bd2f59a 8121 BuildTruncFunction (ProcSym, ConstExpr)
1eee94d3
GM		 8122 ELSIF IsFloat (ProcSym)
8123 THEN
4bd2f59a 8124 BuildFloatFunction (ProcSym, ConstExpr)
1eee94d3
GM		 8125 ELSIF ProcSym = Min
8126 THEN
8127 BuildMinFunction
8128 ELSIF ProcSym = Max
8129 THEN
8130 BuildMaxFunction
8131 ELSIF ProcSym = AddAdr
8132 THEN
4bd2f59a 8133 BuildAddAdrFunction (ProcSym, ConstExpr)
1eee94d3
GM		 8134 ELSIF ProcSym = SubAdr
8135 THEN
4bd2f59a 8136 BuildSubAdrFunction (ProcSym, ConstExpr)
1eee94d3
GM		 8137 ELSIF ProcSym = DifAdr
8138 THEN
4bd2f59a 8139 BuildDifAdrFunction (ProcSym, ConstExpr)
1eee94d3
GM		 8140 ELSIF ProcSym = Cast
8141 THEN
4bd2f59a 8142 BuildCastFunction (ProcSym, ConstExpr)
1eee94d3
GM		 8143 ELSIF ProcSym = Shift
8144 THEN
8145 BuildShiftFunction
8146 ELSIF ProcSym = Rotate
8147 THEN
8148 BuildRotateFunction
8149 ELSIF ProcSym = MakeAdr
8150 THEN
8151 BuildMakeAdrFunction
8152 ELSIF ProcSym = Re
8153 THEN
4bd2f59a 8154 BuildReFunction (ProcSym, ConstExpr)
1eee94d3
GM		 8155 ELSIF ProcSym = Im
8156 THEN
4bd2f59a 8157 BuildImFunction (ProcSym, ConstExpr)
1eee94d3
GM		 8158 ELSIF ProcSym = Cmplx
8159 THEN
4bd2f59a 8160 BuildCmplxFunction (ProcSym, ConstExpr)
1eee94d3
GM		 8161 ELSE
8162 InternalError ('pseudo function not implemented yet')
8163 END
8164END BuildPseudoFunctionCall ;
8165
8166
8167(*
8168 BuildAddAdrFunction - builds the pseudo procedure call ADDADR.
8169
8170 PROCEDURE ADDADR (addr: ADDRESS; offset: CARDINAL): ADDRESS ;
8171
8172 Which returns address given by (addr + offset),
8173 [ the standard says that it _may_
8174 "raise an exception if this address is not valid."
8175 currently we do not generate any exception code ]
8176
8177 The Stack:
8178
8179 Entry Exit
8180
8181 Ptr ->
8182 +----------------+
8183 | NoOfParam |
8184 |----------------|
8185 | Param 1 |
8186 |----------------|
8187 | Param 2 | <- Ptr
8188 |----------------| +------------+
8189 | ProcSym | Type | | ReturnVar |
8190 |----------------| |------------|
8191*)
8192
4bd2f59a 8193PROCEDURE BuildAddAdrFunction (ProcSym: CARDINAL; ConstExpr: BOOLEAN) ;
1eee94d3
GM		 8194VAR
8195 combinedtok,
8196 functok,
4bd2f59a 8197 vartok,
1eee94d3 8198 optok : CARDINAL ;
64b0130b 8199 opa,
1eee94d3
GM		 8200 ReturnVar,
8201 NoOfParam,
8202 OperandSym,
8203 VarSym : CARDINAL ;
8204BEGIN
8205 PopT (NoOfParam) ;
8206 functok := OperandTtok (NoOfParam + 1) ;
8207 IF NoOfParam=2
8208 THEN
8209 VarSym := OperandT (2) ;
4bd2f59a 8210 vartok := OperandTok (2) ;
1eee94d3
GM		 8211 OperandSym := OperandT (1) ;
8212 optok := OperandTok (1) ;
4bd2f59a 8213 combinedtok := MakeVirtual2Tok (functok, optok) ;
1eee94d3 8214 PopN (NoOfParam + 1) ;
4bd2f59a
GM		 8215 IF ConstExprError (ProcSym, VarSym, vartok, ConstExpr) OR
8216 ConstExprError (ProcSym, OperandSym, optok, ConstExpr)
8217 THEN
8218 (* Fake return result. *)
8219 PushTFtok (MakeConstLit (combinedtok, MakeKey('0'), Address),
8220 Address, combinedtok)
8221 ELSIF IsVar (VarSym)
1eee94d3
GM		 8222 THEN
8223 IF IsReallyPointer (VarSym) OR (GetSType (VarSym) = Address)
8224 THEN
8225 ReturnVar := MakeTemporary (combinedtok, RightValue) ;
8226 PutVar (ReturnVar, Address) ;
64b0130b
GM		 8227 opa := ConvertToAddress (optok, DereferenceLValue (optok, OperandSym)) ;
8228 GenQuadOtok (combinedtok, AddOp, ReturnVar, VarSym, opa, TRUE,
8229 combinedtok, combinedtok, combinedtok) ;
1eee94d3
GM		 8230 PushTFtok (ReturnVar, Address, combinedtok)
8231 ELSE
8232 MetaErrorT1 (functok,
8233 'the first parameter to ADDADR {%1Ea} must be a variable of type ADDRESS or a {%EkPOINTER}, rather than a {%1Etsd}',
8234 VarSym) ;
8235 PushTFtok (MakeConstLit (combinedtok, MakeKey('0'), Address), Address, combinedtok)
8236 END
8237 ELSE
8238 MetaErrorT0 (functok, '{%E}SYSTEM procedure ADDADR expects a variable of type ADDRESS or POINTER as its first parameter') ;
8239 PushTFtok (MakeConstLit (combinedtok, MakeKey('0'), Address), Address, combinedtok)
8240 END
8241 ELSE
4bd2f59a
GM		 8242 MetaErrorT0 (functok,
8243 '{%E}SYSTEM procedure {%EkADDADR} expects 2 parameters') ;
8244 PopN (NoOfParam+1) ;
8245 PushTFtok (MakeConstLit (functok, MakeKey('0'), Address), Address, functok)
1eee94d3
GM		 8246 END
8247END BuildAddAdrFunction ;
8248
8249
8250(*
8251 BuildSubAdrFunction - builds the pseudo procedure call ADDADR.
8252
8253 PROCEDURE SUBADR (addr: ADDRESS; offset: CARDINAL): ADDRESS ;
8254
8255 Which returns address given by (addr - offset),
8256 [ the standard says that it _may_
8257 "raise an exception if this address is not valid."
8258 currently we do not generate any exception code ]
8259
8260 The Stack:
8261
8262 Entry Exit
8263
8264 Ptr ->
8265 +----------------+
8266 | NoOfParam |
8267 |----------------|
8268 | Param 1 |
8269 |----------------|
8270 | Param 2 | <- Ptr
8271 |----------------| +------------+
8272 | ProcSym | Type | | ReturnVar |
8273 |----------------| |------------|
8274*)
8275
4bd2f59a 8276PROCEDURE BuildSubAdrFunction (ProcSym: CARDINAL; ConstExpr: BOOLEAN) ;
1eee94d3
GM		 8277VAR
8278 functok,
8279 combinedtok,
8280 optok,
8281 vartok : CARDINAL ;
8282 ReturnVar,
8283 NoOfParam,
8284 OperandSym,
64b0130b 8285 opa,
1eee94d3
GM		 8286 VarSym : CARDINAL ;
8287BEGIN
8288 PopT (NoOfParam) ;
8289 functok := OperandTtok (NoOfParam + 1) ;
1eee94d3
GM		 8290 IF NoOfParam = 2
8291 THEN
4bd2f59a
GM		 8292 optok := OperandTok (1) ;
8293 OperandSym := OperandT (1) ;
1eee94d3
GM		 8294 VarSym := OperandT (2) ;
8295 vartok := OperandTok (2) ;
8296 combinedtok := MakeVirtualTok (functok, functok, optok) ;
8297 PopN (NoOfParam + 1) ;
4bd2f59a
GM		 8298 IF ConstExprError (ProcSym, VarSym, vartok, ConstExpr) OR
8299 ConstExprError (ProcSym, OperandSym, optok, ConstExpr)
8300 THEN
8301 (* Fake return result. *)
8302 PushTFtok (MakeConstLit (combinedtok, MakeKey('0'), Address),
8303 Address, combinedtok)
8304 ELSIF IsVar (VarSym)
1eee94d3
GM		 8305 THEN
8306 IF IsReallyPointer (VarSym) OR (GetSType (VarSym) = Address)
8307 THEN
8308 ReturnVar := MakeTemporary (combinedtok, RightValue) ;
8309 PutVar (ReturnVar, Address) ;
64b0130b
GM		 8310 opa := ConvertToAddress (optok, DereferenceLValue (optok, OperandSym)) ;
8311 GenQuadOtok (combinedtok, SubOp, ReturnVar, VarSym, opa, TRUE,
8312 combinedtok, combinedtok, combinedtok) ;
1eee94d3
GM		 8313 PushTFtok (ReturnVar, Address, combinedtok)
8314 ELSE
8315 MetaErrorT1 (functok,
8316 'the first parameter to {%EkSUBADR} {%1Ea} must be a variable of type ADDRESS or a {%EkPOINTER}, rather than a {%1Etsd}',
8317 VarSym) ;
8318 PushTFtok (MakeConstLit (vartok, MakeKey('0'), Address), Address, vartok)
8319 END
8320 ELSE
8321 combinedtok := MakeVirtualTok (functok, functok, optok) ;
8322 MetaErrorT0 (combinedtok,
8323 '{%E}SYSTEM procedure {%EkSUBADR} expects a variable of type ADDRESS or POINTER as its first parameter') ;
8324 PushTFtok (MakeConstLit (combinedtok, MakeKey ('0'), Address), Address, combinedtok)
8325 END
8326 ELSE
1eee94d3
GM		 8327 MetaErrorT0 (functok,
8328 '{%E}SYSTEM procedure {%EkSUBADR} expects 2 parameters') ;
8329 PopN (NoOfParam+1) ;
4bd2f59a 8330 PushTFtok (MakeConstLit (functok, MakeKey('0'), Address), Address, functok)
1eee94d3
GM		 8331 END
8332END BuildSubAdrFunction ;
8333
8334
8335(*
8336 BuildDifAdrFunction - builds the pseudo procedure call DIFADR.
8337
8338 PROCEDURE DIFADR (addr1, addr2: ADDRESS): INTEGER ;
8339
8340 Which returns address given by (addr1 - addr2),
8341 [ the standard says that it _may_
8342 "raise an exception if this address is invalid or
8343 address space is non-contiguous."
8344 currently we do not generate any exception code ]
8345
8346 The Stack:
8347
8348 Entry Exit
8349
8350 Ptr ->
8351 +----------------+
8352 | NoOfParam |
8353 |----------------|
8354 | Param 1 |
8355 |----------------|
8356 | Param 2 | <- Ptr
8357 |----------------| +------------+
8358 | ProcSym | Type | | ReturnVar |
8359 |----------------| |------------|
8360*)
8361
4bd2f59a 8362PROCEDURE BuildDifAdrFunction (ProcSym: CARDINAL; ConstExpr: BOOLEAN) ;
1eee94d3
GM		 8363VAR
8364 functok,
8365 optok,
8366 vartok,
8367 combinedtok: CARDINAL ;
8368 TempVar,
8369 NoOfParam,
8370 OperandSym,
64b0130b 8371 opa,
1eee94d3
GM		 8372 VarSym : CARDINAL ;
8373BEGIN
8374 PopT (NoOfParam) ;
8375 functok := OperandTtok (NoOfParam + 1) ;
4bd2f59a
GM		 8376 IF NoOfParam >= 1
8377 THEN
8378 OperandSym := OperandT (1) ;
8379 optok := OperandTok (1)
8380 ELSE
8381 optok := functok
8382 END ;
1eee94d3
GM		 8383 IF NoOfParam = 2
8384 THEN
8385 VarSym := OperandT (2) ;
8386 vartok := OperandTok (2) ;
8387 combinedtok := MakeVirtualTok (functok, functok, optok) ;
8388 PopN (NoOfParam + 1) ;
4bd2f59a
GM		 8389 IF ConstExprError (ProcSym, VarSym, vartok, ConstExpr) OR
8390 ConstExprError (ProcSym, OperandSym, optok, ConstExpr)
8391 THEN
8392 (* Fake return result. *)
8393 PushTFtok (MakeConstLit (combinedtok, MakeKey('0'), Integer),
8394 Integer, combinedtok)
8395 ELSIF IsVar (VarSym)
1eee94d3
GM		 8396 THEN
8397 IF IsReallyPointer (VarSym) OR (GetSType (VarSym) = Address)
8398 THEN
8399 IF IsReallyPointer (OperandSym) OR (GetSType (OperandSym) = Address)
8400 THEN
8401 TempVar := MakeTemporary (vartok, RightValue) ;
8402 PutVar (TempVar, Address) ;
64b0130b
GM		 8403 opa := ConvertToAddress (optok, DereferenceLValue (optok, OperandSym)) ;
8404 GenQuadOtok (combinedtok, SubOp, TempVar, VarSym, opa, TRUE,
8405 combinedtok, combinedtok, combinedtok) ;
1eee94d3
GM		 8406 (*
8407 Build macro: CONVERT( INTEGER, TempVar )
8408 *)
8409 PushTFtok (Convert, NulSym, functok) ;
8410 PushTtok (Integer, functok) ;
8411 PushTtok (TempVar, vartok) ;
8412 PushT (2) ; (* Two parameters *)
4bd2f59a 8413 BuildConvertFunction (Convert, ConstExpr)
1eee94d3 8414 ELSE
029c7ebe 8415 MetaError1 ('the second parameter to {%EkDIFADR} {%1Ea} must be a variable of type ADDRESS or a {%EkPOINTER}, rather than a {%1Etsd}',
1eee94d3
GM		 8416 OperandSym) ;
8417 PushTFtok (MakeConstLit (combinedtok, MakeKey ('0'), Integer), Integer, combinedtok)
8418 END
8419 ELSE
029c7ebe
GM		 8420 MetaErrorT1 (vartok,
8421 'the first parameter to {%EkDIFADR} {%1Ea} must be a variable of type ADDRESS or a {%EkPOINTER}, rather than a {%1Etsd}',
8422 VarSym) ;
1eee94d3
GM		 8423 PushTFtok (MakeConstLit (combinedtok, MakeKey ('0'), Integer), Integer, combinedtok)
8424 END
8425 ELSE
029c7ebe 8426 MetaError0 ('{%E}SYSTEM procedure {%EkDIFADR} expects a variable of type ADDRESS or POINTER as its first parameter') ;
1eee94d3
GM		 8427 PushTFtok (MakeConstLit (combinedtok, MakeKey('0'), Integer), Integer, combinedtok)
8428 END
8429 ELSE
4bd2f59a
GM		 8430 combinedtok := MakeVirtual2Tok (functok, optok) ;
8431 MetaErrorT0 (combinedtok, '{%E}SYSTEM procedure {%EkDIFADR} expects 2 parameters') ;
1eee94d3
GM		 8432 PopN (NoOfParam+1) ;
8433 PushTFtok (MakeConstLit (combinedtok, MakeKey('0'), Integer), Integer, combinedtok)
8434 END
8435END BuildDifAdrFunction ;
8436
8437
8438(*
8439 BuildHighFunction - checks the stack in preparation for generating
8440 quadruples which perform HIGH.
8441 This procedure does not alter the stack but
8442 determines whether, a, in HIGH(a) is an ArraySym
8443 or UnboundedSym.
8444 Both cases are different and appropriate quadruple
8445 generating routines are called.
8446
8447 The Stack:
8448
8449
8450 Entry Exit
8451
8452 Ptr ->
8453 +----------------+
8454 | NoOfParam |
8455 |----------------|
8456 | Param 1 |
8457 |----------------|
8458 | Param 2 |
8459 |----------------|
8460 . .
8461 . .
8462 . .
8463 |----------------|
8464 | Param # | <- Ptr
8465 |----------------| +------------+
8466 | ProcSym | Type | | ReturnVar |
8467 |----------------| |------------|
8468
8469*)
8470
8471PROCEDURE BuildHighFunction ;
8472VAR
8473 functok,
8474 combinedtok,
8475 paramtok : CARDINAL ;
8476 ProcSym,
8477 Type,
8478 NoOfParam,
8479 Param : CARDINAL ;
8480BEGIN
8481 PopT (NoOfParam) ;
8482 ProcSym := OperandT (NoOfParam+1) ;
8483 functok := OperandTok (NoOfParam + 1) ;
8484 BuildSizeCheckEnd (ProcSym) ; (* quadruple generation now on *)
8485 IF NoOfParam = 1
8486 THEN
8487 Param := OperandT (1) ;
8488 paramtok := OperandTok (1) ;
8489 combinedtok := MakeVirtualTok (paramtok, functok, paramtok) ;
8490 Type := GetDType (Param) ;
8491 (* Restore stack to original form *)
8492 PushT (NoOfParam) ;
8493 IF (NOT IsVar(Param)) AND (NOT IsConstString(Param)) AND (NOT IsConst(Param))
8494 THEN
8495 (* we cannot test for IsConst(Param) AND (GetSType(Param)=Char) as the type might not be assigned yet *)
8496 MetaError1 ('base procedure {%EkHIGH} expects a variable or string constant as its parameter {%1d:rather than {%1d}} {%1asa}', Param)
8497 ELSIF IsUnbounded(Type)
8498 THEN
8499 BuildHighFromUnbounded (combinedtok)
8500 ELSE
8501 BuildConstHighFromSym (combinedtok)
8502 END
8503 ELSE
8504 MetaError0 ('base procedure {%EkHIGH} requires one parameter') ;
8505 PopN (2) ;
8506 PushTFtok (MakeConstLit (functok, MakeKey ('0'), Cardinal), Cardinal, functok)
8507 END
8508END BuildHighFunction ;
8509
8510
8511(*
8512 BuildConstHighFromSym - builds the pseudo function HIGH from an Sym.
8513 Sym is a constant or an array which has constant bounds
8514 and therefore it can be calculated at compile time.
8515
8516 The Stack:
8517
8518
8519 Entry Exit
8520
8521 Ptr ->
8522 +----------------+
8523 | NoOfParam |
8524 |----------------|
8525 | Param 1 |
8526 |----------------|
8527 | Param 2 |
8528 |----------------|
8529 . .
8530 . .
8531 . .
8532 |----------------|
8533 | Param # | <- Ptr
8534 |----------------| +------------+
8535 | ProcSym | Type | | ReturnVar |
8536 |----------------| |------------|
8537*)
8538
8539PROCEDURE BuildConstHighFromSym (tok: CARDINAL) ;
8540VAR
1eee94d3
GM		 8541 NoOfParam,
8542 ReturnVar: CARDINAL ;
8543BEGIN
8544 PopT (NoOfParam) ;
8545 ReturnVar := MakeTemporary (tok, ImmediateValue) ;
6dbf0d25 8546 PutConst (ReturnVar, Cardinal) ;
1eee94d3
GM		 8547 GenHigh (tok, ReturnVar, 1, OperandT (1)) ;
8548 PopN (NoOfParam+1) ;
8549 PushTtok (ReturnVar, tok)
8550END BuildConstHighFromSym ;
8551
8552
8553(*
8554 BuildHighFromUnbounded - builds the pseudo function HIGH from an
8555 UnboundedSym.
8556
8557 The Stack:
8558
8559
8560 Entry Exit
8561
8562 Ptr ->
8563 +----------------+
8564 | NoOfParam |
8565 |----------------|
8566 | Param # | <- Ptr
8567 |----------------| +------------+
8568 | ProcSym | Type | | ReturnVar |
8569 |----------------| |------------|
8570
8571*)
8572
8573PROCEDURE BuildHighFromUnbounded (tok: CARDINAL) ;
8574VAR
8575 Dim,
8576 NoOfParam,
8577 ReturnVar: CARDINAL ;
8578BEGIN
8579 PopT (NoOfParam) ;
8580 Assert (NoOfParam=1) ;
8581 ReturnVar := MakeTemporary (tok, RightValue) ;
8582 PutVar (ReturnVar, Cardinal) ;
8583 Dim := OperandD (1) ;
8584 INC (Dim) ;
8585 IF Dim > 1
8586 THEN
8587 GenHigh (tok, ReturnVar, Dim, OperandA(1))
8588 ELSE
8589 GenHigh (tok, ReturnVar, Dim, OperandT(1))
8590 END ;
8591 PopN (2) ;
8592 PushTFtok (ReturnVar, GetSType(ReturnVar), tok)
8593END BuildHighFromUnbounded ;
8594
8595
8596(*
8597 GetQualidentImport - returns the symbol as if it were qualified from, module.n.
8598 This is used to reference runtime support procedures and an
8599 error is generated if the symbol cannot be obtained.
8600*)
8601
8602PROCEDURE GetQualidentImport (tokno: CARDINAL;
8603 n: Name; module: Name) : CARDINAL ;
8604VAR
8605 ModSym: CARDINAL ;
8606BEGIN
8607 ModSym := MakeDefinitionSource (tokno, module) ;
8608 IF ModSym=NulSym
8609 THEN
8610 MetaErrorNT2 (tokno,
8611 'module %a cannot be found and is needed to import %a', module, n) ;
8612 FlushErrors ;
8613 RETURN NulSym
8614 END ;
8615 Assert(IsDefImp(ModSym)) ;
8616 IF (GetExported (tokno, ModSym, n)=NulSym) OR IsUnknown (GetExported (tokno, ModSym, n))
8617 THEN
8618 MetaErrorN2 ('module %a does not export procedure %a which is a necessary component of the runtime system, hint check the path and library/language variant',
8619 module, n) ;
8620 FlushErrors ;
8621 RETURN NulSym
8622 END ;
8623 RETURN GetExported (tokno, MakeDefinitionSource (tokno, module), n)
8624END GetQualidentImport ;
8625
8626
4bd2f59a
GM		 8627(*
8628 ConstExprError - return TRUE if a constant expression is being built and Var is a variable.
8629*)
8630
8631PROCEDURE ConstExprError (Func, Var: CARDINAL; optok: CARDINAL; ConstExpr: BOOLEAN) : BOOLEAN ;
8632BEGIN
8633 IF ConstExpr AND IsVar (Var)
8634 THEN
8635 MetaErrorT2 (optok,
8636 'the procedure function {%1Ea} is being called from within a constant expression and therefore the parameter {%2a} must be a constant, seen a {%2da}',
8637 Func, Var) ;
8638 RETURN TRUE
8639 ELSE
8640 RETURN FALSE
8641 END
8642END ConstExprError ;
8643
8644
1eee94d3 8645(*
78b72ee5 8646 DeferMakeLengthConst - creates a constant which contains the length of string, sym.
1eee94d3
GM		 8647*)
8648
78b72ee5
GM		 8649PROCEDURE DeferMakeLengthConst (tok: CARDINAL; sym: CARDINAL) : CARDINAL ;
8650VAR
8651 const: CARDINAL ;
1eee94d3 8652BEGIN
78b72ee5
GM		 8653 const := MakeTemporary (tok, ImmediateValue) ;
8654 PutVar (const, ZType) ;
8655 GenQuadO (tok, StringLengthOp, const, 0, sym, FALSE) ;
8656 RETURN const
8657END DeferMakeLengthConst ;
1eee94d3
GM		 8658
8659
8660(*
8661 BuildLengthFunction - builds the inline standard function LENGTH.
8662
8663 The Stack:
8664
8665
8666 Entry Exit
8667
8668 Ptr ->
8669 +----------------+
8670 | NoOfParam |
8671 |----------------|
8672 | Param 1 | <- Ptr
8673 |----------------| +------------+
8674 | ProcSym | Type | | ReturnVar |
8675 |----------------| |------------|
8676
8677*)
8678
4bd2f59a 8679PROCEDURE BuildLengthFunction (Function: CARDINAL; ConstExpr: BOOLEAN) ;
1eee94d3
GM		 8680VAR
8681 combinedtok,
8682 paramtok,
8683 functok : CARDINAL ;
8684 ProcSym,
8685 Type,
8686 NoOfParam,
8687 Param,
8688 ReturnVar : CARDINAL ;
8689BEGIN
8690 PopT (NoOfParam) ;
8691 Param := OperandT (1) ;
8692 paramtok := OperandTok (1) ;
8693 functok := OperandTok (NoOfParam + 1) ;
78b72ee5 8694 (* Restore stack to origional form. *)
1eee94d3 8695 PushT (NoOfParam) ;
78b72ee5 8696 Type := GetSType (Param) ; (* Get the type from the symbol, not the stack. *)
1eee94d3
GM		 8697 IF NoOfParam # 1
8698 THEN
c980eeb8 8699 MetaErrorT1 (functok, 'base procedure {%1EkLENGTH} expects 1 parameter, seen {%1n} parameters', NoOfParam)
1eee94d3
GM		 8700 END ;
8701 IF NoOfParam >= 1
8702 THEN
4bd2f59a 8703 combinedtok := MakeVirtual2Tok (functok, paramtok) ;
1eee94d3
GM		 8704 IF IsConst (Param) AND (GetSType (Param) = Char)
8705 THEN
8706 PopT (NoOfParam) ;
8707 PopN (NoOfParam + 1) ;
8708 ReturnVar := MakeConstLit (combinedtok, MakeKey ('1'), Cardinal) ;
8709 PushTtok (ReturnVar, combinedtok)
8710 ELSIF IsConstString (Param)
8711 THEN
8712 PopT (NoOfParam) ;
78b72ee5 8713 ReturnVar := DeferMakeLengthConst (combinedtok, OperandT (1)) ;
1eee94d3
GM		 8714 PopN (NoOfParam + 1) ;
8715 PushTtok (ReturnVar, combinedtok)
8716 ELSE
8717 ProcSym := GetQualidentImport (functok, MakeKey ('Length'), MakeKey ('M2RTS')) ;
8718 IF (ProcSym # NulSym) AND IsProcedure (ProcSym)
8719 THEN
8720 PopT (NoOfParam) ;
4bd2f59a 8721 IF IsConst (Param)
1eee94d3 8722 THEN
4bd2f59a 8723 (* This can be folded in M2GenGCC. *)
1eee94d3
GM		 8724 ReturnVar := MakeTemporary (combinedtok, ImmediateValue) ;
8725 PutVar (ReturnVar, Cardinal) ;
4bd2f59a 8726 GenQuad (StandardFunctionOp, ReturnVar, ProcSym, Param) ;
1eee94d3
GM		 8727 PopN (NoOfParam + 1) ;
8728 PushTtok (ReturnVar, combinedtok)
4bd2f59a
GM		 8729 ELSIF ConstExprError (Function, Param, paramtok, ConstExpr)
8730 THEN
8731 (* Fake a result as we have detected and reported an error. *)
8732 PopN (NoOfParam + 1) ;
8733 ReturnVar := MakeConstLit (combinedtok, MakeKey ('1'), Cardinal) ;
8734 PushTtok (ReturnVar, combinedtok)
1eee94d3 8735 ELSE
4bd2f59a 8736 (* We must resolve this at runtime or in the GCC optimizer. *)
1eee94d3
GM		 8737 PopTF (Param, Type);
8738 PopN (NoOfParam) ;
8739 PushTtok (ProcSym, functok) ;
8740 PushTFtok (Param, Type, paramtok) ;
8741 PushT (NoOfParam) ;
81d5ca0b 8742 BuildRealFunctionCall (functok, FALSE)
1eee94d3
GM		 8743 END
8744 ELSE
8745 PopT (NoOfParam) ;
8746 PopN (NoOfParam + 1) ;
8747 PushTtok (MakeConstLit (combinedtok, MakeKey ('0'), Cardinal), combinedtok) ;
c980eeb8 8748 MetaErrorT0 (functok, 'no procedure Length found for substitution to the standard function {%1EkLENGTH} which is required to calculate non constant string lengths')
1eee94d3
GM		 8749 END
8750 END
8751 ELSE
8752 (* NoOfParam is _very_ wrong, we flush all outstanding errors *)
8753 FlushErrors
8754 END
8755END BuildLengthFunction ;
8756
8757
8758(*
8759 BuildOddFunction - builds the pseudo procedure call ODD.
8760 This procedure is actually a "macro" for
8761 ORD(x) --> VAL(BOOLEAN, x MOD 2)
8762 However we cannot push tokens back onto the input stack
8763 because the compiler is currently building a function
8764 call and expecting a ReturnVar on the stack.
8765 Hence we manipulate the stack and call
8766 BuildConvertFunction.
8767
8768 The Stack:
8769
8770
8771 Entry Exit
8772
8773 Ptr ->
8774 +----------------+
8775 | NoOfParam |
8776 |----------------|
8777 | Param 1 |
8778 |----------------|
8779 | Param 2 |
8780 |----------------|
8781 . .
8782 . .
8783 . .
8784 |----------------|
8785 | Param # |
8786 |----------------|
8787 | ProcSym | Type | Empty
8788 |----------------|
8789*)
8790
4bd2f59a 8791PROCEDURE BuildOddFunction (ProcSym: CARDINAL; ConstExpr: BOOLEAN) ;
1eee94d3
GM		 8792VAR
8793 combinedtok,
8794 optok,
8795 functok : CARDINAL ;
8796 NoOfParam,
8797 Res, Var : CARDINAL ;
8798BEGIN
8799 PopT (NoOfParam) ;
8800 functok := OperandTok (NoOfParam + 1) ;
8801 IF NoOfParam=1
8802 THEN
8803 Var := OperandT (1) ;
8804 optok := OperandTok (1) ;
8805 combinedtok := MakeVirtualTok (functok, functok, optok) ;
4bd2f59a
GM		 8806 IF ConstExprError (ProcSym, Var, optok, ConstExpr)
8807 THEN
8808 (* Nothing to do. *)
8809 PushTtok (False, combinedtok)
8810 ELSIF IsVar(Var) OR IsConst(Var)
1eee94d3
GM		 8811 THEN
8812 PopN (NoOfParam + 1) ;
8813 (*
8814 Build macro: VAL(BOOLEAN, (x MOD 2))
8815 *)
8816
8817 (* compute (x MOD 2) *)
8818 PushTFtok (Var, GetSType (Var), optok) ;
8819 PushT (ModTok) ;
8820 PushTFtok (MakeConstLit (optok, MakeKey ('2'), ZType), ZType, optok) ;
8821 BuildBinaryOp ;
8822 PopT (Res) ;
8823
8824 (* compute IF ...=0 *)
8825 PushTtok (Res, optok) ;
8826 PushT (EqualTok) ;
8827 PushTFtok (MakeConstLit (optok, MakeKey ('0'), ZType), ZType, optok) ;
8828 BuildRelOp (combinedtok) ;
8829 BuildThenIf ;
8830
8831 Res := MakeTemporary (combinedtok, RightValue) ;
8832 PutVar (Res, Boolean) ;
8833
8834 PushTtok (Res, combinedtok) ;
8835 PushTtok (False, combinedtok) ;
8836 BuildAssignment (combinedtok) ;
8837 BuildElse ;
8838 PushTtok (Res, combinedtok) ;
8839 PushTtok (True, combinedtok) ;
8840 BuildAssignment (combinedtok) ;
8841 BuildEndIf ;
8842
8843 PushTtok (Res, combinedtok)
8844 ELSE
029c7ebe 8845 MetaErrorT1 (optok,
c980eeb8 8846 'the parameter to {%1EkODD} must be a variable or constant, seen {%1ad}',
1eee94d3
GM		 8847 Var) ;
8848 PushTtok (False, combinedtok)
8849 END
8850 ELSE
8851 MetaErrorT1 (functok,
029c7ebe 8852 'the pseudo procedure {%E1kODD} only has one parameter, seen {%1n} parameters',
1eee94d3
GM		 8853 NoOfParam) ;
8854 PushTtok (False, functok)
8855 END
8856END BuildOddFunction ;
8857
8858
8859(*
8860 BuildAbsFunction - builds a call to the standard function ABS.
8861
8862 We cannot implement it as a macro or inline an
8863 IF THEN statement as the IF THEN ELSE requires
8864 we write the value to the same variable (or constant)
8865 twice. The macro implementation will fail as
8866 the compiler maybe building a function
8867 call and expecting a ReturnVar on the stack.
8868 The only method to implement this is to pass it to the
8869 gcc backend.
8870
8871 The Stack:
8872
8873
8874 Entry Exit
8875
8876 Ptr ->
8877 +----------------+
8878 | NoOfParam |
8879 |----------------|
8880 | Param 1 |
8881 |----------------|
8882 | Param 2 |
8883 |----------------|
8884 . .
8885 . .
8886 . .
8887 |----------------|
8888 | Param # |
8889 |----------------|
8890 | ProcSym | Type | Empty
8891 |----------------|
8892*)
8893
4bd2f59a 8894PROCEDURE BuildAbsFunction (ProcSym: CARDINAL; ConstExpr: BOOLEAN) ;
1eee94d3 8895VAR
029c7ebe 8896 vartok,
1eee94d3
GM		 8897 functok,
8898 combinedtok: CARDINAL ;
8899 NoOfParam,
1eee94d3
GM		 8900 Res, Var : CARDINAL ;
8901BEGIN
8902 PopT (NoOfParam) ;
8903 functok := OperandTok (NoOfParam + 1) ;
8904 IF NoOfParam = 1
8905 THEN
8906 Var := OperandT (1) ;
029c7ebe 8907 vartok := OperandTok (1) ;
4bd2f59a 8908 PopN (NoOfParam + 1) ;
1eee94d3 8909 combinedtok := MakeVirtualTok (functok, functok, vartok) ;
4bd2f59a
GM		 8910 IF ConstExprError (ProcSym, Var, vartok, ConstExpr)
8911 THEN
8912 (* Create fake result. *)
8913 Res := MakeTemporary (combinedtok, AreConstant (IsConst (Var))) ;
8914 PutVar (Res, GetSType (Var)) ;
8915 PushTFtok (Res, GetSType (Var), combinedtok)
8916 ELSIF IsVar(Var) OR IsConst(Var)
1eee94d3 8917 THEN
1eee94d3
GM		 8918 Res := MakeTemporary (combinedtok, AreConstant (IsConst (Var))) ;
8919 PutVar (Res, GetSType (Var)) ;
8920
8921 GenQuadO (combinedtok, StandardFunctionOp, Res, ProcSym, Var, FALSE) ;
8922 PushTFtok (Res, GetSType (Var), combinedtok)
8923 ELSE
029c7ebe 8924 MetaErrorT1 (vartok,
c980eeb8 8925 'the parameter to {%AkABS} must be a variable or constant, seen {%1ad}',
1eee94d3
GM		 8926 Var)
8927 END
8928 ELSE
8929 MetaErrorT1 (functok,
c980eeb8 8930 'the pseudo procedure {%AkABS} only has one parameter, seen {%1n} parameters',
1eee94d3
GM		 8931 NoOfParam)
8932 END
8933END BuildAbsFunction ;
8934
8935
8936(*
8937 BuildCapFunction - builds the pseudo procedure call CAP.
8938 We generate a the following quad:
8939
8940
8941 StandardFunctionOp ReturnVal Cap Param1
8942
8943 The Stack:
8944
8945
8946 Entry Exit
8947
8948 Ptr ->
8949 +----------------+
8950 | NoOfParam = 1 |
8951 |----------------|
8952 | Param 1 |
8953 |----------------| +-------------+
8954 | ProcSym | Type | | ReturnVal |
8955 |----------------| |-------------|
8956*)
8957
4bd2f59a 8958PROCEDURE BuildCapFunction (ProcSym: CARDINAL; ConstExpr: BOOLEAN) ;
1eee94d3
GM		 8959VAR
8960 optok,
8961 functok,
8962 combinedtok: CARDINAL ;
8963 NoOfParam,
1eee94d3
GM		 8964 Res, Var : CARDINAL ;
8965BEGIN
8966 PopT (NoOfParam) ;
8967 functok := OperandTok (NoOfParam + 1) ;
8968 IF NoOfParam = 1
8969 THEN
8970 Var := OperandT (1) ;
8971 optok := OperandTok (1) ;
4bd2f59a
GM		 8972 PopN (NoOfParam + 1) ;
8973 IF ConstExprError (ProcSym, Var, optok, ConstExpr)
1eee94d3 8974 THEN
4bd2f59a
GM		 8975 (* Create fake result. *)
8976 combinedtok := MakeVirtual2Tok (functok, optok) ;
8977 Res := MakeTemporary (combinedtok, AreConstant (IsConst (Var))) ;
8978 PutVar (Res, Char) ;
8979 PushTFtok (Res, Char, combinedtok)
8980 ELSIF IsVar (Var) OR IsConst (Var)
8981 THEN
8982 combinedtok := MakeVirtual2Tok (functok, optok) ;
1eee94d3
GM		 8983 Res := MakeTemporary (combinedtok, AreConstant (IsConst (Var))) ;
8984 PutVar (Res, Char) ;
8985 GenQuadO (combinedtok, StandardFunctionOp, Res, ProcSym, Var, FALSE) ;
8986 PushTFtok (Res, Char, combinedtok)
8987 ELSE
029c7ebe 8988 MetaErrorT1 (optok,
c980eeb8 8989 'the parameter to {%AkCAP} must be a variable or constant, seen {%1ad}',
1eee94d3
GM		 8990 Var)
8991 END
8992 ELSE
8993 MetaErrorT1 (functok,
c980eeb8 8994 'the pseudo procedure {%AkCAP} only has one parameter, seen {%1n} parameters',
1eee94d3
GM		 8995 NoOfParam)
8996 END
8997END BuildCapFunction ;
8998
8999
9000(*
9001 BuildChrFunction - builds the pseudo procedure call CHR.
9002 This procedure is actually a "macro" for
9003 CHR(x) --> CONVERT(CHAR, x)
9004 However we cannot push tokens back onto the input stack
9005 because the compiler is currently building a function
9006 call and expecting a ReturnVar on the stack.
9007 Hence we manipulate the stack and call
9008 BuildConvertFunction.
9009
9010 The Stack:
9011
9012
9013 Entry Exit
9014
9015 Ptr ->
9016 +----------------+
9017 | NoOfParam |
9018 |----------------|
9019 | Param 1 |
9020 |----------------|
9021 | Param 2 |
9022 |----------------|
9023 . .
9024 . .
9025 . .
9026 |----------------|
9027 | Param # |
9028 |----------------|
9029 | ProcSym | Type | Empty
9030 |----------------|
9031*)
9032
4bd2f59a 9033PROCEDURE BuildChrFunction (ProcSym: CARDINAL; ConstExpr: BOOLEAN) ;
1eee94d3
GM		 9034VAR
9035 functok,
4bd2f59a 9036 combinedtok,
1eee94d3 9037 optok : CARDINAL ;
4bd2f59a 9038 ReturnVar,
1eee94d3
GM		 9039 NoOfParam,
9040 Var : CARDINAL ;
9041BEGIN
9042 PopT (NoOfParam) ;
9043 functok := OperandTok (NoOfParam + 1) ;
9044 IF NoOfParam = 1
9045 THEN
9046 Var := OperandT (1) ;
9047 optok := OperandTok (1) ;
4bd2f59a
GM		 9048 PopN (NoOfParam + 1) ;
9049 IF ConstExprError (ProcSym, Var, optok, ConstExpr)
9050 THEN
9051 (* Generate fake result. *)
9052 combinedtok := MakeVirtual2Tok (functok, optok) ;
9053 ReturnVar := MakeTemporary (combinedtok, AreConstant (IsConst (Var))) ;
9054 PutVar (ReturnVar, Char) ;
9055 PushTFtok (ReturnVar, Char, combinedtok)
9056 ELSIF IsVar (Var) OR IsConst (Var)
1eee94d3 9057 THEN
1eee94d3
GM		 9058 (*
9059 Build macro: CONVERT( CHAR, Var )
9060 *)
9061 PushTFtok (Convert, NulSym, functok) ;
9062 PushTtok (Char, functok) ;
9063 PushTtok (Var, optok) ;
9064 PushT (2) ; (* Two parameters *)
4bd2f59a 9065 BuildConvertFunction (Convert, ConstExpr)
1eee94d3 9066 ELSE
029c7ebe 9067 MetaErrorT1 (optok,
c980eeb8 9068 'the parameter to {%AkCHR} must be a variable or constant, seen {%1ad}',
1eee94d3
GM		 9069 Var)
9070 END
9071 ELSE
9072 MetaErrorT1 (functok,
c980eeb8 9073 'the pseudo procedure {%AkCHR} only has one parameter, seen {%1n} parameters',
1eee94d3
GM		 9074 NoOfParam)
9075 END
9076END BuildChrFunction ;
9077
9078
9079(*
9080 BuildOrdFunction - builds the pseudo procedure call ORD.
9081 This procedure is actually a "macro" for
9082 ORD(x) --> CONVERT(GetSType(sym), x)
9083 However we cannot push tokens back onto the input stack
9084 because the compiler is currently building a function
9085 call and expecting a ReturnVar on the stack.
9086 Hence we manipulate the stack and call
9087 BuildConvertFunction.
9088
9089 The Stack:
9090
9091
9092 Entry Exit
9093
9094 Ptr ->
9095 +----------------+
9096 | NoOfParam |
9097 |----------------|
9098 | Param 1 |
9099 |----------------|
9100 | Param 2 |
9101 |----------------|
9102 . .
9103 . .
9104 . .
9105 |----------------|
9106 | Param # |
9107 |----------------|
9108 | ProcSym | Type | Empty
9109 |----------------|
9110*)
9111
4bd2f59a 9112PROCEDURE BuildOrdFunction (Sym: CARDINAL; ConstExpr: BOOLEAN) ;
1eee94d3 9113VAR
4bd2f59a 9114 combinedtok,
1eee94d3 9115 functok,
4bd2f59a
GM		 9116 optok : CARDINAL ;
9117 ReturnVar,
1eee94d3 9118 NoOfParam,
4bd2f59a 9119 Type, Var : CARDINAL ;
1eee94d3
GM		 9120BEGIN
9121 PopT (NoOfParam) ;
9122 functok := OperandTok (NoOfParam + 1) ;
9123 IF NoOfParam = 1
9124 THEN
9125 Var := OperandT (1) ;
9126 optok := OperandTok (1) ;
4bd2f59a
GM		 9127 PopN (NoOfParam + 1) ;
9128 IF ConstExprError (Sym, Var, optok, ConstExpr)
9129 THEN
9130 (* Generate fake result. *)
9131 combinedtok := MakeVirtual2Tok (functok, optok) ;
9132 ReturnVar := MakeTemporary (combinedtok, AreConstant (IsConst (Var))) ;
9133 PutVar (ReturnVar, Cardinal) ;
9134 PushTFtok (ReturnVar, Cardinal, combinedtok)
9135 ELSIF IsVar (Var) OR IsConst (Var)
1eee94d3
GM		 9136 THEN
9137 Type := GetSType (Sym) ;
1eee94d3
GM		 9138 (*
9139 Build macro: CONVERT( CARDINAL, Var )
9140 *)
9141 PushTFtok (Convert, NulSym, functok) ;
9142 PushTtok (Type, optok) ;
9143 PushTtok (Var, optok) ;
9144 PushT (2) ; (* Two parameters *)
4bd2f59a 9145 BuildConvertFunction (Convert, ConstExpr)
1eee94d3 9146 ELSE
029c7ebe
GM		 9147 MetaErrorT2 (optok,
9148 'the parameter to {%1Aa} must be a variable or constant, seen {%2ad}',
1eee94d3
GM		 9149 Sym, Var)
9150 END
9151 ELSE
9152 MetaErrorT2 (functok,
029c7ebe 9153 'the pseudo procedure {%1Aa} only has one parameter, seen {%2n} parameters',
1eee94d3
GM		 9154 Sym, NoOfParam)
9155 END
9156END BuildOrdFunction ;
9157
9158
9159(*
9160 BuildIntFunction - builds the pseudo procedure call INT.
9161 This procedure is actually a "macro" for
9162 INT(x) --> CONVERT(INTEGER, x)
9163 However we cannot push tokens back onto the input stack
9164 because the compiler is currently building a function
9165 call and expecting a ReturnVar on the stack.
9166 Hence we manipulate the stack and call
9167 BuildConvertFunction.
9168
9169 The Stack:
9170
9171
9172 Entry Exit
9173
9174 Ptr ->
9175 +----------------+
9176 | NoOfParam |
9177 |----------------|
9178 | Param 1 |
9179 |----------------|
9180 | Param 2 |
9181 |----------------|
9182 . .
9183 . .
9184 . .
9185 |----------------|
9186 | Param # |
9187 |----------------|
9188 | ProcSym | Type | Empty
9189 |----------------|
9190*)
9191
4bd2f59a 9192PROCEDURE BuildIntFunction (Sym: CARDINAL; ConstExpr: BOOLEAN) ;
1eee94d3
GM		 9193VAR
9194 combinedtok,
9195 functok,
9196 optok : CARDINAL ;
4bd2f59a 9197 ReturnVar,
1eee94d3
GM		 9198 NoOfParam,
9199 Type, Var : CARDINAL ;
9200BEGIN
9201 PopT (NoOfParam) ;
9202 functok := OperandTok (NoOfParam + 1) ;
9203 IF NoOfParam = 1
9204 THEN
9205 Var := OperandT (1) ;
9206 optok := OperandTok (1) ;
4bd2f59a
GM		 9207 PopN (NoOfParam + 1) ;
9208 IF ConstExprError (Sym, Var, optok, ConstExpr)
9209 THEN
9210 (* Generate fake result. *)
9211 combinedtok := MakeVirtual2Tok (functok, optok) ;
9212 ReturnVar := MakeTemporary (combinedtok, AreConstant (IsConst (Var))) ;
9213 PutVar (ReturnVar, Integer) ;
9214 PushTFtok (ReturnVar, Integer, combinedtok)
9215 ELSIF IsVar (Var) OR IsConst (Var)
1eee94d3
GM		 9216 THEN
9217 Type := GetSType (Sym) ; (* return type of function *)
1eee94d3
GM		 9218 (* Build macro: CONVERT( CARDINAL, Var ). *)
9219 PushTFtok (Convert, NulSym, functok) ;
9220 PushTtok (Type, functok) ;
9221 PushTtok (Var, optok) ;
9222 PushT (2) ; (* Two parameters *)
4bd2f59a 9223 BuildConvertFunction (Convert, ConstExpr)
1eee94d3
GM		 9224 ELSE
9225 combinedtok := MakeVirtualTok (functok, optok, optok) ;
029c7ebe
GM		 9226 MetaErrorT2 (optok,
9227 'the parameter to {%1Ea} must be a variable or constant, seen {%2ad}',
1eee94d3
GM		 9228 Sym, Var) ;
9229 PushTtok (combinedtok, MakeConstLit (combinedtok, MakeKey ('0'), ZType))
9230 END
9231 ELSE
9232 MetaErrorT2 (functok,
029c7ebe 9233 'the pseudo procedure {%1Ea} only has one parameter, seen {%2n} parameters',
1eee94d3
GM		 9234 Sym, NoOfParam) ;
9235 PushTtok (functok, MakeConstLit (functok, MakeKey ('0'), ZType))
9236 END
9237END BuildIntFunction ;
9238
9239
9240(*
9241 BuildMakeAdrFunction - builds the pseudo procedure call MAKEADR.
9242
9243 The Stack:
9244
9245
9246 Entry Exit
9247
9248 Ptr ->
9249 +----------------+
9250 | NoOfParam |
9251 |----------------|
9252 | Param 1 |
9253 |----------------|
9254 | Param 2 |
9255 |----------------|
9256 . .
9257 . .
9258 . .
9259 |----------------|
9260 | Param # |
9261 |----------------|
9262 | ProcSym | Type | Empty
9263 |----------------|
9264*)
9265
9266PROCEDURE BuildMakeAdrFunction ;
9267VAR
9268 functok,
9269 starttok,
9270 endtok,
9271 resulttok : CARDINAL ;
9272 AreConst : BOOLEAN ;
9273 i, pi,
9274 NoOfParameters: CARDINAL ;
9275 ReturnVar : CARDINAL ;
9276BEGIN
9277 PopT (NoOfParameters) ;
9278 functok := OperandTok (NoOfParameters + 1) ;
9279 IF NoOfParameters>0
9280 THEN
9281 starttok := OperandTok (NoOfParameters + 1) ; (* ADR token. *)
9282 endtok := OperandTok (1) ; (* last parameter. *)
9283 GenQuad (ParamOp, 0, MakeAdr, MakeAdr) ;
9284 i := NoOfParameters ;
9285 (* stack index referencing stacked parameter, i *)
9286 pi := 1 ;
9287 WHILE i > 0 DO
9288 GenQuadO (OperandTok (pi), ParamOp, i, MakeAdr, OperandT (pi), TRUE) ;
9289 DEC (i) ;
9290 INC (pi)
9291 END ;
9292 AreConst := TRUE ;
9293 i := 1 ;
9294 WHILE i <= NoOfParameters DO
9295 IF IsVar (OperandT (i))
9296 THEN
9297 AreConst := FALSE ;
9298 ELSIF NOT IsConst (OperandT (i))
9299 THEN
c980eeb8 9300 MetaError1 ('problem in the {%1EN} argument for {%kMAKEADR}, all arguments to {%kMAKEADR} must be either variables or constants', i)
1eee94d3
GM		 9301 END ;
9302 INC (i)
9303 END ;
9304 (* ReturnVar - will have the type of the procedure *)
9305 resulttok := MakeVirtualTok (starttok, starttok, endtok) ;
9306 ReturnVar := MakeTemporary (resulttok, AreConstant(AreConst)) ;
9307 PutVar (ReturnVar, GetSType(MakeAdr)) ;
9308 GenQuadO (resulttok, FunctValueOp, ReturnVar, NulSym, MakeAdr, TRUE) ;
9309 PopN (NoOfParameters+1) ;
9310 PushTFtok (ReturnVar, GetSType (MakeAdr), resulttok)
9311 ELSE
c980eeb8 9312 MetaError1 ('the pseudo procedure {%EkMAKEADR} requires at least one parameter, seen {%1n}', NoOfParameters) ;
1eee94d3
GM		 9313 PopN (1) ;
9314 PushTFtok (Nil, GetSType (MakeAdr), functok)
9315 END
9316END BuildMakeAdrFunction ;
9317
9318
9319(*
9320 BuildShiftFunction - builds the pseudo procedure call SHIFT.
9321
9322 PROCEDURE SHIFT (val: <any type>;
9323 num: INTEGER): <any type> ;
9324
9325 "Returns a bit sequence obtained from val by
9326 shifting up or down (left or right) by the
9327 absolute value of num, introducing
9328 zeros as necessary. The direction is down if
9329 the sign of num is negative, otherwise the
9330 direction is up."
9331
9332 The Stack:
9333
9334 Entry Exit
9335
9336 Ptr ->
9337 +----------------+
9338 | NoOfParam |
9339 |----------------|
9340 | Param 1 |
9341 |----------------|
9342 | Param 2 | <- Ptr
9343 |----------------| +------------+
9344 | ProcSym | Type | | ReturnVar |
9345 |----------------| |------------|
9346*)
9347
9348PROCEDURE BuildShiftFunction ;
9349VAR
9350 combinedtok,
9351 paramtok,
9352 functok,
9353 vartok,
9354 exptok : CARDINAL ;
9355 r,
9356 procSym,
9357 returnVar,
9358 NoOfParam,
9359 derefExp,
9360 Exp,
9361 varSet : CARDINAL ;
9362BEGIN
9363 PopT (NoOfParam) ;
9364 paramtok := OperandTok (1) ;
9365 functok := OperandTok (NoOfParam + 1) ;
9366 IF NoOfParam=2
9367 THEN
9368 PopTrwtok (Exp, r, exptok) ;
9369 MarkAsRead (r) ;
9370 PopTtok (varSet, vartok) ;
9371 PopT (procSym) ;
96a9355a 9372 combinedtok := MakeVirtualTok (functok, functok, exptok) ;
1eee94d3
GM		 9373 IF (GetSType (varSet) # NulSym) AND IsSet (GetDType (varSet))
9374 THEN
9375 derefExp := DereferenceLValue (exptok, Exp) ;
9376 BuildRange (InitShiftCheck (varSet, derefExp)) ;
9377 returnVar := MakeTemporary (combinedtok, RightValue) ;
9378 PutVar (returnVar, GetSType (varSet)) ;
96a9355a 9379 GenQuadO (combinedtok, LogicalShiftOp, returnVar, varSet, derefExp, TRUE) ;
1eee94d3
GM		 9380 PushTFtok (returnVar, GetSType (varSet), combinedtok)
9381 ELSE
029c7ebe
GM		 9382 MetaErrorT1 (vartok,
9383 'SYSTEM procedure {%1EkSHIFT} expects a constant or variable which has a type of SET as its first parameter, seen {%1ad}',
9384 varSet) ;
1eee94d3
GM		 9385 PushTFtok (MakeConstLit (combinedtok, MakeKey ('0'), Cardinal), Cardinal, combinedtok)
9386 END
9387 ELSE
9388 combinedtok := MakeVirtualTok (functok, functok, paramtok) ;
9389 MetaErrorT1 (functok,
c980eeb8 9390 'the pseudo procedure {%kSHIFT} requires at least two parameters, seen {%1En}',
1eee94d3
GM		 9391 NoOfParam) ;
9392 PopN (NoOfParam + 1) ;
9393 PushTFtok (MakeConstLit (combinedtok, MakeKey ('0'), Cardinal), Cardinal, combinedtok)
9394 END
9395END BuildShiftFunction ;
9396
9397
9398(*
9399 BuildRotateFunction - builds the pseudo procedure call ROTATE.
9400
9401 PROCEDURE ROTATE (val: <any type>;
9402 num: INTEGER): <any type> ;
9403
9404 "Returns a bit sequence obtained from val
9405 by rotating up or down (left or right) by
9406 the absolute value of num. The direction is
9407 down if the sign of num is negative, otherwise
9408 the direction is up."
9409
9410 The Stack:
9411
9412 Entry Exit
9413
9414 Ptr ->
9415 +----------------+
9416 | NoOfParam |
9417 |----------------|
9418 | Param 1 |
9419 |----------------|
9420 | Param 2 | <- Ptr
9421 |----------------| +------------+
9422 | ProcSym | Type | | ReturnVar |
9423 |----------------| |------------|
9424*)
9425
9426PROCEDURE BuildRotateFunction ;
9427VAR
9428 combinedtok,
9429 functok,
9430 vartok,
9431 exptok : CARDINAL ;
9432 r,
9433 procSym,
9434 returnVar,
9435 NoOfParam,
9436 derefExp,
9437 Exp,
9438 varSet : CARDINAL ;
9439BEGIN
9440 PopT (NoOfParam) ;
9441 functok := OperandTok (NoOfParam + 1) ;
9442 IF NoOfParam = 2
9443 THEN
9444 PopTrwtok (Exp, r, exptok) ;
9445 MarkAsRead (r) ;
9446 PopTtok (varSet, vartok) ;
9447 PopT (procSym) ;
9448 IF (GetSType (varSet) # NulSym) AND IsSet (GetDType (varSet))
9449 THEN
9450 combinedtok := MakeVirtualTok (functok, functok, exptok) ;
9451 derefExp := DereferenceLValue (exptok, Exp) ;
9452 BuildRange (InitRotateCheck (varSet, derefExp)) ;
9453 returnVar := MakeTemporary (combinedtok, RightValue) ;
9454 PutVar (returnVar, GetSType (varSet)) ;
9455 GenQuadO (combinedtok, LogicalRotateOp, returnVar, varSet, derefExp, TRUE) ;
9456 PushTFtok (returnVar, GetSType (varSet), combinedtok)
9457 ELSE
029c7ebe
GM		 9458 MetaErrorT1 (vartok,
9459 'SYSTEM procedure {%EkROTATE} expects a constant or variable which has a type of SET as its first parameter, seen {%1ad}',
9460 varSet) ;
1eee94d3
GM		 9461 PushTFtok (MakeConstLit (functok, MakeKey('0'), Cardinal), Cardinal, functok)
9462 END
9463 ELSE
9464 MetaErrorT1 (functok,
9465 'SYSTEM procedure {%EkROTATE} expects 2 parameters and was given {%1n} parameters',
9466 NoOfParam) ;
9467 PopN (NoOfParam + 1) ;
9468 PushTFtok (MakeConstLit (functok, MakeKey ('0'), Cardinal), Cardinal, functok)
9469 END
9470END BuildRotateFunction ;
9471
9472
9473(*
9474 BuildValFunction - builds the pseudo procedure call VAL.
9475 This procedure is actually a "macro" for
9476 VAL(Type, x) --> CONVERT(Type, x)
9477 However we cannot push tokens back onto the input stack
9478 because the compiler is currently building a function
9479 call and expecting a ReturnVar on the stack.
9480 Hence we manipulate the stack and call
9481 BuildConvertFunction.
9482
9483 The Stack:
9484
9485
9486 Entry Exit
9487
9488 Ptr ->
9489 +----------------+
9490 | NoOfParam |
9491 |----------------|
9492 | Param 1 |
9493 |----------------|
9494 | Param 2 |
9495 |----------------|
9496 . .
9497 . .
9498 . .
9499 |----------------|
9500 | Param # |
9501 |----------------|
9502 | ProcSym | Type | Empty
9503 |----------------|
9504*)
9505
4bd2f59a 9506PROCEDURE BuildValFunction (ProcSym: CARDINAL; ConstExpr: BOOLEAN) ;
1eee94d3 9507VAR
4bd2f59a
GM		 9508 combinedtok,
9509 functok : CARDINAL ;
9510 ReturnVar,
1eee94d3 9511 NoOfParam,
4bd2f59a 9512 Exp, Type : CARDINAL ;
1eee94d3
GM		 9513 tok, r,
9514 typetok,
4bd2f59a 9515 exptok : CARDINAL ;
1eee94d3
GM		 9516BEGIN
9517 PopT (NoOfParam) ;
9518 functok := OperandTok (NoOfParam + 1) ;
9519 IF NoOfParam = 2
9520 THEN
9521 PopTrwtok (Exp, r, exptok) ;
9522 MarkAsRead (r) ;
9523 PopTtok (Type, typetok) ;
9524 PopTtok (ProcSym, tok) ;
9525 IF IsUnknown (Type)
9526 THEN
9527 (* not sensible to try and recover when we dont know the return type. *)
9528 MetaErrorT1 (typetok,
8089f26b 9529 'undeclared type found in builtin procedure function {%AkVAL} {%1ad}',
1eee94d3
GM		 9530 Type)
9531 (* non recoverable error. *)
4bd2f59a
GM		 9532 ELSIF ConstExprError (ProcSym, Exp, exptok, ConstExpr)
9533 THEN
9534 (* Generate fake result. *)
9535 combinedtok := MakeVirtualTok (functok, functok, exptok) ;
9536 ReturnVar := MakeTemporary (combinedtok, AreConstant (IsConst (Exp))) ;
9537 PutVar (ReturnVar, Type) ;
9538 PushTFtok (ReturnVar, Type, combinedtok)
1eee94d3
GM		 9539 ELSIF (IsSet (Type) OR IsEnumeration (Type) OR IsSubrange (Type) OR
9540 IsType (Type) OR IsPointer (Type) OR IsProcType (Type)) AND
9541 (IsVar (Exp) OR IsConst (Exp) OR IsProcedure (Exp))
9542 THEN
9543 (*
9544 Build macro: CONVERT( Type, Var )
9545 *)
9546 PushTFtok (Convert, NulSym, tok) ;
9547 PushTtok (Type, typetok) ;
9548 PushTtok (Exp, exptok) ;
9549 PushT (2) ; (* Two parameters *)
4bd2f59a 9550 BuildConvertFunction (Convert, ConstExpr)
1eee94d3
GM		 9551 ELSE
9552 (* not sensible to try and recover when we dont know the return type. *)
9553 MetaErrorT0 (functok,
8089f26b 9554 'the builtin procedure {%AkVAL} has the following formal parameter declaration {%kVAL} (type, expression)')
1eee94d3
GM		 9555 (* non recoverable error. *)
9556 END
9557 ELSE
9558 (* not sensible to try and recover when we dont know the return type. *)
9559 MetaErrorT1 (functok,
9560 'the builtin procedure {%AkVAL} expects 2 parameters, a type and an expression, but was given {%1n} parameters', NoOfParam)
9561 (* non recoverable error. *)
9562 END
9563END BuildValFunction ;
9564
9565
9566(*
9567 BuildCastFunction - builds the pseudo procedure call CAST.
9568 This procedure is actually a "macro" for
9569 CAST(Type, x) --> Type(x)
9570 However we cannot push tokens back onto the input stack
9571 because the compiler is currently building a function
9572 call and expecting a ReturnVar on the stack.
9573 Hence we manipulate the stack and call
9574 BuildConvertFunction.
9575
9576 The Stack:
9577
9578
9579 Entry Exit
9580
9581 Ptr ->
9582 +----------------+
9583 | NoOfParam |
9584 |----------------|
9585 | Param 1 |
9586 |----------------|
9587 | Param 2 |
9588 |----------------|
9589 . .
9590 . .
9591 . .
9592 |----------------|
9593 | Param # |
9594 |----------------|
9595 | ProcSym | Type | Empty
9596 |----------------|
9597*)
9598
4bd2f59a 9599PROCEDURE BuildCastFunction (ProcSym: CARDINAL; ConstExpr: BOOLEAN) ;
1eee94d3
GM		 9600VAR
9601 combinedtok,
4bd2f59a 9602 exptok,
1eee94d3 9603 typetok,
4bd2f59a 9604 functok : CARDINAL ;
1eee94d3
GM		 9605 ReturnVar,
9606 NoOfParam,
4bd2f59a 9607 Exp, Type : CARDINAL ;
1eee94d3
GM		 9608BEGIN
9609 PopT (NoOfParam) ;
9610 functok := OperandTok (NoOfParam + 1) ;
9611 IF NoOfParam = 2
9612 THEN
9613 Type := OperandT (2) ;
9614 typetok := OperandTok (2) ;
4bd2f59a
GM		 9615 Exp := OperandT (1) ;
9616 exptok := OperandTok (1) ;
1eee94d3
GM		 9617 IF IsUnknown (Type)
9618 THEN
4bd2f59a
GM		 9619 (* we cannot recover if we dont have a type. *)
9620 MetaErrorT1 (typetok, 'undeclared type {%1Aad} found in {%kCAST}', Type)
9621 (* non recoverable error. *)
9622 ELSIF ConstExprError (ProcSym, Exp, exptok, ConstExpr)
9623 THEN
9624 (* Generate fake result. *)
9625 combinedtok := MakeVirtualTok (functok, functok, exptok) ;
9626 ReturnVar := MakeTemporary (combinedtok, AreConstant (IsConst (Exp))) ;
9627 PutVar (ReturnVar, Type) ;
9628 PushTFtok (ReturnVar, Type, combinedtok)
1eee94d3
GM		 9629 ELSIF IsSet (Type) OR IsEnumeration (Type) OR IsSubrange (Type) OR IsType (Type) OR
9630 IsPointer (Type) OR IsArray (Type) OR IsProcType (Type)
9631 THEN
4bd2f59a 9632 IF IsConst (Exp)
1eee94d3
GM		 9633 THEN
9634 PopN (NoOfParam+1) ;
9635 (*
9636 Build macro: Type( Var )
9637 *)
9638 PushTFtok (Type, NulSym, typetok) ;
4bd2f59a 9639 PushTtok (Exp, exptok) ;
1eee94d3 9640 PushT (1) ; (* one parameter *)
eadd05d5 9641 BuildTypeCoercion (ConstExpr)
4bd2f59a 9642 ELSIF IsVar (Exp) OR IsProcedure (Exp)
1eee94d3
GM		 9643 THEN
9644 PopN (NoOfParam + 1) ;
4bd2f59a 9645 combinedtok := MakeVirtual2Tok (functok, exptok) ;
1eee94d3
GM		 9646 ReturnVar := MakeTemporary (combinedtok, RightValue) ;
9647 PutVar (ReturnVar, Type) ;
4bd2f59a 9648 GenQuadO (combinedtok, CastOp, ReturnVar, Type, Exp, FALSE) ;
1eee94d3
GM		 9649 PushTFtok (ReturnVar, Type, combinedtok)
9650 ELSE
9651 (* not sensible to try and recover when we dont know the return type. *)
9652 MetaErrorT0 (functok,
8089f26b 9653 'the second parameter to the builtin procedure {%AkCAST} must either be a variable, constant or a procedure. The formal parameters to cast are {%kCAST} (type, variable or constant or procedure)')
1eee94d3
GM		 9654 (* non recoverable error. *)
9655 END
9656 ELSE
9657 (* not sensible to try and recover when we dont know the return type. *)
9658 MetaErrorT0 (functok,
9659 'the builtin procedure {%AkCAST} has the following formal parameter declaration {%kCAST} (type, expression)')
9660 (* non recoverable error. *)
9661 END
9662 ELSE
9663 (* not sensible to try and recover when we dont know the return type. *)
9664 MetaErrorT1 (functok,
9665 'the builtin procedure {%AkCAST} `expects 2 parameters, a type and an expression, but was given {%1n} parameters', NoOfParam)
9666 (* non recoverable error. *)
9667 END
9668END BuildCastFunction ;
9669
9670
9671(*
9672 BuildConvertFunction - builds the pseudo function CONVERT.
9673 CONVERT( Type, Variable ) ;
9674
9675 The Stack:
9676
9677
9678 Entry Exit
9679
9680 Ptr ->
9681 +----------------+
9682 | NoOfParam |
9683 |----------------|
9684 | Param 1 |
9685 |----------------|
9686 | Param 2 |
9687 |----------------|
9688 . .
9689 . .
9690 . .
9691 |----------------|
9692 | Param # | <- Ptr
9693 |----------------| +---------------------+
9694 | ProcSym | Type | | ReturnVar | Param1 |
9695 |----------------| |---------------------|
9696
9697 Quadruples:
9698
9699 ConvertOp ReturnVar Param1 Param2
9700
9701 Converts variable Param2 into a variable Param1
9702 with a type Param1.
9703*)
9704
4bd2f59a 9705PROCEDURE BuildConvertFunction (ProcSym: CARDINAL; ConstExpr: BOOLEAN) ;
1eee94d3
GM		 9706VAR
9707 combinedtok,
9708 functok,
9709 typetok,
9710 exptok : CARDINAL ;
9711 t, r,
9712 Exp, Type,
1eee94d3
GM		 9713 NoOfParam,
9714 ReturnVar : CARDINAL ;
9715BEGIN
9716 PopT (NoOfParam) ;
9717 functok := OperandTok (NoOfParam + 1) ;
9718 IF NoOfParam = 2
9719 THEN
9720 PopTrwtok (Exp, r, exptok) ;
9721 MarkAsRead (r) ;
9722 PopTtok (Type, typetok) ;
9723 PopT (ProcSym) ;
9724 IF IsUnknown (Type)
9725 THEN
9726 (* we cannot recover if we dont have a type. *)
c980eeb8 9727 MetaErrorT1 (typetok, 'undeclared type {%1Aad} found in {%kCONVERT}', Type)
1eee94d3
GM		 9728 (* non recoverable error. *)
9729 ELSIF IsUnknown (Exp)
9730 THEN
9731 (* we cannot recover if we dont have a type. *)
c980eeb8 9732 MetaErrorT1 (typetok, 'unknown {%1Ad} {%1ad} found in {%kCONVERT}', Exp)
1eee94d3 9733 (* non recoverable error. *)
4bd2f59a
GM		 9734 ELSIF ConstExprError (ProcSym, Exp, exptok, ConstExpr)
9735 THEN
9736 (* Generate fake result. *)
9737 combinedtok := MakeVirtualTok (functok, functok, exptok) ;
9738 ReturnVar := MakeTemporary (combinedtok, AreConstant (IsConst (Exp))) ;
9739 PutVar (ReturnVar, Type) ;
9740 PushTFtok (ReturnVar, Type, combinedtok)
1eee94d3
GM		 9741 ELSIF (IsSet (Type) OR IsEnumeration (Type) OR IsSubrange (Type) OR
9742 IsType (Type) OR IsPointer (Type) OR IsProcType (Type) OR IsRecord (Type)) AND
9743 (IsVar (Exp) OR IsConst (Exp) OR IsProcedure (Exp))
9744 THEN
9745 (* firstly dereference Var *)
9746 IF GetMode (Exp) = LeftValue
9747 THEN
9748 t := MakeTemporary (exptok, RightValue) ;
9749 PutVar (t, GetSType (Exp)) ;
9750 CheckPointerThroughNil (exptok, Exp) ;
9751 doIndrX (exptok, t, Exp) ;
9752 Exp := t
9753 END ;
9754
9755 combinedtok := MakeVirtualTok (functok, functok, exptok) ;
9756 ReturnVar := MakeTemporary (combinedtok, AreConstant (IsConst (Exp))) ;
9757 PutVar (ReturnVar, Type) ;
9758 GenQuadO (combinedtok, ConvertOp, ReturnVar, Type, Exp, TRUE) ;
9759 PushTFtok (ReturnVar, Type, combinedtok)
9760 ELSE
9761 (* not sensible to try and recover when we dont know the return type. *)
9762 MetaErrorT0 (functok,
9763 'the builtin procedure {%AkCONVERT} has the following formal parameter declaration {%kCONVERT} (type, expression)')
9764 (* non recoverable error. *)
9765 END
9766 ELSE
9767 (* not sensible to try and recover when we dont know the return type. *)
9768 MetaErrorT1 (functok,
9769 'the builtin procedure {%AkCONVERT} expects 2 parameters, a type and an expression, but was given {%1n} parameters', NoOfParam)
9770 (* non recoverable error. *)
9771 END
9772END BuildConvertFunction ;
9773
9774
9775(*
9776 CheckBaseTypeValue - checks to see whether the value, min, really exists.
9777*)
9778
9779PROCEDURE CheckBaseTypeValue (tok: CARDINAL;
9780 type: CARDINAL;
9781 min: CARDINAL;
9782 func: CARDINAL) : CARDINAL ;
9783BEGIN
9784 IF (type = Real) OR (type = LongReal) OR (type = ShortReal)
9785 THEN
9786 PushValue (min) ;
9787 IF NOT IsValueAndTreeKnown ()
9788 THEN
9789 MetaErrorT2 (tok,
9790 '{%1Ead} ({%2ad}) cannot be calculated at compile time for the target architecture', func, type) ;
9791 RETURN MakeConstLit (tok, MakeKey ('1.0'), RType)
9792 END
9793 END ;
9794 RETURN min
9795END CheckBaseTypeValue ;
9796
9797
9798(*
9799 GetTypeMin - returns the minimium value of type.
9800*)
9801
9802PROCEDURE GetTypeMin (tok: CARDINAL; func, type: CARDINAL) : CARDINAL ;
9803VAR
9804 min, max: CARDINAL ;
9805BEGIN
9806 IF IsSubrange (type)
9807 THEN
9808 min := MakeTemporary (tok, ImmediateValue) ;
9809 PutVar (min, type) ;
9810 GenQuad (SubrangeLowOp, min, NulSym, type) ;
9811 RETURN min
9812 ELSIF IsSet (SkipType (type))
9813 THEN
9814 RETURN GetTypeMin (tok, func, GetSType (SkipType (type)))
9815 ELSIF IsBaseType (type) OR IsEnumeration (type)
9816 THEN
9817 GetBaseTypeMinMax (type, min, max) ;
9818 min := CheckBaseTypeValue (tok, type, min, func) ;
9819 RETURN min
9820 ELSIF IsSystemType (type)
9821 THEN
9822 GetSystemTypeMinMax (type, min, max) ;
9823 RETURN min
9824 ELSIF GetSType (type) = NulSym
9825 THEN
9826 MetaErrorT1 (tok,
8089f26b 9827 'unable to obtain the {%AkMIN} value for type {%1ad}', type) ;
1eee94d3 9828 (* non recoverable error. *)
9fadd8de 9829 InternalError ('MetaErrorT1 {%AkMIN} should call abort')
1eee94d3
GM		 9830 ELSE
9831 RETURN GetTypeMin (tok, func, GetSType (type))
9832 END
9833END GetTypeMin ;
9834
9835
9836(*
9837 GetTypeMax - returns the maximum value of type.
9838*)
9839
9840PROCEDURE GetTypeMax (tok: CARDINAL; func, type: CARDINAL) : CARDINAL ;
9841VAR
9842 min, max: CARDINAL ;
9843BEGIN
9844 IF IsSubrange (type)
9845 THEN
9846 max := MakeTemporary (tok, ImmediateValue) ;
9847 PutVar (max, type) ;
9848 GenQuad (SubrangeHighOp, max, NulSym, type) ;
9849 RETURN max
9850 ELSIF IsSet (SkipType (type))
9851 THEN
9852 RETURN GetTypeMax (tok, func, GetSType (SkipType (type)))
9853 ELSIF IsBaseType (type) OR IsEnumeration (type)
9854 THEN
9855 GetBaseTypeMinMax (type, min, max) ;
9856 min := CheckBaseTypeValue (tok, type, min, func) ;
9857 RETURN max
9858 ELSIF IsSystemType (type)
9859 THEN
9860 GetSystemTypeMinMax (type, min, max) ;
9861 RETURN max
9862 ELSIF GetSType (type) = NulSym
9863 THEN
9864 MetaErrorT1 (tok,
8089f26b 9865 'unable to obtain the {%AkMAX} value for type {%1ad}', type) ;
1eee94d3 9866 (* non recoverable error. *)
9fadd8de 9867 InternalError ('MetaErrorT1 {%AkMAX} should call abort')
1eee94d3
GM		 9868 ELSE
9869 RETURN GetTypeMax (tok, func, GetSType (type))
9870 END
9871END GetTypeMax ;
9872
9873
9874(*
9875 BuildMinFunction - builds the pseudo function call Min.
9876
9877 The Stack:
9878
9879 Entry Exit
9880
9881 Ptr ->
9882 +----------------+
9883 | NoOfParam=1 |
9884 |----------------|
9885 | Param 1 |
9886 |----------------|
9887 | ProcSym | Type | Empty
9888 |----------------|
9889*)
9890
9891PROCEDURE BuildMinFunction ;
9892VAR
9893 combinedtok,
9894 functok,
9895 vartok : CARDINAL ;
9896 func,
9897 min,
9898 NoOfParam,
9899 Var : CARDINAL ;
9900BEGIN
9901 PopT (NoOfParam) ;
9902 func := OperandT (NoOfParam + 1) ;
9903 functok := OperandTtok (NoOfParam + 1) ;
9904 IF NoOfParam = 1
9905 THEN
9906 Var := OperandT (1) ;
9907 vartok := OperandTok (1) ;
9908 PopN (NoOfParam+1) ; (* destroy arguments to this function *)
9909 combinedtok := MakeVirtualTok (functok, functok, vartok) ;
9910 IF IsAModula2Type (Var)
9911 THEN
9912 min := GetTypeMin (vartok, func, Var) ;
9913 PushTFtok (min, GetSType (min), combinedtok)
9914 ELSIF IsVar (Var)
9915 THEN
9916 min := GetTypeMin (vartok, func, GetSType (Var)) ;
9917 PushTFtok (min, GetSType (Var), combinedtok)
9918 ELSE
9919 (* we dont know the type therefore cannot fake a return. *)
9920 MetaErrorT1 (vartok,
8089f26b 9921 'parameter to {%AkMIN} must be a type or a variable, seen {%1ad}',
1eee94d3
GM		 9922 Var)
9923 (* non recoverable error. *)
9924 END
9925 ELSE
9926 (* we dont know the type therefore cannot fake a return. *)
9927 MetaErrorT1 (functok,
8089f26b 9928 'the pseudo builtin procedure function {%AkMIN} only has one parameter, seen {%1n}',
1eee94d3
GM		 9929 NoOfParam)
9930 (* non recoverable error. *)
9931 END
9932END BuildMinFunction ;
9933
9934
9935(*
9936 BuildMaxFunction - builds the pseudo function call Max.
9937
9938 The Stack:
9939
9940 Entry Exit
9941
9942 Ptr ->
9943 +----------------+
9944 | NoOfParam=1 |
9945 |----------------|
9946 | Param 1 |
9947 |----------------|
9948 | ProcSym | Type | Empty
9949 |----------------|
9950*)
9951
9952PROCEDURE BuildMaxFunction ;
9953VAR
9954 combinedtok,
9955 functok,
9956 vartok : CARDINAL ;
9957 func,
9958 max,
9959 NoOfParam,
9960 Var : CARDINAL ;
9961BEGIN
9962 PopT (NoOfParam) ;
9963 func := OperandT (NoOfParam + 1) ;
9964 functok := OperandTtok (NoOfParam + 1) ;
9965 IF NoOfParam = 1
9966 THEN
9967 Var := OperandT (1) ;
9968 vartok := OperandTok (1) ;
9969 PopN (NoOfParam + 1) ; (* destroy arguments to this function *)
9970 combinedtok := MakeVirtualTok (functok, functok, vartok) ;
9971 IF IsAModula2Type (Var)
9972 THEN
9973 max := GetTypeMax (vartok, func, Var) ;
9974 PushTFtok (max, GetSType (max), combinedtok)
9975 ELSIF IsVar(Var)
9976 THEN
9977 max := GetTypeMax (vartok, func, GetSType (Var)) ;
9978 PushTFtok (max, GetSType (Var), combinedtok)
9979 ELSE
9980 (* we dont know the type therefore cannot fake a return. *)
9981 MetaErrorT1 (vartok,
8089f26b 9982 'parameter to {%AkMAX} must be a type or a variable, seen {%1ad}',
1eee94d3 9983 Var)
9fadd8de 9984 (* non recoverable error. *) ;
1eee94d3
GM		 9985 END
9986 ELSE
9987 (* we dont know the type therefore cannot fake a return. *)
9988 MetaErrorT1 (functok,
8089f26b 9989 'the pseudo builtin procedure function {%AkMAX} only has one parameter, seen {%1n}',
1eee94d3
GM		 9990 NoOfParam)
9991 (* non recoverable error. *)
9992 END
9993END BuildMaxFunction ;
9994
9995
9996(*
9997 BuildTruncFunction - builds the pseudo procedure call TRUNC.
9998 This procedure is actually a "macro" for
9999 TRUNC(x) --> CONVERT(INTEGER, x)
10000 However we cannot push tokens back onto the input stack
10001 because the compiler is currently building a function
10002 call and expecting a ReturnVar on the stack.
10003 Hence we manipulate the stack and call
10004 BuildConvertFunction.
10005
10006 The Stack:
10007
10008
10009 Entry Exit
10010
10011 Ptr ->
10012 +----------------+
10013 | NoOfParam |
10014 |----------------|
10015 | Param 1 |
10016 |----------------|
10017 | Param 2 |
10018 |----------------|
10019 . .
10020 . .
10021 . .
10022 |----------------|
10023 | Param # |
10024 |----------------|
10025 | ProcSym | Type | Empty
10026 |----------------|
10027*)
10028
4bd2f59a 10029PROCEDURE BuildTruncFunction (Sym: CARDINAL; ConstExpr: BOOLEAN) ;
1eee94d3 10030VAR
4bd2f59a 10031 combinedtok,
1eee94d3 10032 vartok,
4bd2f59a
GM		 10033 functok : CARDINAL ;
10034 NoOfParam : CARDINAL ;
10035 ReturnVar,
1eee94d3
GM		 10036 ProcSym,
10037 Type,
4bd2f59a 10038 Var : CARDINAL ;
1eee94d3
GM		 10039BEGIN
10040 PopT (NoOfParam) ;
10041 Assert (IsTrunc (OperandT (NoOfParam+1))) ;
10042 functok := OperandTtok (NoOfParam + 1) ;
10043 IF NoOfParam = 1
10044 THEN
10045 ProcSym := RequestSym (functok, MakeKey ('CONVERT')) ;
10046 IF (ProcSym # NulSym) AND IsProcedure (ProcSym)
10047 THEN
10048 Var := OperandT (1) ;
10049 vartok := OperandTtok (1) ;
10050 Type := GetSType (Sym) ;
10051 PopN (NoOfParam + 1) ; (* destroy arguments to this function *)
4bd2f59a
GM		 10052 IF ConstExprError (Sym, Var, vartok, ConstExpr)
10053 THEN
10054 (* Generate fake result. *)
10055 combinedtok := MakeVirtual2Tok (functok, vartok) ;
10056 ReturnVar := MakeTemporary (combinedtok, AreConstant (IsConst (Var))) ;
10057 PutVar (ReturnVar, Type) ;
10058 PushTFtok (ReturnVar, Type, combinedtok)
10059 ELSIF IsVar (Var) OR IsConst (Var)
1eee94d3
GM		 10060 THEN
10061 IF IsRealType (GetSType (Var))
10062 THEN
10063 (* build macro: CONVERT( INTEGER, Var ). *)
10064 PushTFtok (ProcSym, NulSym, functok) ;
10065 PushTtok (Type, functok) ;
10066 PushTtok (Var, vartok) ;
10067 PushT (2) ; (* two parameters *)
4bd2f59a 10068 BuildConvertFunction (Convert, ConstExpr)
1eee94d3
GM		 10069 ELSE
10070 MetaErrorT1 (functok,
a6845818 10071 'argument to {%1Ead} must be a float point type', Sym) ;
1eee94d3
GM		 10072 PushTFtok (MakeConstLit (functok, MakeKey('0'), Type), Type, functok)
10073 END
10074 ELSE
029c7ebe 10075 MetaErrorT2 (vartok,
a6845818 10076 'argument to {%1Ead} must be a variable or constant, seen {%2ad}',
1eee94d3
GM		 10077 Sym, Var) ;
10078 PushTFtok (MakeConstLit (functok, MakeKey('0'), Type), Type, functok)
10079 END
10080 ELSE
10081 InternalError ('CONVERT procedure not found for TRUNC substitution')
10082 END
10083 ELSE
10084 (* we dont know the type therefore cannot fake a return. *)
10085 MetaErrorT1 (functok,
8089f26b 10086 'the pseudo builtin procedure function {%AkTRUNC} only has one parameter, seen {%1n}', NoOfParam)
1eee94d3
GM		 10087 (* non recoverable error. *)
10088 END
10089END BuildTruncFunction ;
10090
10091
10092(*
10093 BuildFloatFunction - builds the pseudo procedure call FLOAT.
10094 This procedure is actually a "macro" for
10095 FLOAT(x) --> CONVERT(REAL, x)
10096 However we cannot push tokens back onto the input stack
10097 because the compiler is currently building a function
10098 call and expecting a ReturnVar on the stack.
10099 Hence we manipulate the stack and call
10100 BuildConvertFunction.
10101
10102 The Stack:
10103
10104
10105 Entry Exit
10106
10107 Ptr ->
10108 +----------------+
10109 | NoOfParam |
10110 |----------------|
10111 | Param 1 |
10112 |----------------|
10113 | Param 2 |
10114 |----------------|
10115 . .
10116 . .
10117 . .
10118 |----------------|
10119 | Param # |
10120 |----------------|
10121 | ProcSym | Type | Empty
10122 |----------------|
10123*)
10124
4bd2f59a 10125PROCEDURE BuildFloatFunction (Sym: CARDINAL; ConstExpr: BOOLEAN) ;
1eee94d3 10126VAR
4bd2f59a 10127 combinedtok,
1eee94d3 10128 vartok,
4bd2f59a
GM		 10129 functok : CARDINAL ;
10130 NoOfParam : CARDINAL ;
10131 ReturnVar,
1eee94d3
GM		 10132 Type,
10133 Var,
4bd2f59a 10134 ProcSym : CARDINAL ;
1eee94d3
GM		 10135BEGIN
10136 PopT (NoOfParam) ;
10137 functok := OperandTtok (NoOfParam + 1) ;
10138 Type := GetSType (Sym) ;
10139 IF NoOfParam = 1
10140 THEN
10141 ProcSym := RequestSym (functok, MakeKey ('CONVERT')) ;
10142 IF (ProcSym # NulSym) AND IsProcedure (ProcSym)
10143 THEN
10144 Var := OperandT (1) ;
10145 vartok := OperandTtok (1) ;
4bd2f59a
GM		 10146 PopN (NoOfParam + 1) ; (* destroy arguments to this function. *)
10147 IF ConstExprError (Sym, Var, vartok, ConstExpr)
10148 THEN
10149 (* Generate fake result. *)
10150 combinedtok := MakeVirtual2Tok (functok, vartok) ;
10151 ReturnVar := MakeTemporary (combinedtok, AreConstant (IsConst (Var))) ;
10152 PutVar (ReturnVar, Type) ;
10153 PushTFtok (ReturnVar, Type, combinedtok)
10154 ELSIF IsVar (Var) OR IsConst (Var)
1eee94d3 10155 THEN
1eee94d3
GM		 10156 (* build macro: CONVERT (REAL, Var). *)
10157 PushTFtok (ProcSym, NulSym, functok) ;
10158 PushTtok (Type, functok) ;
10159 PushTtok (Var, vartok) ;
10160 PushT(2) ; (* two parameters. *)
4bd2f59a 10161 BuildConvertFunction (ProcSym, ConstExpr)
1eee94d3 10162 ELSE
029c7ebe 10163 MetaErrorT1 (vartok,
a6845818 10164 'argument to {%1Ead} must be a variable or constant', ProcSym) ;
1eee94d3
GM		 10165 PushTFtok (MakeConstLit (functok, MakeKey('0.0'), Type), Type, functok)
10166 END
10167 ELSE
10168 InternalError ('CONVERT procedure not found for FLOAT substitution')
10169 END
10170 ELSE
4bd2f59a 10171 PopN (NoOfParam + 1) ; (* destroy arguments to this function. *)
1eee94d3
GM		 10172 MetaErrorT1 (functok,
10173 'the builtin procedure function {%1Ead} only has one parameter',
10174 Sym) ;
10175 PushTFtok (MakeConstLit (functok, MakeKey('0.0'), Type), Type, functok)
10176 END
10177END BuildFloatFunction ;
10178
10179
10180(*
10181 BuildReFunction - builds the pseudo procedure call RE.
10182
10183 The Stack:
10184
10185
10186 Entry Exit
10187
10188 Ptr ->
10189 +----------------+
10190 | NoOfParam |
10191 |----------------|
10192 | Param 1 |
10193 |----------------|
10194 | Param 2 |
10195 |----------------|
10196 . .
10197 . .
10198 . .
10199 |----------------|
10200 | Param # |
10201 |----------------|
10202 | ProcSym | Type | Empty
10203 |----------------|
10204*)
10205
4bd2f59a 10206PROCEDURE BuildReFunction (Sym: CARDINAL; ConstExpr: BOOLEAN) ;
1eee94d3
GM		 10207VAR
10208 func,
10209 combinedtok,
10210 vartok,
10211 functok : CARDINAL ;
10212 NoOfParam : CARDINAL ;
10213 ReturnVar,
4bd2f59a 10214 Type,
1eee94d3
GM		 10215 Var : CARDINAL ;
10216BEGIN
10217 PopT (NoOfParam) ;
10218 functok := OperandTtok (NoOfParam + 1) ;
10219 func := OperandT (NoOfParam + 1) ;
10220 IF NoOfParam=1
10221 THEN
10222 Var := OperandT (1) ;
10223 vartok := OperandTok (1) ;
10224 combinedtok := MakeVirtualTok (functok, functok, vartok) ;
4bd2f59a
GM		 10225 Type := ComplexToScalar (GetDType (Var)) ;
10226 PopN (NoOfParam+1) ; (* destroy arguments to this function *)
10227 IF ConstExprError (Sym, Var, vartok, ConstExpr)
1eee94d3 10228 THEN
4bd2f59a
GM		 10229 (* Generate fake result. *)
10230 combinedtok := MakeVirtual2Tok (functok, vartok) ;
1eee94d3 10231 ReturnVar := MakeTemporary (combinedtok, AreConstant (IsConst (Var))) ;
4bd2f59a
GM		 10232 PutVar (ReturnVar, Type) ;
10233 PushTFtok (ReturnVar, Type, combinedtok)
10234 ELSIF IsVar(Var) OR IsConst(Var)
10235 THEN
10236 ReturnVar := MakeTemporary (combinedtok, AreConstant (IsConst (Var))) ;
10237 PutVar (ReturnVar, Type) ;
1eee94d3 10238 GenQuadO (combinedtok, StandardFunctionOp, ReturnVar, Re, Var, FALSE) ;
4bd2f59a 10239 PushTFtok (ReturnVar, Type, combinedtok)
1eee94d3 10240 ELSE
1eee94d3 10241 PushTFtok (MakeConstLit (combinedtok, MakeKey ('1.0'), RType), RType, combinedtok) ;
029c7ebe 10242 MetaErrorT2 (vartok,
1eee94d3
GM		 10243 'the parameter to the builtin procedure function {%1Ead} must be a constant or a variable, seen {%2ad}',
10244 func, Var)
10245 END
10246 ELSE
10247 PopN (NoOfParam+1) ; (* destroy arguments to this function *)
10248 PushTFtok (MakeConstLit (functok, MakeKey ('1.0'), RType), RType, functok) ;
10249 MetaErrorT2 (functok,
10250 'the builtin procedure function {%1Ead} only has one parameter, seen {%2n}',
10251 func, NoOfParam)
10252 END
10253END BuildReFunction ;
10254
10255
10256(*
10257 BuildImFunction - builds the pseudo procedure call IM.
10258
10259 The Stack:
10260
10261
10262 Entry Exit
10263
10264 Ptr ->
10265 +----------------+
10266 | NoOfParam |
10267 |----------------|
10268 | Param 1 |
10269 |----------------|
10270 | Param 2 |
10271 |----------------|
10272 . .
10273 . .
10274 . .
10275 |----------------|
10276 | Param # |
10277 |----------------|
10278 | ProcSym | Type | Empty
10279 |----------------|
10280*)
10281
4bd2f59a 10282PROCEDURE BuildImFunction (Sym: CARDINAL; ConstExpr: BOOLEAN) ;
1eee94d3
GM		 10283VAR
10284 func,
10285 combinedtok,
10286 vartok,
10287 functok : CARDINAL ;
10288 NoOfParam : CARDINAL ;
10289 ReturnVar,
4bd2f59a 10290 Type,
1eee94d3
GM		 10291 Var : CARDINAL ;
10292BEGIN
10293 PopT (NoOfParam) ;
10294 functok := OperandTtok (NoOfParam + 1) ;
10295 func := OperandT (NoOfParam + 1) ;
10296 IF NoOfParam=1
10297 THEN
10298 Var := OperandT (1) ;
10299 vartok := OperandTok (1) ;
4bd2f59a 10300 Type := ComplexToScalar (GetDType (Var)) ;
1eee94d3 10301 combinedtok := MakeVirtualTok (functok, functok, vartok) ;
4bd2f59a
GM		 10302 PopN (NoOfParam+1) ; (* destroy arguments to this function *)
10303 IF ConstExprError (Sym, Var, vartok, ConstExpr)
10304 THEN
10305 (* Generate fake result. *)
10306 combinedtok := MakeVirtual2Tok (functok, vartok) ;
10307 ReturnVar := MakeTemporary (combinedtok, AreConstant (IsConst (Var))) ;
10308 PutVar (ReturnVar, Type) ;
10309 PushTFtok (ReturnVar, Type, combinedtok)
10310 ELSIF IsVar(Var) OR IsConst(Var)
1eee94d3
GM		 10311 THEN
10312 ReturnVar := MakeTemporary (combinedtok, AreConstant (IsConst (Var))) ;
805be8fb 10313 PutVar (ReturnVar, ComplexToScalar (GetDType (Var))) ;
1eee94d3 10314 GenQuadO (combinedtok, StandardFunctionOp, ReturnVar, Im, Var, FALSE) ;
1eee94d3
GM		 10315 PushTFtok (ReturnVar, GetSType (ReturnVar), combinedtok)
10316 ELSE
1eee94d3 10317 PushTFtok (MakeConstLit (combinedtok, MakeKey ('1.0'), RType), RType, combinedtok) ;
029c7ebe 10318 MetaErrorT2 (vartok,
1eee94d3
GM		 10319 'the parameter to the builtin procedure function {%1Ead} must be a constant or a variable, seen {%2ad}',
10320 func, Var)
10321 END
10322 ELSE
10323 PopN (NoOfParam+1) ; (* destroy arguments to this function *)
10324 PushTFtok (MakeConstLit (functok, MakeKey ('1.0'), RType), RType, functok) ;
10325 MetaErrorT2 (functok,
10326 'the builtin procedure function {%1Ead} only has one parameter, seen {%2n}',
10327 func, NoOfParam)
10328 END
10329END BuildImFunction ;
10330
10331
10332(*
10333 BuildCmplxFunction - builds the pseudo procedure call CMPLX.
10334
10335 The Stack:
10336
10337
10338 Entry Exit
10339
10340 Ptr ->
10341 +----------------+
10342 | NoOfParam |
10343 |----------------|
10344 | Param 1 |
10345 |----------------|
10346 | Param 2 |
10347 |----------------|
10348 . .
10349 . .
10350 . .
10351 |----------------|
10352 | Param # |
10353 |----------------|
10354 | ProcSym | Type | Empty
10355 |----------------|
10356*)
10357
4bd2f59a 10358PROCEDURE BuildCmplxFunction (func: CARDINAL; ConstExpr: BOOLEAN) ;
1eee94d3 10359VAR
4bd2f59a 10360 failure : BOOLEAN ;
1eee94d3 10361 functok,
4bd2f59a 10362 rtok, ltok,
1eee94d3
GM		 10363 combinedtok: CARDINAL ;
10364 NoOfParam : CARDINAL ;
4bd2f59a 10365 type,
1eee94d3
GM		 10366 ReturnVar,
10367 l, r : CARDINAL ;
10368BEGIN
10369 PopT (NoOfParam) ;
10370 functok := OperandTtok (NoOfParam + 1) ;
1eee94d3
GM		 10371 IF NoOfParam = 2
10372 THEN
10373 l := OperandT (2) ;
4bd2f59a 10374 ltok := OperandTtok (2) ;
1eee94d3 10375 r := OperandT (1) ;
4bd2f59a
GM		 10376 rtok := OperandTtok (1) ;
10377 combinedtok := MakeVirtual2Tok (functok, rtok) ;
10378 PopN (NoOfParam+1) ; (* Destroy arguments to this function. *)
10379 type := GetCmplxReturnType (GetDType (l), GetDType (r)) ;
10380 ReturnVar := MakeTemporary (combinedtok, AreConstant (IsConst (l) AND IsConst (r))) ;
10381 PutVar (ReturnVar, type) ;
10382 failure := FALSE ;
10383 IF ConstExprError (func, l, ltok, ConstExpr)
10384 THEN
10385 (* ConstExprError has generated an error message we will fall through
10386 and check the right operand. *)
10387 failure := TRUE
10388 END ;
10389 IF ConstExprError (func, r, rtok, ConstExpr)
10390 THEN
10391 (* Right operand is in error as a variable. *)
10392 failure := TRUE
10393 END ;
10394 IF failure
10395 THEN
10396 (* Generate a fake result if either operand was a variable (and we
10397 are in a const expression). *)
10398 PushTFtok (ReturnVar, type, combinedtok)
10399 ELSIF (IsVar (l) OR IsConst (l)) AND
10400 (IsVar (r) OR IsConst (r))
1eee94d3
GM		 10401 THEN
10402 CheckExpressionCompatible (combinedtok, GetSType(l), GetSType(r)) ;
1eee94d3 10403 GenQuadO (combinedtok, StandardFunctionOp, ReturnVar, Cmplx, Make2Tuple (l, r), TRUE) ;
4bd2f59a 10404 PushTFtok (ReturnVar, type, combinedtok)
1eee94d3
GM		 10405 ELSE
10406 IF IsVar (l) OR IsConst (l)
10407 THEN
10408 MetaErrorT2 (functok,
10409 'the builtin procedure {%1Ead} requires two parameters, both must be variables or constants but the second parameter is {%2d}',
10410 func, r)
10411 ELSE
10412 MetaErrorT2 (functok,
10413 'the builtin procedure {%1Ead} requires two parameters, both must be variables or constants but the first parameter is {%2d}',
10414 func, l)
10415 END ;
1eee94d3
GM		 10416 PushTFtok (MakeConstLit (combinedtok, MakeKey ('1.0'), CType), CType, combinedtok)
10417 END
10418 ELSE
10419 MetaErrorT2 (functok,
10420 'the builtin procedure {%1Ead} requires two parameters, seen {%2n}',
10421 func, NoOfParam) ;
10422 PopN (NoOfParam + 1) ; (* destroy arguments to this function *)
10423 PushTFtok (MakeConstLit (functok, MakeKey ('1.0'), CType), CType, functok)
10424 END
10425END BuildCmplxFunction ;
10426
10427
10428(*
10429 BuildAdrFunction - builds the pseudo function ADR
10430 The Stack:
10431
10432
10433 Entry Exit
10434
10435 Ptr ->
10436 +----------------+
10437 | NoOfParam |
10438 |----------------|
10439 | Param 1 |
10440 |----------------|
10441 | Param 2 |
10442 |----------------|
10443 . .
10444 . .
10445 . .
10446 |----------------|
10447 | Param # | <- Ptr
10448 |----------------| +------------+
10449 | ProcSym | Type | | ReturnVar |
10450 |----------------| |------------|
10451
10452*)
10453
10454PROCEDURE BuildAdrFunction ;
10455VAR
10456 endtok,
10457 combinedTok,
10458 procTok,
10459 t,
10460 UnboundedSym,
10461 Dim,
10462 Field,
10463 noOfParameters,
10464 procSym,
10465 returnVar,
10466 Type, rw : CARDINAL ;
10467BEGIN
10468 DisplayStack ;
10469 PopT (noOfParameters) ;
10470 procSym := OperandT (noOfParameters + 1) ;
10471 procTok := OperandTok (noOfParameters + 1) ; (* token of procedure ADR. *)
10472 endtok := OperandTok (1) ; (* last parameter. *)
10473 combinedTok := MakeVirtualTok (procTok, procTok, endtok) ;
10474 IF noOfParameters # 1
10475 THEN
10476 MetaErrorNT0 (combinedTok,
10477 'SYSTEM procedure ADR expects 1 parameter') ;
10478 PopN (noOfParameters + 1) ; (* destroy the arguments and function *)
10479 PushTF (Nil, Address)
10480 ELSIF IsConstString (OperandT (1))
10481 THEN
10482 returnVar := MakeLeftValue (combinedTok, OperandT (1), RightValue,
10483 GetSType (procSym)) ;
10484 PopN (noOfParameters + 1) ; (* destroy the arguments and function *)
10485 PushTFtok (returnVar, GetSType (returnVar), combinedTok)
10486 ELSIF (NOT IsVar(OperandT(1))) AND (NOT IsProcedure(OperandT(1)))
10487 THEN
10488 MetaErrorNT0 (combinedTok,
10489 'SYSTEM procedure ADR expects a variable, procedure or a constant string as its parameter') ;
10490 PopN (noOfParameters + 1) ; (* destroy the arguments and function *)
10491 PushTFtok (Nil, Address, combinedTok)
10492 ELSIF IsProcedure (OperandT (1))
10493 THEN
10494 returnVar := MakeLeftValue (combinedTok, OperandT (1), RightValue,
10495 GetSType (procSym)) ;
10496 PopN (noOfParameters + 1) ; (* destroy the arguments and function *)
10497 PushTFtok (returnVar, GetSType (returnVar), combinedTok)
10498 ELSE
10499 Type := GetSType (OperandT (1)) ;
10500 Dim := OperandD (1) ;
10501 MarkArrayWritten (OperandT (1)) ;
10502 MarkArrayWritten (OperandA (1)) ;
10503 (* if the operand is an unbounded which has not been indexed
10504 then we will lookup its address from the unbounded record.
10505 Otherwise we obtain the address of the operand.
10506 *)
10507 IF IsUnbounded (Type) AND (Dim = 0)
10508 THEN
10509 (* we will reference the address field of the unbounded structure *)
10510 UnboundedSym := OperandT (1) ;
10511 rw := OperandRW (1) ;
10512 PushTFrw (UnboundedSym, GetSType (UnboundedSym), rw) ;
10513 Field := GetUnboundedAddressOffset (GetSType (UnboundedSym)) ;
10514 PushTF (Field, GetSType (Field)) ;
10515 PushT (1) ;
10516 BuildDesignatorRecord (combinedTok) ;
10517 PopTrw (returnVar, rw) ;
10518 IF GetMode (returnVar) = LeftValue
10519 THEN
10520 t := MakeTemporary (combinedTok, RightValue) ;
10521 PutVar (t, GetSType (procSym)) ;
10522 doIndrX (combinedTok, t, returnVar) ;
10523 returnVar := t
10524 ELSE
10525 (* we need to cast returnVar into ADDRESS *)
10526 t := MakeTemporary (combinedTok, RightValue) ;
10527 PutVar (t, GetSType (procSym)) ;
10528 GenQuadO (combinedTok, ConvertOp, t, GetSType (procSym), returnVar, FALSE) ;
10529 returnVar := t
10530 END
10531 ELSE
10532 returnVar := MakeTemporary (combinedTok, RightValue) ;
10533 PutVar (returnVar, GetSType (procSym)) ;
10534 IF GetMode (OperandT (1)) = LeftValue
10535 THEN
10536 PutVar (returnVar, GetSType (procSym)) ;
10537 GenQuadO (combinedTok, ConvertOp, returnVar, GetSType (procSym), OperandT (1), FALSE)
10538 ELSE
10539 GenQuadO (combinedTok, AddrOp, returnVar, NulSym, OperandT (1), FALSE)
10540 END ;
1bd13193 10541 PutWriteQuad (OperandT (1), GetMode (OperandT (1)), NextQuad-1) ;
1eee94d3
GM		 10542 rw := OperandMergeRW (1) ;
10543 Assert (IsLegal (rw))
10544 END ;
10545 PopN (noOfParameters + 1) ; (* destroy the arguments and function *)
10546 PushTFrwtok (returnVar, GetSType (returnVar), rw, combinedTok)
10547 END
10548END BuildAdrFunction ;
10549
10550
10551(*
10552 BuildSizeFunction - builds the pseudo function SIZE
10553 The Stack:
10554
10555
10556 Entry Exit
10557
10558 Ptr ->
10559 +----------------+
10560 | NoOfParam |
10561 |----------------|
10562 | Param 1 |
10563 |----------------|
10564 | Param 2 |
10565 |----------------|
10566 . .
10567 . .
10568 . .
10569 |----------------|
10570 | Param # | <- Ptr
10571 |----------------| +------------+
10572 | ProcSym | Type | | ReturnVar |
10573 |----------------| |------------|
10574*)
10575
10576PROCEDURE BuildSizeFunction ;
10577VAR
10578 resulttok,
10579 paramtok,
10580 functok : CARDINAL ;
10581 dim : CARDINAL ;
10582 Type,
10583 NoOfParam,
10584 ProcSym,
10585 ReturnVar : CARDINAL ;
10586BEGIN
10587 PopT (NoOfParam) ;
10588 ProcSym := OperandT (NoOfParam + 1) ;
10589 functok := OperandTtok (NoOfParam + 1) ;
10590 IF NoOfParam # 1
10591 THEN
10592 MetaErrorT1 (functok,
10593 '{%E} SYSTEM procedure function {%kSIZE} requires one parameter, seen {%1n}',
10594 NoOfParam) ;
10595 resulttok := functok ;
10596 ReturnVar := MakeConstLit (resulttok, MakeKey('0'), Cardinal)
10597 ELSIF IsAModula2Type (OperandT (1))
10598 THEN
10599 paramtok := OperandTok (1) ;
10600 resulttok := MakeVirtualTok (functok, functok, paramtok) ;
8089f26b 10601 BuildSizeCheckEnd (ProcSym) ; (* Quadruple generation now on. *)
1eee94d3
GM		 10602 ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
10603 GenQuadO (resulttok, SizeOp, ReturnVar, NulSym, OperandT(1), TRUE)
10604 ELSIF IsVar (OperandT (1))
10605 THEN
8089f26b 10606 BuildSizeCheckEnd (ProcSym) ; (* Quadruple generation now on. *)
1eee94d3
GM		 10607 Type := GetSType (OperandT (1)) ;
10608 paramtok := OperandTok (1) ;
10609 resulttok := MakeVirtualTok (functok, functok, paramtok) ;
10610 IF IsUnbounded (Type)
10611 THEN
8089f26b 10612 (* Eg. SIZE(a) ; where a is unbounded dereference HIGH and multiply by the TYPE. *)
1eee94d3
GM		 10613 dim := OperandD (1) ;
10614 IF dim = 0
10615 THEN
10616 ReturnVar := calculateMultipicand (resulttok, OperandT (1), Type, dim)
10617 ELSE
10618 ReturnVar := calculateMultipicand (resulttok, OperandA (1), Type, dim)
10619 END
10620 ELSE
10621 ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
10622 IF Type = NulSym
10623 THEN
10624 MetaErrorT1 (resulttok,
c980eeb8 10625 'cannot get the type and size of {%1Ead}', OperandT (1))
1eee94d3
GM		 10626 END ;
10627 GenQuadO (resulttok, SizeOp, ReturnVar, NulSym, Type, TRUE)
10628 END
10629 ELSE
10630 resulttok := functok ;
10631 MetaErrorT1 (resulttok,
c980eeb8 10632 '{%E}SYSTEM procedure {%kSIZE} expects a variable as its parameter, seen {%1Ed}',
1eee94d3
GM		 10633 OperandT (1)) ;
10634 ReturnVar := MakeConstLit (resulttok, MakeKey('0'), Cardinal)
10635 END ;
8089f26b 10636 PopN (NoOfParam+1) ; (* Destroy the arguments and function. *)
1eee94d3
GM		 10637 PushTFtok (ReturnVar, GetSType(ProcSym), resulttok)
10638END BuildSizeFunction ;
10639
10640
10641(*
10642 BuildTSizeFunction - builds the pseudo function TSIZE
10643 The Stack:
10644
10645
10646 Entry Exit
10647
10648 Ptr ->
10649 +----------------+
10650 | NoOfParam |
10651 |----------------|
10652 | Param 1 |
10653 |----------------|
10654 | Param 2 |
10655 |----------------|
10656 . .
10657 . .
10658 . .
10659 |----------------|
10660 | Param # | <- Ptr
10661 |----------------| +------------+
10662 | ProcSym | Type | | ReturnVar |
10663 |----------------| |------------|
10664
10665*)
10666
10667PROCEDURE BuildTSizeFunction ;
10668VAR
10669 resulttok,
10670 paramtok,
10671 functok : CARDINAL ;
10672 NoOfParam: CARDINAL ;
10673 ProcSym,
10674 Record,
10675 ReturnVar: CARDINAL ;
10676BEGIN
10677 PopT (NoOfParam) ;
10678 ProcSym := OperandT (NoOfParam + 1) ;
10679 functok := OperandTtok (NoOfParam) ;
10680 BuildSizeCheckEnd (ProcSym) ; (* quadruple generation now on *)
10681 IF NoOfParam = 1
10682 THEN
10683 paramtok := OperandTtok (1) ;
10684 resulttok := MakeVirtualTok (functok, functok, paramtok) ;
10685 IF IsAModula2Type (OperandT (1))
10686 THEN
10687 ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
64b0130b 10688 PutVar (ReturnVar, Cardinal) ;
1eee94d3
GM		 10689 GenQuadO (resulttok, SizeOp, ReturnVar, NulSym, OperandT (1), FALSE)
10690 ELSIF IsVar (OperandT (1))
10691 THEN
10692 ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
64b0130b 10693 PutVar (ReturnVar, Cardinal) ;
1eee94d3
GM		 10694 GenQuadO (resulttok, SizeOp, ReturnVar, NulSym, GetSType (OperandT (1)), FALSE)
10695 ELSE
10696 MetaErrorT1 (resulttok,
c980eeb8 10697 '{%E}SYSTEM procedure function {%kTSIZE} expects a variable as its first parameter, seen {%1Ed}',
1eee94d3
GM		 10698 OperandT (1)) ;
10699 ReturnVar := MakeConstLit (resulttok, MakeKey ('0'), Cardinal)
10700 END
10701 ELSIF NoOfParam = 0
10702 THEN
10703 resulttok := functok ;
10704 MetaErrorT0 (resulttok,
10705 '{%E}SYSTEM procedure function {%kTSIZE} expects either one or two parameters, seen none') ;
10706 ReturnVar := MakeConstLit (resulttok, MakeKey ('0'), Cardinal)
10707 ELSE
10708 Record := OperandT (NoOfParam) ;
10709 paramtok := OperandTtok (1) ;
10710 resulttok := OperandTtok (NoOfParam) ;
10711 IF IsRecord (Record)
10712 THEN
10713 paramtok := OperandTtok (1) ;
10714 resulttok := MakeVirtualTok (functok, functok, paramtok) ;
10715 ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
64b0130b 10716 PutVar (ReturnVar, Cardinal) ;
1eee94d3
GM		 10717 GenQuadO (resulttok, SizeOp, ReturnVar, NulSym, Record, FALSE)
10718 ELSE
10719 resulttok := MakeVirtualTok (functok, functok, paramtok) ;
10720 MetaErrorT1 (resulttok,
c980eeb8 10721 '{%E}SYSTEM procedure function {%kTSIZE} expects the first parameter to be a record type, seen {%1d}',
1eee94d3
GM		 10722 Record) ;
10723 ReturnVar := MakeConstLit (resulttok, MakeKey ('0'), Cardinal)
10724 END
10725 END ;
10726 PopN (NoOfParam+1) ; (* destroy the arguments and function *)
10727 PushTFtok (ReturnVar, GetSType (ProcSym), resulttok)
10728END BuildTSizeFunction ;
10729
10730
10731(*
10732 BuildTBitSizeFunction - builds the pseudo function TBITSIZE
10733 The Stack:
10734
10735
10736 Entry Exit
10737
10738 Ptr ->
10739 +----------------+
10740 | NoOfParam |
10741 |----------------|
10742 | Param 1 |
10743 |----------------|
10744 | Param 2 |
10745 |----------------|
10746 . .
10747 . .
10748 . .
10749 |----------------|
10750 | Param # | <- Ptr
10751 |----------------| +------------+
10752 | ProcSym | Type | | ReturnVar |
10753 |----------------| |------------|
10754
10755*)
10756
10757PROCEDURE BuildTBitSizeFunction ;
10758VAR
10759 resulttok,
10760 paramtok,
10761 functok : CARDINAL ;
10762 NoOfParam: CARDINAL ;
10763 ProcSym,
10764 Record,
10765 ReturnVar: CARDINAL ;
10766BEGIN
10767 PopT (NoOfParam) ;
10768 ProcSym := OperandT (NoOfParam + 1) ;
10769 functok := OperandTtok (NoOfParam) ;
10770 BuildSizeCheckEnd (ProcSym) ; (* quadruple generation now on *)
10771 IF NoOfParam = 1
10772 THEN
10773 paramtok := OperandTtok (1) ;
10774 resulttok := MakeVirtualTok (functok, functok, paramtok) ;
10775 IF IsAModula2Type (OperandT (1))
10776 THEN
10777 ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
10778 GenQuadO (resulttok, StandardFunctionOp, ReturnVar, ProcSym, OperandT (1), FALSE)
10779 ELSIF IsVar (OperandT (1))
10780 THEN
10781 ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
10782 GenQuadO (resulttok, StandardFunctionOp, ReturnVar, ProcSym, OperandT(1), FALSE)
10783 ELSE
10784 MetaErrorT1 (resulttok,
c980eeb8 10785 '{%E}SYSTEM procedure function {%kTBITSIZE} expects a variable as its first parameter, seen {%1d}',
1eee94d3
GM		 10786 OperandT (1)) ;
10787 ReturnVar := MakeConstLit (resulttok, MakeKey ('0'), Cardinal)
10788 END
10789 ELSIF NoOfParam = 0
10790 THEN
10791 resulttok := functok ;
10792 MetaErrorT0 (functok,
10793 '{%E}SYSTEM procedure function {%kTBITSIZE} expects either one or two parameters, seen none') ;
10794 ReturnVar := MakeConstLit (functok, MakeKey ('0'), Cardinal)
10795 ELSE
10796 Record := OperandT (NoOfParam) ;
10797 paramtok := OperandTtok (1) ;
10798 resulttok := OperandTtok (NoOfParam) ;
10799 IF IsRecord (Record)
10800 THEN
10801 paramtok := OperandTtok (1) ;
10802 resulttok := MakeVirtualTok (functok, functok, paramtok) ;
10803 ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
10804 GenQuad(StandardFunctionOp, ReturnVar, ProcSym, OperandT(1)) ;
10805 ELSE
10806 resulttok := MakeVirtualTok (functok, functok, paramtok) ;
10807 MetaErrorT1 (resulttok,
c980eeb8 10808 '{%E}SYSTEM procedure function {%kTBITSIZE} expects the first parameter to be a record type, seen {%1d}',
1eee94d3
GM		 10809 Record) ;
10810 ReturnVar := MakeConstLit (resulttok, MakeKey ('0'), Cardinal)
10811 END
10812 END ;
10813 PopN (NoOfParam + 1) ; (* destroy the arguments and function *)
10814 PushTFtok (ReturnVar, GetSType (ProcSym), resulttok)
10815END BuildTBitSizeFunction ;
10816
10817
10818(*
10819 ExpectingParameterType -
10820*)
10821
10822PROCEDURE ExpectingParameterType (BlockSym, Type: CARDINAL) ;
10823BEGIN
10824 IF NOT IsAModula2Type (Type)
10825 THEN
10826 IF (Type = NulSym) OR IsPartialUnbounded (Type) OR IsUnknown (Type)
10827 THEN
10828 MetaError1 ('the type used in the formal parameter declaration in {%1Md} {%1a} is unknown',
10829 BlockSym)
10830 ELSE
10831 MetaError2 ('the type {%1Ead} used in the formal parameter declaration in {%2Md} {%2a} was not declared as a type',
10832 Type, BlockSym)
10833 END
10834 END
10835END ExpectingParameterType ;
10836
10837
10838(*
10839 ExpectingVariableType -
10840*)
10841
10842PROCEDURE ExpectingVariableType (BlockSym, Type: CARDINAL) ;
10843BEGIN
10844 IF NOT IsAModula2Type(Type)
10845 THEN
10846 IF Type=NulSym
10847 THEN
10848 MetaError1 ('the type used during the variable declaration section in procedure {%1EMad} is unknown',
10849 BlockSym) ;
10850 MetaError1 ('the type used during the variable declaration section in procedure {%1Ead} is unknown',
10851 BlockSym)
10852 ELSIF IsPartialUnbounded(Type) OR IsUnknown(Type)
10853 THEN
10854 MetaError2 ('the type {%1EMad} used during variable declaration section in procedure {%2ad} is unknown',
10855 Type, BlockSym) ;
10856 MetaError2 ('the type {%1Ead} used during variable declaration section in procedure {%2Mad} is unknown',
10857 Type, BlockSym)
10858 ELSE
10859 MetaError2 ('the {%1d} {%1Ea} is not a type and therefore cannot be used to declare a variable in {%2d} {%2a}',
10860 Type, BlockSym)
10861 END
10862 END
10863END ExpectingVariableType ;
10864
10865
10866(*
10867 CheckVariablesAndParameterTypesInBlock - checks to make sure that block, BlockSym, has
10868 parameters types and variable types which are legal.
10869*)
10870
10871PROCEDURE CheckVariablesAndParameterTypesInBlock (BlockSym: CARDINAL) ;
10872VAR
10873 i, n,
10874 ParamNo: CARDINAL ;
10875BEGIN
10876 IF IsProcedure(BlockSym)
10877 THEN
10878 ParamNo := NoOfParam(BlockSym)
10879 ELSE
10880 ParamNo := 0
10881 END ;
10882 i := 1 ;
10883 REPEAT
10884 n := GetNth(BlockSym, i) ;
10885 IF (n#NulSym) AND (NOT IsTemporary(n)) AND
10886 (IsProcedure(BlockSym) OR ((IsDefImp(BlockSym) AND (GetMainModule()=BlockSym)) OR IsModule(BlockSym)))
10887 THEN
10888 IF i<=ParamNo
10889 THEN
10890 (* n is a parameter *)
10891 ExpectingParameterType(BlockSym, GetSType(n))
10892 ELSE
10893 (* n is a local variable *)
10894 ExpectingVariableType(BlockSym, GetSType(n))
10895 END
10896 END ;
10897 INC(i)
10898 UNTIL n=NulSym ;
10899END CheckVariablesAndParameterTypesInBlock ;
10900
10901
10902(*
10903 BuildProcedureStart - Builds start of the procedure. Generates a
10904 quadruple which indicated the start of
10905 this procedure declarations scope.
10906 The Stack is expected to contain:
10907
10908
10909 Entry Exit
10910 ===== ====
10911
10912 Ptr -> <- Ptr
10913 +------------+ +-----------+
10914 | ProcSym | | ProcSym |
10915 |------------| |-----------|
10916 | Name | | Name |
10917 |------------| |-----------|
10918
10919
10920 Quadruples:
10921
10922 q ProcedureScopeOp Line# Scope ProcSym
10923*)
10924
10925PROCEDURE BuildProcedureStart ;
10926VAR
10927 ProcSym: CARDINAL ;
10928BEGIN
10929 PopT(ProcSym) ;
10930 Assert(IsProcedure(ProcSym)) ;
10931 PutProcedureScopeQuad(ProcSym, NextQuad) ;
10932 GenQuad(ProcedureScopeOp, GetPreviousTokenLineNo(), GetScope(ProcSym), ProcSym) ;
10933 PushT(ProcSym)
10934END BuildProcedureStart ;
10935
10936
10937(*
10938 BuildProcedureBegin - determines the start of the BEGIN END block of
10939 the procedure.
10940 The Stack is expected to contain:
10941
10942
10943 Entry Exit
10944 ===== ====
10945
10946 Ptr -> <- Ptr
10947 +------------+ +-----------+
10948 | ProcSym | | ProcSym |
10949 |------------| |-----------|
10950 | Name | | Name |
10951 |------------| |-----------|
10952
10953
10954 Quadruples:
10955
10956 q NewLocalVarOp TokenNo(BEGIN) _ ProcSym
10957*)
10958
10959PROCEDURE BuildProcedureBegin ;
10960VAR
10961 ProcSym: CARDINAL ;
10962BEGIN
10963 PopT(ProcSym) ;
10964 Assert(IsProcedure(ProcSym)) ;
10965 PutProcedureStartQuad(ProcSym, NextQuad) ;
10966 PutProcedureBegin(ProcSym, GetTokenNo()) ;
10967 GenQuad(NewLocalVarOp, GetTokenNo(), GetScope(ProcSym), ProcSym) ;
10968 CurrentProc := ProcSym ;
10969 PushWord(ReturnStack, 0) ;
10970 PushT(ProcSym) ;
10971 CheckVariablesAt(ProcSym) ;
10972 CheckNeedPriorityBegin(GetTokenNo(), ProcSym, GetCurrentModule()) ;
10973 PushWord(TryStack, NextQuad) ;
10974 PushWord(CatchStack, 0) ;
10975 IF HasExceptionBlock(ProcSym)
10976 THEN
10977 GenQuad(TryOp, NulSym, NulSym, 0)
10978 END
10979END BuildProcedureBegin ;
10980
10981
10982(*
10983 BuildProcedureEnd - Builds end of the procedure. Destroys space for
10984 the local variables.
10985 The Stack is expected to contain:
10986
10987
10988 Entry Exit
10989 ===== ====
10990
10991 Ptr -> <- Ptr
10992 +------------+ +-----------+
10993 | ProcSym | | ProcSym |
10994 |------------| |-----------|
10995 | Name | | Name |
10996 |------------| |-----------|
10997
10998
10999 Quadruples:
11000
11001 q KillLocalVarOp TokenNo(END) _ ProcSym
11002*)
11003
11004PROCEDURE BuildProcedureEnd ;
11005VAR
11006 tok : CARDINAL ;
11007 ProcSym: CARDINAL ;
11008BEGIN
11009 PopTtok(ProcSym, tok) ;
11010 IF HasExceptionBlock(ProcSym)
11011 THEN
11012 BuildRTExceptLeave(tok, TRUE) ;
11013 GenQuad(CatchEndOp, NulSym, NulSym, NulSym)
11014 END ;
11015 IF GetSType(ProcSym)#NulSym
11016 THEN
11017 BuildError(InitNoReturnRangeCheck())
11018 END ;
11019 BackPatch(PopWord(ReturnStack), NextQuad) ;
11020 CheckNeedPriorityEnd(tok, ProcSym, GetCurrentModule()) ;
11021 CurrentProc := NulSym ;
11022 PutProcedureEnd(ProcSym, GetTokenNo()-1) ; (* --fixme-- *)
11023 GenQuad(KillLocalVarOp, GetTokenNo()-1, NulSym, ProcSym) ;
11024 PutProcedureEndQuad(ProcSym, NextQuad) ;
11025 GenQuad(ReturnOp, NulSym, NulSym, ProcSym) ;
11026 CheckFunctionReturn(ProcSym) ;
11027 CheckVariablesInBlock(ProcSym) ;
11028 RemoveTop (CatchStack) ;
11029 RemoveTop (TryStack) ;
11030 PushT(ProcSym)
11031END BuildProcedureEnd ;
11032
11033
1eee94d3
GM		 11034(*
11035 IsNeverAltered - returns TRUE if variable, sym, is never altered
11036 between quadruples: Start..End
11037*)
11038
11039PROCEDURE IsNeverAltered (sym: CARDINAL; Start, End: CARDINAL) : BOOLEAN ;
11040VAR
11041 WriteStart, WriteEnd: CARDINAL ;
11042BEGIN
b0762d4c
GM		 11043 GetWriteLimitQuads (sym, GetMode (sym), Start, End, WriteStart, WriteEnd) ;
11044 RETURN( (WriteStart = 0) AND (WriteEnd = 0) )
1eee94d3
GM		 11045END IsNeverAltered ;
11046
11047
11048(*
11049 IsConditionVariable - returns TRUE if the condition at quadruple, q, is variable.
11050*)
11051
11052PROCEDURE IsConditionVariable (q: CARDINAL; Start, End: CARDINAL) : BOOLEAN ;
11053VAR
11054 op : QuadOperator ;
11055 op1, op2, op3: CARDINAL ;
11056 LeftFixed,
11057 RightFixed : BOOLEAN ;
11058BEGIN
b0762d4c
GM		 11059 GetQuad (q, op, op1, op2, op3) ;
11060 IF op = GotoOp
1eee94d3
GM		 11061 THEN
11062 RETURN( FALSE )
11063 ELSE
11064 LeftFixed := IsConst(op1) ;
11065 RightFixed := IsConst(op2) ;
11066 IF NOT LeftFixed
11067 THEN
11068 LeftFixed := IsNeverAltered(op1, Start, End)
11069 END ;
11070 IF NOT RightFixed
11071 THEN
11072 RightFixed := IsNeverAltered(op2, Start, End)
11073 END ;
11074 RETURN( NOT (LeftFixed AND RightFixed) )
11075 END
11076END IsConditionVariable ;
11077
11078
11079(*
11080 IsInfiniteLoop - returns TRUE if an infinite loop is found.
11081 Given a backwards jump at, End, it returns a BOOLEAN which depends on
11082 whether a jump is found to jump beyond, End. If a conditonal jump is found
11083 to pass over, End, the condition is tested for global variables, procedure variables and
11084 constants.
11085
11086 constant - ignored
11087 variables - tested to see whether they are altered inside the loop
11088 global variable - the procedure tests to see whether it is altered as above
11089 but will also test to see whether this loop calls a procedure
11090 in which case it believes the loop NOT to be infinite
11091 (as this procedure call might alter the global variable)
11092
11093 Note that this procedure can easily be fooled by the user altering variables
11094 with pointers.
11095*)
11096
11097PROCEDURE IsInfiniteLoop (End: CARDINAL) : BOOLEAN ;
11098VAR
11099 SeenCall,
11100 IsGlobal : BOOLEAN ;
11101 Current,
11102 Start : CARDINAL ;
11103 op : QuadOperator ;
11104 op1, op2, op3: CARDINAL ;
11105BEGIN
11106 SeenCall := FALSE ;
11107 IsGlobal := FALSE ;
11108 GetQuad(End, op, op1, op2, Start) ;
11109 Current := Start ;
11110 WHILE Current#End DO
11111 GetQuad(Current, op, op1, op2, op3) ;
11112 (* remember that this function is only called once we have optimized the redundant gotos and conditionals *)
11113 IF IsConditional(Current) AND (NOT IsGlobal)
11114 THEN
11115 IsGlobal := (IsVar(op1) AND (NOT IsProcedure(GetVarScope(op1)))) OR
11116 (IsVar(op2) AND (NOT IsProcedure(GetVarScope(op2))))
11117 END ;
11118 IF op=CallOp
11119 THEN
11120 SeenCall := TRUE
11121 END ;
11122 IF (op=GotoOp) OR (IsConditional(Current) AND IsConditionVariable(Current, Start, End))
11123 THEN
11124 IF (op3>End) OR (op3<Start)
11125 THEN
11126 RETURN( FALSE ) (* may jump out of this loop, good *)
11127 END
11128 END ;
11129 Current := GetNextQuad(Current)
11130 END ;
11131 GetQuad(End, op, op1, op2, op3) ;
11132 IF IsConditional(End)
11133 THEN
11134 IF IsConditionVariable(End, Start, End)
11135 THEN
11136 RETURN( FALSE )
11137 ELSE
11138 IF NOT IsGlobal
11139 THEN
11140 IsGlobal := (IsVar(op1) AND (NOT IsProcedure(GetVarScope(op1)))) OR
11141 (IsVar(op2) AND (NOT IsProcedure(GetVarScope(op2))))
11142 END
11143 END
11144 END ;
11145 (* we have found a likely infinite loop if no conditional uses a global and no procedure call was seen *)
11146 RETURN( NOT (IsGlobal AND SeenCall) )
11147END IsInfiniteLoop ;
11148
11149
11150(*
11151 LoopAnalysis - checks whether an infinite loop exists.
11152*)
11153
40b91158 11154PROCEDURE LoopAnalysis (Scope: CARDINAL; Current, End: CARDINAL) ;
1eee94d3
GM		 11155VAR
11156 op : QuadOperator ;
11157 op1, op2, op3: CARDINAL ;
11158BEGIN
11159 IF Pedantic
11160 THEN
11161 WHILE (Current<=End) AND (Current#0) DO
11162 GetQuad(Current, op, op1, op2, op3) ;
11163 IF (op=GotoOp) OR IsConditional(Current)
11164 THEN
11165 IF op3<=Current
11166 THEN
11167 (* found a loop - ie a branch which goes back in quadruple numbers *)
11168 IF IsInfiniteLoop(Current)
11169 THEN
40b91158
GM		 11170 MetaErrorT1 (QuadToTokenNo(op3),
11171 'it is very likely (although not absolutely certain) that the top of an infinite loop exists here in {%1Wad}',
11172 Scope) ;
11173 MetaErrorT1 (QuadToTokenNo(Current),
11174 'and the bottom of the infinite loop is ends here in {%1Wad} or alternatively a component of this loop is never executed',
11175 Scope) ;
11176(*
1eee94d3
GM		 11177 WarnStringAt(InitString('it is very likely (although not absolutely certain) that the top of an infinite loop is here'),
11178 QuadToTokenNo(op3)) ;
11179 WarnStringAt(InitString('and the bottom of the infinite loop is ends here or alternatively a component of this loop is never executed'),
11180 QuadToTokenNo(Current))
40b91158 11181*)
1eee94d3
GM		 11182 END
11183 END
11184 END ;
11185 Current := GetNextQuad(Current)
11186 END
11187 END
11188END LoopAnalysis ;
11189
11190
1eee94d3
GM		 11191(*
11192 CheckVariablesInBlock - given a block, BlockSym, check whether all variables are used.
11193*)
11194
11195PROCEDURE CheckVariablesInBlock (BlockSym: CARDINAL) ;
11196BEGIN
89b58667 11197 CheckVariablesAndParameterTypesInBlock (BlockSym)
1eee94d3
GM		 11198END CheckVariablesInBlock ;
11199
11200
11201(*
11202 CheckFunctionReturn - checks to see that a RETURN statement was present in a function.
11203*)
11204
11205PROCEDURE CheckFunctionReturn (ProcSym: CARDINAL) ;
11206VAR
11207 Op : QuadOperator ;
11208 Op1, Op2, Op3,
11209 Scope,
11210 Start, End : CARDINAL ;
11211BEGIN
11212 IF GetSType(ProcSym)#NulSym
11213 THEN
11214 (* yes it is a function *)
11215 GetProcedureQuads(ProcSym, Scope, Start, End) ;
11216 GetQuad(Start, Op, Op1, Op2, Op3) ;
11217 IF Start=0
11218 THEN
11219 InternalError ('incorrect start quad')
11220 END ;
11221 WHILE (Start#End) AND (Op#ReturnValueOp) AND (Op#InlineOp) DO
11222 Start := GetNextQuad(Start) ;
11223 GetQuad(Start, Op, Op1, Op2, Op3)
11224 END ;
11225 IF (Op#ReturnValueOp) AND (Op#InlineOp)
11226 THEN
11227 (* an InlineOp can always be used to emulate a RETURN *)
11228 MetaError1 ('procedure function {%1Ea} does not RETURN a value', ProcSym)
11229 END
11230 END
11231END CheckFunctionReturn ;
11232
11233
11234(*
11235 CheckReturnType - checks to see that the return type from currentProc is
11236 assignment compatible with actualType.
11237*)
11238
11239PROCEDURE CheckReturnType (tokno: CARDINAL; currentProc, actualVal, actualType: CARDINAL) ;
11240VAR
11241 procType: CARDINAL ;
11242 s1, s2 : String ;
11243 n1, n2 : Name ;
11244BEGIN
11245 procType := GetSType (currentProc) ;
11246 IF procType = NulSym
11247 THEN
11248 MetaError1 ('attempting to RETURN a value from procedure {%1Ea} which was not a declared as a procedure function', currentProc)
11249 ELSIF AssignmentRequiresWarning (actualType, GetSType (currentProc))
11250 THEN
11251 MetaError2 ('attempting to RETURN a value {%1Wa} with an incompatible type {%1Wtsa} from a procedure function {%1a} which returns {%1tsa}', actualVal, currentProc)
11252 ELSIF NOT IsAssignmentCompatible (actualType, procType)
11253 THEN
11254 n1 := GetSymName(actualType) ;
11255 n2 := GetSymName(procType) ;
11256 WriteFormat2('attempting to RETURN a value with an incompatible type (%a) from a function which returns (%a)',
11257 n1, n2)
11258 ELSIF IsProcedure(actualVal) AND (NOT IsAssignmentCompatible(actualVal, procType))
11259 THEN
11260(*
11261 MetaWarnings2('attempting to RETURN a value with an incompatible type {%1ad} from function {%2a} which returns {%2ta}',
11262 actualVal, currentProc)
11263
11264 --fixme-- introduce MetaWarning, MetaWarning2, MetaWarning3 into M2MetaError
11265*)
11266 s1 := InitStringCharStar(KeyToCharStar(GetSymName(actualVal))) ;
11267 s2 := InitStringCharStar(KeyToCharStar(GetSymName(procType))) ;
11268 ErrorString(NewWarning(GetTokenNo()),
11269 Sprintf2(Mark(InitString('attempting to RETURN a value with a (possibly on other targets) incompatible type (%s) from a function which returns (%s)')),
11270 s1, s2))
11271 ELSIF IsProcedure(actualVal) AND (NOT IsAssignmentCompatible(actualVal, GetSType(CurrentProc)))
11272 THEN
11273 n1 := GetSymName(actualVal) ;
11274 n2 := GetSymName(GetSType(currentProc)) ;
11275 WriteFormat2('attempting to RETURN a value with an incompatible type (%a) from a function which returns (%a)',
11276 n1, n2)
11277 ELSE
11278 (* this checks the types are compatible, not the data contents. *)
11279 BuildRange (InitTypesAssignmentCheck (tokno, currentProc, actualVal))
11280 END
11281END CheckReturnType ;
11282
11283
11284(*
11285 BuildReturn - Builds the Return part of the procedure.
c787f593 11286 tokreturn is the location of the RETURN keyword.
1eee94d3
GM		 11287 The Stack is expected to contain:
11288
11289
11290 Entry Exit
11291 ===== ====
11292
11293 Ptr ->
11294 +------------+
11295 | e1 | Empty
11296 |------------|
11297*)
11298
c787f593 11299PROCEDURE BuildReturn (tokreturn: CARDINAL) ;
1eee94d3 11300VAR
c787f593
GM		 11301 tokcombined,
11302 tokexpr : CARDINAL ;
1eee94d3
GM		 11303 e2, t2,
11304 e1, t1,
11305 t, f,
c787f593 11306 Des : CARDINAL ;
1eee94d3
GM		 11307BEGIN
11308 IF IsBoolean (1)
11309 THEN
c787f593 11310 PopBooltok (t, f, tokexpr) ;
1eee94d3 11311 (* Des will be a boolean type *)
c787f593 11312 Des := MakeTemporary (tokexpr, RightValue) ;
1eee94d3 11313 PutVar (Des, Boolean) ;
c787f593
GM		 11314 PushTFtok (Des, Boolean, tokexpr) ;
11315 PushBooltok (t, f, tokexpr) ;
11316 BuildAssignmentWithoutBounds (tokreturn, FALSE, TRUE) ;
11317 PushTFtok (Des, Boolean, tokexpr)
1eee94d3 11318 END ;
c787f593
GM		 11319 PopTFtok (e1, t1, tokexpr) ;
11320 tokcombined := MakeVirtualTok (tokreturn, tokreturn, tokexpr) ;
1eee94d3
GM		 11321 IF e1 # NulSym
11322 THEN
11323 (* this will check that the type returned is compatible with
11324 the formal return type of the procedure. *)
c787f593 11325 CheckReturnType (tokcombined, CurrentProc, e1, t1) ;
1eee94d3
GM		 11326 (* dereference LeftValue if necessary *)
11327 IF GetMode (e1) = LeftValue
11328 THEN
11329 t2 := GetSType (CurrentProc) ;
c787f593 11330 e2 := MakeTemporary (tokexpr, RightValue) ;
1eee94d3 11331 PutVar(e2, t2) ;
c787f593
GM		 11332 CheckPointerThroughNil (tokexpr, e1) ;
11333 doIndrX (tokexpr, e2, e1) ;
1eee94d3 11334 (* here we check the data contents to ensure no overflow. *)
c787f593
GM		 11335 BuildRange (InitReturnRangeCheck (tokcombined, CurrentProc, e2)) ;
11336 GenQuadOtok (tokcombined, ReturnValueOp, e2, NulSym, CurrentProc, FALSE,
11337 tokcombined, UnknownTokenNo, GetDeclaredMod (CurrentProc))
1eee94d3
GM		 11338 ELSE
11339 (* here we check the data contents to ensure no overflow. *)
c787f593
GM		 11340 BuildRange (InitReturnRangeCheck (tokcombined, CurrentProc, e1)) ;
11341 GenQuadOtok (tokcombined, ReturnValueOp, e1, NulSym, CurrentProc, FALSE,
11342 tokcombined, UnknownTokenNo, GetDeclaredMod (CurrentProc))
1eee94d3
GM		 11343 END
11344 END ;
c787f593 11345 GenQuadO (tokcombined, GotoOp, NulSym, NulSym, PopWord (ReturnStack), FALSE) ;
1eee94d3
GM		 11346 PushWord (ReturnStack, NextQuad-1)
11347END BuildReturn ;
11348
11349
11350(*
11351 IsReadOnly - a helper procedure function to detect constants.
11352*)
11353
11354PROCEDURE IsReadOnly (sym: CARDINAL) : BOOLEAN ;
11355BEGIN
11356 RETURN IsConst (sym) OR (IsVar (sym) AND IsVarConst (sym))
11357END IsReadOnly ;
11358
11359
11360(*
11361 BuildDesignatorRecord - Builds the record referencing.
11362 The Stack is expected to contain:
11363
11364
11365 Entry Exit
11366 ===== ====
11367
11368 Ptr ->
11369 +--------------+
11370 | n |
11371 |--------------|
11372 | fld1 | type1 |
11373 |--------------|
11374 . .
11375 . .
11376 . .
11377 |--------------|
11378 | fldn | typen | <- Ptr
11379 |--------------| +-------------+
11380 | Sym | Type | | S | type1|
11381 |--------------| |-------------|
11382*)
11383
11384PROCEDURE BuildDesignatorRecord (dottok: CARDINAL) ;
11385VAR
11386 RecordTok,
11387 FieldTok,
11388 combinedtok: CARDINAL ;
11389 n, rw,
11390 Field,
11391 FieldType,
11392 RecordSym,
11393 Res : CARDINAL ;
11394BEGIN
11395 PopT(n) ;
11396 RecordSym := OperandT (n+1) ;
11397 (* RecordType could be found by: SkipType (OperandF (n+1)). *)
11398 RecordTok := OperandTok (n+1) ;
11399 rw := OperandMergeRW (n+1) ;
11400 Assert (IsLegal (rw)) ;
11401 Field := OperandT (n) ;
11402 FieldType := SkipType (OperandF (n)) ;
11403 FieldTok := OperandTok (n) ;
11404 combinedtok := MakeVirtualTok (dottok, RecordTok, FieldTok) ;
11405 IF n>1
11406 THEN
11407 InternalError ('not expecting to see n>1')
11408 END ;
11409 IF IsUnused (Field)
11410 THEN
11411 MetaErrors1 ('record field {%1Dad} was declared as unused by a pragma',
11412 'record field {%1ad} is being used after being declared as unused by a pragma', Field)
11413 END ;
11414 Res := MakeComponentRef (MakeComponentRecord (combinedtok,
11415 RightValue, RecordSym), Field) ;
11416 PutVarConst (Res, IsReadOnly (RecordSym)) ;
11417 GenQuadO (combinedtok, RecordFieldOp, Res, RecordSym, Field, FALSE) ;
11418 PopN (n+1) ;
11419 PushTFrwtok (Res, FieldType, rw, combinedtok)
11420END BuildDesignatorRecord ;
11421
11422
11423(*
11424 BuildDesignatorError - removes the designator from the stack and replaces
11425 it with an error symbol.
11426*)
11427
11428PROCEDURE BuildDesignatorError (message: ARRAY OF CHAR) ;
11429VAR
11430 combinedTok,
11431 arrayTok,
11432 exprTok : CARDINAL ;
11433 e, d, error,
11434 Sym,
11435 Type : CARDINAL ;
11436BEGIN
11437 PopTtok (e, exprTok) ;
11438 PopTFDtok (Sym, Type, d, arrayTok) ;
11439 combinedTok := MakeVirtualTok (arrayTok, arrayTok, exprTok) ;
11440 error := MakeError (combinedTok, MakeKey (message)) ;
11441 PushTFDtok (error, Type, d, arrayTok)
11442END BuildDesignatorError ;
11443
11444
11445
11446(*
11447 BuildDesignatorArray - Builds the array referencing.
11448 The purpose of this procedure is to work out
11449 whether the DesignatorArray is a static or
11450 dynamic array and to call the appropriate
11451 BuildRoutine.
11452
11453 The Stack is expected to contain:
11454
11455
11456 Entry Exit
11457 ===== ====
11458
11459 Ptr ->
11460 +--------------+
11461 | e | <- Ptr
11462 |--------------| +------------+
11463 | Sym | Type | | S | T |
11464 |--------------| |------------|
11465*)
11466
11467PROCEDURE BuildDesignatorArray ;
11468VAR
11469 combinedTok,
11470 arrayTok,
8a47474f
GM		 11471 exprTok : CARDINAL ;
11472 e, type, dim,
11473 result,
1eee94d3 11474 Sym,
8a47474f 11475 Type : CARDINAL ;
1eee94d3 11476BEGIN
8a47474f 11477 IF IsConst (OperandT (2))
1eee94d3 11478 THEN
8a47474f
GM		 11479 type := GetDType (OperandT (2)) ;
11480 IF type = NulSym
1eee94d3 11481 THEN
8a47474f
GM		 11482 InternalError ('constant type should have been resolved')
11483 ELSIF IsArray (type)
1eee94d3
GM		 11484 THEN
11485 PopTtok (e, exprTok) ;
8a47474f
GM		 11486 PopTFDtok (Sym, Type, dim, arrayTok) ;
11487 result := MakeTemporary (exprTok, RightValue) ;
11488 PutVar (result, Type) ;
11489 PushTFtok (result, GetSType (result), exprTok) ;
1eee94d3
GM		 11490 PushTtok (Sym, arrayTok) ;
11491 combinedTok := MakeVirtualTok (arrayTok, arrayTok, exprTok) ;
8a47474f 11492 PutVarConst (result, TRUE) ;
1eee94d3 11493 BuildAssignConstant (combinedTok) ;
8a47474f 11494 PushTFDtok (result, GetDType (result), dim, arrayTok) ;
1eee94d3
GM		 11495 PushTtok (e, exprTok)
11496 END
11497 END ;
11498 IF (NOT IsVar (OperandT (2))) AND (NOT IsTemporary (OperandT (2)))
11499 THEN
11500 MetaErrorT1 (OperandTtok (2),
11501 'can only access arrays using variables or formal parameters not {%1Ead}',
11502 OperandT (2)) ;
11503 BuildDesignatorError ('bad array access')
11504 END ;
11505 Sym := OperandT (2) ;
11506 Type := GetDType (Sym) ;
11507 arrayTok := OperandTtok (2) ;
11508 IF Type = NulSym
11509 THEN
11510 IF (arrayTok = UnknownTokenNo) OR (arrayTok = BuiltinTokenNo)
11511 THEN
11512 arrayTok := GetTokenNo ()
11513 END ;
11514 MetaErrorT0 (arrayTok, "type of array is undefined") ;
11515 BuildDesignatorError ('bad array access')
11516 ELSIF IsUnbounded (Type)
11517 THEN
11518 BuildDynamicArray
11519 ELSIF IsArray (Type)
11520 THEN
11521 BuildStaticArray
11522 ELSE
11523 MetaErrorT1 (arrayTok,
11524 'can only index static or dynamic arrays, {%1Ead} is not an array but a {%tad}',
11525 Sym) ;
11526 BuildDesignatorError ('bad array access')
11527 END
11528END BuildDesignatorArray ;
11529
11530
11531(*
11532 BuildStaticArray - Builds the array referencing for static arrays.
11533 The Stack is expected to contain:
11534
11535
11536 Entry Exit
11537 ===== ====
11538
11539 Ptr ->
11540 +--------------+
11541 | e | <- Ptr
11542 |--------------| +------------+
11543 | Sym | Type | | S | T |
11544 |--------------| |------------|
11545*)
11546
11547PROCEDURE BuildStaticArray ;
11548VAR
11549 combinedTok,
11550 indexTok,
11551 arrayTok : CARDINAL ;
11552 rw,
11553 Dim,
11554 Array,
11555 Index,
11556 BackEndType,
11557 Type, Adr : CARDINAL ;
11558BEGIN
11559 Index := OperandT (1) ;
11560 indexTok := OperandTtok (1) ;
11561 Array := OperandT (2) ;
11562 arrayTok := OperandTtok (2) ;
11563 Type := SkipType (OperandF (2)) ;
11564 rw := OperandMergeRW (2) ;
11565 Assert (IsLegal (rw)) ;
11566 Dim := OperandD (2) ;
11567 INC (Dim) ;
11568 IF GetMode (Index)=LeftValue
11569 THEN
11570 Index := MakeRightValue (indexTok, Index, GetSType (Index))
11571 END ;
11572 BuildRange (InitStaticArraySubscriptRangeCheck (GetArraySubscript (Type), Index, Dim)) ;
11573
11574 (* now make Adr point to the address of the indexed element *)
11575 combinedTok := MakeVirtualTok (arrayTok, arrayTok, indexTok) ;
11576 Adr := MakeTemporary (combinedTok, LeftValue) ;
11577 IF IsVar (Array)
11578 THEN
11579 (* BuildDesignatorArray may have detected des is a constant. *)
11580 PutVarConst (Adr, IsVarConst (Array))
11581 END ;
40b91158 11582 PutVarArrayRef (Adr, TRUE) ;
1eee94d3
GM		 11583 (*
11584 From now on it must reference the array element by its lvalue
11585 - so we create the type of the referenced entity
11586 *)
11587
11588 BackEndType := MakePointer (combinedTok, NulName) ;
11589 PutPointer (BackEndType, GetDType (Type)) ;
11590 (* PutVar(Adr, BackEndType) ; *)
11591 PutLeftValueFrontBackType (Adr, GetDType (Type), BackEndType) ;
11592
11593 GenQuadO (combinedTok, ArrayOp, Adr, Index, Array, TRUE) ;
11594 PopN (2) ; (* remove all parameters to this procedure *)
11595 PushTFDrwtok (Adr, GetSType (Adr), Dim, rw, combinedTok)
11596END BuildStaticArray ;
11597
11598
11599(*
11600 calculateMultipicand - generates quadruples which calculate the
11601 multiplicand for the array at dimension, dim.
11602*)
11603
11604PROCEDURE calculateMultipicand (tok: CARDINAL;
11605 arraySym, arrayType: CARDINAL; dim: CARDINAL) : CARDINAL ;
11606VAR
11607 ti, tj, tk, tl: CARDINAL ;
11608BEGIN
11609 IF dim = GetDimension (arrayType)
11610 THEN
11611 (* ti has no type since constant *)
11612 ti := MakeTemporary (tok, ImmediateValue) ;
40b91158 11613 PutVar (ti, Cardinal) ;
1eee94d3
GM		 11614 GenQuadO (tok, ElementSizeOp, ti, arrayType, 1, TRUE)
11615 ELSE
11616 INC(dim) ;
11617 tk := MakeTemporary (tok, RightValue) ;
40b91158 11618 PutVar (tk, Cardinal) ;
1eee94d3
GM		 11619 GenHigh (tok, tk, dim, arraySym) ;
11620 tl := MakeTemporary (tok, RightValue) ;
40b91158 11621 PutVar (tl, Cardinal) ;
64b0130b
GM		 11622 GenQuadOtok (tok, AddOp, tl, tk, MakeConstLit (tok, MakeKey ('1'), Cardinal), TRUE,
11623 tok, tok, tok) ;
1eee94d3
GM		 11624 tj := calculateMultipicand (tok, arraySym, arrayType, dim) ;
11625 ti := MakeTemporary (tok, RightValue) ;
11626 PutVar (ti, Cardinal) ;
11627 GenQuadO (tok, MultOp, ti, tj, tl, TRUE)
11628 END ;
11629 RETURN ti
11630END calculateMultipicand ;
11631
11632
64b0130b
GM		 11633(*
11634 ConvertToAddress - convert sym to an address.
11635*)
11636
11637PROCEDURE ConvertToAddress (tokpos: CARDINAL; sym: CARDINAL) : CARDINAL ;
11638VAR
11639 adr: CARDINAL ;
11640BEGIN
11641 IF GetSType (sym) = Address
11642 THEN
11643 RETURN sym
11644 ELSE
11645 PushTF (RequestSym (tokpos, MakeKey ('CONVERT')), NulSym) ;
11646 PushT (Address) ;
11647 PushTtok (sym, tokpos) ;
11648 PushT(2) ; (* Two parameters *)
4bd2f59a 11649 BuildConvertFunction (Convert, FALSE) ;
64b0130b
GM		 11650 PopT (adr) ;
11651 RETURN adr
11652 END
11653END ConvertToAddress ;
11654
11655
1eee94d3
GM		 11656(*
11657 BuildDynamicArray - Builds the array referencing for dynamic arrays.
11658 The Stack is expected to contain:
11659
11660
11661 Entry Exit
11662 ===== ====
11663
11664 Ptr ->
11665 +-----------------------+
11666 | Index | <- Ptr
11667 |-----------------------| +---------------------------+
11668 | ArraySym | Type | Dim | | S | T | ArraySym | Dim+1 |
11669 |-----------------------| |---------------------------|
11670
11671
11672 if Dim=1
11673 then
11674 S := base of ArraySym + TSIZE(Type)*Index
11675 else
11676 S := S + TSIZE(Type)*Index
11677 fi
11678*)
11679
11680PROCEDURE BuildDynamicArray ;
11681VAR
11682 combinedTok,
11683 arrayTok,
11684 indexTok : CARDINAL ;
11685 Sym, idx,
11686 Type, Adr,
11687 ArraySym,
11688 BackEndType,
11689 UnboundedType,
11690 PtrToBase,
11691 Base,
11692 Dim, rw,
64b0130b
GM		 11693 ti, tj, tk,
11694 tka : CARDINAL ;
1eee94d3
GM		 11695BEGIN
11696 DisplayStack ;
11697 Sym := OperandT (2) ;
11698 Type := SkipType (OperandF (2)) ;
11699 arrayTok := OperandTok (2) ;
11700 indexTok := OperandTok (1) ;
11701 combinedTok := MakeVirtualTok (arrayTok, arrayTok, indexTok) ;
11702 Dim := OperandD (2) ;
11703 rw := OperandMergeRW (2) ;
11704 Assert (IsLegal (rw)) ;
11705 INC (Dim) ;
11706 IF Dim = 1
11707 THEN
11708 (*
11709 Base has type address since
11710 BuildDesignatorRecord references by address.
11711
11712 Build a record for retrieving the address of dynamic array.
11713 BuildDesignatorRecord will generate the required quadruples,
11714 therefore build sets up the stack for BuildDesignatorRecord
11715 which will generate the quads to access the record.
11716 *)
11717 ArraySym := Sym ;
11718 UnboundedType := GetUnboundedRecordType (GetSType (Sym)) ;
11719 PushTFrwtok (Sym, UnboundedType, rw, arrayTok) ;
11720 PushTF (GetUnboundedAddressOffset (GetSType (Sym)),
11721 GetSType (GetUnboundedAddressOffset (GetSType (Sym)))) ;
11722 PushT (1) ; (* One record field to dereference *)
11723 BuildDesignatorRecord (combinedTok) ;
11724 PopT (PtrToBase) ;
11725 DisplayStack ;
11726 (* Now actually copy Unbounded.ArrayAddress into base *)
11727 IF GetMode(PtrToBase) = LeftValue
11728 THEN
11729 Base := MakeTemporary (arrayTok, RightValue) ;
11730 PutVar (Base, Address) ; (* has type ADDRESS *)
11731 CheckPointerThroughNil (arrayTok, PtrToBase) ;
11732 GenQuad (IndrXOp, Base, Address, PtrToBase) (* Base = *PtrToBase *)
11733 ELSE
11734 Assert (GetMode (PtrToBase) # ImmediateValue) ;
11735 Base := PtrToBase
11736 END
11737 ELSE
11738 (* Base already calculated previously and pushed to stack *)
11739 UnboundedType := SkipType (OperandF (2)) ;
11740 Base := Sym ;
11741 ArraySym := OperandA (2)
11742 END ;
11743 Assert (GetSType (Sym) = Type) ;
11744 ti := calculateMultipicand (indexTok, Sym, Type, Dim) ;
11745 idx := OperandT (1) ;
eadd05d5 11746 IF IsConst (idx) AND IsConst (ti)
1eee94d3
GM		 11747 THEN
11748 (* tj has no type since constant *)
11749 tj := MakeTemporary (indexTok, ImmediateValue) ;
11750 tk := MakeTemporary (indexTok, ImmediateValue) ;
11751 PutVar (tj, Cardinal) ;
11752 PutVar (tk, Cardinal)
11753 ELSE
11754 (* tj has Cardinal type since we have multiplied array indices *)
11755 tj := MakeTemporary (indexTok, RightValue) ;
11756 IF GetSType (idx) # Cardinal
11757 THEN
11758 PushTF (RequestSym (indexTok, MakeKey ('CONVERT')), NulSym) ;
11759 PushT (Cardinal) ;
11760 PushTtok (idx, indexTok) ;
11761 PushT(2) ; (* Two parameters *)
4bd2f59a 11762 BuildConvertFunction (Convert, FALSE) ;
1eee94d3
GM		 11763 PopT (idx)
11764 END ;
11765 PutVar (tj, Cardinal) ;
11766 tk := MakeTemporary (indexTok, RightValue) ;
11767 PutVar (tk, Cardinal)
11768 END ;
11769 BuildRange (InitDynamicArraySubscriptRangeCheck (ArraySym, idx, Dim)) ;
11770
11771 PushTtok (tj, indexTok) ;
11772 PushTtok (idx, indexTok) ;
11773 BuildAssignmentWithoutBounds (indexTok, FALSE, TRUE) ;
11774
11775 GenQuad (MultOp, tk, ti, tj) ;
11776 Adr := MakeTemporary (combinedTok, LeftValue) ;
40b91158 11777 PutVarArrayRef (Adr, TRUE) ;
1eee94d3
GM		 11778 (*
11779 Ok must reference by address
11780 - but we contain the type of the referenced entity
11781 *)
11782 BackEndType := MakePointer (combinedTok, NulName) ;
11783 PutPointer (BackEndType, GetSType (Type)) ;
64b0130b
GM		 11784 (* Create a temporary pointer for addition. *)
11785 tka := ConvertToAddress (combinedTok, tk) ;
1eee94d3
GM		 11786
11787 IF Dim = GetDimension (Type)
11788 THEN
11789 PutLeftValueFrontBackType (Adr, GetSType(Type), BackEndType) ;
11790
64b0130b
GM		 11791 GenQuadOtok (combinedTok, AddOp, Adr, Base, tka, FALSE,
11792 combinedTok, combinedTok, combinedTok) ;
1eee94d3
GM		 11793 PopN (2) ;
11794 PushTFADrwtok (Adr, GetSType(Adr), ArraySym, Dim, rw, combinedTok)
11795 ELSE
11796 (* more to index *)
11797 PutLeftValueFrontBackType (Adr, Type, BackEndType) ;
11798
64b0130b
GM		 11799 GenQuadOtok (combinedTok, AddOp, Adr, Base, tka, FALSE,
11800 combinedTok, combinedTok, combinedTok) ;
1eee94d3
GM		 11801 PopN (2) ;
11802 PushTFADrwtok (Adr, GetSType(Adr), ArraySym, Dim, rw, combinedTok)
11803 END
11804END BuildDynamicArray ;
11805
11806
b0762d4c
GM		 11807(*
11808 DebugLocation -
11809*)
11810
11811PROCEDURE DebugLocation (tok: CARDINAL; message: ARRAY OF CHAR) ;
11812BEGIN
11813 IF DebugTokPos
11814 THEN
11815 WarnStringAt (InitString (message), tok)
11816 END
11817END DebugLocation ;
11818
11819
1eee94d3
GM		 11820(*
11821 BuildDesignatorPointer - Builds a pointer reference.
11822 The Stack is expected to contain:
11823
11824
11825 Entry Exit
11826 ===== ====
11827
11828 Ptr -> <- Ptr
11829 +--------------+ +--------------+
11830 | Sym1 | Type1| | Sym2 | Type2|
11831 |--------------| |--------------|
11832*)
11833
11834PROCEDURE BuildDesignatorPointer (ptrtok: CARDINAL) ;
11835VAR
11836 combinedtok,
11837 exprtok : CARDINAL ;
11838 rw,
11839 Sym1, Type1,
11840 Sym2, Type2: CARDINAL ;
11841BEGIN
11842 PopTFrwtok (Sym1, Type1, rw, exprtok) ;
b0762d4c
GM		 11843 DebugLocation (exprtok, "expression") ;
11844
1eee94d3 11845 Type1 := SkipType (Type1) ;
a0c59538
GM		 11846 IF Type1 = NulSym
11847 THEN
11848 MetaErrorT1 (ptrtok, '{%1ad} has no type and therefore cannot be dereferenced by ^', Sym1)
11849 ELSIF IsUnknown (Sym1)
1eee94d3
GM		 11850 THEN
11851 MetaError1 ('{%1EMad} is undefined and therefore {%1ad}^ cannot be resolved', Sym1)
11852 ELSIF IsPointer (Type1)
11853 THEN
11854 Type2 := GetSType (Type1) ;
11855 Sym2 := MakeTemporary (ptrtok, LeftValue) ;
11856 (*
11857 Ok must reference by address
11858 - but we contain the type of the referenced entity
11859 *)
11860 MarkAsRead (rw) ;
11861 PutVarPointerCheck (Sym1, TRUE) ;
11862 CheckPointerThroughNil (ptrtok, Sym1) ;
11863 IF GetMode (Sym1) = LeftValue
11864 THEN
11865 rw := NulSym ;
11866 PutLeftValueFrontBackType (Sym2, Type2, Type1) ;
b0762d4c 11867 GenQuadO (ptrtok, IndrXOp, Sym2, Type1, Sym1, FALSE) (* Sym2 := *Sym1 *)
1eee94d3
GM		 11868 ELSE
11869 PutLeftValueFrontBackType (Sym2, Type2, NulSym) ;
b0762d4c 11870 GenQuadO (ptrtok, BecomesOp, Sym2, NulSym, Sym1, FALSE) (* Sym2 := Sym1 *)
1eee94d3
GM		 11871 END ;
11872 PutVarPointerCheck (Sym2, TRUE) ; (* we should check this for *)
11873 (* Sym2 later on (pointer via NIL) *)
11874 combinedtok := MakeVirtualTok (exprtok, exprtok, ptrtok) ;
b0762d4c
GM		 11875 PushTFrwtok (Sym2, Type2, rw, combinedtok) ;
11876 DebugLocation (combinedtok, "pointer expression")
1eee94d3
GM		 11877 ELSE
11878 MetaError2 ('{%1ad} is not a pointer type but a {%2d}', Sym1, Type1)
11879 END
11880END BuildDesignatorPointer ;
11881
11882
11883(*
11884 StartBuildWith - performs the with statement.
11885 The Stack:
11886
11887 Entry Exit
11888
11889 +------------+
11890 | Sym | Type | Empty
11891 |------------|
11892*)
11893
11894PROCEDURE StartBuildWith (withTok: CARDINAL) ;
11895VAR
11896 tok : CARDINAL ;
11897 Sym, Type,
11898 Ref : CARDINAL ;
11899BEGIN
b0762d4c 11900 DebugLocation (withtok, "with") ;
66132b1f 11901 BuildStmtNoteTok (withTok) ;
1eee94d3
GM		 11902 DisplayStack ;
11903 PopTFtok (Sym, Type, tok) ;
b0762d4c 11904 DebugLocation (tok, "expression") ;
1eee94d3
GM		 11905 Type := SkipType (Type) ;
11906
11907 Ref := MakeTemporary (tok, LeftValue) ;
11908 PutVar (Ref, Type) ;
11909 IF GetMode (Sym) = LeftValue
11910 THEN
b0762d4c 11911 (* Copy LeftValue. *)
1eee94d3
GM		 11912 GenQuadO (tok, BecomesOp, Ref, NulSym, Sym, TRUE)
11913 ELSE
b0762d4c 11914 (* Calculate the address of Sym. *)
1eee94d3
GM		 11915 GenQuadO (tok, AddrOp, Ref, NulSym, Sym, TRUE)
11916 END ;
11917
11918 PushWith (Sym, Type, Ref, tok) ;
b0762d4c 11919 DebugLocation (tok, "with ref") ;
1eee94d3
GM		 11920 IF Type = NulSym
11921 THEN
11922 MetaError1 ('{%1Ea} {%1d} has a no type, the {%kWITH} statement requires a variable or parameter of a {%kRECORD} type',
11923 Sym)
11924 ELSIF NOT IsRecord(Type)
11925 THEN
11926 MetaError1 ('the {%kWITH} statement requires that {%1Ea} {%1d} be of a {%kRECORD} {%1tsa:type rather than {%1tsa}}',
11927 Sym)
11928 END ;
11929 StartScope (Type)
11930 ; DisplayStack ;
11931END StartBuildWith ;
11932
11933
11934(*
11935 EndBuildWith - terminates the innermost with scope.
11936*)
11937
11938PROCEDURE EndBuildWith ;
11939BEGIN
11940 DisplayStack ;
11941 EndScope ;
11942 PopWith
11943 ; DisplayStack ;
11944END EndBuildWith ;
11945
11946
11947(*
11948 PushWith - pushes sym and type onto the with stack. It checks for
11949 previous declaration of this record type.
11950*)
11951
11952PROCEDURE PushWith (Sym, Type, Ref, Tok: CARDINAL) ;
11953VAR
11954 i, n: CARDINAL ;
11955 f : WithFrame ;
11956BEGIN
11957 IF Pedantic
11958 THEN
11959 n := NoOfItemsInStackAddress(WithStack) ;
b0762d4c 11960 i := 1 ; (* Top of the stack. *)
1eee94d3 11961 WHILE i <= n DO
b0762d4c 11962 (* Search for other declarations of the with using Type. *)
1eee94d3
GM		 11963 f := PeepAddress(WithStack, i) ;
11964 IF f^.RecordSym=Type
11965 THEN
11966 MetaErrorT1 (Tok,
11967 'cannot have nested {%kWITH} statements referencing the same {%kRECORD} {%1Ead}',
11968 Sym) ;
11969 MetaErrorT1 (f^.RecordTokPos,
11970 'cannot have nested {%kWITH} statements referencing the same {%kRECORD} {%1Ead}',
11971 f^.RecordSym)
11972 END ;
11973 INC (i)
11974 END
11975 END ;
11976 NEW (f) ;
11977 WITH f^ DO
11978 RecordSym := Sym ;
11979 RecordType := Type ;
11980 RecordRef := Ref ;
11981 rw := Sym ;
11982 RecordTokPos := Tok
11983 END ;
11984 PushAddress (WithStack, f)
11985END PushWith ;
11986
11987
11988PROCEDURE PopWith ;
11989VAR
11990 f: WithFrame ;
11991BEGIN
11992 f := PopAddress (WithStack) ;
11993 DISPOSE (f)
11994END PopWith ;
11995
11996
11997(*
11998 CheckWithReference - performs the with statement.
11999 The Stack:
12000
12001 Entry Exit
12002
12003 +------------+ +------------+
12004 | Sym | Type | | Sym | Type |
12005 |------------| |------------|
12006*)
12007
12008PROCEDURE CheckWithReference ;
12009VAR
12010 f : WithFrame ;
12011 tokpos,
12012 i, n, rw,
12013 Sym, Type: CARDINAL ;
12014BEGIN
12015 n := NoOfItemsInStackAddress(WithStack) ;
12016 IF (n>0) AND (NOT SuppressWith)
12017 THEN
12018 PopTFrwtok (Sym, Type, rw, tokpos) ;
12019 Assert (tokpos # UnknownTokenNo) ;
12020 (* inner WITH always has precidence *)
12021 i := 1 ; (* top of stack *)
12022 WHILE i<=n DO
12023 (* WriteString('Checking for a with') ; *)
12024 f := PeepAddress (WithStack, i) ;
12025 WITH f^ DO
12026 IF IsRecordField (Sym) AND (GetRecord (GetParent (Sym)) = RecordType)
12027 THEN
12028 IF IsUnused (Sym)
12029 THEN
12030 MetaError1('record field {%1Dad} was declared as unused by a pragma', Sym)
12031 END ;
12032 (* Fake a RecordSym.op *)
12033 PushTFrwtok (RecordRef, RecordType, rw, RecordTokPos) ;
12034 PushTFtok (Sym, Type, tokpos) ;
12035 BuildAccessWithField ;
12036 PopTFrw (Sym, Type, rw) ;
12037 i := n+1 (* Finish loop. *)
12038 ELSE
12039 INC (i)
12040 END
12041 END
12042 END ;
12043 PushTFrwtok (Sym, Type, rw, tokpos)
12044 END
12045END CheckWithReference ;
12046
12047
12048(*
12049 BuildAccessWithField - similar to BuildDesignatorRecord except it
12050 does not perform the address operation.
12051 The address will have been computed at the
12052 beginning of the WITH statement.
12053 It also stops the GenQuad procedure from examining the
12054 with stack.
12055
12056 The Stack
12057
12058 Entry
12059
12060 Ptr ->
12061 +--------------+
12062 | Field | Type1| <- Ptr
12063 |-------|------| +-------------+
12064 | Adr | Type2| | Sym | Type1|
12065 |--------------| |-------------|
12066*)
12067
12068PROCEDURE BuildAccessWithField ;
12069VAR
12070 rectok, fieldtok : CARDINAL ;
12071 OldSuppressWith : BOOLEAN ;
12072 rw,
12073 Field, FieldType,
12074 Record, RecordType,
12075 Ref : CARDINAL ;
12076BEGIN
12077 OldSuppressWith := SuppressWith ;
12078 SuppressWith := TRUE ;
12079 (*
12080 now the WITH cannot look at the stack of outstanding WITH records.
12081 *)
12082 PopTFtok (Field, FieldType, fieldtok) ;
12083 PopTFrwtok (Record, RecordType, rw, rectok) ;
12084
12085 Ref := MakeComponentRef (MakeComponentRecord (fieldtok,
12086 RightValue, Record), Field) ;
12087 PutVarConst (Ref, IsReadOnly (Record)) ;
12088 GenQuadO (fieldtok,
12089 RecordFieldOp, Ref, Record, Field, TRUE) ;
12090
12091 PushTFrwtok (Ref, FieldType, rw, fieldtok) ;
12092 SuppressWith := OldSuppressWith
12093END BuildAccessWithField ;
12094
12095
12096(*
12097 BuildNulExpression - Builds a nul expression on the stack.
12098 The Stack:
12099
12100 Entry Exit
12101
12102 <- Ptr
12103 Empty +------------+
12104 | NulSym |
12105 |------------|
f065c582 12106 tokpos is the position of the RETURN token.
1eee94d3
GM		 12107*)
12108
f065c582 12109PROCEDURE BuildNulExpression (tokpos: CARDINAL) ;
1eee94d3 12110BEGIN
f065c582 12111 PushTtok (NulSym, tokpos)
1eee94d3
GM		 12112END BuildNulExpression ;
12113
12114
12115(*
12116 BuildTypeForConstructor - pushes the type implied by the current constructor.
12117 If no constructor is currently being built then
12118 it Pushes a Bitset type.
12119*)
12120
f065c582 12121PROCEDURE BuildTypeForConstructor (tokpos: CARDINAL) ;
1eee94d3
GM		 12122VAR
12123 c: ConstructorFrame ;
12124BEGIN
12125 IF NoOfItemsInStackAddress(ConstructorStack)=0
12126 THEN
f065c582 12127 PushTtok (Bitset, tokpos)
1eee94d3
GM		 12128 ELSE
12129 c := PeepAddress(ConstructorStack, 1) ;
12130 WITH c^ DO
f065c582 12131 IF IsArray (type) OR IsSet (type)
1eee94d3 12132 THEN
f065c582
GM		 12133 PushTtok (GetSType (type), tokpos)
12134 ELSIF IsRecord (type)
1eee94d3 12135 THEN
f065c582 12136 PushTtok (GetSType (GetNth (type, index)), tokpos)
1eee94d3 12137 ELSE
f065c582
GM		 12138 MetaError1 ('{%1ad} is not a set, record or array type which is expected when constructing an aggregate entity',
12139 type)
1eee94d3
GM		 12140 END
12141 END
12142 END
12143END BuildTypeForConstructor ;
12144
12145
12146(*
12147 BuildSetStart - Pushes a Bitset type on the stack.
12148
12149 The Stack:
12150
12151 Entry Exit
12152
12153 Ptr -> <- Ptr
12154
12155 Empty +--------------+
12156 | Bitset |
12157 |--------------|
12158*)
12159
f065c582 12160PROCEDURE BuildSetStart (tokpos: CARDINAL) ;
1eee94d3 12161BEGIN
f065c582 12162 PushTtok (Bitset, tokpos)
1eee94d3
GM		 12163END BuildSetStart ;
12164
12165
12166(*
12167 BuildSetEnd - pops the set value and type from the stack
12168 and pushes the value,type pair.
12169
12170 Entry Exit
12171
12172 Ptr ->
12173 +--------------+
12174 | Set Value | <- Ptr
12175 |--------------| +--------------+
12176 | Set Type | | Value | Type |
12177 |--------------| |--------------|
12178*)
12179
12180PROCEDURE BuildSetEnd ;
12181VAR
f065c582
GM		 12182 valuepos, typepos,
12183 combined,
12184 value, type : CARDINAL ;
1eee94d3 12185BEGIN
f065c582
GM		 12186 PopTtok (value, valuepos) ;
12187 PopTtok (type, typepos) ;
12188 combined := MakeVirtual2Tok (typepos, valuepos) ;
12189 PushTFtok (value, type, combined) ;
12190 Assert (IsSet (type))
1eee94d3
GM		 12191END BuildSetEnd ;
12192
12193
12194(*
12195 BuildEmptySet - Builds an empty set on the stack.
12196 The Stack:
12197
12198 Entry Exit
12199
12200 <- Ptr
12201 +-------------+
12202 Ptr -> | Value |
12203 +-----------+ |-------------|
12204 | SetType | | SetType |
12205 |-----------| |-------------|
12206
f065c582 12207 tokpos points to the opening '{'.
1eee94d3
GM		 12208*)
12209
f065c582 12210PROCEDURE BuildEmptySet (tokpos: CARDINAL) ;
1eee94d3 12211VAR
f065c582
GM		 12212 n : Name ;
12213 typepos,
12214 Type : CARDINAL ;
12215 NulSet : CARDINAL ;
1eee94d3 12216BEGIN
f065c582
GM		 12217 PopTtok (Type, typepos) ; (* type of set we are building *)
12218 IF (Type = NulSym) AND Pim
1eee94d3
GM		 12219 THEN
12220 (* allowed generic {} in PIM Modula-2 *)
f065c582
GM		 12221 typepos := tokpos
12222 ELSIF IsUnknown (Type)
1eee94d3 12223 THEN
f065c582
GM		 12224 n := GetSymName (Type) ;
12225 WriteFormat1 ('set type %a is undefined', n) ;
1eee94d3 12226 Type := Bitset
f065c582 12227 ELSIF NOT IsSet (SkipType (Type))
1eee94d3 12228 THEN
f065c582 12229 n := GetSymName (Type) ;
1eee94d3
GM		 12230 WriteFormat1('expecting a set type %a', n) ;
12231 Type := Bitset
12232 ELSE
f065c582
GM		 12233 Type := SkipType (Type) ;
12234 Assert (Type # NulSym)
1eee94d3 12235 END ;
f065c582
GM		 12236 NulSet := MakeTemporary (typepos, ImmediateValue) ;
12237 PutVar (NulSet, Type) ;
12238 PutConstSet (NulSet) ;
1eee94d3
GM		 12239 IF CompilerDebugging
12240 THEN
f065c582
GM		 12241 n := GetSymName (Type) ;
12242 printf1 ('set type = %a\n', n)
1eee94d3 12243 END ;
f065c582
GM		 12244 PushNulSet (Type) ; (* onto the ALU stack *)
12245 PopValue (NulSet) ; (* ALU -> symbol table *)
1eee94d3
GM		 12246
12247 (* and now construct the M2Quads stack as defined by the comments above *)
f065c582
GM		 12248 PushTtok (Type, typepos) ;
12249 PushTtok (NulSet, typepos) ;
1eee94d3
GM		 12250 IF CompilerDebugging
12251 THEN
f065c582
GM		 12252 n := GetSymName (Type) ;
12253 printf2 ('Type = %a (%d) built empty set\n', n, Type) ;
1eee94d3
GM		 12254 DisplayStack (* Debugging info *)
12255 END
12256END BuildEmptySet ;
12257
12258
12259(*
12260 BuildInclRange - includes a set range with a set.
12261
12262
12263 Entry Exit
12264 ===== ====
12265
12266
12267 Ptr ->
12268 +------------+
12269 | El2 |
12270 |------------|
12271 | El1 | <- Ptr
12272 |------------| +-------------------+
12273 | Set Value | | Value + {El1..El2}|
12274 |------------| |-------------------|
12275
12276 No quadruples produced as the range info is contained within
12277 the set value.
12278*)
12279
12280PROCEDURE BuildInclRange ;
12281VAR
12282 n : Name ;
12283 el1, el2,
12284 value : CARDINAL ;
12285BEGIN
12286 PopT(el2) ;
12287 PopT(el1) ;
12288 PopT(value) ;
12289 IF NOT IsConstSet(value)
12290 THEN
12291 n := GetSymName(el1) ;
12292 WriteFormat1('can only add bit ranges to a constant set, %a is not a constant set', n)
12293 END ;
12294 IF IsConst(el1) AND IsConst(el2)
12295 THEN
12296 PushValue(value) ; (* onto ALU stack *)
12297 AddBitRange(GetTokenNo(), el1, el2) ;
12298 PopValue(value) (* ALU -> symboltable *)
12299 ELSE
12300 IF NOT IsConst(el1)
12301 THEN
12302 n := GetSymName(el1) ;
12303 WriteFormat1('must use constants as ranges when defining a set constant, problem with the low value %a', n)
12304 END ;
12305 IF NOT IsConst(el2)
12306 THEN
12307 n := GetSymName(el2) ;
12308 WriteFormat1('must use constants as ranges when defining a set constant, problem with the high value %a', n)
12309 END
12310 END ;
12311 PushT(value)
12312END BuildInclRange ;
12313
12314
12315(*
12316 BuildInclBit - includes a bit into the set.
12317
12318 Entry Exit
12319 ===== ====
12320
12321
12322 Ptr ->
12323 +------------+
12324 | Element | <- Ptr
12325 |------------| +------------+
12326 | Value | | Value |
12327 |------------| |------------|
12328
12329*)
12330
12331PROCEDURE BuildInclBit ;
12332VAR
12333 tok : CARDINAL ;
12334 el, value, t: CARDINAL ;
12335BEGIN
12336 PopT(el) ;
12337 PopT(value) ;
12338 tok := GetTokenNo () ;
12339 IF IsConst(el)
12340 THEN
12341 PushValue(value) ; (* onto ALU stack *)
12342 AddBit(tok, el) ;
12343 PopValue(value) (* ALU -> symboltable *)
12344 ELSE
12345 IF GetMode(el)=LeftValue
12346 THEN
12347 t := MakeTemporary(tok, RightValue) ;
12348 PutVar(t, GetSType(el)) ;
12349 CheckPointerThroughNil (tok, el) ;
12350 doIndrX(tok, t, el) ;
12351 el := t
12352 END ;
12353 IF IsConst(value)
12354 THEN
12355 (* move constant into a variable to achieve the include *)
12356 t := MakeTemporary(tok, RightValue) ;
12357 PutVar(t, GetSType(value)) ;
12358 GenQuad(BecomesOp, t, NulSym, value) ;
12359 value := t
12360 END ;
12361 GenQuad(InclOp, value, NulSym, el)
12362 END ;
12363 PushT(value)
12364END BuildInclBit ;
12365
12366
12367(*
12368 PushConstructor -
12369*)
12370
12371PROCEDURE PushConstructor (sym: CARDINAL) ;
12372VAR
12373 c: ConstructorFrame ;
12374BEGIN
12375 NEW(c) ;
12376 WITH c^ DO
12377 type := SkipType(sym) ;
12378 index := 1
12379 END ;
12380 PushAddress(ConstructorStack, c)
12381END PushConstructor ;
12382
12383
12384(*
12385 PopConstructor - removes the top constructor from the top of stack.
12386*)
12387
12388PROCEDURE PopConstructor ;
12389VAR
12390 c: ConstructorFrame ;
12391BEGIN
12392 c := PopAddress (ConstructorStack) ;
12393 DISPOSE(c)
12394END PopConstructor ;
12395
12396
12397(*
12398 NextConstructorField - increments the top of constructor stacks index by one.
12399*)
12400
12401PROCEDURE NextConstructorField ;
12402VAR
12403 c: ConstructorFrame ;
12404BEGIN
12405 c := PeepAddress(ConstructorStack, 1) ;
12406 INC(c^.index)
12407END NextConstructorField ;
12408
12409
12410(*
12411 SilentBuildConstructor - places NulSym into the constructor fifo queue.
12412*)
12413
12414PROCEDURE SilentBuildConstructor ;
12415BEGIN
12416 PutConstructorIntoFifoQueue (NulSym)
12417END SilentBuildConstructor ;
12418
12419
12420(*
12421 BuildConstructor - builds a constructor.
12422 Stack
12423
12424 Entry Exit
12425
12426 Ptr ->
12427 +------------+
12428 | Type | <- Ptr
12429 |------------+
12430*)
12431
12432PROCEDURE BuildConstructor (tokcbrpos: CARDINAL) ;
12433VAR
12434 tok : CARDINAL ;
12435 constValue,
12436 type : CARDINAL ;
12437BEGIN
12438 PopTtok (type, tok) ;
12439 constValue := MakeTemporary (tok, ImmediateValue) ;
12440 PutVar (constValue, type) ;
12441 PutConstructor (constValue) ;
12442 PushValue (constValue) ;
12443 IF type = NulSym
12444 THEN
12445 MetaErrorT0 (tokcbrpos,
1542e8a4 12446 '{%E}constructor requires a type before the opening %{')
1eee94d3
GM		 12447 ELSE
12448 ChangeToConstructor (tok, type) ;
12449 PutConstructorFrom (constValue, type) ;
12450 PopValue (constValue) ;
12451 PutConstructorIntoFifoQueue (constValue)
12452 END ;
12453 PushConstructor (type)
12454END BuildConstructor ;
12455
12456
12457(*
12458 SilentBuildConstructorStart - removes an entry from the constructor fifo queue.
12459*)
12460
12461PROCEDURE SilentBuildConstructorStart ;
12462VAR
12463 constValue: CARDINAL ;
12464BEGIN
12465 GetConstructorFromFifoQueue (constValue)
12466END SilentBuildConstructorStart ;
12467
12468
12469(*
12470 BuildConstructorStart - builds a constructor.
12471 Stack
12472
12473 Entry Exit
12474
12475 Ptr -> <- Ptr
12476 +------------+ +----------------+
12477 | Type | | ConstructorSym |
12478 |------------+ |----------------|
12479*)
12480
12481PROCEDURE BuildConstructorStart (cbratokpos: CARDINAL) ;
12482VAR
f065c582 12483 typepos,
1eee94d3
GM		 12484 constValue,
12485 type : CARDINAL ;
12486BEGIN
f065c582 12487 PopTtok (type, typepos) ; (* we ignore the type as we already have the constructor symbol from pass C *)
1eee94d3 12488 GetConstructorFromFifoQueue (constValue) ;
5ededfa5
GM		 12489 IF type # GetSType (constValue)
12490 THEN
12491 MetaErrorT3 (cbratokpos,
12492 '{%E}the constructor type is {%1ad} and this is different from the constant {%2ad} which has a type {%2tad}',
12493 type, constValue, constValue)
12494 END ;
1eee94d3
GM		 12495 PushTtok (constValue, cbratokpos) ;
12496 PushConstructor (type)
12497END BuildConstructorStart ;
12498
12499
12500(*
12501 BuildConstructorEnd - removes the current constructor frame from the
12502 constructor stack (it does not effect the quad
12503 stack)
12504
12505 Entry Exit
12506
12507 Ptr -> <- Ptr
12508 +------------+ +------------+
12509 | const | | const |
12510 |------------| |------------|
f065c582
GM		 12511
12512 startpos is the start of the constructor, either the typename or '{'
12513 cbratokpos is the '}'.
1eee94d3
GM		 12514*)
12515
f065c582 12516PROCEDURE BuildConstructorEnd (startpos, cbratokpos: CARDINAL) ;
1eee94d3 12517VAR
1eee94d3
GM		 12518 value, valtok: CARDINAL ;
12519BEGIN
f065c582
GM		 12520 IF DebugTokPos
12521 THEN
12522 WarnStringAt (InitString ('startpos'), startpos) ;
12523 WarnStringAt (InitString ('cbratokpos'), cbratokpos)
12524 END ;
1eee94d3 12525 PopTtok (value, valtok) ;
f065c582 12526 IF DebugTokPos
1eee94d3 12527 THEN
f065c582 12528 WarnStringAt (InitString ('value valtok'), valtok)
1eee94d3 12529 END ;
f065c582 12530 valtok := MakeVirtual2Tok (startpos, cbratokpos) ;
1eee94d3
GM		 12531 PutDeclared (valtok, value) ;
12532 PushTtok (value, valtok) ; (* Use valtok as we now know it was a constructor. *)
f065c582
GM		 12533 PopConstructor ;
12534 IF DebugTokPos
12535 THEN
12536 WarnStringAt (InitString ('aggregate constant'), valtok)
12537 END
1eee94d3
GM		 12538END BuildConstructorEnd ;
12539
12540
12541(*
12542 AddFieldTo - adds field, e, to, value.
12543*)
12544
12545PROCEDURE AddFieldTo (value, e: CARDINAL) : CARDINAL ;
12546BEGIN
12547 IF IsSet(GetDType(value))
12548 THEN
12549 PutConstSet(value) ;
12550 PushT(value) ;
12551 PushT(e) ;
12552 BuildInclBit ;
12553 PopT(value)
12554 ELSE
12555 PushValue(value) ;
12556 AddField(GetTokenNo(), e) ;
12557 PopValue(value)
12558 END ;
12559 RETURN( value )
12560END AddFieldTo ;
12561
12562
12563(*
12564 BuildComponentValue - builds a component value.
12565
12566 Entry Exit
12567
12568 Ptr -> <- Ptr
12569
12570
12571 +------------+ +------------+
12572 | const | | const |
12573 |------------| |------------|
12574*)
12575
12576PROCEDURE BuildComponentValue ;
12577VAR
12578 const,
12579 e1, e2 : CARDINAL ;
12580 nuldotdot,
12581 nulby : Name ;
12582BEGIN
12583 PopT(nulby) ;
12584 IF nulby=NulTok
12585 THEN
12586 PopT(nuldotdot) ;
12587 IF nuldotdot=NulTok
12588 THEN
12589 PopT(e1) ;
12590 PopT(const) ;
12591 PushT(AddFieldTo(const, e1))
12592 ELSE
12593 PopT(e2) ;
12594 PopT(e1) ;
12595 PopT(const) ;
12596 PushValue(const) ;
12597 AddBitRange(GetTokenNo(), e1, e2) ;
12598 PopValue(const) ;
12599 PushT(const)
12600 END
12601 ELSE
12602 PopT(e1) ;
12603 PopT(nuldotdot) ;
12604 IF nuldotdot=NulTok
12605 THEN
12606 PopT(e2) ;
12607 PopT(const) ;
12608 PushValue(const) ;
12609 AddElements(GetTokenNo(), e2, e1) ;
12610 PopValue(const) ;
12611 PushT(const)
12612 ELSE
12613 PopT(e2) ;
12614 PopT(e1) ;
12615 PopT(const) ;
12616 WriteFormat0('the constant must be an array constructor or a set constructor but not both') ;
12617 PushT(const)
12618 END
12619 END
12620END BuildComponentValue ;
12621
12622
12623(*
12624 RecordOp - Records the operator passed on the stack.
12625 Checks for AND operator or OR operator
12626 if either of these operators are found then BackPatching
12627 takes place.
12628 The Expected Stack:
12629
12630 Entry Exit
12631
12632 Ptr -> <- Ptr
12633 +-------------+ +-------------+
12634 | OperatorTok | | OperatorTok |
12635 |-------------| |-------------|
12636 | t | f | | t | f |
12637 |-------------| |-------------|
12638
12639
12640 If OperatorTok=AndTok
12641 Then
12642 BackPatch(f, NextQuad)
12643 Elsif OperatorTok=OrTok
12644 Then
12645 BackPatch(t, NextQuad)
12646 End
12647*)
12648
12649PROCEDURE RecordOp ;
12650VAR
12651 Op : Name ;
12652 tokno: CARDINAL ;
12653 t, f : CARDINAL ;
12654BEGIN
12655 PopTtok(Op, tokno) ;
12656 IF (Op=AndTok) OR (Op=AmbersandTok)
12657 THEN
12658 CheckBooleanId ;
12659 PopBool(t, f) ;
12660 BackPatch(t, NextQuad) ;
12661 PushBool(0, f)
12662 ELSIF Op=OrTok
12663 THEN
12664 CheckBooleanId ;
12665 PopBool(t, f) ;
12666 BackPatch(f, NextQuad) ;
12667 PushBool(t, 0)
12668 END ;
12669 PushTtok(Op, tokno)
12670END RecordOp ;
12671
12672
12673(*
12674 CheckLogicalOperator - returns a logical operator if the operands imply
12675 a logical operation should be performed.
12676*)
12677
12678PROCEDURE CheckLogicalOperator (Tok: Name; left, lefttype: CARDINAL) : Name ;
12679BEGIN
12680 IF (Tok=PlusTok) OR (Tok=TimesTok) OR (Tok=DivideTok) OR (Tok=MinusTok)
12681 THEN
12682 (* --fixme-- when we add complex arithmetic, we must check constructor is not a complex constant. *)
12683 IF ((lefttype#NulSym) AND IsSet(SkipType(lefttype))) OR
12684 IsConstSet(left) OR IsConstructor(left)
12685 THEN
12686 IF Tok=PlusTok
12687 THEN
12688 RETURN( LogicalOrTok )
12689 ELSIF Tok=DivideTok
12690 THEN
12691 RETURN( LogicalXorTok )
12692 ELSIF Tok=TimesTok
12693 THEN
12694 RETURN( LogicalAndTok )
12695 ELSIF Tok=MinusTok
12696 THEN
12697 RETURN( LogicalDifferenceTok )
12698 END
12699 END
12700 END ;
12701 RETURN( Tok )
12702END CheckLogicalOperator ;
12703
12704
12705(*
12706 doCheckGenericNulSet - checks to see whether e1 is a generic nul set and if so it alters it
12707 to the nul set of t2.
12708*)
12709
12710(*
12711PROCEDURE doCheckGenericNulSet (e1: CARDINAL; VAR t1: CARDINAL; t2: CARDINAL) ;
12712BEGIN
12713 IF IsConstSet (e1)
12714 THEN
12715 IF NOT IsSet (t2)
12716 THEN
12717 MetaError2 ('incompatibility between a set constant {%1Ea} of type {%1tsa} and an object of type {%2sa}',
12718 e1, t2)
12719 END ;
12720 PushValue (e1) ;
12721 IF IsGenericNulSet ()
12722 THEN
12723 PopValue (e1) ;
12724 PushNulSet (t2) ;
12725 t1 := t2
12726 END ;
12727 PopValue (e1)
12728 END
12729END doCheckGenericNulSet ;
12730*)
12731
12732
12733(*
12734 CheckGenericNulSet - if e1 or e2 is the generic nul set then
12735 alter it to the nul set of the other operands type.
12736*)
12737
12738(*
12739PROCEDURE CheckGenericNulSet (e1, e2: CARDINAL; VAR t1, t2: CARDINAL) ;
12740BEGIN
12741 IF t1#t2
12742 THEN
12743 doCheckGenericNulSet(e1, t1, t2) ;
12744 doCheckGenericNulSet(e2, t2, t1)
12745 END
12746END CheckGenericNulSet ;
12747*)
12748
12749
12750(*
12751 CheckDivModRem - initiates calls to check the divisor for DIV, MOD, REM
12752 expressions.
12753*)
12754
12755PROCEDURE CheckDivModRem (TokPos: CARDINAL; tok: Name; d, e: CARDINAL) ;
12756BEGIN
12757 IF tok=DivTok
12758 THEN
12759 BuildRange (InitWholeZeroDivisionCheck (TokPos, d, e))
12760 ELSIF tok=ModTok
12761 THEN
12762 BuildRange (InitWholeZeroDivisionCheck (TokPos, d, e))
12763 ELSIF tok=RemTok
12764 THEN
12765 BuildRange (InitWholeZeroRemainderCheck (TokPos, d, e))
12766 END
12767END CheckDivModRem ;
12768
12769
12770(*
12771 doConvert - convert, sym, to a new symbol with, type.
12772 Return the new symbol.
12773*)
12774
12775PROCEDURE doConvert (type: CARDINAL; sym: CARDINAL) : CARDINAL ;
12776BEGIN
12777 IF GetSType(sym)#type
12778 THEN
12779 PushTF(Convert, NulSym) ;
12780 PushT(type) ;
12781 PushT(sym) ;
12782 PushT(2) ; (* Two parameters *)
4bd2f59a 12783 BuildConvertFunction (Convert, FALSE) ;
1eee94d3
GM		 12784 PopT(sym)
12785 END ;
12786 RETURN( sym )
12787END doConvert ;
12788
12789
12790(*
12791 BuildBinaryOp - Builds a binary operation from the quad stack.
12792 Be aware that this procedure will check for
12793 the overloading of the bitset operators + - \ *.
12794 So do NOT call this procedure if you are building
12795 a reference to an array which has a bitset type or
12796 the address arithmetic will be wrongly coersed into
12797 logical ORs.
12798
12799 The Stack is expected to contain:
12800
12801
12802 Entry Exit
12803 ===== ====
12804
12805 Ptr ->
12806 +------------+
12807 | Sym1 |
12808 |------------|
12809 | Operator | <- Ptr
12810 |------------| +------------+
12811 | Sym2 | | Temporary |
12812 |------------| |------------|
12813
12814
12815 Quadruples Produced
12816
12817 q Operator Temporary Sym1 Sym2
12818
12819
12820 OR
12821
12822
12823 Entry Exit
12824 ===== ====
12825
12826 Ptr ->
12827 +------------+
12828 | T1 | F1 |
12829 |------------|
12830 | OrTok | <- Ptr
12831 |------------| +------------+
12832 | T2 | F2 | | T1+T2| F1 |
12833 |------------| |------------|
12834
12835
12836 Quadruples Produced
12837
12838*)
12839
12840PROCEDURE BuildBinaryOp ;
12841BEGIN
12842 doBuildBinaryOp (TRUE, TRUE)
12843END BuildBinaryOp ;
12844
12845
12846(*
12847 doBuildBinaryOp - build the binary op, with or without type
12848 checking.
12849*)
12850
12851PROCEDURE doBuildBinaryOp (checkTypes, checkOverflow: BOOLEAN) ;
12852VAR
12853 s : String ;
12854 NewOp,
12855 Operator : Name ;
12856 OperatorPos,
12857 OldPos,
12858 leftrw, rightrw,
12859 t1, f1,
12860 t2, f2,
12861 lefttype, righttype,
12862 left, right,
12863 leftpos, rightpos : CARDINAL ;
12864 value : CARDINAL ;
12865BEGIN
b0762d4c 12866 Operator := OperandT (2) ;
1eee94d3
GM		 12867 IF Operator = OrTok
12868 THEN
12869 CheckBooleanId ;
84104022 12870 PopBooltok (t1, f1, rightpos) ;
1eee94d3 12871 PopTtok (Operator, OperatorPos) ;
84104022 12872 PopBooltok (t2, f2, leftpos) ;
1eee94d3 12873 Assert (f2=0) ;
84104022
GM		 12874 OperatorPos := MakeVirtualTok (OperatorPos, leftpos, rightpos) ;
12875 PushBooltok (Merge (t1, t2), f1, OperatorPos)
1eee94d3
GM		 12876 ELSIF (Operator = AndTok) OR (Operator = AmbersandTok)
12877 THEN
12878 CheckBooleanId ;
84104022 12879 PopBooltok (t1, f1, rightpos) ;
1eee94d3 12880 PopTtok (Operator, OperatorPos) ;
84104022 12881 PopBooltok (t2, f2, leftpos) ;
1eee94d3 12882 Assert (t2=0) ;
84104022
GM		 12883 OperatorPos := MakeVirtualTok (OperatorPos, leftpos, rightpos) ;
12884 PushBooltok (t1, Merge (f1, f2), OperatorPos)
1eee94d3
GM		 12885 ELSE
12886 PopTFrwtok (right, righttype, rightrw, rightpos) ;
12887 PopTtok (Operator, OperatorPos) ;
12888 PopTFrwtok (left, lefttype, leftrw, leftpos) ;
12889 MarkAsRead (rightrw) ;
12890 MarkAsRead (leftrw) ;
12891 NewOp := CheckLogicalOperator (Operator, (* right, righttype, *) left, lefttype) ;
12892 IF NewOp = Operator
12893 THEN
12894 (*
12895 BinaryOps and UnaryOps only work with immediate and
12896 offset addressing. This is fine for calculating
12897 array and record offsets but we need to get the real
12898 values to perform normal arithmetic. Not address
12899 arithmetic.
12900
12901 However the set operators will dereference LValues
12902 (to optimize large set arithemetic)
12903 *)
12904 IF GetMode (right) = LeftValue
12905 THEN
12906 value := MakeTemporary (rightpos, RightValue) ;
12907 PutVar (value, righttype) ;
12908 CheckPointerThroughNil (rightpos, right) ;
12909 doIndrX (rightpos, value, right) ;
12910 right := value
12911 END ;
12912 IF GetMode (left) = LeftValue
12913 THEN
12914 value := MakeTemporary (leftpos, RightValue) ;
12915 PutVar (value, lefttype) ;
12916 CheckPointerThroughNil (leftpos, left) ;
12917 doIndrX (leftpos, value, left) ;
12918 left := value
12919 END
12920 ELSE
12921 (* CheckForGenericNulSet(e1, e2, t1, t2) *)
12922 END ;
eb619490
GM		 12923 OldPos := OperatorPos ;
12924 OperatorPos := MakeVirtualTok (OperatorPos, leftpos, rightpos) ;
1eee94d3
GM		 12925 IF (Operator = PlusTok) AND IsConstString(left) AND IsConstString(right)
12926 THEN
78b72ee5
GM		 12927 value := MakeConstString (OperatorPos, NulName) ;
12928 PutConstStringKnown (OperatorPos, value, NulName, FALSE, FALSE) ;
12929 GenQuadOtok (OperatorPos, MakeOp (PlusTok), value, left, right, FALSE,
12930 OperatorPos, leftpos, rightpos)
1eee94d3 12931 ELSE
1eee94d3
GM		 12932 IF checkTypes
12933 THEN
12934 BuildRange (InitTypesExpressionCheck (OperatorPos, left, right, FALSE, FALSE))
12935 END ;
12936 value := MakeTemporaryFromExpressions (OperatorPos,
12937 right, left,
12938 AreConstant (IsConst (left) AND IsConst (right))) ;
12939
12940 CheckDivModRem (OperatorPos, NewOp, value, right) ;
12941
12942 IF DebugTokPos
12943 THEN
12944 s := InitStringCharStar (KeyToCharStar (GetTokenName (Operator))) ;
12945 WarnStringAt (s, OldPos) ;
12946 s := InitString ('left') ;
12947 WarnStringAt (s, leftpos) ;
12948 s := InitString ('right') ;
12949 WarnStringAt (s, rightpos) ;
12950 s := InitString ('caret') ;
12951 WarnStringAt (s, OldPos) ;
12952 s := InitString ('combined') ;
12953 WarnStringAt (s, OperatorPos) ;
12954 (* MetaErrorT1 (GetDeclaredMod (t), 'in binary with a {%1a}', t) *)
12955 END ;
12956 GenQuadOtok (OperatorPos, MakeOp (NewOp), value, left, right, checkOverflow,
12957 OperatorPos, leftpos, rightpos)
12958 END ;
12959 PushTFtok (value, GetSType (value), OperatorPos)
12960 END
12961END doBuildBinaryOp ;
12962
12963
12964(*
12965 BuildUnaryOp - Builds a unary operation from the quad stack.
12966 The Stack is expected to contain:
12967
12968
12969 Entry Exit
12970 ===== ====
12971
12972 Ptr ->
12973 +------------+
12974 | Sym |
12975 |------------| +------------+
12976 | Operator | | Temporary | <- Ptr
12977 |------------| |------------|
12978
12979
12980 Quadruples Produced
12981
12982 q Operator Temporary _ Sym
12983
12984*)
12985
12986PROCEDURE BuildUnaryOp ;
12987VAR
12988 sympos,
12989 tokpos : CARDINAL ;
12990 Tok : Name ;
12991 type,
12992 Sym,
12993 SymT, r, t: CARDINAL ;
12994BEGIN
12995 PopTrwtok (Sym, r, sympos) ;
12996 PopTtok (Tok, tokpos) ;
12997 IF Tok=MinusTok
12998 THEN
12999 MarkAsRead(r) ;
13000 type := NegateType (GetSType (Sym) (* , sympos *) ) ;
13001 tokpos := MakeVirtualTok (tokpos, tokpos, sympos) ;
13002
13003 t := MakeTemporary (tokpos, AreConstant(IsConst(Sym))) ;
13004 PutVar(t, type) ;
13005
13006 (*
13007 variables must have a type and REAL/LONGREAL constants must
13008 be typed
13009 *)
13010
13011 IF NOT IsConst(Sym)
13012 THEN
13013 IF (type#NulSym) AND IsSet(SkipType(type))
13014 THEN
13015 (* do not dereference set variables *)
13016 ELSIF GetMode(Sym)=LeftValue
13017 THEN
13018 (* dereference symbols which are not sets and which are variables *)
13019
13020 SymT := MakeTemporary (sympos, RightValue) ;
13021 PutVar (SymT, GetSType (Sym)) ;
13022 CheckPointerThroughNil (sympos, Sym) ;
13023 doIndrX (sympos, SymT, Sym) ;
13024 Sym := SymT
13025 END
13026 END ;
13027 GenQuadO (tokpos, NegateOp, t, NulSym, Sym, TRUE) ;
13028 PushTtok (t, tokpos)
13029 ELSIF Tok=PlusTok
13030 THEN
13031 tokpos := MakeVirtualTok (tokpos, tokpos, sympos) ;
13032 PushTrwtok (Sym, r, tokpos)
13033 ELSE
13034 MetaErrorNT1 (tokpos,
13035 'expecting an unary operator, seen {%Ek%a}', Tok)
13036 END
13037END BuildUnaryOp ;
13038
13039
13040(*
13041 AreConstant - returns immediate addressing mode if b is true else
13042 offset mode is returned. b determines whether the
13043 operands are all constant - in which case we can use
13044 a constant temporary variable.
13045*)
13046
13047PROCEDURE AreConstant (b: BOOLEAN) : ModeOfAddr ;
13048BEGIN
13049 IF b
13050 THEN
13051 RETURN ImmediateValue
13052 ELSE
13053 RETURN RightValue
13054 END
13055END AreConstant ;
13056
13057
13058(*
13059 ConvertBooleanToVariable - converts a BoolStack(i) from a Boolean True|False
13060 exit pair into a variable containing the value TRUE or
13061 FALSE. The parameter, i, is relative to the top
13062 of the stack.
13063*)
13064
13065PROCEDURE ConvertBooleanToVariable (tok: CARDINAL; i: CARDINAL) ;
13066VAR
13067 Des: CARDINAL ;
13068 f : BoolFrame ;
13069BEGIN
13070 Assert (IsBoolean (i)) ;
4e3c8257
GM		 13071 (* We need to convert the boolean top of stack into a variable or
13072 constant boolean. *)
13073 Des := MakeTemporary (tok, AreConstant (IsInConstExpression ())) ;
1eee94d3
GM		 13074 PutVar (Des, Boolean) ;
13075 PushTtok (Des, tok) ; (* we have just increased the stack so we must use i+1 *)
13076 f := PeepAddress (BoolStack, i+1) ;
13077 PushBool (f^.TrueExit, f^.FalseExit) ;
13078 BuildAssignmentWithoutBounds (tok, FALSE, TRUE) ; (* restored stack *)
13079 f := PeepAddress (BoolStack, i) ;
13080 WITH f^ DO
4e3c8257 13081 TrueExit := Des ; (* Alter Stack(i) to contain the variable. *)
1eee94d3 13082 FalseExit := Boolean ;
4e3c8257 13083 BooleanOp := FALSE ; (* No longer a Boolean True|False pair. *)
1eee94d3
GM		 13084 Unbounded := NulSym ;
13085 Dimension := 0 ;
13086 ReadWrite := NulSym ;
13087 tokenno := tok ;
13088 Annotation := KillString (Annotation) ;
13089 Annotation := InitString ('%1s(%1d)|%2s(%2d)||boolean var|type')
13090 END
13091END ConvertBooleanToVariable ;
13092
13093
13094(*
13095 BuildBooleanVariable - tests to see whether top of stack is a boolean
13096 conditional and if so it converts it into a boolean
13097 variable.
13098*)
13099
13100PROCEDURE BuildBooleanVariable ;
13101BEGIN
13102 IF IsBoolean (1)
13103 THEN
13104 ConvertBooleanToVariable (OperandTtok (1), 1)
13105 END
13106END BuildBooleanVariable ;
13107
13108
13109(*
13110 BuildRelOpFromBoolean - builds a relational operator sequence of quadruples
13111 instead of using a temporary boolean variable.
13112 This function can only be used when we perform
13113 the following translation:
13114
13115 (a=b) # (c=d) alternatively (a=b) = (c=d)
13116 ^ ^
13117
13118 it only allows # = to be used as >= <= > < all
13119 assume a particular value for TRUE and FALSE.
13120 (In which case the user should specify ORD)
13121
13122
13123 before
13124
13125 q if r1 op1 op2 t2
13126 q+1 Goto f2
13127 q+2 if r2 op3 op4 t1
13128 q+3 Goto f1
13129
13130 after (in case of =)
13131
13132 q if r1 op1 op2 q+2
13133 q+1 Goto q+4
13134 q+2 if r2 op3 op4 t
13135 q+3 Goto f
13136 q+4 if r2 op3 op4 f
13137 q+5 Goto t
13138
13139 after (in case of #)
13140
13141 q if r1 op1 op2 q+2
13142 q+1 Goto q+4
13143 q+2 if r2 op3 op4 f
13144 q+3 Goto t
13145 q+4 if r2 op3 op4 t
13146 q+5 Goto f
13147
13148 The Stack is expected to contain:
13149
13150
13151 Entry Exit
13152 ===== ====
13153
13154 Ptr ->
13155 +------------+
13156 | t1 | f1 |
13157 |------------|
13158 | Operator | <- Ptr
13159 |------------| +------------+
13160 | t2 | f2 | | t | f |
13161 |------------| |------------|
13162
13163
13164*)
13165
13166PROCEDURE BuildRelOpFromBoolean (tokpos: CARDINAL) ;
13167VAR
13168 Tok,
13169 t1, f1,
13170 t2, f2: CARDINAL ;
13171 f : QuadFrame ;
13172BEGIN
13173 Assert (IsBoolean (1) AND IsBoolean (3)) ;
13174 IF OperandT (2) = EqualTok
13175 THEN
13176 (* are the two boolean expressions the same? *)
13177 PopBool (t1, f1) ;
13178 PopT (Tok) ;
13179 PopBool (t2, f2) ;
13180 (* give the false exit a second chance *)
13181 BackPatch (t2, t1) ; (* q if _ _ q+2 *)
13182 BackPatch (f2, NextQuad) ; (* q+1 if _ _ q+4 *)
13183 Assert (NextQuad = f1+1) ;
13184 f := GetQF (t1) ;
13185 WITH f^ DO
13186 GenQuadO (tokpos, Operator, Operand1, Operand2, 0, FALSE)
13187 END ;
13188 GenQuadO (tokpos, GotoOp, NulSym, NulSym, 0, FALSE) ;
84104022 13189 PushBooltok (Merge (NextQuad-1, t1), Merge (NextQuad-2, f1), tokpos)
1eee94d3
GM		 13190 ELSIF (OperandT (2) = HashTok) OR (OperandT (2) = LessGreaterTok)
13191 THEN
b7f70cfd 13192 (* are the two boolean expressions different? *)
1eee94d3
GM		 13193 PopBool (t1, f1) ;
13194 PopT (Tok) ;
13195 PopBool (t2, f2) ;
13196 (* give the false exit a second chance *)
13197 BackPatch (t2, t1) ; (* q if _ _ q+2 *)
13198 BackPatch (f2, NextQuad) ; (* q+1 if _ _ q+4 *)
13199 Assert (NextQuad = f1+1) ;
13200 f := GetQF (t1) ;
13201 WITH f^ DO
13202 GenQuadO (tokpos, Operator, Operand1, Operand2, 0, FALSE)
13203 END ;
13204 GenQuadO (tokpos, GotoOp, NulSym, NulSym, 0, FALSE) ;
84104022 13205 PushBooltok (Merge (NextQuad-2, f1), Merge (NextQuad-1, t1), tokpos)
1eee94d3
GM		 13206 ELSE
13207 MetaError0 ('only allowed to use the relation operators {%Ek=} {%Ek#} rather than {%Ek<} or {%Ek>} on {%EkBOOLEAN} expressions as these do not imply an ordinal value for {%kTRUE} or {%kFALSE}')
13208 END
13209END BuildRelOpFromBoolean ;
13210
13211
13212(*
13213 CheckVariableOrConstantOrProcedure - checks to make sure sym is a variable, constant or procedure.
13214*)
13215
13216PROCEDURE CheckVariableOrConstantOrProcedure (tokpos: CARDINAL; sym: CARDINAL) ;
13217VAR
13218 type: CARDINAL ;
13219BEGIN
13220 type := GetSType (sym) ;
13221 IF IsUnknown (sym)
13222 THEN
13223 MetaErrorT1 (tokpos, '{%1EUad} has not been declared', sym) ;
13224 UnknownReported (sym)
13225 ELSIF IsPseudoSystemFunction (sym) OR IsPseudoBaseFunction (sym)
13226 THEN
13227 MetaErrorT1 (tokpos,
13228 '{%1Ead} expected a variable, procedure, constant or expression, not an intrinsic procedure function',
13229 sym)
13230 ELSIF (NOT IsConst(sym)) AND (NOT IsVar(sym)) AND
13231 (NOT IsProcedure(sym)) AND
13232 (NOT IsTemporary(sym)) AND (NOT MustNotCheckBounds)
13233 THEN
13234 MetaErrorsT1 (tokpos,
13235 '{%1Ead} expected a variable, procedure, constant or expression',
13236 'and it was declared as a {%1Dd}', sym) ;
13237 ELSIF (type#NulSym) AND IsArray(type)
13238 THEN
13239 MetaErrorsT1 (tokpos,
13240 '{%1EU} not expecting an array variable as an operand for either comparison or binary operation',
13241 'it was declared as a {%1Dd}', sym)
78b72ee5 13242 ELSIF IsConstString (sym) AND IsConstStringKnown (sym) AND (GetStringLength (tokpos, sym) > 1)
1eee94d3
GM		 13243 THEN
13244 MetaErrorT1 (tokpos,
13245 '{%1EU} not expecting a string constant as an operand for either comparison or binary operation',
13246 sym)
13247 END
13248END CheckVariableOrConstantOrProcedure ;
13249
13250
13251(*
13252 BuildRelOp - Builds a relative operation from the quad stack.
13253 The Stack is expected to contain:
13254
13255
13256 Entry Exit
13257 ===== ====
13258
13259 Ptr ->
13260 +------------+
13261 | e1 |
13262 |------------| <- Ptr
13263 | Operator |
13264 |------------| +------------+
13265 | e2 | | t | f |
13266 |------------| |------------|
13267
13268
13269 Quadruples Produced
13270
13271 q IFOperator e2 e1 TrueExit ; e2 e1 since
13272 q+1 GotoOp FalseExit ; relation > etc
13273 ; requires order.
13274*)
13275
13276PROCEDURE BuildRelOp (optokpos: CARDINAL) ;
13277VAR
13278 combinedTok,
13279 rightpos,
13280 leftpos : CARDINAL ;
13281 Op : Name ;
13282 t,
13283 rightType, leftType,
13284 right, left : CARDINAL ;
b0762d4c 13285 s : String ;
1eee94d3
GM		 13286BEGIN
13287 IF CompilerDebugging
13288 THEN
13289 DisplayStack (* Debugging info *)
13290 END ;
13291 IF IsBoolean (1) AND IsBoolean (3)
13292 THEN
13293 (*
13294 we allow # and = to be used with Boolean expressions.
13295 we do not allow > < >= <= though
13296 *)
13297 BuildRelOpFromBoolean (optokpos)
13298 ELSE
13299 IF IsBoolean (1)
13300 THEN
13301 ConvertBooleanToVariable (OperandTtok (1), 1)
13302 END ;
13303 IF IsBoolean (3)
13304 THEN
13305 ConvertBooleanToVariable (OperandTtok (3), 3)
13306 END ;
13307 PopTFtok (right, rightType, rightpos) ;
13308 PopT (Op) ;
13309 PopTFtok (left, leftType, leftpos) ;
13310
13311 CheckVariableOrConstantOrProcedure (rightpos, right) ;
13312 CheckVariableOrConstantOrProcedure (leftpos, left) ;
8bf244e3 13313 combinedTok := MakeVirtualTok (optokpos, leftpos, rightpos) ;
1eee94d3
GM		 13314
13315 IF (left#NulSym) AND (right#NulSym)
13316 THEN
13317 (* BuildRange will check the expression later on once gcc knows about all data types. *)
8bf244e3
GM		 13318 BuildRange (InitTypesExpressionCheck (combinedTok, left, right, TRUE,
13319 Op = InTok))
1eee94d3
GM		 13320 END ;
13321
13322 (* Must dereference LeftValue operands. *)
13323 IF GetMode(right) = LeftValue
13324 THEN
13325 t := MakeTemporary (rightpos, RightValue) ;
13326 PutVar(t, GetSType(right)) ;
13327 CheckPointerThroughNil (rightpos, right) ;
13328 doIndrX (rightpos, t, right) ;
13329 right := t
13330 END ;
13331 IF GetMode(left) = LeftValue
13332 THEN
13333 t := MakeTemporary (leftpos, RightValue) ;
13334 PutVar (t, GetSType (left)) ;
13335 CheckPointerThroughNil (leftpos, left) ;
13336 doIndrX (leftpos, t, left) ;
13337 left := t
13338 END ;
b0762d4c
GM		 13339
13340 IF DebugTokPos
13341 THEN
13342 s := InitStringCharStar (KeyToCharStar (GetTokenName (Op))) ;
13343 WarnStringAt (s, optokpos) ;
13344 s := InitString ('left') ;
13345 WarnStringAt (s, leftpos) ;
13346 s := InitString ('right') ;
13347 WarnStringAt (s, rightpos) ;
13348 s := InitString ('caret') ;
13349 WarnStringAt (s, optokpos) ;
13350 s := InitString ('combined') ;
13351 WarnStringAt (s, combinedTok)
13352 END ;
13353
13354 GenQuadOtok (combinedTok, MakeOp (Op), left, right, 0, FALSE,
13355 leftpos, rightpos, UnknownTokenNo) ; (* True Exit *)
1eee94d3 13356 GenQuadO (combinedTok, GotoOp, NulSym, NulSym, 0, FALSE) ; (* False Exit *)
84104022 13357 PushBooltok (NextQuad-2, NextQuad-1, combinedTok)
1eee94d3
GM		 13358 END
13359END BuildRelOp ;
13360
13361
13362(*
13363 BuildNot - Builds a NOT operation from the quad stack.
13364 The Stack is expected to contain:
13365
13366
13367 Entry Exit
13368 ===== ====
13369
13370 Ptr -> <- Ptr
13371 +------------+ +------------+
13372 | t | f | | f | t |
13373 |------------| |------------|
13374*)
13375
c8f2be5d 13376PROCEDURE BuildNot (notTokPos: CARDINAL) ;
1eee94d3 13377VAR
c8f2be5d
GM		 13378 combinedTok,
13379 exprTokPos : CARDINAL ;
13380 t, f : CARDINAL ;
1eee94d3
GM		 13381BEGIN
13382 CheckBooleanId ;
c8f2be5d
GM		 13383 PopBooltok (t, f, exprTokPos) ;
13384 combinedTok := MakeVirtualTok (notTokPos, notTokPos, exprTokPos) ;
13385 PushBooltok (f, t, combinedTok)
1eee94d3
GM		 13386END BuildNot ;
13387
13388
13389(*
13390 MakeOp - returns the equalent quadruple operator to a token, t.
13391*)
13392
13393PROCEDURE MakeOp (t: Name) : QuadOperator ;
13394BEGIN
ac7c9954
GM		 13395 IF t=ArithPlusTok
13396 THEN
13397 RETURN ArithAddOp
13398 ELSIF t=PlusTok
1eee94d3
GM		 13399 THEN
13400 RETURN( AddOp )
13401 ELSIF t=MinusTok
13402 THEN
13403 RETURN( SubOp )
13404 ELSIF t=DivTok
13405 THEN
13406 RETURN( DivM2Op )
13407 ELSIF t=DivideTok
13408 THEN
13409 RETURN( DivTruncOp )
13410 ELSIF t=RemTok
13411 THEN
13412 RETURN( ModTruncOp )
13413 ELSIF t=ModTok
13414 THEN
13415 RETURN( ModM2Op )
13416 ELSIF t=TimesTok
13417 THEN
13418 RETURN( MultOp )
13419 ELSIF t=HashTok
13420 THEN
13421 RETURN( IfNotEquOp )
13422 ELSIF t=LessGreaterTok
13423 THEN
13424 RETURN( IfNotEquOp )
13425 ELSIF t=GreaterEqualTok
13426 THEN
13427 RETURN( IfGreEquOp )
13428 ELSIF t=LessEqualTok
13429 THEN
13430 RETURN( IfLessEquOp )
13431 ELSIF t=EqualTok
13432 THEN
13433 RETURN( IfEquOp )
13434 ELSIF t=LessTok
13435 THEN
13436 RETURN( IfLessOp )
13437 ELSIF t=GreaterTok
13438 THEN
13439 RETURN( IfGreOp )
13440 ELSIF t=InTok
13441 THEN
13442 RETURN( IfInOp )
13443 ELSIF t=LogicalOrTok
13444 THEN
13445 RETURN( LogicalOrOp )
13446 ELSIF t=LogicalAndTok
13447 THEN
13448 RETURN( LogicalAndOp )
13449 ELSIF t=LogicalXorTok
13450 THEN
13451 RETURN( LogicalXorOp )
13452 ELSIF t=LogicalDifferenceTok
13453 THEN
13454 RETURN( LogicalDiffOp )
13455 ELSE
13456 InternalError('binary operation not implemented yet')
13457 END
13458END MakeOp ;
13459
13460
13461(*
13462 GenQuadO - generate a quadruple with Operation, Op1, Op2, Op3, overflow.
13463*)
13464
13465PROCEDURE GenQuadO (TokPos: CARDINAL;
13466 Operation: QuadOperator;
13467 Op1, Op2, Op3: CARDINAL; overflow: BOOLEAN) ;
b80e3c46
GM		 13468BEGIN
13469 GenQuadOTrash (TokPos, Operation, Op1, Op2, Op3, overflow, NulSym)
13470END GenQuadO ;
13471
13472
13473(*
13474 GenQuadOTrash - generate a quadruple with Operation, Op1, Op2, Op3, overflow.
13475*)
13476
13477PROCEDURE GenQuadOTrash (TokPos: CARDINAL;
13478 Operation: QuadOperator;
13479 Op1, Op2, Op3: CARDINAL;
13480 overflow: BOOLEAN; trash: CARDINAL) ;
1eee94d3
GM		 13481VAR
13482 f: QuadFrame ;
13483BEGIN
13484 (* WriteString('Potential Quad: ') ; *)
13485 IF QuadrupleGeneration
13486 THEN
13487 IF NextQuad # Head
13488 THEN
13489 f := GetQF (NextQuad-1) ;
13490 f^.Next := NextQuad
13491 END ;
13492 PutQuadO (NextQuad, Operation, Op1, Op2, Op3, overflow) ;
13493 f := GetQF (NextQuad) ;
13494 WITH f^ DO
b80e3c46 13495 Trash := trash ;
1eee94d3
GM		 13496 Next := 0 ;
13497 LineNo := GetLineNo () ;
13498 IF TokPos = UnknownTokenNo
13499 THEN
13500 TokenNo := GetTokenNo ()
13501 ELSE
13502 TokenNo := TokPos
1bafa6a3
GM		 13503 END ;
13504 IF GetDebugTraceQuad ()
13505 THEN
13506 printf0('generating: ') ;
13507 DisplayQuad (NextQuad) ;
13508 (* MetaErrorT1 (TokenNo, '{%1On}', NextQuad) *)
1eee94d3
GM		 13509 END
13510 END ;
13511 IF NextQuad=BreakAtQuad
13512 THEN
13513 stop
13514 END ;
1eee94d3
GM		 13515 NewQuad (NextQuad)
13516 END
b80e3c46
GM		 13517END GenQuadOTrash ;
13518
13519
13520(*
13521 GetQuadTrash - return the symbol associated with the trashed operand.
13522*)
13523
13524PROCEDURE GetQuadTrash (quad: CARDINAL) : CARDINAL ;
13525VAR
13526 f: QuadFrame ;
13527BEGIN
13528 f := GetQF (quad) ;
13529 LastQuadNo := quad ;
13530 RETURN f^.Trash
13531END GetQuadTrash ;
1eee94d3
GM		 13532
13533
13534(*
13535 GenQuad - Generate a quadruple with Operation, Op1, Op2, Op3.
13536*)
13537
13538PROCEDURE GenQuad (Operation: QuadOperator;
13539 Op1, Op2, Op3: CARDINAL) ;
13540BEGIN
13541 GenQuadO (UnknownTokenNo, Operation, Op1, Op2, Op3, TRUE)
13542END GenQuad ;
13543
13544
13545(*
13546 GenQuadOtok - generate a quadruple with Operation, Op1, Op2, Op3, overflow.
13547*)
13548
13549PROCEDURE GenQuadOtok (TokPos: CARDINAL;
13550 Operation: QuadOperator;
13551 Op1, Op2, Op3: CARDINAL; overflow: BOOLEAN;
13552 Op1Pos, Op2Pos, Op3Pos: CARDINAL) ;
161a67b2
GM		 13553BEGIN
13554 GenQuadOTypetok (TokPos, Operation, Op1, Op2, Op3, overflow, TRUE,
13555 Op1Pos, Op2Pos, Op3Pos)
13556END GenQuadOtok ;
13557
13558
13559(*
13560 GenQuadOTypetok - assigns the fields of the quadruple with
13561 the parameters.
13562*)
13563
13564PROCEDURE GenQuadOTypetok (TokPos: CARDINAL;
13565 Operation: QuadOperator;
13566 Op1, Op2, Op3: CARDINAL;
13567 overflow, typecheck: BOOLEAN;
13568 Op1Pos, Op2Pos, Op3Pos: CARDINAL) ;
1eee94d3
GM		 13569VAR
13570 f: QuadFrame ;
13571BEGIN
13572 (* WriteString('Potential Quad: ') ; *)
13573 IF QuadrupleGeneration
13574 THEN
13575 IF NextQuad # Head
13576 THEN
13577 f := GetQF (NextQuad-1) ;
13578 f^.Next := NextQuad
13579 END ;
161a67b2 13580 PutQuadOType (NextQuad, Operation, Op1, Op2, Op3, overflow, typecheck) ;
1eee94d3
GM		 13581 f := GetQF (NextQuad) ;
13582 WITH f^ DO
13583 Next := 0 ;
13584 LineNo := GetLineNo () ;
13585 IF TokPos = UnknownTokenNo
13586 THEN
13587 TokenNo := GetTokenNo ()
13588 ELSE
13589 TokenNo := TokPos
13590 END ;
13591 op1pos := Op1Pos ;
13592 op2pos := Op2Pos ;
1bafa6a3
GM		 13593 op3pos := Op3Pos ;
13594 IF GetDebugTraceQuad ()
13595 THEN
13596 printf0('generating: ') ;
13597 DisplayQuad (NextQuad) ;
13598 (* MetaErrorT1 (TokenNo, '{%1On}', NextQuad) *)
13599 END
1eee94d3
GM		 13600 END ;
13601 IF NextQuad=BreakAtQuad
13602 THEN
13603 stop
13604 END ;
1eee94d3
GM		 13605 NewQuad (NextQuad)
13606 END
161a67b2 13607END GenQuadOTypetok ;
1eee94d3
GM		 13608
13609
13610(*
48d49200
GM		 13611 DumpUntil - dump all quadruples until we seen the ending quadruple
13612 with procsym in the third operand.
13613 Return the quad number containing the match.
1eee94d3
GM		 13614*)
13615
48d49200
GM		 13616PROCEDURE DumpUntil (ending: QuadOperator;
13617 procsym: CARDINAL; quad: CARDINAL) : CARDINAL ;
13618VAR
13619 op : QuadOperator ;
13620 op1, op2, op3: CARDINAL ;
13621 f : QuadFrame ;
13622BEGIN
13623 fprintf0 (GetDumpFile (), '\n...\n\n');
13624 REPEAT
13625 GetQuad (quad, op, op1, op2, op3) ;
13626 DisplayQuad (quad) ;
13627 f := GetQF (quad) ;
13628 quad := f^.Next
13629 UNTIL (op = ending) AND (op3 = procsym) ;
13630 RETURN quad
13631END DumpUntil ;
13632
13633
13634(*
13635 GetCtorInit - return the init procedure for the module.
13636*)
13637
13638PROCEDURE GetCtorInit (sym: CARDINAL) : CARDINAL ;
13639VAR
13640 ctor, init, fini, dep: CARDINAL ;
13641BEGIN
13642 GetModuleCtors (sym, ctor, init, fini, dep) ;
13643 RETURN init
13644END GetCtorInit ;
13645
13646
13647(*
13648 GetCtorFini - return the fini procedure for the module.
13649*)
13650
13651PROCEDURE GetCtorFini (sym: CARDINAL) : CARDINAL ;
13652VAR
13653 ctor, init, fini, dep: CARDINAL ;
13654BEGIN
13655 GetModuleCtors (sym, ctor, init, fini, dep) ;
13656 RETURN fini
13657END GetCtorFini ;
13658
13659
13660(*
13661 DumpQuadrupleFilter -
13662*)
13663
13664PROCEDURE DumpQuadrupleFilter ;
13665VAR
13666 f : QuadFrame ;
13667 i : CARDINAL ;
13668 op : QuadOperator ;
13669 op1, op2, op3: CARDINAL ;
13670BEGIN
13671 i := Head ;
13672 WHILE i # 0 DO
13673 GetQuad (i, op, op1, op2, op3) ;
13674 IF (op = ProcedureScopeOp) AND IsDumpRequired (op3, TRUE)
13675 THEN
13676 i := DumpUntil (KillLocalVarOp, op3, i)
13677 ELSIF (op = InitStartOp) AND IsDumpRequired (GetCtorInit (op3), TRUE)
13678 THEN
13679 i := DumpUntil (InitEndOp, op3, i)
13680 ELSIF (op = FinallyStartOp) AND IsDumpRequired (GetCtorFini (op3), TRUE)
13681 THEN
13682 i := DumpUntil (FinallyEndOp, op3, i)
13683 ELSE
13684 f := GetQF (i) ;
13685 i := f^.Next
13686 END
13687 END
13688END DumpQuadrupleFilter ;
13689
13690
13691(*
13692 DumpQuadrupleAll - dump all quadruples.
13693*)
13694
13695PROCEDURE DumpQuadrupleAll ;
1eee94d3 13696VAR
1eee94d3 13697 f: QuadFrame ;
48d49200 13698 i: CARDINAL ;
1eee94d3 13699BEGIN
1eee94d3 13700 i := Head ;
48d49200
GM		 13701 WHILE i # 0 DO
13702 DisplayQuad (i) ;
13703 f := GetQF (i) ;
1eee94d3
GM		 13704 i := f^.Next
13705 END
48d49200
GM		 13706END DumpQuadrupleAll ;
13707
13708
13709(*
13710 DumpQuadruples - dump all quadruples providing the -fq, -fdump-lang-quad,
13711 -fdump-lang-quad= or -fdump-lang-all were issued to the
13712 command line.
13713*)
13714
13715PROCEDURE DumpQuadruples (title: ARRAY OF CHAR) ;
13716BEGIN
eadd05d5 13717 IF GetDumpQuad ()
48d49200
GM		 13718 THEN
13719 CreateDumpQuad (title) ;
13720 IF GetM2DumpFilter () = NIL
13721 THEN
13722 DumpQuadrupleAll
13723 ELSE
13724 DumpQuadrupleFilter
13725 END ;
13726 CloseDumpQuad
13727 END
13728END DumpQuadruples ;
1eee94d3
GM		 13729
13730
13731(*
13732 DisplayQuadRange - displays all quads in list range, start..end.
13733*)
13734
40b91158 13735PROCEDURE DisplayQuadRange (scope: CARDINAL; start, end: CARDINAL) ;
1eee94d3
GM		 13736VAR
13737 f: QuadFrame ;
13738BEGIN
48d49200 13739 fprintf1 (GetDumpFile (), 'Quadruples for scope: %d\n', scope) ;
40b91158
GM		 13740 WHILE (start <= end) AND (start # 0) DO
13741 DisplayQuad (start) ;
13742 f := GetQF (start) ;
1eee94d3
GM		 13743 start := f^.Next
13744 END
13745END DisplayQuadRange ;
13746
13747
13748(*
13749 BackPatch - Makes each of the quadruples on the list pointed to by
13750 StartQuad, take quadruple Value as a target.
13751*)
13752
13753PROCEDURE BackPatch (QuadNo, Value: CARDINAL) ;
13754VAR
13755 i: CARDINAL ;
13756 f: QuadFrame ;
13757BEGIN
13758 IF QuadrupleGeneration
13759 THEN
13760 WHILE QuadNo#0 DO
40b91158 13761 f := GetQF (QuadNo) ;
1eee94d3
GM		 13762 WITH f^ DO
13763 i := Operand3 ; (* Next Link along the BackPatch *)
40b91158 13764 ManipulateReference (QuadNo, Value) (* Filling in the BackPatch. *)
1eee94d3
GM		 13765 END ;
13766 QuadNo := i
13767 END
13768 END
13769END BackPatch ;
13770
13771
13772(*
13773 Merge - joins two quad lists, QuadList2 to the end of QuadList1.
13774 A QuadList of value zero is a nul list.
13775*)
13776
13777PROCEDURE Merge (QuadList1, QuadList2: CARDINAL) : CARDINAL ;
13778VAR
13779 i, j: CARDINAL ;
13780 f : QuadFrame ;
13781BEGIN
13782 IF QuadList1=0
13783 THEN
13784 RETURN( QuadList2 )
13785 ELSIF QuadList2=0
13786 THEN
13787 RETURN( QuadList1 )
13788 ELSE
13789 i := QuadList1 ;
13790 REPEAT
13791 j := i ;
13792 f := GetQF(i) ;
13793 i := f^.Operand3
13794 UNTIL i=0 ;
13795 ManipulateReference(j, QuadList2) ;
13796 RETURN( QuadList1 )
13797 END
13798END Merge ;
13799
13800
13801(*
13802 Annotate - annotate the top of stack.
13803*)
13804
13805PROCEDURE Annotate (a: ARRAY OF CHAR) ;
13806VAR
13807 f: BoolFrame ;
13808BEGIN
13809 IF DebugStackOn AND CompilerDebugging AND (NoOfItemsInStackAddress(BoolStack)>0)
13810 THEN
13811 f := PeepAddress(BoolStack, 1) ; (* top of stack *)
13812 WITH f^ DO
13813 IF Annotation#NIL
13814 THEN
13815 Annotation := KillString(Annotation)
13816 END ;
13817 Annotation := InitString(a)
13818 END
13819 END
13820END Annotate ;
13821
13822
13823(*
13824 OperandAnno - returns the annotation string associated with the
13825 position, n, on the stack.
13826*)
13827
13828PROCEDURE OperandAnno (n: CARDINAL) : String ;
13829VAR
13830 f: BoolFrame ;
13831BEGIN
13832 f := PeepAddress (BoolStack, n) ;
13833 RETURN f^.Annotation
13834END OperandAnno ;
13835
13836
13837(*
13838 DisplayStack - displays the compile time symbol stack.
13839*)
13840
13841PROCEDURE DisplayStack ;
13842BEGIN
13843 IF DebugStackOn AND CompilerDebugging
13844 THEN
13845 DebugStack (NoOfItemsInStackAddress (BoolStack),
13846 OperandTno, OperandFno, OperandA,
13847 OperandD, OperandRW, OperandTok, OperandAnno)
13848 END
13849END DisplayStack ;
13850
13851
13852(*
13853 ds - tiny procedure name, useful for calling from the gdb shell.
13854*)
13855
13856(*
13857PROCEDURE ds ;
13858BEGIN
13859 DisplayStack
13860END ds ;
13861*)
13862
13863
13864(*
13865 DisplayQuad - displays a quadruple, QuadNo.
13866*)
13867
13868PROCEDURE DisplayQuad (QuadNo: CARDINAL) ;
13869BEGIN
13870 DSdbEnter ;
48d49200 13871 fprintf1 (GetDumpFile (), '%4d ', QuadNo) ; WriteQuad(QuadNo) ; fprintf0 (GetDumpFile (), '\n') ;
1eee94d3
GM		 13872 DSdbExit
13873END DisplayQuad ;
13874
13875
13876(*
13877 DisplayProcedureAttributes -
13878*)
13879
13880PROCEDURE DisplayProcedureAttributes (proc: CARDINAL) ;
13881BEGIN
13882 IF IsCtor (proc)
13883 THEN
48d49200 13884 fprintf0 (GetDumpFile (), " (ctor)")
1eee94d3
GM		 13885 END ;
13886 IF IsPublic (proc)
13887 THEN
48d49200 13888 fprintf0 (GetDumpFile (), " (public)")
1eee94d3
GM		 13889 END ;
13890 IF IsExtern (proc)
13891 THEN
48d49200 13892 fprintf0 (GetDumpFile (), " (extern)")
1eee94d3
GM		 13893 END ;
13894 IF IsMonoName (proc)
13895 THEN
48d49200 13896 fprintf0 (GetDumpFile (), " (mononame)")
1eee94d3
GM		 13897 END
13898END DisplayProcedureAttributes ;
13899
13900
13901(*
13902 WriteQuad - Writes out the Quad BufferQuad.
13903*)
13904
13905PROCEDURE WriteQuad (BufferQuad: CARDINAL) ;
13906VAR
13907 n1, n2: Name ;
13908 f : QuadFrame ;
13909 n : Name ;
13910 l : CARDINAL ;
13911BEGIN
13912 f := GetQF(BufferQuad) ;
13913 WITH f^ DO
13914 WriteOperator(Operator) ;
4e3c8257
GM		 13915 fprintf1 (GetDumpFile (), ' [%d]', NoOfTimesReferenced) ;
13916 IF ConstExpr
13917 THEN
13918 fprintf0 (GetDumpFile (), ' const ')
13919 ELSE
13920 fprintf0 (GetDumpFile (), ' ')
13921 END ;
1eee94d3
GM		 13922 CASE Operator OF
13923
13924 HighOp : WriteOperand(Operand1) ;
48d49200 13925 fprintf1 (GetDumpFile (), ' %4d ', Operand2) ;
1eee94d3
GM		 13926 WriteOperand(Operand3) |
13927 InitAddressOp,
13928 SavePriorityOp,
13929 RestorePriorityOp,
13930 SubrangeLowOp,
13931 SubrangeHighOp,
13932 BecomesOp,
13933 InclOp,
13934 ExclOp,
13935 UnboundedOp,
13936 ReturnValueOp,
13937 FunctValueOp,
13938 NegateOp,
78b72ee5
GM		 13939 AddrOp,
13940 StringConvertCnulOp,
13941 StringConvertM2nulOp,
13942 StringLengthOp : WriteOperand(Operand1) ;
48d49200 13943 fprintf0 (GetDumpFile (), ' ') ;
1eee94d3
GM		 13944 WriteOperand(Operand3) |
13945 ElementSizeOp,
13946 IfInOp,
13947 IfNotInOp,
13948 IfNotEquOp,
13949 IfEquOp,
13950 IfLessOp,
13951 IfGreOp,
13952 IfLessEquOp,
13953 IfGreEquOp : WriteOperand(Operand1) ;
48d49200 13954 fprintf0 (GetDumpFile (), ' ') ;
1eee94d3 13955 WriteOperand(Operand2) ;
48d49200 13956 fprintf1 (GetDumpFile (), ' %4d', Operand3) |
1eee94d3
GM		 13957
13958 InlineOp,
13959 RetryOp,
13960 TryOp,
48d49200 13961 GotoOp : fprintf1 (GetDumpFile (), '%4d', Operand3) |
1eee94d3
GM		 13962
13963 StatementNoteOp : l := TokenToLineNo(Operand3, 0) ;
13964 n := GetTokenName (Operand3) ;
48d49200
GM		 13965 fprintf4 (GetDumpFile (), '%a:%d:%a (tokenno %d)', Operand1, l, n, Operand3) |
13966 LineNumberOp : fprintf2 (GetDumpFile (), '%a:%d', Operand1, Operand3) |
1eee94d3
GM		 13967
13968 EndFileOp : n1 := GetSymName(Operand3) ;
48d49200 13969 fprintf1 (GetDumpFile (), '%a', n1) |
1eee94d3
GM		 13970
13971 ThrowOp,
13972 ReturnOp,
13973 CallOp,
13974 KillLocalVarOp : WriteOperand(Operand3) |
13975
13976 ProcedureScopeOp : n1 := GetSymName(Operand2) ;
13977 n2 := GetSymName(Operand3) ;
48d49200 13978 fprintf3 (GetDumpFile (), ' %4d %a %a', Operand1, n1, n2) ;
1eee94d3
GM		 13979 DisplayProcedureAttributes (Operand3) |
13980 NewLocalVarOp,
13981 FinallyStartOp,
13982 FinallyEndOp,
13983 InitEndOp,
13984 InitStartOp : n1 := GetSymName(Operand2) ;
13985 n2 := GetSymName(Operand3) ;
48d49200 13986 fprintf3 (GetDumpFile (), ' %4d %a %a', Operand1, n1, n2) |
1eee94d3
GM		 13987
13988 ModuleScopeOp,
13989 StartModFileOp : n1 := GetSymName(Operand3) ;
48d49200 13990 fprintf4 (GetDumpFile (), '%a:%d %a(%d)', Operand2, Operand1, n1, Operand3) |
1eee94d3
GM		 13991
13992 StartDefFileOp : n1 := GetSymName(Operand3) ;
48d49200 13993 fprintf2 (GetDumpFile (), ' %4d %a', Operand1, n1) |
1eee94d3
GM		 13994
13995 OptParamOp,
48d49200 13996 ParamOp : fprintf1 (GetDumpFile (), '%4d ', Operand1) ;
1eee94d3 13997 WriteOperand(Operand2) ;
48d49200 13998 fprintf0 (GetDumpFile (), ' ') ;
1eee94d3
GM		 13999 WriteOperand(Operand3) |
14000 SizeOp,
14001 RecordFieldOp,
14002 IndrXOp,
14003 XIndrOp,
14004 ArrayOp,
14005 LogicalShiftOp,
14006 LogicalRotateOp,
14007 LogicalOrOp,
14008 LogicalAndOp,
14009 LogicalXorOp,
14010 LogicalDiffOp,
ac7c9954 14011 ArithAddOp,
1eee94d3
GM		 14012 CoerceOp,
14013 ConvertOp,
14014 CastOp,
14015 AddOp,
14016 SubOp,
14017 MultOp,
14018 DivM2Op,
14019 ModM2Op,
14020 ModFloorOp,
14021 DivCeilOp,
14022 ModCeilOp,
14023 DivFloorOp,
14024 ModTruncOp,
14025 DivTruncOp : WriteOperand(Operand1) ;
48d49200 14026 fprintf0 (GetDumpFile (), ' ') ;
1eee94d3 14027 WriteOperand(Operand2) ;
48d49200 14028 fprintf0 (GetDumpFile (), ' ') ;
1eee94d3
GM		 14029 WriteOperand(Operand3) |
14030 DummyOp,
14031 CodeOnOp,
14032 CodeOffOp,
14033 ProfileOnOp,
14034 ProfileOffOp,
14035 OptimizeOnOp,
14036 OptimizeOffOp : |
14037 BuiltinConstOp : WriteOperand(Operand1) ;
48d49200 14038 fprintf1 (GetDumpFile (), ' %a', Operand3) |
1eee94d3 14039 BuiltinTypeInfoOp : WriteOperand(Operand1) ;
48d49200
GM		 14040 fprintf1 (GetDumpFile (), ' %a', Operand2) ;
14041 fprintf1 (GetDumpFile (), ' %a', Operand3) |
1eee94d3 14042 StandardFunctionOp: WriteOperand(Operand1) ;
48d49200 14043 fprintf0 (GetDumpFile (), ' ') ;
1eee94d3 14044 WriteOperand(Operand2) ;
48d49200 14045 fprintf0 (GetDumpFile (), ' ') ;
1eee94d3
GM		 14046 WriteOperand(Operand3) |
14047 CatchBeginOp,
14048 CatchEndOp : |
14049
14050 RangeCheckOp,
48d49200 14051 ErrorOp : WriteRangeCheck (Operand3) |
1eee94d3
GM		 14052 SaveExceptionOp,
14053 RestoreExceptionOp: WriteOperand(Operand1) ;
48d49200 14054 fprintf0 (GetDumpFile (), ' ') ;
1eee94d3
GM		 14055 WriteOperand(Operand3)
14056
14057 ELSE
14058 InternalError ('quadruple not recognised')
14059 END
14060 END
14061END WriteQuad ;
14062
14063
14064(*
14065 WriteOperator - writes the name of the quadruple operator.
14066*)
14067
14068PROCEDURE WriteOperator (Operator: QuadOperator) ;
14069BEGIN
14070 CASE Operator OF
14071
48d49200
GM		 14072 ArithAddOp : fprintf0 (GetDumpFile (), 'Arith + ') |
14073 InitAddressOp : fprintf0 (GetDumpFile (), 'InitAddress ') |
14074 LogicalOrOp : fprintf0 (GetDumpFile (), 'Or ') |
14075 LogicalAndOp : fprintf0 (GetDumpFile (), 'And ') |
14076 LogicalXorOp : fprintf0 (GetDumpFile (), 'Xor ') |
14077 LogicalDiffOp : fprintf0 (GetDumpFile (), 'Ldiff ') |
14078 LogicalShiftOp : fprintf0 (GetDumpFile (), 'Shift ') |
14079 LogicalRotateOp : fprintf0 (GetDumpFile (), 'Rotate ') |
14080 BecomesOp : fprintf0 (GetDumpFile (), 'Becomes ') |
14081 IndrXOp : fprintf0 (GetDumpFile (), 'IndrX ') |
14082 XIndrOp : fprintf0 (GetDumpFile (), 'XIndr ') |
14083 ArrayOp : fprintf0 (GetDumpFile (), 'Array ') |
14084 ElementSizeOp : fprintf0 (GetDumpFile (), 'ElementSize ') |
14085 RecordFieldOp : fprintf0 (GetDumpFile (), 'RecordField ') |
14086 AddrOp : fprintf0 (GetDumpFile (), 'Addr ') |
14087 SizeOp : fprintf0 (GetDumpFile (), 'Size ') |
14088 IfInOp : fprintf0 (GetDumpFile (), 'If IN ') |
14089 IfNotInOp : fprintf0 (GetDumpFile (), 'If NOT IN ') |
14090 IfNotEquOp : fprintf0 (GetDumpFile (), 'If <> ') |
14091 IfEquOp : fprintf0 (GetDumpFile (), 'If = ') |
14092 IfLessEquOp : fprintf0 (GetDumpFile (), 'If <= ') |
14093 IfGreEquOp : fprintf0 (GetDumpFile (), 'If >= ') |
14094 IfGreOp : fprintf0 (GetDumpFile (), 'If > ') |
14095 IfLessOp : fprintf0 (GetDumpFile (), 'If < ') |
14096 GotoOp : fprintf0 (GetDumpFile (), 'Goto ') |
14097 DummyOp : fprintf0 (GetDumpFile (), 'Dummy ') |
14098 ModuleScopeOp : fprintf0 (GetDumpFile (), 'ModuleScopeOp ') |
14099 StartDefFileOp : fprintf0 (GetDumpFile (), 'StartDefFile ') |
14100 StartModFileOp : fprintf0 (GetDumpFile (), 'StartModFile ') |
14101 EndFileOp : fprintf0 (GetDumpFile (), 'EndFileOp ') |
14102 InitStartOp : fprintf0 (GetDumpFile (), 'InitStart ') |
14103 InitEndOp : fprintf0 (GetDumpFile (), 'InitEnd ') |
14104 FinallyStartOp : fprintf0 (GetDumpFile (), 'FinallyStart ') |
14105 FinallyEndOp : fprintf0 (GetDumpFile (), 'FinallyEnd ') |
14106 RetryOp : fprintf0 (GetDumpFile (), 'Retry ') |
14107 TryOp : fprintf0 (GetDumpFile (), 'Try ') |
14108 ThrowOp : fprintf0 (GetDumpFile (), 'Throw ') |
14109 CatchBeginOp : fprintf0 (GetDumpFile (), 'CatchBegin ') |
14110 CatchEndOp : fprintf0 (GetDumpFile (), 'CatchEnd ') |
14111 AddOp : fprintf0 (GetDumpFile (), '+ ') |
14112 SubOp : fprintf0 (GetDumpFile (), '- ') |
14113 DivM2Op : fprintf0 (GetDumpFile (), 'DIV M2 ') |
14114 ModM2Op : fprintf0 (GetDumpFile (), 'MOD M2 ') |
14115 DivCeilOp : fprintf0 (GetDumpFile (), 'DIV ceil ') |
14116 ModCeilOp : fprintf0 (GetDumpFile (), 'MOD ceil ') |
14117 DivFloorOp : fprintf0 (GetDumpFile (), 'DIV floor ') |
14118 ModFloorOp : fprintf0 (GetDumpFile (), 'MOD floor ') |
14119 DivTruncOp : fprintf0 (GetDumpFile (), 'DIV trunc ') |
14120 ModTruncOp : fprintf0 (GetDumpFile (), 'MOD trunc ') |
14121 MultOp : fprintf0 (GetDumpFile (), '* ') |
14122 NegateOp : fprintf0 (GetDumpFile (), 'Negate ') |
14123 InclOp : fprintf0 (GetDumpFile (), 'Incl ') |
14124 ExclOp : fprintf0 (GetDumpFile (), 'Excl ') |
14125 ReturnOp : fprintf0 (GetDumpFile (), 'Return ') |
14126 ReturnValueOp : fprintf0 (GetDumpFile (), 'ReturnValue ') |
14127 FunctValueOp : fprintf0 (GetDumpFile (), 'FunctValue ') |
14128 CallOp : fprintf0 (GetDumpFile (), 'Call ') |
14129 ParamOp : fprintf0 (GetDumpFile (), 'Param ') |
14130 OptParamOp : fprintf0 (GetDumpFile (), 'OptParam ') |
14131 NewLocalVarOp : fprintf0 (GetDumpFile (), 'NewLocalVar ') |
14132 KillLocalVarOp : fprintf0 (GetDumpFile (), 'KillLocalVar ') |
14133 ProcedureScopeOp : fprintf0 (GetDumpFile (), 'ProcedureScope ') |
14134 UnboundedOp : fprintf0 (GetDumpFile (), 'Unbounded ') |
14135 CoerceOp : fprintf0 (GetDumpFile (), 'Coerce ') |
14136 ConvertOp : fprintf0 (GetDumpFile (), 'Convert ') |
14137 CastOp : fprintf0 (GetDumpFile (), 'Cast ') |
14138 HighOp : fprintf0 (GetDumpFile (), 'High ') |
14139 CodeOnOp : fprintf0 (GetDumpFile (), 'CodeOn ') |
14140 CodeOffOp : fprintf0 (GetDumpFile (), 'CodeOff ') |
14141 ProfileOnOp : fprintf0 (GetDumpFile (), 'ProfileOn ') |
14142 ProfileOffOp : fprintf0 (GetDumpFile (), 'ProfileOff ') |
14143 OptimizeOnOp : fprintf0 (GetDumpFile (), 'OptimizeOn ') |
14144 OptimizeOffOp : fprintf0 (GetDumpFile (), 'OptimizeOff ') |
14145 InlineOp : fprintf0 (GetDumpFile (), 'Inline ') |
14146 StatementNoteOp : fprintf0 (GetDumpFile (), 'StatementNote ') |
14147 LineNumberOp : fprintf0 (GetDumpFile (), 'LineNumber ') |
14148 BuiltinConstOp : fprintf0 (GetDumpFile (), 'BuiltinConst ') |
14149 BuiltinTypeInfoOp : fprintf0 (GetDumpFile (), 'BuiltinTypeInfo ') |
14150 StandardFunctionOp : fprintf0 (GetDumpFile (), 'StandardFunction ') |
14151 SavePriorityOp : fprintf0 (GetDumpFile (), 'SavePriority ') |
14152 RestorePriorityOp : fprintf0 (GetDumpFile (), 'RestorePriority ') |
14153 RangeCheckOp : fprintf0 (GetDumpFile (), 'RangeCheck ') |
14154 ErrorOp : fprintf0 (GetDumpFile (), 'Error ') |
14155 SaveExceptionOp : fprintf0 (GetDumpFile (), 'SaveException ') |
14156 RestoreExceptionOp : fprintf0 (GetDumpFile (), 'RestoreException ') |
14157 StringConvertCnulOp : fprintf0 (GetDumpFile (), 'StringConvertCnul ') |
14158 StringConvertM2nulOp : fprintf0 (GetDumpFile (), 'StringConvertM2nul') |
14159 StringLengthOp : fprintf0 (GetDumpFile (), 'StringLength ') |
14160 SubrangeHighOp : fprintf0 (GetDumpFile (), 'SubrangeHigh ') |
14161 SubrangeLowOp : fprintf0 (GetDumpFile (), 'SubrangeLow ')
1eee94d3
GM		 14162
14163 ELSE
14164 InternalError ('operator not expected')
14165 END
14166END WriteOperator ;
14167
14168
14169(*
14170 WriteOperand - displays the operands name, symbol id and mode of addressing.
14171*)
14172
14173PROCEDURE WriteOperand (Sym: CARDINAL) ;
14174VAR
14175 n: Name ;
14176BEGIN
40b91158 14177 IF Sym = NulSym
1eee94d3 14178 THEN
48d49200 14179 fprintf0 (GetDumpFile (), '<nulsym>')
1eee94d3 14180 ELSE
40b91158 14181 n := GetSymName (Sym) ;
48d49200 14182 fprintf1 (GetDumpFile (), '%a', n) ;
40b91158 14183 IF IsVar (Sym) OR IsConst (Sym)
1eee94d3 14184 THEN
48d49200 14185 fprintf0 (GetDumpFile (), '[') ; WriteMode (GetMode (Sym)) ; fprintf0 (GetDumpFile (), ']')
1eee94d3 14186 END ;
48d49200 14187 fprintf1 (GetDumpFile (), '(%d)', Sym)
1eee94d3
GM		 14188 END
14189END WriteOperand ;
14190
14191
14192PROCEDURE WriteMode (Mode: ModeOfAddr) ;
14193BEGIN
14194 CASE Mode OF
14195
48d49200
GM		 14196 ImmediateValue: fprintf0 (GetDumpFile (), 'i') |
14197 NoValue : fprintf0 (GetDumpFile (), 'n') |
14198 RightValue : fprintf0 (GetDumpFile (), 'r') |
14199 LeftValue : fprintf0 (GetDumpFile (), 'l')
1eee94d3
GM		 14200
14201 ELSE
14202 InternalError ('unrecognised mode')
14203 END
14204END WriteMode ;
14205
14206
14207(*
14208 GetQuadOp - returns the operator for quad.
14209*)
14210
14211PROCEDURE GetQuadOp (quad: CARDINAL) : QuadOperator ;
14212VAR
14213 f: QuadFrame ;
14214BEGIN
14215 f := GetQF (quad) ;
14216 RETURN f^.Operator
14217END GetQuadOp ;
14218
14219
14220(*
14221 GetM2OperatorDesc - returns the Modula-2 string associated with the quad operator
14222 (if possible). It returns NIL if no there is not an obvious match
14223 in Modula-2. It is assummed that the string will be used during
14224 construction of error messages and therefore keywords are
14225 wrapped with a format specifier.
14226*)
14227
14228PROCEDURE GetM2OperatorDesc (op: QuadOperator) : String ;
14229BEGIN
14230 CASE op OF
14231
14232 NegateOp : RETURN InitString ('-') |
14233 AddOp : RETURN InitString ('+') |
14234 SubOp : RETURN InitString ('-') |
14235 MultOp : RETURN InitString ('*') |
14236 DivM2Op,
14237 DivCeilOp,
14238 DivFloorOp,
14239 DivTruncOp : RETURN InitString ('{%kDIV}') |
14240 ModM2Op,
14241 ModCeilOp,
14242 ModFloorOp : RETURN InitString ('{%kMOD}') |
14243 ModTruncOp : RETURN InitString ('{%kREM}') |
14244 LogicalOrOp : RETURN InitString ('{%kOR}') |
14245 LogicalAndOp: RETURN InitString ('{%kAND}') |
14246 InclOp : RETURN InitString ('{%kINCL}') |
40b91158
GM		 14247 ExclOp : RETURN InitString ('{%kEXCL}') |
14248 IfEquOp : RETURN InitString ('=') |
14249 IfLessEquOp : RETURN InitString ('<=') |
14250 IfGreEquOp : RETURN InitString ('>=') |
14251 IfGreOp : RETURN InitString ('>') |
14252 IfLessOp : RETURN InitString ('<') |
14253 IfNotEquOp : RETURN InitString ('#') |
14254 IfInOp : RETURN InitString ('IN') |
14255 IfNotInOp : RETURN InitString ('NOT IN')
1eee94d3
GM		 14256
14257 ELSE
14258 RETURN NIL
14259 END
14260END GetM2OperatorDesc ;
14261
14262
14263
14264(*
14265 PushExit - pushes the exit value onto the EXIT stack.
14266*)
14267
14268PROCEDURE PushExit (Exit: CARDINAL) ;
14269BEGIN
14270 PushWord(ExitStack, Exit)
14271END PushExit ;
14272
14273
14274(*
14275 PopExit - pops the exit value from the EXIT stack.
14276*)
14277
14278PROCEDURE PopExit() : WORD ;
14279BEGIN
14280 RETURN( PopWord(ExitStack) )
14281END PopExit ;
14282
14283
14284(*
14285 PushFor - pushes the exit value onto the FOR stack.
14286*)
14287
14288PROCEDURE PushFor (Exit: CARDINAL) ;
14289BEGIN
14290 PushWord(ForStack, Exit)
14291END PushFor ;
14292
14293
14294(*
14295 PopFor - pops the exit value from the FOR stack.
14296*)
14297
14298PROCEDURE PopFor() : WORD ;
14299BEGIN
14300 RETURN( PopWord(ForStack) )
14301END PopFor ;
14302
14303
14304(*
14305 OperandTno - returns the ident operand stored in the true position
14306 on the boolean stack. This is exactly the same as
14307 OperandT but it has no IsBoolean checking.
14308*)
14309
14310PROCEDURE OperandTno (pos: CARDINAL) : WORD ;
14311VAR
14312 f: BoolFrame ;
14313BEGIN
14314 Assert(pos>0) ;
14315 f := PeepAddress(BoolStack, pos) ;
14316 RETURN( f^.TrueExit )
14317END OperandTno ;
14318
14319
14320(*
14321 OperandFno - returns the ident operand stored in the false position
14322 on the boolean stack. This is exactly the same as
14323 OperandF but it has no IsBoolean checking.
14324*)
14325
14326PROCEDURE OperandFno (pos: CARDINAL) : WORD ;
14327VAR
14328 f: BoolFrame ;
14329BEGIN
14330 Assert(pos>0) ;
14331 f := PeepAddress (BoolStack, pos) ;
14332 RETURN f^.FalseExit
14333END OperandFno ;
14334
14335
14336(*
14337 OperandTtok - returns the token associated with the position, pos
14338 on the boolean stack.
14339*)
14340
14341PROCEDURE OperandTtok (pos: CARDINAL) : CARDINAL ;
14342VAR
14343 f: BoolFrame ;
14344BEGIN
14345 Assert (pos > 0) ;
14346 f := PeepAddress (BoolStack, pos) ;
14347 RETURN f^.tokenno
14348END OperandTtok ;
14349
14350
14351(*
c8f2be5d
GM		 14352 PopBooltok - Pops a True and a False exit quad number from the True/False
14353 stack.
1eee94d3
GM		 14354*)
14355
c8f2be5d 14356PROCEDURE PopBooltok (VAR True, False: CARDINAL; VAR tokno: CARDINAL) ;
1eee94d3
GM		 14357VAR
14358 f: BoolFrame ;
14359BEGIN
14360 f := PopAddress (BoolStack) ;
14361 WITH f^ DO
14362 True := TrueExit ;
14363 False := FalseExit ;
c8f2be5d 14364 tokno := tokenno ;
1eee94d3
GM		 14365 Assert (BooleanOp)
14366 END ;
14367 DISPOSE (f)
c8f2be5d 14368END PopBooltok ;
1eee94d3
GM		 14369
14370
14371(*
c8f2be5d
GM		 14372 PushBooltok - Push a True and a False exit quad numbers onto the
14373 True/False stack.
1eee94d3
GM		 14374*)
14375
c8f2be5d 14376PROCEDURE PushBooltok (True, False: CARDINAL; tokno: CARDINAL) ;
1eee94d3
GM		 14377VAR
14378 f: BoolFrame ;
14379BEGIN
c8f2be5d
GM		 14380 Assert (True<=NextQuad) ;
14381 Assert (False<=NextQuad) ;
14382 f := newBoolFrame () ;
1eee94d3
GM		 14383 WITH f^ DO
14384 TrueExit := True ;
14385 FalseExit := False ;
14386 BooleanOp := TRUE ;
c8f2be5d 14387 tokenno := tokno ;
1eee94d3
GM		 14388 Annotation := NIL
14389 END ;
14390 PushAddress (BoolStack, f) ;
14391 Annotate ('<q%1d>|<q%2d>||true quad|false quad')
c8f2be5d
GM		 14392END PushBooltok ;
14393
14394
14395(*
14396 PopBool - Pops a True and a False exit quad number from the True/False
14397 stack.
14398*)
14399
14400PROCEDURE PopBool (VAR True, False: CARDINAL) ;
14401VAR
14402 tokno: CARDINAL ;
14403BEGIN
14404 PopBooltok (True, False, tokno)
14405END PopBool ;
14406
14407
14408(*
14409 PushBool - Push a True and a False exit quad numbers onto the
14410 True/False stack.
14411*)
14412
14413PROCEDURE PushBool (True, False: CARDINAL) ;
14414BEGIN
14415 PushBooltok (True, False, UnknownTokenNo)
1eee94d3
GM		 14416END PushBool ;
14417
14418
14419(*
14420 IsBoolean - returns true is the Stack position pos contains a Boolean
14421 Exit. False is returned if an Ident is stored.
14422*)
14423
14424PROCEDURE IsBoolean (pos: CARDINAL) : BOOLEAN ;
14425VAR
14426 f: BoolFrame ;
14427BEGIN
14428 Assert(pos>0) ;
14429 f := PeepAddress(BoolStack, pos) ;
14430 RETURN( f^.BooleanOp )
14431END IsBoolean ;
14432
14433
14434(*
14435 OperandD - returns possible array dimension associated with the ident
14436 operand stored on the boolean stack.
14437*)
14438
14439PROCEDURE OperandD (pos: CARDINAL) : WORD ;
14440VAR
14441 f: BoolFrame ;
14442BEGIN
14443 Assert(pos>0) ;
14444 Assert(NOT IsBoolean (pos)) ;
14445 f := PeepAddress(BoolStack, pos) ;
14446 RETURN( f^.Dimension )
14447END OperandD ;
14448
14449
14450(*
14451 OperandA - returns possible array symbol associated with the ident
14452 operand stored on the boolean stack.
14453*)
14454
14455PROCEDURE OperandA (pos: CARDINAL) : WORD ;
14456VAR
14457 f: BoolFrame ;
14458BEGIN
14459 Assert(pos>0) ;
14460 Assert(NOT IsBoolean (pos)) ;
14461 f := PeepAddress(BoolStack, pos) ;
14462 RETURN( f^.Unbounded )
14463END OperandA ;
14464
14465
14466(*
14467 OperandT - returns the ident operand stored in the true position on the boolean stack.
14468*)
14469
14470PROCEDURE OperandT (pos: CARDINAL) : WORD ;
14471BEGIN
14472 Assert(NOT IsBoolean (pos)) ;
14473 RETURN( OperandTno(pos) )
14474END OperandT ;
14475
14476
14477(*
14478 OperandF - returns the ident operand stored in the false position on the boolean stack.
14479*)
14480
14481PROCEDURE OperandF (pos: CARDINAL) : WORD ;
14482BEGIN
14483 Assert(NOT IsBoolean (pos)) ;
14484 RETURN( OperandFno(pos) )
14485END OperandF ;
14486
14487
14488(*
14489 OperandRW - returns the rw operand stored on the boolean stack.
14490*)
14491
14492PROCEDURE OperandRW (pos: CARDINAL) : WORD ;
14493VAR
14494 f: BoolFrame ;
14495BEGIN
14496 Assert(pos>0) ;
14497 Assert(NOT IsBoolean (pos)) ;
14498 f := PeepAddress(BoolStack, pos) ;
14499 RETURN( f^.ReadWrite )
14500END OperandRW ;
14501
14502
14503(*
14504 OperandMergeRW - returns the rw operand if not NulSym else it
14505 returns True.
14506*)
14507
14508PROCEDURE OperandMergeRW (pos: CARDINAL) : WORD ;
14509BEGIN
14510 IF OperandRW (pos) = NulSym
14511 THEN
14512 RETURN OperandT (pos)
14513 ELSE
14514 RETURN OperandRW (pos)
14515 END
14516END OperandMergeRW ;
14517
14518
14519(*
14520 OperandTok - returns the token associated with pos, on the stack.
14521*)
14522
14523PROCEDURE OperandTok (pos: CARDINAL) : WORD ;
14524BEGIN
14525 Assert (NOT IsBoolean (pos)) ;
14526 RETURN OperandTtok (pos)
14527END OperandTok ;
14528
14529
14530(*
14531 BuildCodeOn - generates a quadruple declaring that code should be
14532 emmitted from henceforth.
14533
14534 The Stack is unnaffected.
14535*)
14536
14537PROCEDURE BuildCodeOn ;
14538BEGIN
14539 GenQuad(CodeOnOp, NulSym, NulSym, NulSym)
14540END BuildCodeOn ;
14541
14542
14543(*
14544 BuildCodeOff - generates a quadruple declaring that code should not be
14545 emmitted from henceforth.
14546
14547 The Stack is unnaffected.
14548*)
14549
14550PROCEDURE BuildCodeOff ;
14551BEGIN
14552 GenQuad(CodeOffOp, NulSym, NulSym, NulSym)
14553END BuildCodeOff ;
14554
14555
14556(*
14557 BuildProfileOn - generates a quadruple declaring that profile timings
14558 should be emmitted from henceforth.
14559
14560 The Stack is unnaffected.
14561*)
14562
14563PROCEDURE BuildProfileOn ;
14564BEGIN
14565 GenQuad(ProfileOnOp, NulSym, NulSym, NulSym)
14566END BuildProfileOn ;
14567
14568
14569(*
14570 BuildProfileOn - generates a quadruple declaring that profile timings
14571 should be emmitted from henceforth.
14572
14573 The Stack is unnaffected.
14574*)
14575
14576PROCEDURE BuildProfileOff ;
14577BEGIN
14578 GenQuad(ProfileOffOp, NulSym, NulSym, NulSym)
14579END BuildProfileOff ;
14580
14581
14582(*
14583 BuildOptimizeOn - generates a quadruple declaring that optimization
14584 should occur from henceforth.
14585
14586 The Stack is unnaffected.
14587*)
14588
14589PROCEDURE BuildOptimizeOn ;
14590BEGIN
14591 GenQuad(OptimizeOnOp, NulSym, NulSym, NulSym)
14592END BuildOptimizeOn ;
14593
14594
14595(*
14596 BuildOptimizeOff - generates a quadruple declaring that optimization
14597 should not occur from henceforth.
14598
14599 The Stack is unnaffected.
14600*)
14601
14602PROCEDURE BuildOptimizeOff ;
14603BEGIN
990d10ab 14604 GenQuad (OptimizeOffOp, NulSym, NulSym, NulSym)
1eee94d3
GM		 14605END BuildOptimizeOff ;
14606
14607
14608(*
c4637cbe
GM		 14609 BuildAsm - builds an Inline pseudo quadruple operator.
14610 The inline interface, Sym, is stored as the operand
14611 to the operator InlineOp.
1eee94d3 14612
c4637cbe 14613 The stack is expected to contain:
1eee94d3
GM		 14614
14615
14616 Entry Exit
14617 ===== ====
14618
c4637cbe
GM		 14619 Ptr ->
14620 +--------------+
14621 | Sym | Empty
14622 |--------------|
1eee94d3
GM		 14623*)
14624
c4637cbe 14625PROCEDURE BuildAsm (tok: CARDINAL) ;
1eee94d3
GM		 14626VAR
14627 Sym: CARDINAL ;
14628BEGIN
990d10ab 14629 PopT (Sym) ;
c4637cbe
GM		 14630 GenQuadO (tok, InlineOp, NulSym, NulSym, Sym, FALSE)
14631END BuildAsm ;
1eee94d3
GM		 14632
14633
14634(*
14635 BuildLineNo - builds a LineNumberOp pseudo quadruple operator.
14636 This quadruple indicates which source line has been
14637 processed, these quadruples are only generated if we
14638 are producing runtime debugging information.
14639
14640 The stack is not affected, read or altered in any way.
14641
14642
14643 Entry Exit
14644 ===== ====
14645
14646 Ptr -> <- Ptr
14647*)
14648
14649PROCEDURE BuildLineNo ;
14650VAR
14651 filename: Name ;
14652 f : QuadFrame ;
14653BEGIN
14654 IF (NextQuad#Head) AND (GenerateLineDebug OR GenerateDebugging) AND FALSE
14655 THEN
990d10ab
GM		 14656 filename := makekey (string (GetFileName ())) ;
14657 f := GetQF (NextQuad-1) ;
14658 IF NOT ((f^.Operator = LineNumberOp) AND (f^.Operand1 = WORD (filename)))
1eee94d3 14659 THEN
990d10ab 14660 GenQuad (LineNumberOp, WORD (filename), NulSym, WORD (GetLineNo ()))
1eee94d3
GM		 14661 END
14662 END
14663END BuildLineNo ;
14664
14665
14666(*
14667 UseLineNote - uses the line note and returns it to the free list.
14668*)
14669
14670PROCEDURE UseLineNote (l: LineNote) ;
14671VAR
14672 f: QuadFrame ;
14673BEGIN
14674 WITH l^ DO
990d10ab
GM		 14675 f := GetQF (NextQuad-1) ;
14676 IF (f^.Operator = LineNumberOp) AND (f^.Operand1 = WORD (File))
1eee94d3
GM		 14677 THEN
14678 (* do nothing *)
14679 ELSE
14680 IF FALSE
14681 THEN
990d10ab 14682 GenQuad (LineNumberOp, WORD (File), NulSym, WORD (Line))
1eee94d3
GM		 14683 END
14684 END ;
14685 Next := FreeLineList
14686 END ;
14687 FreeLineList := l
14688END UseLineNote ;
14689
14690
14691(*
14692 PopLineNo - pops a line note from the line stack.
14693*)
14694
14695PROCEDURE PopLineNo () : LineNote ;
14696VAR
14697 l: LineNote ;
14698BEGIN
14699 l := PopAddress(LineStack) ;
14700 IF l=NIL
14701 THEN
14702 InternalError ('no line note available')
14703 END ;
14704 RETURN( l )
14705END PopLineNo ;
14706
14707
14708(*
14709 InitLineNote - creates a line note and initializes it to
14710 contain, file, line.
14711*)
14712
14713PROCEDURE InitLineNote (file: Name; line: CARDINAL) : LineNote ;
14714VAR
14715 l: LineNote ;
14716BEGIN
14717 IF FreeLineList=NIL
14718 THEN
14719 NEW(l)
14720 ELSE
14721 l := FreeLineList ;
14722 FreeLineList := FreeLineList^.Next
14723 END ;
14724 WITH l^ DO
14725 File := file ;
14726 Line := line
14727 END ;
14728 RETURN( l )
14729END InitLineNote ;
14730
14731
14732(*
14733 PushLineNote -
14734*)
14735
14736PROCEDURE PushLineNote (l: LineNote) ;
14737BEGIN
14738 PushAddress(LineStack, l)
14739END PushLineNote ;
14740
14741
14742(*
14743 PushLineNo - pushes the current file and line number to the stack.
14744*)
14745
14746PROCEDURE PushLineNo ;
14747BEGIN
14748 PushLineNote(InitLineNote(makekey(string(GetFileName())), GetLineNo()))
14749END PushLineNo ;
14750
14751
14752(*
14753 BuildStmtNote - builds a StatementNoteOp pseudo quadruple operator.
14754 This quadruple indicates which source line has been
14755 processed and it represents the start of a statement
14756 sequence.
14757 It differs from LineNumberOp in that multiple successive
14758 LineNumberOps will be removed and the final one is attached to
14759 the next real GCC tree. Whereas a StatementNoteOp is always left
14760 alone. Depending upon the debugging level it will issue a nop
14761 instruction to ensure that the gdb single step will step into
14762 this line. Practically it allows pedalogical debugging to
14763 occur when there is syntax sugar such as:
14764
14765
14766 END (* step *)
14767 END (* step *)
14768 END ; (* step *)
14769 a := 1 ; (* step *)
14770
14771 REPEAT (* step *)
14772 i := 1 (* step *)
14773
14774 The stack is not affected, read or altered in any way.
14775
14776
14777 Entry Exit
14778 ===== ====
14779
14780 Ptr -> <- Ptr
14781*)
14782
14783PROCEDURE BuildStmtNote (offset: INTEGER) ;
14784VAR
66132b1f 14785 tokenno: INTEGER ;
1eee94d3
GM		 14786BEGIN
14787 IF NextQuad#Head
14788 THEN
66132b1f
GM		 14789 tokenno := offset ;
14790 INC (tokenno, GetTokenNo ()) ;
14791 BuildStmtNoteTok (VAL(CARDINAL, tokenno))
1eee94d3
GM		 14792 END
14793END BuildStmtNote ;
14794
14795
66132b1f
GM		 14796(*
14797 BuildStmtNoteTok - adds a nop (with an assigned tokenno location) to the code.
14798*)
14799
14800PROCEDURE BuildStmtNoteTok (tokenno: CARDINAL) ;
14801VAR
14802 filename: Name ;
14803 f : QuadFrame ;
14804BEGIN
14805 f := GetQF (NextQuad-1) ;
14806 (* no need to have multiple notes at the same position. *)
14807 IF (f^.Operator # StatementNoteOp) OR (f^.Operand3 # tokenno)
14808 THEN
14809 filename := makekey (string (GetFileName ())) ;
14810 GenQuad (StatementNoteOp, WORD (filename), NulSym, tokenno)
14811 END
14812END BuildStmtNoteTok ;
14813
14814
1eee94d3
GM		 14815(*
14816 AddRecordToList - adds the record held on the top of stack to the
14817 list of records and varient fields.
14818*)
14819
14820PROCEDURE AddRecordToList ;
14821VAR
14822 r: CARDINAL ;
14823 n: CARDINAL ;
14824BEGIN
14825 r := OperandT(1) ;
14826 Assert(IsRecord(r) OR IsFieldVarient(r)) ;
14827 (*
14828 r might be a field varient if the declaration consists of nested
14829 varients. However ISO TSIZE can only utilise record types, we store
14830 a varient field anyway as the next pass would not know whether to
14831 ignore a varient field.
14832 *)
14833 PutItemIntoList (VarientFields, r) ;
14834 IF DebugVarients
14835 THEN
14836 n := NoOfItemsInList(VarientFields) ;
14837 IF IsRecord(r)
14838 THEN
14839 printf2('in list: record %d is %d\n', n, r)
14840 ELSE
14841 printf2('in list: varient field %d is %d\n', n, r)
14842 END
14843 END
14844END AddRecordToList ;
14845
14846
14847(*
14848 AddVarientToList - adds varient held on the top of stack to the list.
14849*)
14850
14851PROCEDURE AddVarientToList ;
14852VAR
14853 v, n: CARDINAL ;
14854BEGIN
14855 v := OperandT(1) ;
14856 Assert(IsVarient(v)) ;
14857 PutItemIntoList(VarientFields, v) ;
14858 IF DebugVarients
14859 THEN
14860 n := NoOfItemsInList(VarientFields) ;
14861 printf2('in list: varient %d is %d\n', n, v)
14862 END
14863END AddVarientToList ;
14864
14865
14866(*
14867 AddVarientFieldToList - adds varient field, f, to the list of all varient
14868 fields created.
14869*)
14870
14871PROCEDURE AddVarientFieldToList (f: CARDINAL) ;
14872VAR
14873 n: CARDINAL ;
14874BEGIN
14875 Assert(IsFieldVarient(f)) ;
14876 PutItemIntoList(VarientFields, f) ;
14877 IF DebugVarients
14878 THEN
14879 n := NoOfItemsInList(VarientFields) ;
14880 printf2('in list: varient field %d is %d\n', n, f)
14881 END
14882END AddVarientFieldToList ;
14883
14884
14885(*
14886 GetRecordOrField -
14887*)
14888
14889PROCEDURE GetRecordOrField () : CARDINAL ;
14890VAR
14891 f: CARDINAL ;
14892BEGIN
14893 INC(VarientFieldNo) ;
14894 f := GetItemFromList(VarientFields, VarientFieldNo) ;
14895 IF DebugVarients
14896 THEN
14897 IF IsRecord(f)
14898 THEN
14899 printf2('out list: record %d is %d\n', VarientFieldNo, f)
14900 ELSE
14901 printf2('out list: varient field %d is %d\n', VarientFieldNo, f)
14902 END
14903 END ;
14904 RETURN( f )
14905END GetRecordOrField ;
14906
14907
14908(*
14909 BeginVarient - begin a varient record.
14910*)
14911
14912PROCEDURE BeginVarient ;
14913VAR
14914 r, v: CARDINAL ;
14915BEGIN
14916 r := GetRecordOrField() ;
14917 Assert(IsRecord(r) OR IsFieldVarient(r)) ;
14918 v := GetRecordOrField() ;
14919 Assert(IsVarient(v)) ;
89b58667 14920 BuildRange(InitCaseBounds(PushCase(r, v, NulSym)))
1eee94d3
GM		 14921END BeginVarient ;
14922
14923
14924(*
14925 EndVarient - end a varient record.
14926*)
14927
14928PROCEDURE EndVarient ;
14929BEGIN
14930 PopCase
14931END EndVarient ;
14932
14933
14934(*
14935 ElseVarient - associate an ELSE clause with a varient record.
14936*)
14937
14938PROCEDURE ElseVarient ;
14939VAR
14940 f: CARDINAL ;
14941BEGIN
14942 f := GetRecordOrField() ;
14943 Assert(IsFieldVarient(f)) ;
14944 ElseCase(f)
14945END ElseVarient ;
14946
14947
14948
14949(*
14950 BeginVarientList - begin an ident list containing ranges belonging to a
14951 varient list.
14952*)
14953
14954PROCEDURE BeginVarientList ;
14955VAR
14956 f: CARDINAL ;
14957BEGIN
14958 f := GetRecordOrField() ;
14959 Assert(IsFieldVarient(f)) ;
14960 BeginCaseList(f)
14961END BeginVarientList ;
14962
14963
14964(*
14965 EndVarientList - end a range list for a varient field.
14966*)
14967
14968PROCEDURE EndVarientList ;
14969BEGIN
14970 EndCaseList
14971END EndVarientList ;
14972
14973
14974(*
14975 AddVarientRange - creates a range from the top two contant expressions
14976 on the stack which are recorded with the current
14977 varient field. The stack is unaltered.
14978*)
14979
14980PROCEDURE AddVarientRange ;
14981VAR
14982 r1, r2: CARDINAL ;
14983BEGIN
14984 PopT(r2) ;
14985 PopT(r1) ;
14986 AddRange(r1, r2, GetTokenNo())
14987END AddVarientRange ;
14988
14989
14990(*
14991 AddVarientEquality - adds the contant expression on the top of the stack
14992 to the current varient field being recorded.
14993 The stack is unaltered.
14994*)
14995
14996PROCEDURE AddVarientEquality ;
14997VAR
14998 r1: CARDINAL ;
14999BEGIN
15000 PopT(r1) ;
15001 AddRange(r1, NulSym, GetTokenNo())
15002END AddVarientEquality ;
15003
15004
990d10ab
GM		 15005(*
15006 BuildAsmElement - the stack is expected to contain:
15007
15008
15009 Entry Exit
15010 ===== ====
15011
15012 Ptr ->
15013 +------------------+
15014 | expr | tokpos |
15015 |------------------|
15016 | str |
15017 |------------------|
15018 | name |
15019 |------------------| +------------------+
15020 | CurrentInterface | | CurrentInterface |
15021 |------------------| |------------------|
15022 | CurrentAsm | | CurrentAsm |
15023 |------------------| |------------------|
15024 | n | | n |
15025 |------------------| |------------------|
15026*)
15027
bf470895 15028PROCEDURE BuildAsmElement (input, output: BOOLEAN) ;
c4637cbe
GM		 15029CONST
15030 DebugAsmTokPos = FALSE ;
990d10ab 15031VAR
c4637cbe 15032 s : String ;
990d10ab
GM		 15033 n, str, expr, tokpos,
15034 CurrentInterface,
15035 CurrentAsm, name : CARDINAL ;
15036BEGIN
15037 PopTtok (expr, tokpos) ;
15038 PopT (str) ;
15039 PopT (name) ;
15040 PopT (CurrentInterface) ;
15041 PopT (CurrentAsm) ;
15042 Assert (IsGnuAsm (CurrentAsm) OR IsGnuAsmVolatile (CurrentAsm)) ;
15043 PopT (n) ;
15044 INC (n) ;
15045 IF CurrentInterface = NulSym
15046 THEN
15047 CurrentInterface := MakeRegInterface ()
15048 END ;
15049 IF input
15050 THEN
15051 PutRegInterface (tokpos, CurrentInterface, n, name, str, expr,
c4637cbe
GM		 15052 NextQuad, 0) ;
15053 IF DebugAsmTokPos
15054 THEN
15055 s := InitString ('input expression') ;
15056 WarnStringAt (s, tokpos)
15057 END
990d10ab
GM		 15058 END ;
15059 IF output
15060 THEN
15061 PutRegInterface (tokpos, CurrentInterface, n, name, str, expr,
c4637cbe
GM		 15062 0, NextQuad) ;
15063 IF DebugAsmTokPos
15064 THEN
15065 s := InitString ('output expression') ;
15066 WarnStringAt (s, tokpos)
15067 END
990d10ab 15068 END ;
bf470895
GM		 15069 PushT (n) ;
15070 PushT (CurrentAsm) ;
15071 PushT (CurrentInterface)
15072END BuildAsmElement ;
15073
15074
15075(*
15076 BuildAsmTrash - the stack is expected to contain:
15077
15078
15079 Entry Exit
15080 ===== ====
15081
15082 Ptr ->
15083 +------------------+
15084 | expr | tokpos |
15085 |------------------| +------------------+
15086 | CurrentInterface | | CurrentInterface |
15087 |------------------| |------------------|
15088 | CurrentAsm | | CurrentAsm |
15089 |------------------| |------------------|
15090 | n | | n |
15091 |------------------| |------------------|
15092*)
15093
15094PROCEDURE BuildAsmTrash ;
15095VAR
15096 n, expr, tokpos,
15097 CurrentInterface,
15098 CurrentAsm : CARDINAL ;
15099BEGIN
15100 PopTtok (expr, tokpos) ;
15101 PopT (CurrentInterface) ;
15102 PopT (CurrentAsm) ;
15103 Assert (IsGnuAsm (CurrentAsm) OR IsGnuAsmVolatile (CurrentAsm)) ;
15104 PopT (n) ;
15105 INC (n) ;
15106 IF CurrentInterface = NulSym
990d10ab 15107 THEN
bf470895 15108 CurrentInterface := MakeRegInterface ()
990d10ab 15109 END ;
bf470895
GM		 15110 PutRegInterface (tokpos, CurrentInterface, n, NulName, NulSym, expr,
15111 0, NextQuad) ;
990d10ab
GM		 15112 PushT (n) ;
15113 PushT (CurrentAsm) ;
15114 PushT (CurrentInterface)
bf470895 15115END BuildAsmTrash ;
990d10ab
GM		 15116
15117
1eee94d3
GM		 15118(*
15119 IncOperandD - increment the dimension number associated with symbol
15120 at, pos, on the boolean stack.
15121*)
15122
15123(*
15124PROCEDURE IncOperandD (pos: CARDINAL) ;
15125VAR
15126 f: BoolFrame ;
15127BEGIN
15128 f := PeepAddress(BoolStack, pos) ;
15129 INC(f^.Dimension)
15130END IncOperandD ;
15131*)
15132
15133
15134(*
15135 PushTFA - Push True, False, Array, numbers onto the
15136 True/False stack. True and False are assumed to
15137 contain Symbols or Ident etc.
15138*)
15139
15140PROCEDURE PushTFA (True, False, Array: WORD) ;
15141VAR
15142 f: BoolFrame ;
15143BEGIN
15144 f := newBoolFrame () ;
15145 WITH f^ DO
15146 TrueExit := True ;
15147 FalseExit := False ;
15148 Unbounded := Array
15149 END ;
15150 PushAddress(BoolStack, f)
15151END PushTFA ;
15152
15153
15154(*
15155 PushTFAD - Push True, False, Array, Dim, numbers onto the
15156 True/False stack. True and False are assumed to
15157 contain Symbols or Ident etc.
15158*)
15159
15160PROCEDURE PushTFAD (True, False, Array, Dim: WORD) ;
15161VAR
15162 f: BoolFrame ;
15163BEGIN
15164 f := newBoolFrame () ;
15165 WITH f^ DO
15166 TrueExit := True ;
15167 FalseExit := False ;
15168 Unbounded := Array ;
15169 Dimension := Dim
15170 END ;
15171 PushAddress(BoolStack, f)
15172END PushTFAD ;
15173
15174
15175(*
15176 PushTFADtok - Push True, False, Array, Dim, numbers onto the
15177 True/False stack. True and False are assumed to
15178 contain Symbols or Ident etc.
15179*)
15180
15181PROCEDURE PushTFADtok (True, False, Array, Dim: WORD; tokno: CARDINAL) ;
15182VAR
15183 f: BoolFrame ;
15184BEGIN
15185 f := newBoolFrame () ;
15186 WITH f^ DO
15187 TrueExit := True ;
15188 FalseExit := False ;
15189 Unbounded := Array ;
15190 Dimension := Dim ;
15191 tokenno := tokno
15192 END ;
15193 PushAddress (BoolStack, f)
15194END PushTFADtok ;
15195
15196
15197(*
15198 PushTFADrwtok - Push True, False, Array, Dim, rw, numbers onto the
15199 True/False stack. True and False are assumed to
15200 contain Symbols or Ident etc.
15201*)
15202
15203PROCEDURE PushTFADrwtok (True, False, Array, Dim, rw: WORD; Tok: CARDINAL) ;
15204VAR
15205 f: BoolFrame ;
15206BEGIN
15207 f := newBoolFrame () ;
15208 WITH f^ DO
15209 TrueExit := True ;
15210 FalseExit := False ;
15211 Unbounded := Array ;
15212 Dimension := Dim ;
15213 ReadWrite := rw ;
15214 tokenno := Tok
15215 END ;
15216 PushAddress (BoolStack, f)
15217END PushTFADrwtok ;
15218
15219
15220(*
15221 PopTFrwtok - Pop a True and False number from the True/False stack.
15222 True and False are assumed to contain Symbols or Ident etc.
15223*)
15224
15225PROCEDURE PopTFrwtok (VAR True, False, rw: WORD; VAR tokno: CARDINAL) ;
15226VAR
15227 f: BoolFrame ;
15228BEGIN
15229 f := PopAddress(BoolStack) ;
15230 WITH f^ DO
15231 True := TrueExit ;
15232 False := FalseExit ;
15233 Assert(NOT BooleanOp) ;
15234 rw := ReadWrite ;
15235 tokno := tokenno
15236 END ;
15237 DISPOSE(f)
15238END PopTFrwtok ;
15239
15240
15241(*
15242 PushTFrwtok - Push an item onto the stack in the T (true) position,
15243 it is assummed to be a token and its token location is recorded.
15244*)
15245
15246PROCEDURE PushTFrwtok (True, False, rw: WORD; tokno: CARDINAL) ;
15247VAR
15248 f: BoolFrame ;
15249BEGIN
15250 f := newBoolFrame () ;
15251 WITH f^ DO
15252 TrueExit := True ;
15253 FalseExit := False ;
15254 ReadWrite := rw ;
15255 tokenno := tokno
15256 END ;
15257 PushAddress(BoolStack, f)
15258END PushTFrwtok ;
15259
15260
15261(*
15262 PushTFDtok - Push True, False, Dim, numbers onto the
15263 True/False stack. True and False are assumed to
15264 contain Symbols or Ident etc.
15265*)
15266
15267PROCEDURE PushTFDtok (True, False, Dim: WORD; Tok: CARDINAL) ;
15268VAR
15269 f: BoolFrame ;
15270BEGIN
15271 f := newBoolFrame () ;
15272 WITH f^ DO
15273 TrueExit := True ;
15274 FalseExit := False ;
15275 Dimension := Dim ;
15276 tokenno := Tok
15277 END ;
15278 PushAddress (BoolStack, f)
15279END PushTFDtok ;
15280
15281
15282(*
15283 PopTFDtok - Pop a True, False, Dim number from the True/False stack.
15284 True and False are assumed to contain Symbols or Ident etc.
15285*)
15286
15287PROCEDURE PopTFDtok (VAR True, False, Dim: WORD; VAR Tok: CARDINAL) ;
15288VAR
15289 f: BoolFrame ;
15290BEGIN
15291 f := PopAddress(BoolStack) ;
15292 WITH f^ DO
15293 True := TrueExit ;
15294 False := FalseExit ;
15295 Dim := Dimension ;
15296 Tok := tokenno ;
15297 Assert(NOT BooleanOp)
15298 END ;
15299 DISPOSE(f)
15300END PopTFDtok ;
15301
15302
15303(*
15304 PushTFDrwtok - Push True, False, Dim, numbers onto the
15305 True/False stack. True and False are assumed to
15306 contain Symbols or Ident etc.
15307*)
15308
15309PROCEDURE PushTFDrwtok (True, False, Dim, rw: WORD; Tok: CARDINAL) ;
15310VAR
15311 f: BoolFrame ;
15312BEGIN
15313 f := newBoolFrame () ;
15314 WITH f^ DO
15315 TrueExit := True ;
15316 FalseExit := False ;
15317 Dimension := Dim ;
15318 ReadWrite := rw ;
15319 tokenno := Tok
15320 END ;
15321 PushAddress (BoolStack, f)
15322END PushTFDrwtok ;
15323
15324
15325(*
15326 PushTFrw - Push a True and False numbers onto the True/False stack.
15327 True and False are assumed to contain Symbols or Ident etc.
15328 It also pushes the higher level symbol which is associated
15329 with the True symbol. Eg record variable or array variable.
15330*)
15331
15332PROCEDURE PushTFrw (True, False: WORD; rw: CARDINAL) ;
15333VAR
15334 f: BoolFrame ;
15335BEGIN
15336 f := newBoolFrame () ;
15337 WITH f^ DO
15338 TrueExit := True ;
15339 FalseExit := False ;
15340 ReadWrite := rw
15341 END ;
15342 PushAddress(BoolStack, f)
15343END PushTFrw ;
15344
15345
15346(*
15347 PopTFrw - Pop a True and False number from the True/False stack.
15348 True and False are assumed to contain Symbols or Ident etc.
15349*)
15350
15351PROCEDURE PopTFrw (VAR True, False, rw: WORD) ;
15352VAR
15353 f: BoolFrame ;
15354BEGIN
15355 f := PopAddress(BoolStack) ;
15356 WITH f^ DO
15357 True := TrueExit ;
15358 False := FalseExit ;
15359 Assert(NOT BooleanOp) ;
15360 rw := ReadWrite
15361 END ;
15362 DISPOSE(f)
15363END PopTFrw ;
15364
15365
15366(*
15367 PushTF - Push a True and False numbers onto the True/False stack.
15368 True and False are assumed to contain Symbols or Ident etc.
15369*)
15370
15371PROCEDURE PushTF (True, False: WORD) ;
15372VAR
15373 f: BoolFrame ;
15374BEGIN
15375 f := newBoolFrame () ;
15376 WITH f^ DO
15377 TrueExit := True ;
15378 FalseExit := False
15379 END ;
15380 PushAddress(BoolStack, f)
15381END PushTF ;
15382
15383
15384(*
15385 PopTF - Pop a True and False number from the True/False stack.
15386 True and False are assumed to contain Symbols or Ident etc.
15387*)
15388
15389PROCEDURE PopTF (VAR True, False: WORD) ;
15390VAR
15391 f: BoolFrame ;
15392BEGIN
15393 f := PopAddress(BoolStack) ;
15394 WITH f^ DO
15395 True := TrueExit ;
15396 False := FalseExit ;
15397 Assert(NOT BooleanOp)
15398 END ;
15399 DISPOSE(f)
15400END PopTF ;
15401
15402
15403(*
15404 newBoolFrame - creates a new BoolFrame with all fields initialised to their defaults.
15405*)
15406
15407PROCEDURE newBoolFrame () : BoolFrame ;
15408VAR
15409 f: BoolFrame ;
15410BEGIN
c8f2be5d 15411 NEW (f) ;
1eee94d3
GM		 15412 WITH f^ DO
15413 TrueExit := 0 ;
15414 FalseExit := 0 ;
15415 Unbounded := NulSym ;
15416 BooleanOp := FALSE ;
15417 Dimension := 0 ;
15418 ReadWrite := NulSym ;
15419 name := NulSym ;
15420 Annotation := NIL ;
15421 tokenno := UnknownTokenNo
15422 END ;
15423 RETURN f
15424END newBoolFrame ;
15425
15426
15427(*
15428 PushTtok - Push an item onto the stack in the T (true) position,
15429 it is assummed to be a token and its token location is recorded.
15430*)
15431
15432PROCEDURE PushTtok (True: WORD; tokno: CARDINAL) ;
15433VAR
15434 f: BoolFrame ;
15435BEGIN
15436 (* PrintTokenNo (tokno) ; *)
15437 f := newBoolFrame () ;
15438 WITH f^ DO
15439 TrueExit := True ;
15440 tokenno := tokno
15441 END ;
15442 PushAddress (BoolStack, f)
15443END PushTtok ;
15444
15445
15446(*
15447 PushT - Push an item onto the stack in the T (true) position.
15448*)
15449
15450PROCEDURE PushT (True: WORD) ;
15451VAR
15452 f: BoolFrame ;
15453BEGIN
15454 f := newBoolFrame () ;
15455 WITH f^ DO
15456 TrueExit := True
15457 END ;
c8f2be5d 15458 PushAddress (BoolStack, f)
1eee94d3
GM		 15459END PushT ;
15460
15461
15462(*
15463 PopT - Pops the T value from the stack.
15464*)
15465
15466PROCEDURE PopT (VAR True: WORD) ;
15467VAR
15468 f: BoolFrame ;
15469BEGIN
c8f2be5d 15470 f := PopAddress (BoolStack) ;
1eee94d3
GM		 15471 WITH f^ DO
15472 True := TrueExit ;
15473 Assert(NOT BooleanOp)
15474 END ;
15475 DISPOSE(f)
15476END PopT ;
15477
15478
15479(*
15480 PopTtok - Pops the T value from the stack and token position.
15481*)
15482
15483PROCEDURE PopTtok (VAR True: WORD; VAR tok: CARDINAL) ;
15484VAR
15485 f: BoolFrame ;
15486BEGIN
15487 f := PopAddress(BoolStack) ;
15488 WITH f^ DO
15489 True := TrueExit ;
15490 tok := tokenno ;
15491 Assert(NOT BooleanOp)
15492 END ;
15493 DISPOSE(f)
15494END PopTtok ;
15495
15496
15497(*
15498 PushTrw - Push an item onto the True/False stack. The False value will be zero.
15499*)
15500
15501(*
15502PROCEDURE PushTrw (True: WORD; rw: WORD) ;
15503VAR
15504 f: BoolFrame ;
15505BEGIN
15506 f := newBoolFrame () ;
15507 WITH f^ DO
15508 TrueExit := True ;
15509 ReadWrite := rw
15510 END ;
15511 PushAddress(BoolStack, f)
15512END PushTrw ;
15513*)
15514
15515
15516(*
15517 PushTrwtok - Push an item onto the True/False stack. The False value will be zero.
15518*)
15519
15520PROCEDURE PushTrwtok (True: WORD; rw: WORD; tok: CARDINAL) ;
15521VAR
15522 f: BoolFrame ;
15523BEGIN
15524 f := newBoolFrame () ;
15525 WITH f^ DO
15526 TrueExit := True ;
15527 ReadWrite := rw ;
15528 tokenno := tok
15529 END ;
15530 PushAddress(BoolStack, f)
15531END PushTrwtok ;
15532
15533
15534(*
15535 PopTrw - Pop a True field and rw symbol from the stack.
15536*)
15537
15538PROCEDURE PopTrw (VAR True, rw: WORD) ;
15539VAR
15540 f: BoolFrame ;
15541BEGIN
15542 f := PopAddress(BoolStack) ;
15543 WITH f^ DO
15544 True := TrueExit ;
15545 Assert(NOT BooleanOp) ;
15546 rw := ReadWrite
15547 END ;
15548 DISPOSE(f)
15549END PopTrw ;
15550
15551
15552(*
15553 PopTrwtok - Pop a True field and rw symbol from the stack.
15554*)
15555
15556PROCEDURE PopTrwtok (VAR True, rw: WORD; VAR tok: CARDINAL) ;
15557VAR
15558 f: BoolFrame ;
15559BEGIN
15560 f := PopAddress(BoolStack) ;
15561 WITH f^ DO
15562 True := TrueExit ;
15563 Assert(NOT BooleanOp) ;
15564 rw := ReadWrite ;
15565 tok := tokenno
15566 END ;
15567 DISPOSE(f)
15568END PopTrwtok ;
15569
15570
15571(*
15572 PushTFn - Push a True and False numbers onto the True/False stack.
15573 True and False are assumed to contain Symbols or Ident etc.
15574*)
15575
15576PROCEDURE PushTFn (True, False, n: WORD) ;
15577VAR
15578 f: BoolFrame ;
15579BEGIN
15580 f := newBoolFrame () ;
15581 WITH f^ DO
15582 TrueExit := True ;
15583 FalseExit := False ;
15584 name := n
15585 END ;
15586 PushAddress(BoolStack, f)
15587END PushTFn ;
15588
15589
15590(*
15591 PushTFntok - Push a True and False numbers onto the True/False stack.
15592 True and False are assumed to contain Symbols or Ident etc.
15593*)
15594
15595PROCEDURE PushTFntok (True, False, n: WORD; tokno: CARDINAL) ;
15596VAR
15597 f: BoolFrame ;
15598BEGIN
15599 f := newBoolFrame () ;
15600 WITH f^ DO
15601 TrueExit := True ;
15602 FalseExit := False ;
15603 name := n ;
15604 tokenno := tokno
15605 END ;
15606 PushAddress (BoolStack, f)
15607END PushTFntok ;
15608
15609
15610(*
15611 PopTFn - Pop a True and False number from the True/False stack.
15612 True and False are assumed to contain Symbols or Ident etc.
15613*)
15614
15615PROCEDURE PopTFn (VAR True, False, n: WORD) ;
15616VAR
15617 f: BoolFrame ;
15618BEGIN
15619 f := PopAddress(BoolStack) ;
15620 WITH f^ DO
15621 True := TrueExit ;
15622 False := FalseExit ;
15623 n := name ;
15624 Assert(NOT BooleanOp)
15625 END ;
15626 DISPOSE(f)
15627END PopTFn ;
15628
15629
15630(*
15631 PopNothing - pops the top element on the boolean stack.
15632*)
15633
15634PROCEDURE PopNothing ;
15635VAR
15636 f: BoolFrame ;
15637BEGIN
15638 f := PopAddress(BoolStack) ;
15639 DISPOSE(f)
15640END PopNothing ;
15641
15642
15643(*
15644 PopN - pops multiple elements from the BoolStack.
15645*)
15646
15647PROCEDURE PopN (n: CARDINAL) ;
15648BEGIN
15649 WHILE n>0 DO
15650 PopNothing ;
15651 DEC(n)
15652 END
15653END PopN ;
15654
15655
15656(*
15657 PushTFtok - Push an item onto the stack in the T (true) position,
15658 it is assummed to be a token and its token location is recorded.
15659*)
15660
15661PROCEDURE PushTFtok (True, False: WORD; tokno: CARDINAL) ;
15662VAR
15663 f: BoolFrame ;
15664BEGIN
15665 f := newBoolFrame () ;
15666 WITH f^ DO
15667 TrueExit := True ;
15668 FalseExit := False ;
15669 tokenno := tokno
15670 END ;
15671 PushAddress(BoolStack, f)
15672END PushTFtok ;
15673
15674
15675(*
15676 PopTFtok - Pop T/F/tok from the stack.
15677*)
15678
15679PROCEDURE PopTFtok (VAR True, False: WORD; VAR tokno: CARDINAL) ;
15680VAR
15681 f: BoolFrame ;
15682BEGIN
15683 f := PopAddress(BoolStack) ;
15684 WITH f^ DO
15685 True := TrueExit ;
15686 False := FalseExit ;
15687 tokno := tokenno
15688 END
15689END PopTFtok ;
15690
15691
15692(*
15693 PushTFAtok - Push T/F/A/tok to the stack.
15694*)
15695
15696PROCEDURE PushTFAtok (True, False, Array: WORD; tokno: CARDINAL) ;
15697VAR
15698 f: BoolFrame ;
15699BEGIN
15700 f := newBoolFrame () ;
15701 WITH f^ DO
15702 TrueExit := True ;
15703 FalseExit := False ;
15704 Unbounded := Array ;
15705 tokenno := tokno
15706 END ;
15707 PushAddress(BoolStack, f)
15708END PushTFAtok ;
15709
15710
15711(*
15712 Top - returns the no of items held in the stack.
15713*)
15714
15715PROCEDURE Top () : CARDINAL ;
15716BEGIN
15717 RETURN( NoOfItemsInStackAddress(BoolStack) )
15718END Top ;
15719
15720
15721(*
15722 PushAutoOn - push the auto flag and then set it to TRUE.
15723 Any call to ident in the parser will result in the token being pushed.
15724*)
15725
15726PROCEDURE PushAutoOn ;
15727BEGIN
15728 PushWord(AutoStack, IsAutoOn) ;
15729 IsAutoOn := TRUE
15730END PushAutoOn ;
15731
15732
15733(*
15734 PushAutoOff - push the auto flag and then set it to FALSE.
15735*)
15736
15737PROCEDURE PushAutoOff ;
15738BEGIN
15739 PushWord(AutoStack, IsAutoOn) ;
15740 IsAutoOn := FALSE
15741END PushAutoOff ;
15742
15743
15744(*
15745 IsAutoPushOn - returns the value of the current Auto ident push flag.
15746*)
15747
15748PROCEDURE IsAutoPushOn () : BOOLEAN ;
15749BEGIN
15750 RETURN( IsAutoOn )
15751END IsAutoPushOn ;
15752
15753
15754(*
15755 PopAuto - restores the previous value of the Auto flag.
15756*)
15757
15758PROCEDURE PopAuto ;
15759BEGIN
15760 IsAutoOn := PopWord(AutoStack)
15761END PopAuto ;
15762
15763
15764(*
15765 PushInConstExpression - push the InConstExpression flag and then set it to TRUE.
15766*)
15767
15768PROCEDURE PushInConstExpression ;
15769BEGIN
4e3c8257 15770 PushWord(ConstExprStack, InConstExpression) ;
1eee94d3
GM		 15771 InConstExpression := TRUE
15772END PushInConstExpression ;
15773
15774
15775(*
15776 PopInConstExpression - restores the previous value of the InConstExpression.
15777*)
15778
15779PROCEDURE PopInConstExpression ;
15780BEGIN
4e3c8257 15781 InConstExpression := PopWord(ConstExprStack)
1eee94d3
GM		 15782END PopInConstExpression ;
15783
15784
15785(*
15786 IsInConstExpression - returns the value of the InConstExpression.
15787*)
15788
15789PROCEDURE IsInConstExpression () : BOOLEAN ;
15790BEGIN
15791 RETURN( InConstExpression )
15792END IsInConstExpression ;
15793
15794
4e3c8257
GM		 15795(*
15796 PushInConstParameters - push the InConstParameters flag and then set it to TRUE.
15797*)
15798
15799PROCEDURE PushInConstParameters ;
15800BEGIN
15801 PushWord (ConstParamStack, InConstParameters) ;
15802 InConstParameters := TRUE
15803END PushInConstParameters ;
15804
15805
15806(*
15807 PopInConstParameters - restores the previous value of the InConstParameters.
15808*)
15809
15810PROCEDURE PopInConstParameters ;
15811BEGIN
15812 InConstParameters := PopWord(ConstParamStack)
15813END PopInConstParameters ;
15814
15815
15816(*
15817 IsInConstParameters - returns the value of the InConstParameters.
15818*)
15819
15820PROCEDURE IsInConstParameters () : BOOLEAN ;
15821BEGIN
15822 RETURN( InConstParameters )
15823END IsInConstParameters ;
15824
15825
1eee94d3
GM		 15826(*
15827 MustCheckOverflow - returns TRUE if the quadruple should test for overflow.
15828*)
15829
15830PROCEDURE MustCheckOverflow (q: CARDINAL) : BOOLEAN ;
15831VAR
15832 f: QuadFrame ;
15833BEGIN
15834 f := GetQF(q) ;
15835 RETURN( f^.CheckOverflow )
15836END MustCheckOverflow ;
15837
15838
15839(*
15840 StressStack -
15841*)
15842
15843(*
15844PROCEDURE StressStack ;
15845CONST
15846 Maxtries = 1000 ;
15847VAR
15848 n, i, j: CARDINAL ;
15849BEGIN
15850 PushT(1) ;
15851 PopT(i) ;
15852 Assert(i=1) ;
15853 FOR n := 1 TO Maxtries DO
15854 FOR i := n TO 1 BY -1 DO
15855 PushT(i)
15856 END ;
15857 FOR i := n TO 1 BY -1 DO
15858 Assert(OperandT(i)=i)
15859 END ;
15860 FOR i := 1 TO n DO
15861 Assert(OperandT(i)=i)
15862 END ;
15863 FOR i := 1 TO n BY 10 DO
15864 Assert(OperandT(i)=i)
15865 END ;
15866 IF (n>1) AND (n MOD 2 = 0)
15867 THEN
15868 FOR i := 1 TO n DIV 2 DO
15869 PopT(j) ;
15870 Assert(j=i)
15871 END ;
15872 FOR i := n DIV 2 TO 1 BY -1 DO
15873 PushT(i)
15874 END
15875 END ;
15876 FOR i := 1 TO n DO
15877 PopT(j) ;
15878 Assert(j=i)
15879 END
15880 END
15881END StressStack ;
15882*)
15883
15884
15885(*
15886 Init - initialize the M2Quads module, all the stacks, all the lists
15887 and the quads list.
15888*)
15889
15890PROCEDURE Init ;
15891BEGIN
15892 LogicalOrTok := MakeKey('_LOR') ;
15893 LogicalAndTok := MakeKey('_LAND') ;
15894 LogicalXorTok := MakeKey('_LXOR') ;
15895 LogicalDifferenceTok := MakeKey('_LDIFF') ;
ac7c9954 15896 ArithPlusTok := MakeKey ('_ARITH_+') ;
3cdaa649 15897 QuadArray := InitIndexTuned (1, 1024*1024 DIV 16, 16) ;
1eee94d3
GM		 15898 FreeList := 1 ;
15899 NewQuad(NextQuad) ;
15900 Assert(NextQuad=1) ;
15901 BoolStack := InitStackAddress() ;
15902 ExitStack := InitStackWord() ;
15903 RepeatStack := InitStackWord() ;
15904 WhileStack := InitStackWord() ;
15905 ForStack := InitStackWord() ;
15906 WithStack := InitStackAddress() ;
15907 ReturnStack := InitStackWord() ;
15908 LineStack := InitStackAddress() ;
15909 PriorityStack := InitStackWord() ;
15910 TryStack := InitStackWord() ;
15911 CatchStack := InitStackWord() ;
15912 ExceptStack := InitStackWord() ;
15913 ConstructorStack := InitStackAddress() ;
4e3c8257
GM		 15914 ConstParamStack := InitStackWord () ;
15915 ConstExprStack := InitStackWord () ;
1eee94d3
GM		 15916 (* StressStack ; *)
15917 SuppressWith := FALSE ;
15918 Head := 1 ;
15919 LastQuadNo := 0 ;
15920 MustNotCheckBounds := FALSE ;
15921 InitQuad := 0 ;
15922 GrowInitialization := 0 ;
15923 ForInfo := InitIndex (1) ;
15924 QuadrupleGeneration := TRUE ;
15925 BuildingHigh := FALSE ;
15926 BuildingSize := FALSE ;
15927 AutoStack := InitStackWord() ;
15928 IsAutoOn := TRUE ;
15929 InConstExpression := FALSE ;
4e3c8257 15930 InConstParameters := FALSE ;
1eee94d3
GM		 15931 FreeLineList := NIL ;
15932 InitList(VarientFields) ;
15933 VarientFieldNo := 0 ;
48d49200 15934 NoOfQuads := 0 ;
1eee94d3
GM		 15935END Init ;
15936
15937
15938BEGIN
15939 Init
15940END M2Quads.
Mirror of https://gcc.gnu.org/git/gcc.git