gcc/m2/gm2-compiler/M2Quads.mod

   1 (* M2Quads.mod generates quadruples.
   2
   3 Copyright (C) 2001-2023 Free Software Foundation, Inc.
   4 Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
   5
   6 This file is part of GNU Modula-2.
   7
   8 GNU Modula-2 is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 3, or (at your option)
  11 any later version.
  12
  13 GNU Modula-2 is distributed in the hope that it will be useful, but
  14 WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Modula-2; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  *)
  21
  22 IMPLEMENTATION MODULE M2Quads ;
  23
  24
  25 FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
  26 FROM M2Debug IMPORT Assert, WriteDebug ;
  27 FROM NameKey IMPORT Name, NulName, MakeKey, GetKey, makekey, KeyToCharStar, WriteKey ;
  28 FROM FormatStrings IMPORT Sprintf0, Sprintf1, Sprintf2, Sprintf3 ;
  29 FROM M2DebugStack IMPORT DebugStack ;
  30 FROM M2Scaffold IMPORT DeclareScaffold, mainFunction, initFunction,
  31                        finiFunction, linkFunction, PopulateCtorArray,
  32                        ForeachModuleCallInit, ForeachModuleCallFinish ;
  33
  34 FROM M2MetaError IMPORT MetaError0, MetaError1, MetaError2, MetaError3,
  35                         MetaErrors1, MetaErrors2, MetaErrors3,
  36                         MetaErrorT0, MetaErrorT1, MetaErrorT2,
  37                         MetaErrorsT1, MetaErrorsT2,
  38                         MetaErrorStringT0, MetaErrorStringT1,
  39                         MetaErrorString1, MetaErrorString2,
  40                         MetaErrorN1, MetaErrorN2,
  41                         MetaErrorNT0, MetaErrorNT1, MetaErrorNT2 ;
  42
  43 FROM DynamicStrings IMPORT String, string, InitString, KillString,
  44                            ConCat, InitStringCharStar, Dup, Mark,
  45                            PushAllocation, PopAllocationExemption,
  46                            InitStringDB, InitStringCharStarDB,
  47                            InitStringCharDB, MultDB, DupDB, SliceDB ;
  48
  49 FROM SymbolTable IMPORT ModeOfAddr, GetMode, PutMode, GetSymName, IsUnknown,
  50                         MakeTemporary,
  51                         MakeTemporaryFromExpression,
  52                         MakeTemporaryFromExpressions,
  53                         MakeConstLit, MakeConstLitString,
  54                         MakeConstString, MakeConstant,
  55                         Make2Tuple,
  56                         RequestSym, MakePointer, PutPointer,
  57                         SkipType,
  58                         GetDType, GetSType, GetLType,
  59                         GetScope, GetCurrentScope,
  60                         GetSubrange, SkipTypeAndSubrange,
  61                         GetModule, GetMainModule,
  62                         GetCurrentModule, GetFileModule, GetLocalSym,
  63                         GetStringLength, GetString,
  64                         GetArraySubscript, GetDimension,
  65                         GetParam,
  66                         GetNth, GetNthParam,
  67                         GetFirstUsed, GetDeclaredMod,
  68                         GetQuads, GetReadQuads, GetWriteQuads,
  69                         GetWriteLimitQuads, GetReadLimitQuads,
  70                         GetVarScope,
  71                         GetModuleQuads, GetProcedureQuads,
  72                         GetModuleCtors,
  73                         MakeProcedure,
  74                         MakeConstStringCnul, MakeConstStringM2nul,
  75                         PutConstString,
  76                         PutModuleStartQuad, PutModuleEndQuad,
  77                         PutModuleFinallyStartQuad, PutModuleFinallyEndQuad,
  78                         PutProcedureStartQuad, PutProcedureEndQuad,
  79                         PutProcedureScopeQuad,
  80                         PutVar, PutConstSet,
  81                         GetVarPointerCheck, PutVarPointerCheck,
  82                         PutVarWritten,
  83                         PutReadQuad, RemoveReadQuad,
  84                         PutWriteQuad, RemoveWriteQuad,
  85                         PutPriority, GetPriority,
  86                         PutProcedureBegin, PutProcedureEnd,
  87                         PutVarConst, IsVarConst,
  88                         IsVarParam, IsProcedure, IsPointer, IsParameter,
  89                         IsUnboundedParam, IsEnumeration, IsDefinitionForC,
  90                         IsVarAParam, IsVarient, IsLegal,
  91                         UsesVarArgs, UsesOptArg,
  92                         GetOptArgInit,
  93                         IsReturnOptional,
  94                         NoOfElements,
  95                         NoOfParam,
  96                         StartScope, EndScope,
  97                         HasExceptionBlock, PutExceptionBlock,
  98                         HasExceptionFinally, PutExceptionFinally,
  99                         GetParent, GetRecord, IsRecordField, IsFieldVarient, IsRecord,
 100                         IsFieldEnumeration,
 101                         IsVar, IsProcType, IsType, IsSubrange, IsExported,
 102                         IsConst, IsConstString, IsModule, IsDefImp,
 103                         IsArray, IsUnbounded, IsProcedureNested,
 104                         IsParameterUnbounded,
 105                         IsPartialUnbounded, IsProcedureBuiltin,
 106                         IsSet, IsConstSet, IsConstructor, PutConst,
 107                         PutConstructor, PutConstructorFrom,
 108                         PutDeclared,
 109                         MakeComponentRecord, MakeComponentRef,
 110                         IsSubscript,
 111                         IsTemporary,
 112                         IsAModula2Type,
 113                         PutLeftValueFrontBackType,
 114                         PushSize, PushValue, PopValue,
 115                         GetVariableAtAddress, IsVariableAtAddress,
 116                         MakeError, UnknownReported,
 117                         IsError,
 118                         IsInnerModule,
 119                         IsImportStatement, IsImport, GetImportModule, GetImportDeclared,
 120                         GetImportStatementList,
 121                         GetModuleDefImportStatementList, GetModuleModImportStatementList,
 122                         IsCtor, IsPublic, IsExtern, IsMonoName,
 123
 124                         GetUnboundedRecordType,
 125                         GetUnboundedAddressOffset,
 126                         GetUnboundedHighOffset,
 127
 128                         ForeachFieldEnumerationDo, ForeachLocalSymDo,
 129                         GetExported, PutImported, GetSym,
 130                         IsUnused,
 131                         NulSym ;
 132
 133 FROM M2Batch IMPORT MakeDefinitionSource ;
 134 FROM M2GCCDeclare IMPORT PutToBeSolvedByQuads ;
 135
 136 FROM FifoQueue IMPORT GetConstFromFifoQueue,
 137                       PutConstructorIntoFifoQueue, GetConstructorFromFifoQueue ;
 138
 139 FROM M2Comp IMPORT CompilingImplementationModule,
 140                    CompilingProgramModule ;
 141
 142 FROM M2LexBuf IMPORT currenttoken, UnknownTokenNo, BuiltinTokenNo,
 143                      GetToken, MakeVirtualTok,
 144                      GetFileName, TokenToLineNo, GetTokenName,
 145                      GetTokenNo, GetLineNo, GetPreviousTokenLineNo, PrintTokenNo ;
 146
 147 FROM M2Error IMPORT Error,
 148                     InternalError,
 149                     WriteFormat0, WriteFormat1, WriteFormat2, WriteFormat3,
 150                     NewError, NewWarning, ErrorFormat0, ErrorFormat1,
 151                     ErrorFormat2, ErrorFormat3, FlushErrors, ChainError,
 152                     ErrorString,
 153                     ErrorStringAt, ErrorStringAt2, ErrorStringsAt2,
 154                     WarnStringAt, WarnStringAt2, WarnStringsAt2 ;
 155
 156 FROM M2Printf IMPORT printf0, printf1, printf2, printf3, printf4 ;
 157
 158 FROM M2Reserved IMPORT PlusTok, MinusTok, TimesTok, DivTok, ModTok,
 159                        DivideTok, RemTok,
 160                        OrTok, AndTok, AmbersandTok,
 161                        EqualTok, LessEqualTok, GreaterEqualTok,
 162                        LessTok, GreaterTok, HashTok, LessGreaterTok,
 163                        InTok,
 164                        UpArrowTok, RParaTok, LParaTok, CommaTok,
 165                        NulTok, ByTok,
 166                        SemiColonTok, toktype ;
 167
 168 FROM M2Base IMPORT True, False, Boolean, Cardinal, Integer, Char,
 169                    Real, LongReal, ShortReal, Nil,
 170                    ZType, RType, CType,
 171                    Re, Im, Cmplx,
 172                    NegateType, ComplexToScalar, GetCmplxReturnType,
 173                    IsAssignmentCompatible, IsExpressionCompatible,
 174                    AssignmentRequiresWarning,
 175                    CannotCheckTypeInPass3, ScalarToComplex, MixTypes,
 176                    CheckAssignmentCompatible, CheckExpressionCompatible,
 177                    High, LengthS, New, Dispose, Inc, Dec, Incl, Excl,
 178                    Cap, Abs, Odd,
 179                    IsOrd, Chr, Convert, Val, IsFloat, IsTrunc,
 180                    IsInt, Min, Max,
 181                    IsPseudoBaseProcedure, IsPseudoBaseFunction,
 182                    IsMathType, IsOrdinalType, IsRealType,
 183                    IsBaseType, GetBaseTypeMinMax, ActivationPointer ;
 184
 185 FROM M2System IMPORT IsPseudoSystemFunction, IsPseudoSystemProcedure,
 186                      IsSystemType, GetSystemTypeMinMax,
 187                      IsPseudoSystemFunctionConstExpression,
 188                      IsGenericSystemType,
 189                      Adr, TSize, TBitSize, AddAdr, SubAdr, DifAdr, Cast,
 190                      Shift, Rotate, MakeAdr, Address, Byte, Word, Loc, Throw ;
 191
 192 FROM M2Size IMPORT Size ;
 193 FROM M2Bitset IMPORT Bitset ;
 194
 195 FROM M2ALU IMPORT PushInt, Gre, Less, PushNulSet, AddBitRange, AddBit,
 196                   IsGenericNulSet, IsValueAndTreeKnown, AddField,
 197                   AddElements, ChangeToConstructor ;
 198
 199 FROM Lists IMPORT List, InitList, GetItemFromList, NoOfItemsInList, PutItemIntoList,
 200                   IsItemInList, KillList, IncludeItemIntoList ;
 201
 202 FROM M2Options IMPORT NilChecking,
 203                       WholeDivChecking, WholeValueChecking,
 204                       IndexChecking, RangeChecking,
 205                       CaseElseChecking, ReturnChecking,
 206                       UnusedVariableChecking, UnusedParameterChecking,
 207                       Iso, Pim, Pim2, Pim3, Pim4, PositiveModFloorDiv,
 208                       Pedantic, CompilerDebugging, GenerateDebugging,
 209                       GenerateLineDebug, Exceptions,
 210                       Profiling, Coding, Optimizing,
 211                       ScaffoldDynamic, ScaffoldStatic, cflag,
 212                       ScaffoldMain, SharedFlag, WholeProgram ;
 213
 214 FROM M2Pass IMPORT IsPassCodeGeneration, IsNoPass ;
 215
 216 FROM M2StackAddress IMPORT StackOfAddress, InitStackAddress, KillStackAddress,
 217                            PushAddress, PopAddress, PeepAddress,
 218                            IsEmptyAddress, NoOfItemsInStackAddress ;
 219
 220 FROM M2StackWord IMPORT StackOfWord, InitStackWord, KillStackWord,
 221                         PushWord, PopWord, PeepWord, RemoveTop,
 222                         IsEmptyWord, NoOfItemsInStackWord ;
 223
 224 FROM Indexing IMPORT Index, InitIndex, GetIndice, PutIndice, InBounds, HighIndice, IncludeIndiceIntoIndex ;
 225
 226 FROM M2Range IMPORT InitAssignmentRangeCheck,
 227                     InitReturnRangeCheck,
 228                     InitSubrangeRangeCheck,
 229                     InitStaticArraySubscriptRangeCheck,
 230                     InitDynamicArraySubscriptRangeCheck,
 231                     InitIncRangeCheck,
 232                     InitDecRangeCheck,
 233                     InitInclCheck,
 234                     InitExclCheck,
 235                     InitRotateCheck,
 236                     InitShiftCheck,
 237                     InitTypesAssignmentCheck,
 238                     InitTypesExpressionCheck,
 239                     InitTypesParameterCheck,
 240                     InitForLoopBeginRangeCheck,
 241                     InitForLoopToRangeCheck,
 242                     InitForLoopEndRangeCheck,
 243                     InitPointerRangeCheck,
 244                     InitNoReturnRangeCheck,
 245                     InitNoElseRangeCheck,
 246                     InitCaseBounds,
 247                     InitWholeZeroDivisionCheck,
 248                     InitWholeZeroRemainderCheck,
 249                     InitParameterRangeCheck,
 250                     (* CheckRangeAddVariableRead,  *)
 251                     (* CheckRangeRemoveVariableRead,  *)
 252                     WriteRangeCheck ;
 253
 254 FROM M2CaseList IMPORT PushCase, PopCase, AddRange, BeginCaseList, EndCaseList, ElseCase ;
 255 FROM PCSymBuild IMPORT SkipConst ;
 256 FROM m2builtins IMPORT GetBuiltinTypeInfoType ;
 257
 258 IMPORT M2Error ;
 259
 260
 261 CONST
 262    DebugStackOn = TRUE ;
 263    DebugVarients = FALSE ;
 264    BreakAtQuad = 4423 ;
 265    DebugTokPos = FALSE ;
 266
 267 TYPE
 268    ConstructorFrame = POINTER TO constructorFrame ;
 269    constructorFrame = RECORD
 270                          type : CARDINAL ;
 271                          index: CARDINAL ;
 272                       END ;
 273
 274    BoolFrame = POINTER TO RECORD
 275                              TrueExit  : CARDINAL ;
 276                              FalseExit : CARDINAL ;
 277                              Unbounded : CARDINAL ;
 278                              BooleanOp : BOOLEAN ;
 279                              Dimension : CARDINAL ;
 280                              ReadWrite : CARDINAL ;
 281                              name      : CARDINAL ;
 282                              Annotation: String ;
 283                              tokenno   : CARDINAL ;
 284                           END ;
 285
 286    QuadFrame = POINTER TO RECORD
 287                              Operator           : QuadOperator ;
 288                              Operand1           : CARDINAL ;
 289                              Operand2           : CARDINAL ;
 290                              Operand3           : CARDINAL ;
 291                              Next               : CARDINAL ;     (* Next quadruple                 *)
 292                              LineNo             : CARDINAL ;     (* Line No of source text         *)
 293                              TokenNo            : CARDINAL ;     (* Token No of source text        *)
 294                              NoOfTimesReferenced: CARDINAL ;     (* No of times quad is referenced *)
 295                              CheckOverflow      : BOOLEAN ;      (* should backend check overflow  *)
 296                              op1pos,
 297                              op2pos,
 298                              op3pos             : CARDINAL ;     (* token position of operands.    *)
 299                           END ;
 300
 301    WithFrame = POINTER TO RECORD
 302                              RecordSym   : CARDINAL ;
 303                              RecordType  : CARDINAL ;
 304                              RecordRef   : CARDINAL ;
 305                              rw          : CARDINAL ;  (* The record variable.  *)
 306                              RecordTokPos: CARDINAL ;  (* Token of the record.  *)
 307                           END ;
 308
 309    ForLoopInfo = POINTER TO RECORD
 310                                IncrementQuad,
 311                                StartOfForLoop,                 (* we keep a list of all for      *)
 312                                EndOfForLoop,                   (* loops so we can check index    *)
 313                                ForLoopIndex,
 314                                IndexTok      : CARDINAL ;      (* variables are not abused       *)
 315                             END ;
 316
 317    LineNote  = POINTER TO RECORD
 318                              Line: CARDINAL ;
 319                              File: Name ;
 320                              Next: LineNote ;
 321                           END ;
 322 VAR
 323    ConstructorStack,
 324    LineStack,
 325    BoolStack,
 326    WithStack            : StackOfAddress ;
 327    TryStack,
 328    CatchStack,
 329    ExceptStack,
 330    ConstStack,
 331    AutoStack,
 332    RepeatStack,
 333    WhileStack,
 334    ForStack,
 335    ExitStack,
 336    ReturnStack          : StackOfWord ;   (* Return quadruple of the procedure.      *)
 337    PriorityStack        : StackOfWord ;   (* temporary variable holding old priority *)
 338    SuppressWith         : BOOLEAN ;
 339    QuadArray            : Index ;
 340    NextQuad             : CARDINAL ;  (* Next quadruple number to be created.    *)
 341    FreeList             : CARDINAL ;  (* FreeList of quadruples.                 *)
 342    CurrentProc          : CARDINAL ;  (* Current procedure being compiled, used  *)
 343                                       (* to determine which procedure a RETURN   *)
 344                                       (* ReturnValueOp must have as its 3rd op.  *)
 345    InitQuad             : CARDINAL ;  (* Initial Quad BackPatch that starts the  *)
 346                                       (* suit of Modules.                        *)
 347    LastQuadNo           : CARDINAL ;  (* Last Quadruple accessed by GetQuad.     *)
 348    LogicalOrTok,                      (* Internal _LOR token.                    *)
 349    LogicalAndTok,                     (* Internal _LAND token.                   *)
 350    LogicalXorTok,                     (* Internal _LXOR token.                   *)
 351    LogicalDifferenceTok : Name ;      (* Internal _LDIFF token.                  *)
 352    InConstExpression,
 353    IsAutoOn,                          (* should parser automatically push idents *)
 354    MustNotCheckBounds   : BOOLEAN ;
 355    ForInfo              : Index ;     (* start and end of all FOR loops       *)
 356    GrowInitialization   : CARDINAL ;  (* upper limit of where the initialized    *)
 357                                       (* quadruples.                             *)
 358    BuildingHigh,
 359    BuildingSize,
 360    QuadrupleGeneration  : BOOLEAN ;      (* should we be generating quadruples?  *)
 361    FreeLineList         : LineNote ;  (* free list of line notes                 *)
 362    VarientFields        : List ;      (* the list of all varient fields created  *)
 363    VarientFieldNo       : CARDINAL ;  (* used to retrieve the VarientFields      *)
 364                                       (* in order.                               *)
 365    NoOfQuads            : CARDINAL ;  (* Number of used quadruples.              *)
 366    Head                 : CARDINAL ;  (* Head of the list of quadruples *)
 367
 368
 369 (*
 370    Rules for file and initialization quadruples:
 371
 372    StartModFileOp  - indicates that this file (module) has produced the
 373                      following code
 374    StartDefFileOp  - indicates that this definition module has produced
 375                      this code.
 376    EndFileOp       - indicates that a module has finished
 377    InitStartOp     - the start of the initialization code of a module
 378    InitEndOp       - the end of the above
 379    FinallyStartOp  - the start of the finalization code of a module
 380    FinallyEndOp    - the end of the above
 381 *)
 382
 383
 384 (*
 385 #define InitString(X) InitStringDB(X, __FILE__, __LINE__)
 386 #define InitStringCharStar(X) InitStringCharStarDB(X, __FILE__, __LINE__)
 387 #define InitStringChar(X) InitStringCharDB(X, __FILE__, __LINE__)
 388 #define Mult(X,Y) MultDB(X, Y, __FILE__, __LINE__)
 389 #define Dup(X) DupDB(X, __FILE__, __LINE__)
 390 #define Slice(X,Y,Z) SliceDB(X, Y, Z, __FILE__, __LINE__)
 391 *)
 392
 393
 394 (*
 395    doDSdbEnter -
 396 *)
 397
 398 (*
 399 PROCEDURE doDSdbEnter ;
 400 BEGIN
 401    PushAllocation
 402 END doDSdbEnter ;
 403 *)
 404
 405 (*
 406    doDSdbExit -
 407 *)
 408
 409 (*
 410 PROCEDURE doDSdbExit (s: String) ;
 411 BEGIN
 412    s := PopAllocationExemption(TRUE, s)
 413 END doDSdbExit ;
 414 *)
 415
 416 (*
 417    DSdbEnter -
 418 *)
 419
 420 PROCEDURE DSdbEnter ;
 421 BEGIN
 422 END DSdbEnter ;
 423
 424
 425 (*
 426    DSdbExit -
 427 *)
 428
 429 PROCEDURE DSdbExit ;
 430 BEGIN
 431 END DSdbExit ;
 432
 433
 434 (*
 435 #define DBsbEnter doDBsbEnter
 436 #define DBsbExit  doDBsbExit
 437 *)
 438
 439
 440 (*
 441    SetOptionProfiling - builds a profile quadruple if the profiling
 442                         option was given to the compiler.
 443 *)
 444
 445 PROCEDURE SetOptionProfiling (b: BOOLEAN) ;
 446 BEGIN
 447    IF b#Profiling
 448    THEN
 449       IF b
 450       THEN
 451          BuildProfileOn
 452       ELSE
 453          BuildProfileOff
 454       END ;
 455       Profiling := b
 456    END
 457 END SetOptionProfiling ;
 458
 459
 460 (*
 461    SetOptionCoding - builds a code quadruple if the profiling
 462                      option was given to the compiler.
 463 *)
 464
 465 PROCEDURE SetOptionCoding (b: BOOLEAN) ;
 466 BEGIN
 467    IF b#Coding
 468    THEN
 469       IF b
 470       THEN
 471          BuildCodeOn
 472       ELSE
 473          BuildCodeOff
 474       END ;
 475       Coding := b
 476    END
 477 END SetOptionCoding ;
 478
 479
 480 (*
 481    SetOptionOptimizing - builds a quadruple to say that the optimization option
 482                          has been found in a comment.
 483 *)
 484
 485 PROCEDURE SetOptionOptimizing (b: BOOLEAN) ;
 486 BEGIN
 487    IF b
 488    THEN
 489       BuildOptimizeOn
 490    ELSE
 491       BuildOptimizeOff
 492    END
 493 END SetOptionOptimizing ;
 494
 495
 496 (*
 497    GetQF - returns the QuadFrame associated with, q.
 498 *)
 499
 500 PROCEDURE GetQF (q: CARDINAL) : QuadFrame ;
 501 BEGIN
 502    RETURN QuadFrame (GetIndice (QuadArray, q))
 503 END GetQF ;
 504
 505
 506 (*
 507    Opposite - returns the opposite comparison operator.
 508 *)
 509
 510 PROCEDURE Opposite (Operator: QuadOperator) : QuadOperator ;
 511 VAR
 512    Op: QuadOperator ;
 513 BEGIN
 514    CASE Operator OF
 515
 516    IfNotEquOp : Op := IfEquOp |
 517    IfEquOp    : Op := IfNotEquOp |
 518    IfLessEquOp: Op := IfGreOp |
 519    IfGreOp    : Op := IfLessEquOp |
 520    IfGreEquOp : Op := IfLessOp |
 521    IfLessOp   : Op := IfGreEquOp |
 522    IfInOp     : Op := IfNotInOp |
 523    IfNotInOp  : Op := IfInOp
 524
 525    ELSE
 526       InternalError ('unexpected operator')
 527    END ;
 528    RETURN Op
 529 END Opposite ;
 530
 531
 532 (*
 533    IsReferenced - returns true if QuadNo is referenced by another quadruple.
 534 *)
 535
 536 PROCEDURE IsReferenced (QuadNo: CARDINAL) : BOOLEAN ;
 537 VAR
 538    f: QuadFrame ;
 539 BEGIN
 540    f := GetQF(QuadNo) ;
 541    WITH f^ DO
 542       RETURN( (Operator=ProcedureScopeOp) OR (Operator=NewLocalVarOp) OR
 543               (NoOfTimesReferenced>0) )
 544    END
 545 END IsReferenced ;
 546
 547
 548 (*
 549    IsBackReference - returns TRUE if quadruple, q, is referenced from a quad further on.
 550 *)
 551
 552 PROCEDURE IsBackReference (q: CARDINAL) : BOOLEAN ;
 553 VAR
 554    i            : CARDINAL ;
 555    op           : QuadOperator ;
 556    op1, op2, op3: CARDINAL ;
 557 BEGIN
 558    i := q ;
 559    WHILE i#0 DO
 560       GetQuad (i, op, op1, op2, op3) ;
 561       CASE op OF
 562
 563       NewLocalVarOp,
 564       KillLocalVarOp,
 565       FinallyStartOp,
 566       FinallyEndOp,
 567       InitEndOp,
 568       InitStartOp,
 569       EndFileOp,
 570       StartDefFileOp,
 571       StartModFileOp:  RETURN( FALSE ) |       (* run into end of procedure or module *)
 572
 573       GotoOp,
 574       IfEquOp,
 575       IfLessEquOp,
 576       IfGreEquOp,
 577       IfGreOp,
 578       IfLessOp,
 579       IfNotEquOp,
 580       IfInOp,
 581       IfNotInOp     :  IF op3=q
 582                        THEN
 583                           RETURN( TRUE )
 584                        END
 585
 586       END ;
 587       i := GetNextQuad(i)
 588    END ;
 589    InternalError ('fix this for the sake of efficiency..')
 590 END IsBackReference ;
 591
 592
 593 (*
 594    IsUnConditional - returns true if QuadNo is an unconditional jump.
 595 *)
 596
 597 PROCEDURE IsUnConditional (QuadNo: CARDINAL) : BOOLEAN ;
 598 VAR
 599    f: QuadFrame ;
 600 BEGIN
 601    f := GetQF(QuadNo) ;
 602    WITH f^ DO
 603       CASE Operator OF
 604
 605       ThrowOp,
 606       RetryOp,
 607       CallOp,
 608       ReturnOp,
 609       GotoOp  : RETURN( TRUE )
 610
 611       ELSE
 612          RETURN( FALSE )
 613       END
 614    END
 615 END IsUnConditional ;
 616
 617
 618 (*
 619    IsConditional - returns true if QuadNo is a conditional jump.
 620 *)
 621
 622 PROCEDURE IsConditional (QuadNo: CARDINAL) : BOOLEAN ;
 623 VAR
 624    f: QuadFrame ;
 625 BEGIN
 626    f := GetQF(QuadNo) ;
 627    WITH f^ DO
 628       CASE Operator OF
 629
 630       IfInOp,
 631       IfNotInOp,
 632       IfEquOp,
 633       IfNotEquOp,
 634       IfLessOp,
 635       IfLessEquOp,
 636       IfGreOp,
 637       IfGreEquOp : RETURN( TRUE )
 638
 639       ELSE
 640          RETURN( FALSE )
 641       END ;
 642    END
 643 END IsConditional ;
 644
 645
 646 (*
 647    IsBackReferenceConditional - returns TRUE if quadruple, q, is referenced from
 648                                 a conditional quad further on.
 649 *)
 650
 651 PROCEDURE IsBackReferenceConditional (q: CARDINAL) : BOOLEAN ;
 652 VAR
 653    i            : CARDINAL ;
 654    op           : QuadOperator ;
 655    op1, op2, op3: CARDINAL ;
 656 BEGIN
 657    i := q ;
 658    WHILE i#0 DO
 659       GetQuad (i, op, op1, op2, op3) ;
 660       CASE op OF
 661
 662       NewLocalVarOp,
 663       KillLocalVarOp,
 664       FinallyStartOp,
 665       FinallyEndOp,
 666       InitEndOp,
 667       InitStartOp,
 668       EndFileOp,
 669       StartDefFileOp,
 670       StartModFileOp:  RETURN( FALSE ) |       (* run into end of procedure or module *)
 671
 672       TryOp,
 673       RetryOp,
 674       GotoOp,
 675       IfEquOp,
 676       IfLessEquOp,
 677       IfGreEquOp,
 678       IfGreOp,
 679       IfLessOp,
 680       IfNotEquOp,
 681       IfInOp,
 682       IfNotInOp     :  IF (op3=q) AND IsConditional(q)
 683                        THEN
 684                           RETURN( TRUE )
 685                        END
 686
 687       END ;
 688       i := GetNextQuad(i)
 689    END ;
 690    InternalError ('fix this for the sake of efficiency..')
 691 END IsBackReferenceConditional ;
 692
 693
 694 (*
 695    IsQuadA - returns true if QuadNo is a op.
 696 *)
 697
 698 PROCEDURE IsQuadA (QuadNo: CARDINAL; op: QuadOperator) : BOOLEAN ;
 699 VAR
 700    f: QuadFrame ;
 701 BEGIN
 702    f := GetQF(QuadNo) ;
 703    WITH f^ DO
 704       RETURN( Operator=op )
 705    END
 706 END IsQuadA ;
 707
 708
 709 (*
 710    IsCall - returns true if QuadNo is a call operation.
 711 *)
 712
 713 PROCEDURE IsCall (QuadNo: CARDINAL) : BOOLEAN ;
 714 BEGIN
 715    RETURN( IsQuadA(QuadNo, CallOp) )
 716 END IsCall ;
 717
 718
 719 (*
 720    IsReturn - returns true if QuadNo is a return operation.
 721 *)
 722
 723 PROCEDURE IsReturn (QuadNo: CARDINAL) : BOOLEAN ;
 724 BEGIN
 725    RETURN( IsQuadA(QuadNo, ReturnOp) )
 726 END IsReturn ;
 727
 728
 729 (*
 730    IsNewLocalVar - returns true if QuadNo is a NewLocalVar operation.
 731 *)
 732
 733 PROCEDURE IsNewLocalVar (QuadNo: CARDINAL) : BOOLEAN ;
 734 BEGIN
 735    RETURN( IsQuadA(QuadNo, NewLocalVarOp) )
 736 END IsNewLocalVar ;
 737
 738
 739 (*
 740    IsKillLocalVar - returns true if QuadNo is a KillLocalVar operation.
 741 *)
 742
 743 PROCEDURE IsKillLocalVar (QuadNo: CARDINAL) : BOOLEAN ;
 744 BEGIN
 745    RETURN( IsQuadA(QuadNo, KillLocalVarOp) )
 746 END IsKillLocalVar ;
 747
 748
 749 (*
 750    IsProcedureScope - returns true if QuadNo is a ProcedureScope operation.
 751 *)
 752
 753 PROCEDURE IsProcedureScope (QuadNo: CARDINAL) : BOOLEAN ;
 754 BEGIN
 755    RETURN( IsQuadA(QuadNo, ProcedureScopeOp) )
 756 END IsProcedureScope ;
 757
 758
 759 (*
 760    IsCatchBegin - returns true if QuadNo is a catch begin quad.
 761 *)
 762
 763 PROCEDURE IsCatchBegin (QuadNo: CARDINAL) : BOOLEAN ;
 764 BEGIN
 765    RETURN( IsQuadA(QuadNo, CatchBeginOp) )
 766 END IsCatchBegin ;
 767
 768
 769 (*
 770    IsCatchEnd - returns true if QuadNo is a catch end quad.
 771 *)
 772
 773 PROCEDURE IsCatchEnd (QuadNo: CARDINAL) : BOOLEAN ;
 774 BEGIN
 775    RETURN( IsQuadA(QuadNo, CatchEndOp) )
 776 END IsCatchEnd ;
 777
 778
 779 (*
 780    IsInitStart - returns true if QuadNo is a init start quad.
 781 *)
 782
 783 PROCEDURE IsInitStart (QuadNo: CARDINAL) : BOOLEAN ;
 784 BEGIN
 785    RETURN( IsQuadA(QuadNo, InitStartOp) )
 786 END IsInitStart ;
 787
 788
 789 (*
 790    IsInitEnd - returns true if QuadNo is a init end quad.
 791 *)
 792
 793 PROCEDURE IsInitEnd (QuadNo: CARDINAL) : BOOLEAN ;
 794 BEGIN
 795    RETURN( IsQuadA(QuadNo, InitEndOp) )
 796 END IsInitEnd ;
 797
 798
 799 (*
 800    IsFinallyStart - returns true if QuadNo is a finally start quad.
 801 *)
 802
 803 PROCEDURE IsFinallyStart (QuadNo: CARDINAL) : BOOLEAN ;
 804 BEGIN
 805    RETURN( IsQuadA(QuadNo, FinallyStartOp) )
 806 END IsFinallyStart ;
 807
 808
 809 (*
 810    IsFinallyEnd - returns true if QuadNo is a finally end quad.
 811 *)
 812
 813 PROCEDURE IsFinallyEnd (QuadNo: CARDINAL) : BOOLEAN ;
 814 BEGIN
 815    RETURN( IsQuadA(QuadNo, FinallyEndOp) )
 816 END IsFinallyEnd ;
 817
 818
 819 (*
 820    IsInitialisingConst - returns TRUE if the quadruple is setting
 821                          a const (op1) with a value.
 822 *)
 823
 824 PROCEDURE IsInitialisingConst (QuadNo: CARDINAL) : BOOLEAN ;
 825 VAR
 826    op           : QuadOperator ;
 827    op1, op2, op3: CARDINAL ;
 828 BEGIN
 829    GetQuad (QuadNo, op, op1, op2, op3) ;
 830    CASE op OF
 831
 832    InclOp,
 833    ExclOp,
 834    UnboundedOp,
 835    FunctValueOp,
 836    NegateOp,
 837    BecomesOp,
 838    HighOp,
 839    SizeOp,
 840    AddrOp,
 841    RecordFieldOp,
 842    ArrayOp,
 843    LogicalShiftOp,
 844    LogicalRotateOp,
 845    LogicalOrOp,
 846    LogicalAndOp,
 847    LogicalXorOp,
 848    CoerceOp,
 849    ConvertOp,
 850    CastOp,
 851    AddOp,
 852    SubOp,
 853    MultOp,
 854    ModFloorOp,
 855    DivCeilOp,
 856    ModCeilOp,
 857    DivFloorOp,
 858    ModTruncOp,
 859    DivTruncOp,
 860    DivM2Op,
 861    ModM2Op,
 862    XIndrOp,
 863    IndrXOp,
 864    SaveExceptionOp,
 865    RestoreExceptionOp:  RETURN( IsConst(op1) )
 866
 867    ELSE
 868       RETURN( FALSE )
 869    END
 870 END IsInitialisingConst ;
 871
 872
 873 (*
 874    IsOptimizeOn - returns true if the Optimize flag was true at QuadNo.
 875 *)
 876
 877 PROCEDURE IsOptimizeOn (QuadNo: CARDINAL) : BOOLEAN ;
 878 VAR
 879    f : QuadFrame ;
 880    n,
 881    q : CARDINAL ;
 882    On: BOOLEAN ;
 883 BEGIN
 884    On := Optimizing ;
 885    q := Head ;
 886    WHILE (q#0) AND (q#QuadNo) DO
 887       f := GetQF(q) ;
 888       WITH f^ DO
 889          IF Operator=OptimizeOnOp
 890          THEN
 891             On := TRUE
 892          ELSIF Operator=OptimizeOffOp
 893          THEN
 894             On := FALSE
 895          END ;
 896          n := Next
 897       END ;
 898       q := n
 899    END ;
 900    RETURN( On )
 901 END IsOptimizeOn ;
 902
 903
 904 (*
 905    IsProfileOn - returns true if the Profile flag was true at QuadNo.
 906 *)
 907
 908 PROCEDURE IsProfileOn (QuadNo: CARDINAL) : BOOLEAN ;
 909 VAR
 910    f : QuadFrame ;
 911    n,
 912    q : CARDINAL ;
 913    On: BOOLEAN ;
 914 BEGIN
 915    On := Profiling ;
 916    q := Head ;
 917    WHILE (q#0) AND (q#QuadNo) DO
 918       f := GetQF(q) ;
 919       WITH f^ DO
 920          IF Operator=ProfileOnOp
 921          THEN
 922             On := TRUE
 923          ELSIF Operator=ProfileOffOp
 924          THEN
 925             On := FALSE
 926          END ;
 927          n := Next
 928       END ;
 929       q := n
 930    END ;
 931    RETURN( On )
 932 END IsProfileOn ;
 933
 934
 935 (*
 936    IsCodeOn - returns true if the Code flag was true at QuadNo.
 937 *)
 938
 939 PROCEDURE IsCodeOn (QuadNo: CARDINAL) : BOOLEAN ;
 940 VAR
 941    f : QuadFrame ;
 942    n,
 943    q : CARDINAL ;
 944    On: BOOLEAN ;
 945 BEGIN
 946    On := Coding ;
 947    q := Head ;
 948    WHILE (q#0) AND (q#QuadNo) DO
 949       f := GetQF(q) ;
 950       WITH f^ DO
 951          IF Operator=CodeOnOp
 952          THEN
 953             On := TRUE
 954          ELSIF Operator=CodeOffOp
 955          THEN
 956             On := FALSE
 957          END ;
 958          n := Next
 959       END ;
 960       q := n
 961    END ;
 962    RETURN( On )
 963 END IsCodeOn ;
 964
 965
 966 (*
 967    IsDefOrModFile - returns TRUE if QuadNo is a start of Module or Def file
 968                     directive.
 969 *)
 970
 971 PROCEDURE IsDefOrModFile (QuadNo: CARDINAL) : BOOLEAN ;
 972 VAR
 973    f: QuadFrame ;
 974 BEGIN
 975    f := GetQF(QuadNo) ;
 976    WITH f^ DO
 977       RETURN( (Operator=StartDefFileOp) OR (Operator=StartModFileOp) )
 978    END
 979 END IsDefOrModFile ;
 980
 981
 982 (*
 983    IsPseudoQuad - returns true if QuadNo is a compiler directive.
 984                   ie code, profile and optimize.
 985                      StartFile, EndFile,
 986 *)
 987
 988 PROCEDURE IsPseudoQuad (QuadNo: CARDINAL) : BOOLEAN ;
 989 VAR
 990    f: QuadFrame ;
 991 BEGIN
 992    f := GetQF(QuadNo) ;
 993    WITH f^ DO
 994       RETURN( (Operator=CodeOnOp) OR (Operator=CodeOffOp) OR
 995               (Operator=ProfileOnOp) OR (Operator=ProfileOffOp) OR
 996               (Operator=OptimizeOnOp) OR (Operator=OptimizeOffOp) OR
 997               (Operator=EndFileOp) OR
 998               (Operator=StartDefFileOp) OR (Operator=StartModFileOp)
 999             )
1000    END
1001 END IsPseudoQuad ;
1002
1003
1004 (*
1005    GetLastFileQuad - returns the Quadruple number of the last StartDefFile or
1006                      StartModFile quadruple.
1007 *)
1008
1009 PROCEDURE GetLastFileQuad (QuadNo: CARDINAL) : CARDINAL ;
1010 VAR
1011    f       : QuadFrame ;
1012    q, i,
1013    FileQuad: CARDINAL ;
1014 BEGIN
1015    q := Head ;
1016    FileQuad := 0 ;
1017    REPEAT
1018       f := GetQF(q) ;
1019       WITH f^ DO
1020          IF (Operator=StartModFileOp) OR (Operator=StartDefFileOp)
1021          THEN
1022             FileQuad := q
1023          END ;
1024          i := Next
1025       END ;
1026       q := i
1027    UNTIL (i=QuadNo) OR (i=0) ;
1028    Assert(i#0) ;
1029    Assert(FileQuad#0) ;
1030    RETURN( FileQuad )
1031 END GetLastFileQuad ;
1032
1033
1034 (*
1035    GetLastQuadNo - returns the last quadruple number referenced
1036                    by a GetQuad.
1037 *)
1038
1039 PROCEDURE GetLastQuadNo () : CARDINAL ;
1040 BEGIN
1041    RETURN( LastQuadNo )
1042 END GetLastQuadNo ;
1043
1044
1045 (*
1046    QuadToLineNo - Converts a QuadNo into the approprate line number of the
1047                   source file, the line number is returned.
1048
1049                   This may be used to yield an idea where abouts in the
1050                   source file the code generetion is
1051                   processing.
1052 *)
1053
1054 PROCEDURE QuadToLineNo (QuadNo: CARDINAL) : CARDINAL ;
1055 VAR
1056    f: QuadFrame ;
1057 BEGIN
1058    IF ((LastQuadNo=0) AND (NOT IsNoPass()) AND (NOT IsPassCodeGeneration())) OR
1059       (NOT InBounds(QuadArray, QuadNo))
1060    THEN
1061       RETURN( 0 )
1062    ELSE
1063       f := GetQF(QuadNo) ;
1064       RETURN( f^.LineNo )
1065    END
1066 END QuadToLineNo ;
1067
1068
1069 (*
1070    QuadToTokenNo - Converts a QuadNo into the approprate token number of the
1071                    source file, the line number is returned.
1072
1073                    This may be used to yield an idea where abouts in the
1074                    source file the code generetion is
1075                    processing.
1076 *)
1077
1078 PROCEDURE QuadToTokenNo (QuadNo: CARDINAL) : CARDINAL ;
1079 VAR
1080    f: QuadFrame ;
1081 BEGIN
1082    IF ((LastQuadNo=0) AND (NOT IsNoPass()) AND (NOT IsPassCodeGeneration())) OR
1083       (NOT InBounds(QuadArray, QuadNo))
1084    THEN
1085       RETURN( 0 )
1086    ELSE
1087       f := GetQF(QuadNo) ;
1088       RETURN( f^.TokenNo )
1089    END
1090 END QuadToTokenNo ;
1091
1092
1093 (*
1094    GetQuad - returns the Quadruple QuadNo.
1095 *)
1096
1097 PROCEDURE GetQuad (QuadNo: CARDINAL;
1098                    VAR Op: QuadOperator;
1099                    VAR Oper1, Oper2, Oper3: CARDINAL) ;
1100 VAR
1101    f: QuadFrame ;
1102 BEGIN
1103    f := GetQF(QuadNo) ;
1104    LastQuadNo := QuadNo ;
1105    WITH f^ DO
1106       Op := Operator ;
1107       Oper1 := Operand1 ;
1108       Oper2 := Operand2 ;
1109       Oper3 := Operand3
1110    END
1111 END GetQuad ;
1112
1113
1114 (*
1115    GetQuadtok - returns the Quadruple QuadNo.
1116 *)
1117
1118 PROCEDURE GetQuadtok (QuadNo: CARDINAL;
1119                       VAR Op: QuadOperator;
1120                       VAR Oper1, Oper2, Oper3: CARDINAL;
1121                       VAR Op1Pos, Op2Pos, Op3Pos: CARDINAL) ;
1122 VAR
1123    f: QuadFrame ;
1124 BEGIN
1125    f := GetQF(QuadNo) ;
1126    LastQuadNo := QuadNo ;
1127    WITH f^ DO
1128       Op := Operator ;
1129       Oper1 := Operand1 ;
1130       Oper2 := Operand2 ;
1131       Oper3 := Operand3 ;
1132       Op1Pos := op1pos ;
1133       Op2Pos := op2pos ;
1134       Op3Pos := op3pos
1135    END
1136 END GetQuadtok ;
1137
1138
1139 (*
1140    GetQuadOtok - returns the Quadruple QuadNo.
1141 *)
1142
1143 PROCEDURE GetQuadOtok (QuadNo: CARDINAL;
1144                        VAR tok: CARDINAL;
1145                        VAR Op: QuadOperator;
1146                        VAR Oper1, Oper2, Oper3: CARDINAL;
1147                        VAR Op1Pos, Op2Pos, Op3Pos: CARDINAL) ;
1148 VAR
1149    f: QuadFrame ;
1150 BEGIN
1151    f := GetQF(QuadNo) ;
1152    LastQuadNo := QuadNo ;
1153    WITH f^ DO
1154       Op := Operator ;
1155       Oper1 := Operand1 ;
1156       Oper2 := Operand2 ;
1157       Oper3 := Operand3 ;
1158       Op1Pos := op1pos ;
1159       Op2Pos := op2pos ;
1160       Op3Pos := op3pos ;
1161       tok := TokenNo
1162    END
1163 END GetQuadOtok ;
1164
1165
1166 (*
1167    AddQuadInformation - adds variable analysis and jump analysis to the new quadruple.
1168 *)
1169
1170 PROCEDURE AddQuadInformation (QuadNo: CARDINAL;
1171                               Op: QuadOperator;
1172                               Oper1, Oper2, Oper3: CARDINAL) ;
1173 BEGIN
1174    CASE Op OF
1175
1176    IfInOp,
1177    IfNotInOp,
1178    IfEquOp,
1179    IfNotEquOp,
1180    IfLessOp,
1181    IfLessEquOp,
1182    IfGreOp,
1183    IfGreEquOp : ManipulateReference(QuadNo, Oper3) ;
1184                 CheckAddVariableRead(Oper1, FALSE, QuadNo) ;
1185                 CheckAddVariableRead(Oper2, FALSE, QuadNo) |
1186
1187    TryOp,
1188    RetryOp,
1189    GotoOp     : ManipulateReference(QuadNo, Oper3) |
1190
1191    (* variable references *)
1192
1193    InclOp,
1194    ExclOp            : CheckConst(Oper1) ;
1195                        CheckAddVariableRead(Oper3, FALSE, QuadNo) ;
1196                        CheckAddVariableWrite(Oper1, TRUE, QuadNo) |
1197    UnboundedOp,
1198    FunctValueOp,
1199    NegateOp,
1200    BecomesOp,
1201    HighOp,
1202    SizeOp            : CheckConst(Oper1) ;
1203                        CheckAddVariableWrite(Oper1, FALSE, QuadNo) ;
1204                        CheckAddVariableRead(Oper3, FALSE, QuadNo) |
1205    AddrOp            : CheckConst(Oper1) ;
1206                        CheckAddVariableWrite(Oper1, FALSE, QuadNo) ;
1207                        (* CheckAddVariableReadLeftValue(Oper3, QuadNo) *)
1208                        (* the next line is a kludge and assumes we _will_
1209                           write to the variable as we have taken its address *)
1210                        CheckRemoveVariableWrite(Oper1, TRUE, QuadNo) |
1211    ReturnValueOp     : CheckAddVariableRead(Oper1, FALSE, QuadNo) |
1212    ReturnOp,
1213    NewLocalVarOp,
1214    KillLocalVarOp    : |
1215    CallOp            : CheckAddVariableRead(Oper3, TRUE, QuadNo) |
1216
1217    ParamOp           : CheckAddVariableRead(Oper2, FALSE, QuadNo) ;
1218                        CheckAddVariableRead(Oper3, FALSE, QuadNo) ;
1219                        IF (Oper1>0) AND (Oper1<=NoOfParam(Oper2)) AND
1220                           IsVarParam(Oper2, Oper1)
1221                        THEN
1222                           (* _may_ also write to a var parameter, although we dont know *)
1223                           CheckAddVariableWrite(Oper3, TRUE, QuadNo)
1224                        END |
1225    RecordFieldOp,
1226    ArrayOp,
1227    LogicalShiftOp,
1228    LogicalRotateOp,
1229    LogicalOrOp,
1230    LogicalAndOp,
1231    LogicalXorOp,
1232    CoerceOp,
1233    ConvertOp,
1234    CastOp,
1235    AddOp,
1236    SubOp,
1237    MultOp,
1238    DivM2Op,
1239    ModM2Op,
1240    ModFloorOp,
1241    DivCeilOp,
1242    ModCeilOp,
1243    DivFloorOp,
1244    ModTruncOp,
1245    DivTruncOp        : CheckConst(Oper1) ;
1246                        CheckAddVariableWrite(Oper1, FALSE, QuadNo) ;
1247                        CheckAddVariableRead(Oper2, FALSE, QuadNo) ;
1248                        CheckAddVariableRead(Oper3, FALSE, QuadNo) |
1249
1250    XIndrOp           : CheckConst(Oper1) ;
1251                        CheckAddVariableWrite(Oper1, TRUE, QuadNo) ;
1252                        CheckAddVariableRead(Oper3, FALSE, QuadNo) |
1253
1254    IndrXOp           : CheckConst(Oper1) ;
1255                        CheckAddVariableWrite(Oper1, FALSE, QuadNo) ;
1256                        CheckAddVariableRead(Oper3, TRUE, QuadNo) |
1257
1258 (* RangeCheckOp      : CheckRangeAddVariableRead(Oper3, QuadNo) | *)
1259    SaveExceptionOp   : CheckConst(Oper1) ;
1260                        CheckAddVariableWrite(Oper1, FALSE, QuadNo) |
1261    RestoreExceptionOp: CheckAddVariableRead(Oper1, FALSE, QuadNo)
1262
1263    ELSE
1264    END
1265 END AddQuadInformation ;
1266
1267
1268 PROCEDURE stop ; BEGIN END stop ;
1269
1270
1271 (*
1272    PutQuadO - alters a quadruple QuadNo with Op, Oper1, Oper2, Oper3, and
1273               sets a boolean to determinine whether overflow should be checked.
1274 *)
1275
1276 PROCEDURE PutQuadO (QuadNo: CARDINAL;
1277                     Op: QuadOperator;
1278                     Oper1, Oper2, Oper3: CARDINAL;
1279                     overflow: BOOLEAN) ;
1280 VAR
1281    f: QuadFrame ;
1282 BEGIN
1283    IF QuadNo = BreakAtQuad
1284    THEN
1285       stop
1286    END ;
1287    IF QuadrupleGeneration
1288    THEN
1289       EraseQuad (QuadNo) ;
1290       AddQuadInformation (QuadNo, Op, Oper1, Oper2, Oper3) ;
1291       f := GetQF (QuadNo) ;
1292       WITH f^ DO
1293          Operator      := Op ;
1294          Operand1      := Oper1 ;
1295          Operand2      := Oper2 ;
1296          Operand3      := Oper3 ;
1297          CheckOverflow := overflow
1298       END
1299    END
1300 END PutQuadO ;
1301
1302
1303 (*
1304    PutQuad - overwrites a quadruple QuadNo with Op, Oper1, Oper2, Oper3
1305 *)
1306
1307 PROCEDURE PutQuad (QuadNo: CARDINAL;
1308                    Op: QuadOperator;
1309                    Oper1, Oper2, Oper3: CARDINAL) ;
1310 BEGIN
1311    PutQuadO (QuadNo, Op, Oper1, Oper2, Oper3, TRUE)
1312 END PutQuad ;
1313
1314
1315 (*
1316    UndoReadWriteInfo -
1317 *)
1318
1319 PROCEDURE UndoReadWriteInfo (QuadNo: CARDINAL;
1320                              Op: QuadOperator;
1321                              Oper1, Oper2, Oper3: CARDINAL) ;
1322 BEGIN
1323    CASE Op OF
1324
1325    (* jumps, calls and branches *)
1326    IfInOp,
1327    IfNotInOp,
1328    IfEquOp,
1329    IfNotEquOp,
1330    IfLessOp,
1331    IfLessEquOp,
1332    IfGreOp,
1333    IfGreEquOp        : RemoveReference(QuadNo) ;
1334                        CheckRemoveVariableRead(Oper1, FALSE, QuadNo) ;
1335                        CheckRemoveVariableRead(Oper2, FALSE, QuadNo) |
1336
1337    TryOp,
1338    RetryOp,
1339    GotoOp            : RemoveReference(QuadNo) |
1340
1341    (* variable references *)
1342
1343    InclOp,
1344    ExclOp            : CheckRemoveVariableRead(Oper1, FALSE, QuadNo) ;
1345                        CheckRemoveVariableWrite(Oper1, TRUE, QuadNo) |
1346
1347    UnboundedOp,
1348    FunctValueOp,
1349    NegateOp,
1350    BecomesOp,
1351    HighOp,
1352    SizeOp            : CheckRemoveVariableWrite(Oper1, FALSE, QuadNo) ;
1353                        CheckRemoveVariableRead(Oper3, FALSE, QuadNo) |
1354    AddrOp            : CheckRemoveVariableWrite(Oper1, FALSE, QuadNo) ;
1355                        (* CheckRemoveVariableReadLeftValue(Oper3, QuadNo) ; *)
1356                        (* the next line is a kludge and assumes we _will_
1357                           write to the variable as we have taken its address *)
1358                        CheckRemoveVariableWrite(Oper1, TRUE, QuadNo) |
1359    ReturnValueOp     : CheckRemoveVariableRead(Oper1, FALSE, QuadNo) |
1360    ReturnOp,
1361    CallOp,
1362    NewLocalVarOp,
1363    KillLocalVarOp    : |
1364    ParamOp           : CheckRemoveVariableRead(Oper2, FALSE, QuadNo) ;
1365                        CheckRemoveVariableRead(Oper3, FALSE, QuadNo) ;
1366                        IF (Oper1>0) AND (Oper1<=NoOfParam(Oper2)) AND
1367                           IsVarParam(Oper2, Oper1)
1368                        THEN
1369                           (* _may_ also write to a var parameter, although we dont know *)
1370                           CheckRemoveVariableWrite(Oper3, TRUE, QuadNo)
1371                        END |
1372    RecordFieldOp,
1373    ArrayOp,
1374    LogicalShiftOp,
1375    LogicalRotateOp,
1376    LogicalOrOp,
1377    LogicalAndOp,
1378    LogicalXorOp,
1379    CoerceOp,
1380    ConvertOp,
1381    CastOp,
1382    AddOp,
1383    SubOp,
1384    MultOp,
1385    DivM2Op,
1386    ModM2Op,
1387    ModFloorOp,
1388    DivCeilOp,
1389    ModCeilOp,
1390    DivFloorOp,
1391    ModTruncOp,
1392    DivTruncOp        : CheckRemoveVariableWrite(Oper1, FALSE, QuadNo) ;
1393                        CheckRemoveVariableRead(Oper2, FALSE, QuadNo) ;
1394                        CheckRemoveVariableRead(Oper3, FALSE, QuadNo) |
1395
1396    XIndrOp           : CheckRemoveVariableWrite(Oper1, TRUE, QuadNo) ;
1397                        CheckRemoveVariableRead(Oper3, FALSE, QuadNo) |
1398
1399    IndrXOp           : CheckRemoveVariableWrite(Oper1, FALSE, QuadNo) ;
1400                        CheckRemoveVariableRead(Oper3, TRUE, QuadNo) |
1401
1402 (* RangeCheckOp      : CheckRangeRemoveVariableRead(Oper3, QuadNo) | *)
1403    SaveExceptionOp   : CheckRemoveVariableWrite(Oper1, FALSE, QuadNo) |
1404    RestoreExceptionOp: CheckRemoveVariableRead(Oper1, FALSE, QuadNo)
1405
1406    ELSE
1407    END
1408 END UndoReadWriteInfo ;
1409
1410
1411 (*
1412    EraseQuad - erases a quadruple QuadNo, the quadruple is still in the list
1413                but wiped clean.
1414 *)
1415
1416 PROCEDURE EraseQuad (QuadNo: CARDINAL) ;
1417 VAR
1418    f: QuadFrame ;
1419 BEGIN
1420    f := GetQF(QuadNo) ;
1421    WITH f^ DO
1422       UndoReadWriteInfo(QuadNo, Operator, Operand1, Operand2, Operand3) ;
1423       Operator := DummyOp ;   (* finally blank it out *)
1424       Operand1 := 0 ;
1425       Operand2 := 0 ;
1426       Operand3 := 0 ;
1427       op1pos   := UnknownTokenNo ;
1428       op2pos   := UnknownTokenNo ;
1429       op3pos   := UnknownTokenNo
1430    END
1431 END EraseQuad ;
1432
1433
1434 (*
1435    CheckAddVariableReadLeftValue -
1436 *)
1437
1438 (*
1439 PROCEDURE CheckAddVariableReadLeftValue (sym: CARDINAL; q: CARDINAL) ;
1440 BEGIN
1441    IF IsVar(sym)
1442    THEN
1443       PutReadQuad(sym, LeftValue, q)
1444    END
1445 END CheckAddVariableReadLeftValue ;
1446 *)
1447
1448
1449 (*
1450    CheckRemoveVariableReadLeftValue -
1451 *)
1452
1453 (*
1454 PROCEDURE CheckRemoveVariableReadLeftValue (sym: CARDINAL; q: CARDINAL) ;
1455 BEGIN
1456    IF IsVar(sym)
1457    THEN
1458       RemoveReadQuad(sym, LeftValue, q)
1459    END
1460 END CheckRemoveVariableReadLeftValue ;
1461 *)
1462
1463
1464 (*
1465    CheckAddVariableRead - checks to see whether symbol, Sym, is a variable or
1466                           a parameter and if so it then adds this quadruple
1467                           to the variable list.
1468 *)
1469
1470 PROCEDURE CheckAddVariableRead (Sym: CARDINAL; canDereference: BOOLEAN; Quad: CARDINAL) ;
1471 BEGIN
1472    IF IsVar(Sym)
1473    THEN
1474       PutReadQuad(Sym, GetMode(Sym), Quad) ;
1475       IF (GetMode(Sym)=LeftValue) AND canDereference
1476       THEN
1477          PutReadQuad(Sym, RightValue, Quad)
1478       END
1479    END
1480 END CheckAddVariableRead ;
1481
1482
1483 (*
1484    CheckRemoveVariableRead - checks to see whether, Sym, is a variable or
1485                              a parameter and if so then it removes the
1486                              quadruple from the variable list.
1487 *)
1488
1489 PROCEDURE CheckRemoveVariableRead (Sym: CARDINAL; canDereference: BOOLEAN; Quad: CARDINAL) ;
1490 BEGIN
1491    IF IsVar(Sym)
1492    THEN
1493       RemoveReadQuad(Sym, GetMode(Sym), Quad) ;
1494       IF (GetMode(Sym)=LeftValue) AND canDereference
1495       THEN
1496          RemoveReadQuad(Sym, RightValue, Quad)
1497       END
1498    END
1499 END CheckRemoveVariableRead ;
1500
1501
1502 (*
1503    CheckAddVariableWrite - checks to see whether symbol, Sym, is a variable and
1504                            if so it then adds this quadruple to the variable list.
1505 *)
1506
1507 PROCEDURE CheckAddVariableWrite (Sym: CARDINAL; canDereference: BOOLEAN; Quad: CARDINAL) ;
1508 BEGIN
1509    IF IsVar(Sym)
1510    THEN
1511       IF (GetMode(Sym)=LeftValue) AND canDereference
1512       THEN
1513          PutReadQuad(Sym, LeftValue, Quad) ;
1514          PutWriteQuad(Sym, RightValue, Quad)
1515       ELSE
1516          PutWriteQuad(Sym, GetMode(Sym), Quad)
1517       END
1518    END
1519 END CheckAddVariableWrite ;
1520
1521
1522 (*
1523    CheckRemoveVariableWrite - checks to see whether, Sym, is a variable and
1524                               if so then it removes the quadruple from the
1525                               variable list.
1526 *)
1527
1528 PROCEDURE CheckRemoveVariableWrite (Sym: CARDINAL; canDereference: BOOLEAN; Quad: CARDINAL) ;
1529 BEGIN
1530    IF IsVar(Sym)
1531    THEN
1532       IF (GetMode(Sym)=LeftValue) AND canDereference
1533       THEN
1534          RemoveReadQuad(Sym, LeftValue, Quad) ;
1535          RemoveWriteQuad(Sym, RightValue, Quad)
1536       ELSE
1537          RemoveWriteQuad(Sym, GetMode(Sym), Quad)
1538       END
1539    END
1540 END CheckRemoveVariableWrite ;
1541
1542
1543 (*
1544    CheckConst -
1545 *)
1546
1547 PROCEDURE CheckConst (sym: CARDINAL) ;
1548 BEGIN
1549    IF IsConst(sym)
1550    THEN
1551       PutToBeSolvedByQuads(sym)
1552    END
1553 END CheckConst ;
1554
1555
1556 (*
1557    GetFirstQuad - returns the first quadruple.
1558 *)
1559
1560 PROCEDURE GetFirstQuad () : CARDINAL ;
1561 BEGIN
1562    RETURN( Head )
1563 END GetFirstQuad ;
1564
1565
1566 (*
1567    GetNextQuad - returns the Quadruple number following QuadNo.
1568 *)
1569
1570 PROCEDURE GetNextQuad (QuadNo: CARDINAL) : CARDINAL ;
1571 VAR
1572    f: QuadFrame ;
1573 BEGIN
1574    f := GetQF(QuadNo) ;
1575    RETURN( f^.Next )
1576 END GetNextQuad ;
1577
1578
1579 (*
1580    SubQuad - subtracts a quadruple QuadNo from a list Head.
1581 *)
1582
1583 PROCEDURE SubQuad (QuadNo: CARDINAL) ;
1584 VAR
1585    i   : CARDINAL ;
1586    f, g: QuadFrame ;
1587 BEGIN
1588    f := GetQF(QuadNo) ;
1589    WITH f^ DO
1590       AlterReference(Head, QuadNo, f^.Next) ;
1591       UndoReadWriteInfo(QuadNo, Operator, Operand1, Operand2, Operand3)
1592    END ;
1593    IF Head=QuadNo
1594    THEN
1595       Head := f^.Next
1596    ELSE
1597       i := Head ;
1598       g := GetQF(i) ;
1599       WHILE g^.Next#QuadNo DO
1600          i := g^.Next ;
1601          g := GetQF(i)
1602       END ;
1603       g^.Next := f^.Next
1604    END ;
1605    f^.Operator := DummyOp ;
1606    DEC(NoOfQuads)
1607 END SubQuad ;
1608
1609
1610 (*
1611    GetRealQuad - returns the Quadruple number of the real quadruple
1612                  at QuadNo or beyond.
1613 *)
1614
1615 PROCEDURE GetRealQuad (QuadNo: CARDINAL) : CARDINAL ;
1616 VAR
1617    f: QuadFrame ;
1618 BEGIN
1619    WHILE QuadNo#0 DO
1620       IF InBounds(QuadArray, QuadNo)
1621       THEN
1622          f := GetQF(QuadNo) ;
1623          WITH f^ DO
1624             IF (NOT IsPseudoQuad(QuadNo)) AND
1625                (Operator#DummyOp) AND (Operator#LineNumberOp) AND (Operator#StatementNoteOp)
1626             THEN
1627                RETURN( QuadNo )
1628             END
1629          END ;
1630          INC(QuadNo)
1631       ELSE
1632          RETURN( 0 )
1633       END
1634    END ;
1635    RETURN( 0 )
1636 END GetRealQuad ;
1637
1638
1639 (*
1640    AlterReference - alters all references from OldQuad, to NewQuad in a
1641                     quadruple list Head.
1642 *)
1643
1644 PROCEDURE AlterReference (Head, OldQuad, NewQuad: CARDINAL) ;
1645 VAR
1646    f, g: QuadFrame ;
1647    i   : CARDINAL ;
1648 BEGIN
1649    f := GetQF(OldQuad) ;
1650    WHILE (f^.NoOfTimesReferenced>0) AND (Head#0) DO
1651       g := GetQF(Head) ;
1652       WITH g^ DO
1653          CASE Operator OF
1654
1655          IfInOp,
1656          IfNotInOp,
1657          IfEquOp,
1658          IfNotEquOp,
1659          IfLessOp,
1660          IfLessEquOp,
1661          IfGreOp,
1662          IfGreEquOp,
1663          TryOp,
1664          RetryOp,
1665          GotoOp     : IF Operand3=OldQuad
1666                       THEN
1667                          ManipulateReference(Head, NewQuad)
1668                       END
1669
1670          ELSE
1671          END ;
1672          i := Next
1673       END ;
1674       Head := i
1675    END
1676 END AlterReference ;
1677
1678
1679 (*
1680    GrowQuads - grows the list of quadruples to the quadruple, to.
1681 *)
1682
1683 PROCEDURE GrowQuads (to: CARDINAL) ;
1684 VAR
1685    i: CARDINAL ;
1686    f: QuadFrame ;
1687 BEGIN
1688    IF (to#0) AND (to>GrowInitialization)
1689    THEN
1690       i := GrowInitialization+1 ;
1691       WHILE i<=to DO
1692          IF InBounds(QuadArray, i)
1693          THEN
1694             Assert(GetIndice(QuadArray, i)#NIL)
1695          ELSE
1696             NEW(f) ;
1697             IF f=NIL
1698             THEN
1699                InternalError ('out of memory error when trying to allocate a quadruple')
1700             END ;
1701             PutIndice(QuadArray, i, f) ;
1702             f^.NoOfTimesReferenced := 0
1703          END ;
1704          INC(i)
1705       END ;
1706       GrowInitialization := to
1707    END
1708 END GrowQuads ;
1709
1710
1711 (*
1712    ManipulateReference - manipulates the quadruple, q, so that it now points to quad, to.
1713 *)
1714
1715 PROCEDURE ManipulateReference (q: CARDINAL; to: CARDINAL) ;
1716 VAR
1717    f: QuadFrame ;
1718 BEGIN
1719    Assert((GrowInitialization>=q) OR (to=0)) ;
1720    GrowQuads(to) ;
1721    RemoveReference(q) ;
1722    f := GetQF(q) ;
1723    f^.Operand3 := to ;
1724    IF to#0
1725    THEN
1726       f := GetQF(to) ;
1727       INC(f^.NoOfTimesReferenced)
1728    END
1729 END ManipulateReference ;
1730
1731
1732 (*
1733    RemoveReference - remove the reference by quadruple, q, to wherever
1734                      it was pointing to.
1735 *)
1736
1737 PROCEDURE RemoveReference (q: CARDINAL) ;
1738 VAR
1739    f, g: QuadFrame ;
1740 BEGIN
1741    f := GetQF(q) ;
1742    IF (f^.Operand3#0) AND (f^.Operand3<NextQuad)
1743    THEN
1744       g := GetQF(f^.Operand3) ;
1745       Assert(g^.NoOfTimesReferenced#0) ;
1746       DEC(g^.NoOfTimesReferenced)
1747    END
1748 END RemoveReference ;
1749
1750
1751 (*
1752    CountQuads - returns the number of quadruples.
1753 *)
1754
1755 PROCEDURE CountQuads () : CARDINAL ;
1756 BEGIN
1757    RETURN( NoOfQuads )
1758 END CountQuads ;
1759
1760
1761 (*
1762    NewQuad - sets QuadNo to a new quadruple.
1763 *)
1764
1765 PROCEDURE NewQuad (VAR QuadNo: CARDINAL) ;
1766 VAR
1767    f: QuadFrame ;
1768 BEGIN
1769    QuadNo := FreeList ;
1770    IF InBounds (QuadArray, QuadNo) AND (GetIndice (QuadArray, QuadNo) # NIL)
1771    THEN
1772       f := GetIndice (QuadArray, QuadNo)
1773    ELSE
1774       NEW (f) ;
1775       IF f=NIL
1776       THEN
1777          InternalError ('out of memory error trying to allocate a quadruple')
1778       ELSE
1779          INC (NoOfQuads) ;
1780          PutIndice (QuadArray, QuadNo, f) ;
1781          f^.NoOfTimesReferenced := 0
1782       END
1783    END ;
1784    WITH f^ DO
1785       Operator := DummyOp ;
1786       Operand3 := 0 ;
1787       Next := 0
1788    END ;
1789    INC (FreeList) ;
1790    IF GrowInitialization < FreeList
1791    THEN
1792       GrowInitialization := FreeList
1793    END
1794 END NewQuad ;
1795
1796
1797 (*
1798    CheckVariableAt - checks to see whether, sym, was declared at a particular address.
1799 *)
1800
1801 PROCEDURE CheckVariableAt (sym: CARDINAL) ;
1802 BEGIN
1803    IF IsVar (sym) AND IsVariableAtAddress (sym)
1804    THEN
1805       IF GetMode (sym) = LeftValue
1806       THEN
1807          GenQuad (InitAddressOp, sym, NulSym, GetVariableAtAddress (sym))
1808       ELSE
1809          InternalError ('expecting lvalue for this variable which is declared at an explicit address')
1810       END
1811    END
1812 END CheckVariableAt ;
1813
1814
1815 (*
1816    CheckVariablesAt - checks to see whether we need to initialize any pointers
1817                       which point to variable declared at addresses.
1818 *)
1819
1820 PROCEDURE CheckVariablesAt (scope: CARDINAL) ;
1821 BEGIN
1822    ForeachLocalSymDo (scope, CheckVariableAt)
1823 END CheckVariablesAt ;
1824
1825
1826 (*
1827    GetTurnInterrupts - returns the TurnInterrupts procedure function.
1828 *)
1829
1830 PROCEDURE GetTurnInterrupts (tok: CARDINAL) : CARDINAL ;
1831 BEGIN
1832    IF Iso
1833    THEN
1834       RETURN GetQualidentImport (tok,
1835                                  MakeKey ('TurnInterrupts'), MakeKey ('COROUTINES'))
1836    ELSE
1837       RETURN GetQualidentImport (tok,
1838                                  MakeKey ('TurnInterrupts'), MakeKey ('SYSTEM'))
1839    END
1840 END GetTurnInterrupts ;
1841
1842
1843 (*
1844    GetProtection - returns the PROTECTION data type.
1845 *)
1846
1847 PROCEDURE GetProtection (tok: CARDINAL) : CARDINAL ;
1848 BEGIN
1849    IF Iso
1850    THEN
1851       RETURN GetQualidentImport (tok,
1852                                  MakeKey ('PROTECTION'), MakeKey ('COROUTINES'))
1853    ELSE
1854       RETURN GetQualidentImport (tok,
1855                                  MakeKey ('PROTECTION'), MakeKey ('SYSTEM'))
1856    END
1857 END GetProtection ;
1858
1859
1860 (*
1861    CheckNeedPriorityBegin - checks to see whether we need to save the old
1862                             module priority and change to another module
1863                             priority.
1864                             The current module initialization or procedure
1865                             being built is defined by, scope. The module whose
1866                             priority will be used is defined by, module.
1867 *)
1868
1869 PROCEDURE CheckNeedPriorityBegin (tok: CARDINAL; scope, module: CARDINAL) ;
1870 VAR
1871    ProcSym, old: CARDINAL ;
1872 BEGIN
1873    IF GetPriority (module) # NulSym
1874    THEN
1875       (* module has been given a priority *)
1876       ProcSym := GetTurnInterrupts (tok) ;
1877       IF ProcSym # NulSym
1878       THEN
1879          old := MakeTemporary (tok, RightValue) ;
1880          PutVar (old, GetProtection (tok)) ;
1881
1882          GenQuadO (tok, SavePriorityOp, old, scope, ProcSym, FALSE) ;
1883          PushWord (PriorityStack, old)
1884       END
1885    END
1886 END CheckNeedPriorityBegin ;
1887
1888
1889 (*
1890    CheckNeedPriorityEnd - checks to see whether we need to restore the old
1891                           module priority.
1892                           The current module initialization or procedure
1893                           being built is defined by, scope.
1894 *)
1895
1896 PROCEDURE CheckNeedPriorityEnd (tok: CARDINAL;
1897                                 scope, module: CARDINAL) ;
1898 VAR
1899    ProcSym, old: CARDINAL ;
1900 BEGIN
1901    IF GetPriority (module) # NulSym
1902    THEN
1903       (* module has been given a priority *)
1904       ProcSym := GetTurnInterrupts (tok) ;
1905       IF ProcSym # NulSym
1906       THEN
1907          old := PopWord (PriorityStack) ;
1908          GenQuad (RestorePriorityOp, old, scope, ProcSym)
1909       END
1910    END
1911 END CheckNeedPriorityEnd ;
1912
1913
1914 (*
1915    StartBuildDefFile - generates a StartFileDefOp quadruple indicating the file
1916                        that has produced the subsequent quadruples.
1917                        The code generator uses the StartDefFileOp quadruples
1918                        to relate any error to the appropriate file.
1919
1920
1921                        Entry                   Exit
1922                        =====                   ====
1923
1924
1925                 Ptr ->                                        <- Ptr
1926                        +------------+          +------------+
1927                        | ModuleName |          | ModuleName |
1928                        |------------|          |------------|
1929
1930
1931                        Quadruples Produced
1932
1933                        q     StartDefFileOp  _  _  ModuleSym
1934 *)
1935
1936 PROCEDURE StartBuildDefFile (tok: CARDINAL) ;
1937 VAR
1938    ModuleName: Name ;
1939 BEGIN
1940    PopT (ModuleName) ;
1941    PushT (ModuleName) ;
1942    GenQuadO (tok, StartDefFileOp, tok, NulSym, GetModule (ModuleName), FALSE)
1943 END StartBuildDefFile ;
1944
1945
1946 (*
1947    StartBuildModFile - generates a StartModFileOp quadruple indicating the file
1948                        that has produced the subsequent quadruples.
1949                        The code generator uses the StartModFileOp quadruples
1950                        to relate any error to the appropriate file.
1951
1952
1953                        Entry                   Exit
1954                        =====                   ====
1955
1956
1957                 Ptr ->                                        <- Ptr
1958                        +------------+          +------------+
1959                        | ModuleName |          | ModuleName |
1960                        |------------|          |------------|
1961
1962
1963                        Quadruples Produced
1964
1965                        q     StartModFileOp  lineno  filename  ModuleSym
1966 *)
1967
1968 PROCEDURE StartBuildModFile (tok: CARDINAL) ;
1969 BEGIN
1970    GenQuadO (tok, StartModFileOp, tok,
1971              WORD (makekey (string (GetFileName ()))),
1972              GetFileModule (), FALSE)
1973 END StartBuildModFile ;
1974
1975
1976 (*
1977    EndBuildFile - generates an EndFileOp quadruple indicating the file
1978                   that has produced the previous quadruples has ended.
1979
1980                   Entry                   Exit
1981                   =====                   ====
1982
1983
1984            Ptr ->                                        <- Ptr
1985                   +------------+          +------------+
1986                   | ModuleName |          | ModuleName |
1987                   |------------|          |------------|
1988
1989
1990                   Quadruples Produced
1991
1992                   q     EndFileOp  _  _  ModuleSym
1993 *)
1994
1995 PROCEDURE EndBuildFile (tok: CARDINAL) ;
1996 VAR
1997    ModuleName: Name ;
1998 BEGIN
1999    ModuleName := OperandT (1) ;
2000    GenQuadO (tok, EndFileOp, NulSym, NulSym, GetModule (ModuleName), FALSE)
2001 END EndBuildFile ;
2002
2003
2004 (*
2005    StartBuildInit - Sets the start of initialization code of the
2006                     current module to the next quadruple.
2007 *)
2008
2009 PROCEDURE StartBuildInit (tok: CARDINAL) ;
2010 VAR
2011    name     : Name ;
2012    ModuleSym: CARDINAL ;
2013 BEGIN
2014    PopT(name) ;
2015    ModuleSym := GetCurrentModule() ;
2016    Assert(IsModule(ModuleSym) OR IsDefImp(ModuleSym)) ;
2017    Assert(GetSymName(ModuleSym)=name) ;
2018    PutModuleStartQuad(ModuleSym, NextQuad) ;
2019    GenQuad(InitStartOp, tok, GetFileModule(), ModuleSym) ;
2020    PushWord(ReturnStack, 0) ;
2021    PushT(name) ;
2022    CheckVariablesAt(ModuleSym) ;
2023    CheckNeedPriorityBegin(tok, ModuleSym, ModuleSym) ;
2024    PushWord(TryStack, NextQuad) ;
2025    PushWord(CatchStack, 0) ;
2026    IF HasExceptionBlock(ModuleSym)
2027    THEN
2028       GenQuad(TryOp, NulSym, NulSym, 0)
2029    END
2030 END StartBuildInit ;
2031
2032
2033 (*
2034    EndBuildInit - Sets the end initialization code of a module.
2035 *)
2036
2037 PROCEDURE EndBuildInit (tok: CARDINAL) ;
2038 BEGIN
2039    IF HasExceptionBlock(GetCurrentModule())
2040    THEN
2041       BuildRTExceptLeave (tok, TRUE) ;
2042       GenQuadO (tok, CatchEndOp, NulSym, NulSym, NulSym, FALSE)
2043    END ;
2044    BackPatch (PopWord (ReturnStack), NextQuad) ;
2045    CheckNeedPriorityEnd (tok, GetCurrentModule(), GetCurrentModule()) ;
2046    PutModuleEndQuad (GetCurrentModule(), NextQuad) ;
2047    CheckVariablesInBlock (GetCurrentModule()) ;
2048    GenQuadO (tok, InitEndOp, tok, GetFileModule(), GetCurrentModule(), FALSE)
2049 END EndBuildInit ;
2050
2051
2052 (*
2053    StartBuildFinally - Sets the start of finalization code of the
2054                        current module to the next quadruple.
2055 *)
2056
2057 PROCEDURE StartBuildFinally (tok: CARDINAL) ;
2058 VAR
2059    name     : Name ;
2060    ModuleSym: CARDINAL ;
2061 BEGIN
2062    PopT(name) ;
2063    ModuleSym := GetCurrentModule() ;
2064    Assert(IsModule(ModuleSym) OR IsDefImp(ModuleSym)) ;
2065    Assert(GetSymName(ModuleSym)=name) ;
2066    PutModuleFinallyStartQuad(ModuleSym, NextQuad) ;
2067    GenQuadO (tok, FinallyStartOp, tok, GetFileModule(), ModuleSym, FALSE) ;
2068    PushWord (ReturnStack, 0) ;
2069    PushT (name) ;
2070    (* CheckVariablesAt(ModuleSym) ; *)
2071    CheckNeedPriorityBegin (tok, ModuleSym, ModuleSym) ;
2072    PushWord (TryStack, NextQuad) ;
2073    PushWord (CatchStack, 0) ;
2074    IF HasExceptionFinally (ModuleSym)
2075    THEN
2076       GenQuadO (tok, TryOp, NulSym, NulSym, 0, FALSE)
2077    END
2078 END StartBuildFinally ;
2079
2080
2081 (*
2082    EndBuildFinally - Sets the end finalization code of a module.
2083 *)
2084
2085 PROCEDURE EndBuildFinally (tok: CARDINAL) ;
2086 BEGIN
2087    IF HasExceptionFinally(GetCurrentModule())
2088    THEN
2089       BuildRTExceptLeave (tok, TRUE) ;
2090       GenQuadO (tok, CatchEndOp, NulSym, NulSym, NulSym, FALSE)
2091    END ;
2092    BackPatch (PopWord (ReturnStack), NextQuad) ;
2093    CheckNeedPriorityEnd (tok, GetCurrentModule (), GetCurrentModule ()) ;
2094    PutModuleFinallyEndQuad(GetCurrentModule (), NextQuad) ;
2095    CheckVariablesInBlock (GetCurrentModule ()) ;
2096    GenQuadO (tok, FinallyEndOp, tok, GetFileModule (),
2097              GetCurrentModule(), FALSE)
2098 END EndBuildFinally ;
2099
2100
2101 (*
2102    BuildRTExceptEnter - informs RTExceptions that we are about to enter the except state.
2103 *)
2104
2105 PROCEDURE BuildRTExceptEnter (tok: CARDINAL) ;
2106 VAR
2107    old,
2108    ProcSym: CARDINAL ;
2109 BEGIN
2110    IF Exceptions
2111    THEN
2112       (* now inform the Modula-2 runtime we are in the exception state *)
2113       ProcSym := GetQualidentImport (tok,
2114                                      MakeKey('SetExceptionState'), MakeKey('RTExceptions')) ;
2115       IF ProcSym=NulSym
2116       THEN
2117          MetaErrorT0 (tok,
2118                       '{%W}no procedure SetExceptionState found in RTExceptions which is needed to implement exception handling')
2119       ELSE
2120          old := MakeTemporary (tok, RightValue) ;
2121          PutVar (old, Boolean) ;
2122          GenQuadO (tok, SaveExceptionOp, old, NulSym, ProcSym, FALSE) ;
2123          PushWord (ExceptStack, old)
2124       END
2125    ELSE
2126       MetaErrorT0 (tok,
2127                    '{%E}cannot use {%kEXCEPT} blocks with the -fno-exceptions flag')
2128    END
2129 END BuildRTExceptEnter ;
2130
2131
2132 (*
2133    BuildRTExceptLeave - informs RTExceptions that we are about to leave the except state.
2134                         If, destroy, is TRUE then pop the ExceptStack.
2135 *)
2136
2137 PROCEDURE BuildRTExceptLeave (tok: CARDINAL; destroy: BOOLEAN) ;
2138 VAR
2139    old,
2140    ProcSym: CARDINAL ;
2141 BEGIN
2142    IF Exceptions
2143    THEN
2144       (* now inform the Modula-2 runtime we are in the exception state *)
2145       ProcSym := GetQualidentImport (tok,
2146                                      MakeKey('SetExceptionState'), MakeKey('RTExceptions')) ;
2147       IF ProcSym#NulSym
2148       THEN
2149          IF destroy
2150          THEN
2151             old := PopWord (ExceptStack)
2152          ELSE
2153             old := PeepWord (ExceptStack, 1)
2154          END ;
2155          GenQuadO (tok, RestoreExceptionOp, old, NulSym, ProcSym, FALSE)
2156       END
2157    ELSE
2158       (* no need for an error message here as it will be generated in the Enter procedure above *)
2159    END
2160 END BuildRTExceptLeave ;
2161
2162
2163 (*
2164    BuildExceptInitial - adds an CatchBeginOp, CatchEndOp quadruple
2165                         in the current block.
2166 *)
2167
2168 PROCEDURE BuildExceptInitial (tok: CARDINAL) ;
2169 VAR
2170    previous: CARDINAL ;
2171 BEGIN
2172    (* we have finished the 'try' block, so now goto the return
2173       section which will tidy up (any) priorities before returning.
2174    *)
2175    GenQuadO (tok, GotoOp, NulSym, NulSym, PopWord(ReturnStack), FALSE) ;
2176    PushWord (ReturnStack, NextQuad-1) ;
2177    (*
2178       this is the 'catch' block.
2179    *)
2180    BackPatch (PeepWord (TryStack, 1), NextQuad) ;
2181    GenQuadO (tok, CatchBeginOp, NulSym, NulSym, NulSym, FALSE) ;
2182    previous := PopWord (CatchStack) ;
2183    IF previous # 0
2184    THEN
2185       MetaErrorT0 (tok,
2186                    '{%E}only allowed one EXCEPT statement in a procedure or module')
2187    END ;
2188    PushWord (CatchStack, NextQuad-1) ;
2189    BuildRTExceptEnter (tok)
2190 END BuildExceptInitial ;
2191
2192
2193 (*
2194    BuildExceptFinally - adds an ExceptOp quadruple in a modules
2195                         finally block.
2196 *)
2197
2198 PROCEDURE BuildExceptFinally (tok: CARDINAL) ;
2199 BEGIN
2200    BuildExceptInitial (tok)
2201 END BuildExceptFinally ;
2202
2203
2204 (*
2205    BuildExceptProcedure - adds an ExceptOp quadruple in a procedure
2206                           block.
2207 *)
2208
2209 PROCEDURE BuildExceptProcedure (tok: CARDINAL) ;
2210 BEGIN
2211    BuildExceptInitial (tok)
2212 END BuildExceptProcedure ;
2213
2214
2215 (*
2216    BuildRetry - adds an RetryOp quadruple.
2217 *)
2218
2219 PROCEDURE BuildRetry (tok: CARDINAL);
2220 BEGIN
2221    IF PeepWord (CatchStack, 1) = 0
2222    THEN
2223       MetaErrorT0 (tok,
2224                    '{%E}the {%kRETRY} statement must occur after an {%kEXCEPT} statement in the same module or procedure block')
2225    ELSE
2226       BuildRTExceptLeave (tok, FALSE) ;
2227       GenQuadO (tok, RetryOp, NulSym, NulSym, PeepWord (TryStack, 1), FALSE)
2228    END
2229 END BuildRetry ;
2230
2231
2232 (*
2233    SafeRequestSym - only used during scaffold to get argc, argv, envp.
2234                     It attempts to get symbol name from the current scope(s) and if
2235                     it fails then it falls back onto default constants.
2236 *)
2237
2238 PROCEDURE SafeRequestSym (tok: CARDINAL; name: Name) : CARDINAL ;
2239 VAR
2240    sym: CARDINAL ;
2241 BEGIN
2242    sym := GetSym (name) ;
2243    IF sym = NulSym
2244    THEN
2245       IF name = MakeKey ('argc')
2246       THEN
2247          RETURN MakeConstLit (tok, MakeKey ('0'), ZType)
2248       ELSIF (name = MakeKey ('argv')) OR (name = MakeKey ('envp'))
2249       THEN
2250          RETURN Nil
2251       ELSE
2252          InternalError ('not expecting this parameter name') ;
2253          RETURN Nil
2254       END
2255    END ;
2256    RETURN sym
2257 END SafeRequestSym ;
2258
2259
2260 (*
2261    callRequestDependant - create a call:
2262                           RequestDependant (GetSymName (modulesym), GetSymName (depModuleSym));
2263 *)
2264
2265 PROCEDURE callRequestDependant (tokno: CARDINAL;
2266                                 moduleSym, depModuleSym: CARDINAL;
2267                                 requestDep: CARDINAL) ;
2268 BEGIN
2269    Assert (requestDep # NulSym) ;
2270    PushTtok (requestDep, tokno) ;
2271    PushTF (Adr, Address) ;
2272    PushTtok (MakeConstLitString (tokno, GetSymName (moduleSym)), tokno) ;
2273    PushT (1) ;
2274    BuildAdrFunction ;
2275
2276    IF depModuleSym = NulSym
2277    THEN
2278       PushTF (Nil, Address)
2279    ELSE
2280       PushTF (Adr, Address) ;
2281       PushTtok (MakeConstLitString (tokno, GetSymName (depModuleSym)), tokno) ;
2282       PushT (1) ;
2283       BuildAdrFunction
2284    END ;
2285
2286    PushT (2) ;
2287    BuildProcedureCall (tokno)
2288 END callRequestDependant ;
2289
2290
2291 (*
2292    ForeachImportInDepDo -
2293 *)
2294
2295 PROCEDURE ForeachImportInDepDo (importStatements: List; moduleSym, requestDep: CARDINAL) ;
2296 VAR
2297    i, j,
2298    m, n    : CARDINAL ;
2299    imported,
2300    stmt     : CARDINAL ;
2301    l       : List ;
2302 BEGIN
2303    IF importStatements # NIL
2304    THEN
2305       i := 1 ;
2306       n := NoOfItemsInList (importStatements) ;
2307       WHILE i <= n DO
2308          stmt := GetItemFromList (importStatements, i) ;
2309          Assert (IsImportStatement (stmt)) ;
2310          l := GetImportStatementList (stmt) ;
2311          j := 1 ;
2312          m := NoOfItemsInList (l) ;
2313          WHILE j <= m DO
2314             imported := GetItemFromList (l, j) ;
2315             Assert (IsImport (imported)) ;
2316             callRequestDependant (GetImportDeclared (imported),
2317                                   moduleSym, GetImportModule (imported),
2318                                   requestDep) ;
2319             INC (j) ;
2320          END ;
2321          INC (i)
2322       END
2323    END
2324 END ForeachImportInDepDo ;
2325
2326
2327 (*
2328    ForeachImportedModuleDo -
2329 *)
2330
2331 PROCEDURE ForeachImportedModuleDo (moduleSym, requestDep: CARDINAL) ;
2332 VAR
2333    importStatements: List ;
2334 BEGIN
2335    importStatements := GetModuleModImportStatementList (moduleSym) ;
2336    ForeachImportInDepDo (importStatements, moduleSym, requestDep) ;
2337    importStatements := GetModuleDefImportStatementList (moduleSym) ;
2338    ForeachImportInDepDo (importStatements, moduleSym, requestDep)
2339 END ForeachImportedModuleDo ;
2340
2341
2342 (*
2343    BuildM2DepFunction - creates the dependency graph procedure using IR:
2344                         static void
2345                         dependencies (void)
2346                         {
2347                            M2RTS_RequestDependant (module_name, "b");
2348                            M2RTS_RequestDependant (module_name, NULL);
2349                         }
2350 *)
2351
2352 PROCEDURE BuildM2DepFunction (tokno: CARDINAL; moduleSym: CARDINAL) ;
2353 VAR
2354    requestDep,
2355    ctor, init, fini, dep: CARDINAL ;
2356 BEGIN
2357    IF ScaffoldDynamic
2358    THEN
2359       (* Scaffold required and dynamic dependency graph should be produced.  *)
2360       GetModuleCtors (moduleSym, ctor, init, fini, dep) ;
2361       PushT (dep) ;
2362       BuildProcedureStart ;
2363       BuildProcedureBegin ;
2364       StartScope (dep) ;
2365       requestDep := GetQualidentImport (tokno,
2366                                         MakeKey ("RequestDependant"),
2367                                         MakeKey ("M2RTS")) ;
2368       IF requestDep # NulSym
2369       THEN
2370          ForeachImportedModuleDo (moduleSym, requestDep) ;
2371          callRequestDependant (tokno, moduleSym, NulSym, requestDep)
2372       END ;
2373       EndScope ;
2374       BuildProcedureEnd ;
2375       PopN (1)
2376    END
2377 END BuildM2DepFunction ;
2378
2379
2380 (*
2381    BuildM2LinkFunction - creates the _M2_link procedure which will
2382                          cause the linker to pull in all the module ctors.
2383 *)
2384
2385 PROCEDURE BuildM2LinkFunction (tokno: CARDINAL) ;
2386 BEGIN
2387    IF ScaffoldDynamic
2388    THEN
2389       IF linkFunction # NulSym
2390       THEN
2391          (* void
2392            _M2_link (void)
2393            {
2394               for each module in uselist do
2395                  PROC foo_%d = _M2_module_ctor
2396               done
2397            }.  *)
2398          PushT (linkFunction) ;
2399          BuildProcedureStart ;
2400          BuildProcedureBegin ;
2401          StartScope (linkFunction) ;
2402          PopulateCtorArray (tokno) ;
2403          EndScope ;
2404          BuildProcedureEnd ;
2405          PopN (1)
2406       END
2407    END
2408 END BuildM2LinkFunction ;
2409
2410
2411 (*
2412    BuildTry - build the try statement for main.
2413 *)
2414
2415 PROCEDURE BuildTry (tokno: CARDINAL) ;
2416 BEGIN
2417    IF Exceptions
2418    THEN
2419       PushWord (TryStack, NextQuad) ;
2420       PushWord (CatchStack, 0) ;
2421       GenQuadO (tokno, TryOp, NulSym, NulSym, 0, FALSE)
2422    END
2423 END BuildTry ;
2424
2425
2426 (*
2427    BuildExcept - build the except block for main.
2428 *)
2429
2430 PROCEDURE BuildExcept (tokno: CARDINAL) ;
2431 VAR
2432    catchProcedure: CARDINAL ;
2433 BEGIN
2434    IF Exceptions
2435    THEN
2436       BuildExceptInitial (tokno) ;
2437       catchProcedure := GetQualidentImport (tokno,
2438                                             MakeKey ('DefaultErrorCatch'),
2439                                             MakeKey ('RTExceptions')) ;
2440       IF catchProcedure # NulSym
2441       THEN
2442          PushTtok (catchProcedure, tokno) ;
2443          PushT (0) ;
2444          BuildProcedureCall (tokno)
2445       END ;
2446       BuildRTExceptLeave (tokno, TRUE) ;
2447       GenQuadO (tokno, CatchEndOp, NulSym, NulSym, NulSym, FALSE)
2448    END
2449 END BuildExcept ;
2450
2451
2452 (*
2453    BuildM2MainFunction - creates the main function with appropriate calls to the scaffold.
2454 *)
2455
2456 PROCEDURE BuildM2MainFunction (tokno: CARDINAL) ;
2457 BEGIN
2458    IF (ScaffoldDynamic OR ScaffoldStatic) AND (NOT SharedFlag)
2459    THEN
2460       (* Scaffold required and main should be produced.  *)
2461       (*
2462          int
2463          main (int argc, char *argv[], char *envp[])
2464          {
2465             try {
2466                _M2_init (argc, argv, envp);
2467                _M2_fini (argc, argv, envp);
2468                return 0;
2469             }
2470             catch (...) {
2471                RTExceptions_DefaultErrorCatch ();
2472             }
2473          }
2474       *)
2475       PushT (mainFunction) ;
2476       BuildProcedureStart ;
2477       BuildProcedureBegin ;
2478       StartScope (mainFunction) ;
2479       BuildTry (tokno) ;
2480       (* _M2_init (argc, argv, envp);  *)
2481       PushTtok (initFunction, tokno) ;
2482       PushTtok (RequestSym (tokno, MakeKey ("argc")), tokno) ;
2483       PushTtok (RequestSym (tokno, MakeKey ("argv")), tokno) ;
2484       PushTtok (RequestSym (tokno, MakeKey ("envp")), tokno) ;
2485       PushT (3) ;
2486       BuildProcedureCall (tokno) ;
2487
2488       (* _M2_fini (argc, argv, envp);  *)
2489       PushTtok (finiFunction, tokno) ;
2490       PushTtok (RequestSym (tokno, MakeKey ("argc")), tokno) ;
2491       PushTtok (RequestSym (tokno, MakeKey ("argv")), tokno) ;
2492       PushTtok (RequestSym (tokno, MakeKey ("envp")), tokno) ;
2493       PushT (3) ;
2494       BuildProcedureCall (tokno) ;
2495
2496       PushZero (tokno, Integer) ;
2497       BuildReturn (tokno) ;
2498       BuildExcept (tokno) ;
2499       EndScope ;
2500       BuildProcedureEnd ;
2501       PopN (1)
2502    END
2503 END BuildM2MainFunction ;
2504
2505
2506 (*
2507    BuildM2InitFunction -
2508 *)
2509
2510 PROCEDURE BuildM2InitFunction (tok: CARDINAL; moduleSym: CARDINAL) ;
2511 VAR
2512    constructModules: CARDINAL ;
2513 BEGIN
2514    IF ScaffoldDynamic OR ScaffoldStatic
2515    THEN
2516       (* Scaffold required and main should be produced.  *)
2517       (* int
2518          _M2_init (int argc, char *argv[], char *envp[])
2519          {
2520             M2RTS_ConstructModules (module_name, argc, argv, envp);
2521          }  *)
2522       PushT (initFunction) ;
2523       BuildProcedureStart ;
2524       BuildProcedureBegin ;
2525       StartScope (initFunction) ;
2526       IF ScaffoldDynamic
2527       THEN
2528          IF linkFunction # NulSym
2529          THEN
2530             (* _M2_link ();  *)
2531             PushTtok (linkFunction, tok) ;
2532             PushT (0) ;
2533             BuildProcedureCall (tok)
2534          END ;
2535
2536          (* Lookup ConstructModules and call it.  *)
2537          constructModules := GetQualidentImport (tok,
2538                                                  MakeKey ("ConstructModules"),
2539                                                  MakeKey ("M2RTS")) ;
2540          IF constructModules # NulSym
2541          THEN
2542             (* ConstructModules (module_name, argc, argv, envp);  *)
2543             PushTtok (constructModules, tok) ;
2544
2545             PushTF(Adr, Address) ;
2546             PushTtok (MakeConstLitString (tok, GetSymName (moduleSym)), tok) ;
2547             PushT(1) ;
2548             BuildAdrFunction ;
2549
2550             PushTtok (SafeRequestSym (tok, MakeKey ("argc")), tok) ;
2551             PushTtok (SafeRequestSym (tok, MakeKey ("argv")), tok) ;
2552             PushTtok (SafeRequestSym (tok, MakeKey ("envp")), tok) ;
2553             PushT (4) ;
2554             BuildProcedureCall (tok) ;
2555          END
2556       ELSIF ScaffoldStatic
2557       THEN
2558          ForeachModuleCallInit (tok,
2559                                 SafeRequestSym (tok, MakeKey ("argc")),
2560                                 SafeRequestSym (tok, MakeKey ("argv")),
2561                                 SafeRequestSym (tok, MakeKey ("envp")))
2562       END ;
2563       EndScope ;
2564       BuildProcedureEnd ;
2565       PopN (1)
2566    END
2567 END BuildM2InitFunction ;
2568
2569
2570 (*
2571    BuildM2FiniFunction -
2572 *)
2573
2574 PROCEDURE BuildM2FiniFunction (tok: CARDINAL; moduleSym: CARDINAL) ;
2575 VAR
2576    deconstructModules: CARDINAL ;
2577 BEGIN
2578    IF ScaffoldDynamic OR ScaffoldStatic
2579    THEN
2580       (* Scaffold required and main should be produced.  *)
2581       PushT (finiFunction) ;
2582       BuildProcedureStart ;
2583       BuildProcedureBegin ;
2584       StartScope (finiFunction) ;
2585       IF ScaffoldDynamic
2586       THEN
2587          (* static void
2588             _M2_finish (int argc, char *argv[], char *envp[])
2589             {
2590               M2RTS_DeconstructModules (module_name, argc, argv, envp);
2591             }  *)
2592          deconstructModules := GetQualidentImport (tok,
2593                                                    MakeKey ("DeconstructModules"),
2594                                                    MakeKey ("M2RTS")) ;
2595          IF deconstructModules # NulSym
2596          THEN
2597             (* DeconstructModules (module_name, argc, argv, envp);  *)
2598             PushTtok (deconstructModules, tok) ;
2599
2600             PushTF(Adr, Address) ;
2601             PushTtok (MakeConstLitString (tok, GetSymName (moduleSym)), tok) ;
2602             PushT(1) ;
2603             BuildAdrFunction ;
2604
2605             PushTtok (SafeRequestSym (tok, MakeKey ("argc")), tok) ;
2606             PushTtok (SafeRequestSym (tok, MakeKey ("argv")), tok) ;
2607             PushTtok (SafeRequestSym (tok, MakeKey ("envp")), tok) ;
2608             PushT (4) ;
2609             BuildProcedureCall (tok)
2610          END
2611       ELSIF ScaffoldStatic
2612       THEN
2613          ForeachModuleCallFinish (tok,
2614                                   SafeRequestSym (tok, MakeKey ("argc")),
2615                                   SafeRequestSym (tok, MakeKey ("argv")),
2616                                   SafeRequestSym (tok, MakeKey ("envp")))
2617       END ;
2618       EndScope ;
2619       BuildProcedureEnd ;
2620       PopN (1)
2621    END
2622 END BuildM2FiniFunction ;
2623
2624
2625 (*
2626    BuildM2CtorFunction - create a constructor function associated with moduleSym.
2627
2628                          void
2629                          ctorFunction ()
2630                          {
2631                            M2RTS_RegisterModule (GetSymName (moduleSym),
2632                                                  init, fini, dependencies);
2633                          }
2634 *)
2635
2636 PROCEDURE BuildM2CtorFunction (tok: CARDINAL; moduleSym: CARDINAL) ;
2637 VAR
2638    RegisterModule       : CARDINAL ;
2639    ctor, init, fini, dep: CARDINAL ;
2640 BEGIN
2641    IF ScaffoldDynamic
2642    THEN
2643       GetModuleCtors (moduleSym, ctor, init, fini, dep) ;
2644       IF ctor # NulSym
2645       THEN
2646          Assert (IsProcedure (ctor)) ;
2647          PushT (ctor) ;
2648          BuildProcedureStart ;
2649          BuildProcedureBegin ;
2650          StartScope (ctor) ;
2651          RegisterModule := GetQualidentImport (tok,
2652                                                MakeKey ("RegisterModule"),
2653                                                MakeKey ("M2RTS")) ;
2654          IF RegisterModule # NulSym
2655          THEN
2656             (* RegisterModule (module_name, init, fini, dependencies);  *)
2657             PushTtok (RegisterModule, tok) ;
2658
2659             PushTF (Adr, Address) ;
2660             PushTtok (MakeConstLitString (tok, GetSymName (moduleSym)), tok) ;
2661             PushT (1) ;
2662             BuildAdrFunction ;
2663
2664             PushTtok (init, tok) ;
2665             PushTtok (fini, tok) ;
2666             PushTtok (dep, tok) ;
2667             PushT (4) ;
2668             BuildProcedureCall (tok)
2669          END ;
2670          EndScope ;
2671          BuildProcedureEnd ;
2672          PopN (1)
2673       END
2674    END
2675 END BuildM2CtorFunction ;
2676
2677
2678 (*
2679    BuildScaffold - generate the main, init, finish functions if
2680                    no -c and this is the application module.
2681 *)
2682
2683 PROCEDURE BuildScaffold (tok: CARDINAL; moduleSym: CARDINAL) ;
2684 BEGIN
2685    IF GetMainModule () = moduleSym
2686    THEN
2687       DeclareScaffold (tok) ;
2688       IF (ScaffoldMain OR (NOT cflag))
2689       THEN
2690          (* There are module init/fini functions and
2691             application init/fini functions.
2692             Here we create the application pair.  *)
2693          BuildM2LinkFunction (tok) ;
2694          BuildM2MainFunction (tok) ;
2695          BuildM2InitFunction (tok, moduleSym) ;  (* Application init.  *)
2696          BuildM2FiniFunction (tok, moduleSym) ;  (* Application fini.  *)
2697       END ;
2698       BuildM2DepFunction (tok, moduleSym) ;  (* Per module dependency.  *)
2699       (* Each module needs a ctor to register the module
2700          init/finish/dep with M2RTS.  *)
2701       BuildM2CtorFunction (tok, moduleSym)
2702    ELSIF WholeProgram
2703    THEN
2704       DeclareScaffold (tok) ;
2705       BuildM2DepFunction (tok, moduleSym) ;  (* Per module dependency.  *)
2706       (* Each module needs a ctor to register the module
2707          init/finish/dep with M2RTS.  *)
2708       BuildM2CtorFunction (tok, moduleSym)
2709    END
2710 END BuildScaffold ;
2711
2712
2713 (*
2714    BuildModuleStart - starts current module scope.
2715 *)
2716
2717 PROCEDURE BuildModuleStart (tok: CARDINAL) ;
2718 BEGIN
2719    GenQuadO (tok,
2720              ModuleScopeOp, tok,
2721              WORD (makekey (string (GetFileName ()))), GetCurrentModule (), FALSE)
2722 END BuildModuleStart ;
2723
2724
2725 (*
2726    StartBuildInnerInit - Sets the start of initialization code of the
2727                          inner module to the next quadruple.
2728 *)
2729
2730 PROCEDURE StartBuildInnerInit (tok: CARDINAL) ;
2731 BEGIN
2732    PutModuleStartQuad (GetCurrentModule(), NextQuad) ;
2733    GenQuadO (tok, InitStartOp, tok, NulSym, GetCurrentModule(), FALSE) ;
2734    PushWord (ReturnStack, 0) ;
2735    CheckNeedPriorityBegin (tok, GetCurrentModule(), GetCurrentModule()) ;
2736    PushWord (TryStack, NextQuad) ;
2737    PushWord (CatchStack, 0) ;
2738    IF HasExceptionFinally (GetCurrentModule())
2739    THEN
2740       GenQuadO (tok, TryOp, NulSym, NulSym, 0, FALSE)
2741    END
2742 END StartBuildInnerInit ;
2743
2744
2745 (*
2746    EndBuildInnerInit - Sets the end initialization code of a module.
2747 *)
2748
2749 PROCEDURE EndBuildInnerInit (tok: CARDINAL) ;
2750 BEGIN
2751    IF HasExceptionBlock (GetCurrentModule())
2752    THEN
2753       BuildRTExceptLeave (tok, TRUE) ;
2754       GenQuadO (tok, CatchEndOp, NulSym, NulSym, NulSym, FALSE)
2755    END ;
2756    PutModuleEndQuad (GetCurrentModule(), NextQuad) ;
2757    CheckVariablesInBlock (GetCurrentModule ()) ;
2758    BackPatch (PopWord (ReturnStack), NextQuad) ;
2759    CheckNeedPriorityEnd (tok, GetCurrentModule (), GetCurrentModule ()) ;
2760    GenQuadO (tok, InitEndOp, tok, NulSym, GetCurrentModule (), FALSE)
2761 END EndBuildInnerInit ;
2762
2763
2764 (*
2765    BuildModulePriority - assigns the current module with a priority
2766                          from the top of stack.
2767
2768                          Entry                   Exit
2769                          =====                   ====
2770
2771
2772                   Ptr ->                         Empty
2773                          +------------+
2774                          | Priority   |
2775                          |------------|
2776 *)
2777
2778 PROCEDURE BuildModulePriority ;
2779 VAR
2780    Priority: CARDINAL ;
2781 BEGIN
2782    PopT (Priority) ;
2783    PutPriority (GetCurrentModule (), Priority)
2784 END BuildModulePriority ;
2785
2786
2787 (*
2788    ForLoopAnalysis - checks all the FOR loops for index variable manipulation
2789                      and dangerous usage outside the loop.
2790 *)
2791
2792 PROCEDURE ForLoopAnalysis ;
2793 VAR
2794    i, n   : CARDINAL ;
2795    forDesc: ForLoopInfo ;
2796 BEGIN
2797    IF Pedantic
2798    THEN
2799       n := HighIndice (ForInfo) ;
2800       i := 1 ;
2801       WHILE i <= n DO
2802          forDesc := GetIndice (ForInfo, i) ;
2803          CheckForIndex (forDesc) ;
2804          INC (i)
2805       END
2806    END
2807 END ForLoopAnalysis ;
2808
2809
2810 (*
2811    AddForInfo - adds the description of the FOR loop into the record list.
2812                 This is used if -pedantic is turned on to check index variable
2813                 usage.
2814 *)
2815
2816 PROCEDURE AddForInfo (Start, End, IncQuad: CARDINAL; Sym: CARDINAL; idtok: CARDINAL) ;
2817 VAR
2818    forDesc: ForLoopInfo ;
2819 BEGIN
2820    IF Pedantic
2821    THEN
2822       NEW (forDesc) ;
2823       WITH forDesc^ DO
2824          IncrementQuad := IncQuad ;
2825          StartOfForLoop := Start ;
2826          EndOfForLoop := End ;
2827          ForLoopIndex := Sym ;
2828          IndexTok := idtok
2829       END ;
2830       IncludeIndiceIntoIndex (ForInfo, forDesc)
2831    END
2832 END AddForInfo ;
2833
2834
2835 (*
2836    CheckForIndex - checks the quadruples: Start..End to see whether a
2837                    for loop index is manipulated by the programmer.
2838                    It generates a warning if this is the case.
2839                    It also checks to see whether the IndexSym is read
2840                    immediately outside the loop in which case a warning
2841                    is issued.
2842 *)
2843
2844 PROCEDURE CheckForIndex (forDesc: ForLoopInfo) ;
2845 VAR
2846    ReadStart, ReadEnd,
2847    WriteStart, WriteEnd: CARDINAL ;
2848 BEGIN
2849    GetWriteLimitQuads (forDesc^.ForLoopIndex, RightValue, forDesc^.StartOfForLoop, forDesc^.EndOfForLoop, WriteStart, WriteEnd) ;
2850    IF (WriteStart < forDesc^.IncrementQuad) AND (WriteStart > forDesc^.StartOfForLoop)
2851    THEN
2852       MetaErrorT1 (forDesc^.IndexTok,
2853                    '{%kFOR} loop index variable {%1Wad} is being manipulated inside the loop',
2854                    forDesc^.ForLoopIndex) ;
2855       MetaErrorT1 (QuadToTokenNo (WriteStart),
2856                    '{%kFOR} loop index variable {%1Wad} is being manipulated, this is considered bad practice and may cause unknown program behaviour',
2857                    forDesc^.ForLoopIndex)
2858    END ;
2859    GetWriteLimitQuads (forDesc^.ForLoopIndex, RightValue, forDesc^.EndOfForLoop, 0, WriteStart, WriteEnd) ;
2860    GetReadLimitQuads (forDesc^.ForLoopIndex, RightValue, forDesc^.EndOfForLoop, 0, ReadStart, ReadEnd) ;
2861    IF (ReadStart#0) AND ((ReadStart < WriteStart) OR (WriteStart = 0))
2862    THEN
2863       MetaErrorT1 (forDesc^.IndexTok,
2864                    '{%kFOR} loop index variable {%1Wad} is being read outside the FOR loop (without being reset)',
2865                    forDesc^.ForLoopIndex) ;
2866       MetaErrorT1 (QuadToTokenNo (ReadStart),
2867                    '{%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',
2868                    forDesc^.ForLoopIndex)
2869    END
2870 END CheckForIndex ;
2871
2872
2873 (*
2874    GetCurrentFunctionName - returns the name for the current __FUNCTION__
2875 *)
2876
2877 (*
2878 PROCEDURE GetCurrentFunctionName () : Name ;
2879 VAR
2880    s: String ;
2881    n: Name ;
2882 BEGIN
2883    IF CurrentProc=NulSym
2884    THEN
2885       s := InitStringCharStar(KeyToCharStar(GetSymName(GetCurrentModule()))) ;
2886       s := Sprintf1(Mark(InitString('module %s initialization')), s) ;
2887       n := makekey(string(s)) ;
2888       s := KillString(s) ;
2889       RETURN( n )
2890    ELSE
2891       RETURN( GetSymName(CurrentProc) )
2892    END
2893 END GetCurrentFunctionName ;
2894 *)
2895
2896
2897 (*
2898    BuildRange - generates a RangeCheckOp quad with, r, as its operand.
2899 *)
2900
2901 PROCEDURE BuildRange (r: CARDINAL) ;
2902 BEGIN
2903    GenQuad (RangeCheckOp, WORD (GetLineNo ()), NulSym, r)
2904 END BuildRange ;
2905
2906
2907 (*
2908    BuildError - generates a ErrorOp quad, indicating that if this
2909                 quadruple is reachable, then a runtime error would
2910                 occur.
2911 *)
2912
2913 PROCEDURE BuildError (r: CARDINAL) ;
2914 BEGIN
2915    GenQuad (ErrorOp, WORD (GetLineNo ()), NulSym, r)
2916 END BuildError ;
2917
2918
2919 (*
2920    CheckPointerThroughNil - builds a range quadruple, providing, sym, is
2921                             a candidate for checking against NIL.
2922                             This range quadruple is only expanded into
2923                             code during the code generation phase
2924                             thus allowing limited compile time checking.
2925 *)
2926
2927 PROCEDURE CheckPointerThroughNil (tokpos: CARDINAL; sym: CARDINAL) ;
2928 BEGIN
2929    IF IsVar (sym) AND GetVarPointerCheck (sym)
2930    THEN
2931       (* PutVarPointerCheck(sym, FALSE) ;  (* so we do not detect this again *) *)
2932       BuildRange (InitPointerRangeCheck (tokpos, sym, GetMode (sym) = LeftValue))
2933    END
2934 END CheckPointerThroughNil ;
2935
2936
2937 (*
2938    CollectLow - returns the low of the subrange value.
2939 *)
2940
2941 PROCEDURE CollectLow (sym: CARDINAL) : CARDINAL ;
2942 VAR
2943    low, high: CARDINAL ;
2944 BEGIN
2945    IF IsSubrange (sym)
2946    THEN
2947       GetSubrange (sym, high, low) ;
2948       RETURN low
2949    ELSE
2950       InternalError  ('expecting Subrange symbol')
2951    END
2952 END CollectLow ;
2953
2954
2955 (*
2956    CollectHigh - returns the high of the subrange value, sym.
2957 *)
2958
2959 PROCEDURE CollectHigh (sym: CARDINAL) : CARDINAL ;
2960 VAR
2961    low, high: CARDINAL ;
2962 BEGIN
2963    IF IsSubrange (sym)
2964    THEN
2965       GetSubrange (sym, high, low) ;
2966       RETURN high
2967    ELSE
2968       InternalError  ('expecting Subrange symbol')
2969    END
2970 END CollectHigh ;
2971
2972
2973 (*
2974    BackPatchSubrangesAndOptParam - runs through all the quadruples and finds SubrangeLow or SubrangeHigh
2975                                    quadruples and replaces it by an assignment to the Low or High component
2976                                    of the subrange type.
2977
2978                                    Input:
2979                                    SubrangeLow    op1     op3         (* op3 is a subrange *)
2980
2981                                    Output:
2982                                    Becomes        op1     low
2983
2984                                    Input:
2985                                    SubrangeHigh   op1     op3         (* op3 is a subrange *)
2986
2987                                    Output:
2988                                    Becomes        op1     high
2989
2990                                    Input:
2991                                    OptParam       op1     op2    op3
2992
2993                                    Output:
2994                                    Param          op1     op2    GetOptArgInit(op3)
2995 *)
2996
2997 PROCEDURE BackPatchSubrangesAndOptParam ;
2998 VAR
2999    f: QuadFrame ;
3000    q: CARDINAL ;
3001 BEGIN
3002    q := GetFirstQuad () ;
3003    IF q # 0
3004    THEN
3005       REPEAT
3006          f := GetQF (q) ;
3007          WITH f^ DO
3008             CASE Operator OF
3009
3010             SubrangeLowOp :  Operand3 := CollectLow (Operand3) ;
3011                              Operator := BecomesOp |
3012             SubrangeHighOp:  Operand3 := CollectHigh (Operand3) ;
3013                              Operator := BecomesOp |
3014             OptParamOp    :  Operand3 := GetOptArgInit (Operand3) ;
3015                              Operator := ParamOp
3016
3017             ELSE
3018             END ;
3019             q := Next
3020          END
3021       UNTIL q = 0
3022    END
3023 END BackPatchSubrangesAndOptParam ;
3024
3025
3026 (*
3027    CheckCompatibleWithBecomes - checks to see that symbol, sym, is
3028                                 compatible with the := operator.
3029 *)
3030
3031 PROCEDURE CheckCompatibleWithBecomes (des, expr,
3032                                       destok, exprtok: CARDINAL) ;
3033 BEGIN
3034    IF IsType (des)
3035    THEN
3036       MetaErrorT1 (destok,
3037                    'an assignment cannot assign a value to a type {%1a}', des)
3038    ELSIF IsProcedure (des)
3039    THEN
3040       MetaErrorT1 (destok,
3041                    'an assignment cannot assign a value to a procedure {%1a}', des)
3042    ELSIF IsFieldEnumeration (des)
3043    THEN
3044       MetaErrorT1 (destok,
3045                    'an assignment cannot assign a value to an enumeration field {%1a}', des)
3046    END ;
3047    IF IsPseudoBaseProcedure (expr) OR IsPseudoBaseFunction (expr)
3048    THEN
3049       MetaErrorT1 (exprtok,
3050                   'an assignment cannot assign a {%1d} {%1a}', expr)
3051    END
3052 END CheckCompatibleWithBecomes ;
3053
3054
3055 (*
3056    BuildAssignmentWithoutBounds - calls BuildAssignment but makes sure we do not
3057                                   check bounds.
3058 *)
3059
3060 PROCEDURE BuildAssignmentWithoutBounds (tok: CARDINAL; checkTypes, checkOverflow: BOOLEAN) ;
3061 VAR
3062    old: BOOLEAN ;
3063 BEGIN
3064    old := MustNotCheckBounds ;
3065    MustNotCheckBounds := TRUE ;
3066    doBuildAssignment (tok, checkTypes, checkOverflow) ;
3067    MustNotCheckBounds := old
3068 END BuildAssignmentWithoutBounds ;
3069
3070
3071 (*
3072    MarkArrayWritten - marks, Array, as being written.
3073 *)
3074
3075 PROCEDURE MarkArrayWritten (Array: CARDINAL) ;
3076 BEGIN
3077    IF (Array#NulSym) AND IsVarAParam(Array)
3078    THEN
3079       PutVarWritten(Array, TRUE)
3080    END
3081 END MarkArrayWritten ;
3082
3083
3084 (*
3085    MarkAsReadWrite - marks the variable or parameter as being
3086                      read/write.
3087 *)
3088
3089 PROCEDURE MarkAsReadWrite (sym: CARDINAL) ;
3090 BEGIN
3091    IF (sym#NulSym) AND IsVar(sym)
3092    THEN
3093       PutReadQuad (sym, RightValue, NextQuad) ;
3094       PutWriteQuad (sym, RightValue, NextQuad)
3095    END
3096 END MarkAsReadWrite ;
3097
3098
3099 (*
3100    MarkAsRead - marks the variable or parameter as being read.
3101 *)
3102
3103 PROCEDURE MarkAsRead (sym: CARDINAL) ;
3104 BEGIN
3105    IF (sym#NulSym) AND IsVar(sym)
3106    THEN
3107       PutReadQuad (sym, RightValue, NextQuad)
3108    END
3109 END MarkAsRead ;
3110
3111
3112 (*
3113    MarkAsWrite - marks the variable or parameter as being written.
3114 *)
3115
3116 PROCEDURE MarkAsWrite (sym: CARDINAL) ;
3117 BEGIN
3118    IF (sym#NulSym) AND IsVar(sym)
3119    THEN
3120       PutWriteQuad(sym, RightValue, NextQuad)
3121    END
3122 END MarkAsWrite ;
3123
3124
3125 (*
3126    doVal - return an expression which is VAL(type, expr).  If
3127            expr is a constant then return expr.
3128 *)
3129
3130 PROCEDURE doVal (type, expr: CARDINAL) : CARDINAL ;
3131 BEGIN
3132    IF (NOT IsConst(expr)) AND (SkipType(type)#GetDType(expr))
3133    THEN
3134       PushTF(Convert, NulSym) ;
3135       PushT(SkipType(type)) ;
3136       PushT(expr) ;
3137       PushT(2) ;          (* Two parameters *)
3138       BuildConvertFunction ;
3139       PopT(expr)
3140    END ;
3141    RETURN( expr )
3142 END doVal ;
3143
3144
3145 (*
3146    MoveWithMode -
3147 *)
3148
3149 PROCEDURE MoveWithMode (tokno: CARDINAL;
3150                         Des, Exp, Array: CARDINAL;
3151                         destok, exptok: CARDINAL;
3152                         checkOverflow: BOOLEAN) ;
3153 VAR
3154    t: CARDINAL ;
3155 BEGIN
3156    IF IsConstString(Exp) AND IsConst(Des)
3157    THEN
3158       GenQuadOtok (tokno, BecomesOp, Des, NulSym, Exp, TRUE,
3159                    tokno, destok, exptok) ;
3160       PutConstString (tokno, Des, GetString (Exp))
3161    ELSE
3162       IF GetMode(Des)=RightValue
3163       THEN
3164          IF GetMode(Exp)=LeftValue
3165          THEN
3166             CheckPointerThroughNil (tokno, Exp) ;  (*    Des = *Exp    *)
3167             doIndrX (tokno, Des, Exp)
3168          ELSE
3169             GenQuadOtok (tokno, BecomesOp, Des, NulSym, Exp, TRUE,
3170                          tokno, destok, exptok)
3171          END
3172       ELSIF GetMode(Des)=LeftValue
3173       THEN
3174          MarkArrayWritten (Array) ;
3175          IF GetMode(Exp) = LeftValue
3176          THEN
3177             t := MakeTemporary (tokno, RightValue) ;
3178             PutVar(t, GetSType(Exp)) ;
3179             CheckPointerThroughNil (tokno, Exp) ;
3180             doIndrX (tokno, t, Exp) ;
3181             CheckPointerThroughNil (tokno, Des) ;  (*    *Des = Exp    *)
3182             GenQuadO (tokno, XIndrOp, Des, GetSType (Des), doVal (GetSType (Des), t),
3183                       checkOverflow)
3184          ELSE
3185             CheckPointerThroughNil (tokno, Des) ;  (*    *Des = Exp    *)
3186             GenQuadO (tokno, XIndrOp, Des, GetSType (Des), doVal (GetSType (Des), Exp),
3187                       checkOverflow)
3188          END
3189       ELSE
3190          GenQuadOtok (tokno, BecomesOp, Des, NulSym, Exp, TRUE,
3191                       tokno, destok, exptok)
3192       END
3193    END
3194 END MoveWithMode ;
3195
3196
3197 (*
3198    BuildBuiltinConst - makes reference to a builtin constant within gm2.
3199
3200                               Entry                 Exit
3201
3202                        Ptr ->
3203                               +------------+        +------------+
3204                               | Ident      |        | Sym        |
3205                               |------------|        |------------|
3206
3207                        Quadruple produced:
3208
3209                        q    Sym  BuiltinConstOp  Ident
3210 *)
3211
3212 PROCEDURE BuildBuiltinConst ;
3213 VAR
3214    idtok: CARDINAL ;
3215    Id   : CARDINAL ;
3216    Sym  : CARDINAL ;
3217 BEGIN
3218    PopTtok (Id, idtok) ;
3219    Sym := MakeTemporary (idtok, ImmediateValue) ;
3220    PutVar (Sym, Integer) ;
3221 (*
3222    CASE GetBuiltinConstType(KeyToCharStar(Name(Id))) OF
3223
3224    0:  ErrorFormat1(NewError(GetTokenNo()),
3225                     '%a unrecognised builtin constant', Id) |
3226    1:  PutVar(Sym, Integer) |
3227    2:  PutVar(Sym, Real)
3228
3229    ELSE
3230       InternalError ('unrecognised value')
3231    END ;
3232 *)
3233    GenQuadO (idtok, BuiltinConstOp, Sym, NulSym, Id, FALSE) ;
3234    PushTtok (Sym, idtok)
3235 END BuildBuiltinConst ;
3236
3237
3238 (*
3239    BuildBuiltinTypeInfo - make reference to a builtin typeinfo function
3240                           within gm2.
3241
3242                                  Entry                 Exit
3243
3244                           Ptr ->
3245                                  +-------------+
3246                                  | Type        |
3247                                  |-------------|       +------------+
3248                                  | Ident       |       | Sym        |
3249                                  |-------------|       |------------|
3250
3251                           Quadruple produced:
3252
3253                           q    Sym  BuiltinTypeInfoOp  Type Ident
3254 *)
3255
3256 PROCEDURE BuildBuiltinTypeInfo ;
3257 VAR
3258    idtok: CARDINAL ;
3259    Ident,
3260    Type,
3261    Sym  : CARDINAL ;
3262 BEGIN
3263    PopTtok (Ident, idtok) ;
3264    PopT (Type) ;
3265    Sym := MakeTemporary (BuiltinTokenNo, ImmediateValue) ;
3266    CASE GetBuiltinTypeInfoType (KeyToCharStar (Name (Ident))) OF
3267
3268    0:  ErrorFormat1 (NewError(idtok),
3269                      '%a unrecognised builtin constant', Ident) |
3270    1:  PutVar (Sym, Boolean) |
3271    2:  PutVar (Sym, ZType) |
3272    3:  PutVar (Sym, RType)
3273
3274    ELSE
3275       InternalError ('unrecognised value')
3276    END ;
3277    GenQuadO (idtok, BuiltinTypeInfoOp, Sym, Type, Ident, FALSE) ;
3278    PushTtok (Sym, idtok)
3279 END BuildBuiltinTypeInfo ;
3280
3281
3282 (*
3283    CheckBecomesMeta - checks to make sure that we are not
3284                       assigning a variable to a constant.
3285                       Also check we are not assigning to an
3286                       unbounded array.
3287 *)
3288
3289 PROCEDURE CheckBecomesMeta (Des, Exp: CARDINAL; combinedtok, destok, exprtok: CARDINAL) ;
3290 BEGIN
3291    IF IsConst (Des) AND IsVar (Exp)
3292    THEN
3293       MetaErrorsT2 (combinedtok,
3294                     'in assignment, cannot assign a variable {%2a} to a constant {%1a}',
3295                     'designator {%1Da} is declared as a {%kCONST}', Des, Exp)
3296    END ;
3297    IF (GetDType(Des) # NulSym) AND IsVar (Des) AND IsUnbounded (GetDType (Des))
3298    THEN
3299       MetaErrorT1 (destok,
3300                    'in assignment, cannot assign to an unbounded array {%1ad}', Des)
3301    END ;
3302    IF (GetDType(Exp) # NulSym) AND IsVar (Exp) AND IsUnbounded (GetDType (Exp))
3303    THEN
3304       MetaErrorT1 (exprtok,
3305                   'in assignment, cannot assign from an unbounded array {%1ad}', Exp)
3306    END
3307 END CheckBecomesMeta ;
3308
3309
3310 (*
3311    BuildAssignment - Builds an assignment from the values given on the
3312                      quad stack. Either an assignment to an
3313                      arithmetic expression or an assignment to a
3314                      boolean expression.  This procedure should not
3315                      be called in CONST declarations.
3316                      The Stack is expected to contain:
3317
3318
3319        Either
3320
3321                      Entry                   Exit
3322                      =====                   ====
3323
3324               Ptr ->
3325                      +------------+
3326                      | Expression |
3327                      |------------|
3328                      | Designator |
3329                      |------------|          +------------+
3330                      |            |          |            |  <- Ptr
3331                      |------------|          |------------|
3332
3333
3334                      Quadruples Produced
3335
3336                      q     BecomesOp  Designator  _  Expression
3337
3338        OR
3339
3340                      Entry                   Exit
3341                      =====                   ====
3342
3343               Ptr ->
3344                      +------------+
3345                      | True |False|
3346                      |------------|
3347                      | Designator |
3348                      |------------|          +------------+
3349                      |            |          |            |  <- Ptr
3350                      |------------|          |------------|
3351
3352
3353                      Quadruples Produced
3354
3355                      q     BecomesOp  Designator  _  TRUE
3356                      q+1   GotoOp                    q+3
3357                      q+2   BecomesOp  Designator  _  FALSE
3358
3359 *)
3360
3361 PROCEDURE BuildAssignment (becomesTokNo: CARDINAL) ;
3362 VAR
3363    des, exp   : CARDINAL ;
3364    destok,
3365    exptok,
3366    combinedtok: CARDINAL ;
3367 BEGIN
3368    des := OperandT (2) ;
3369    IF IsReadOnly (des)
3370    THEN
3371       destok := OperandTok (2) ;
3372       exptok := OperandTok (1) ;
3373       exp := OperandT (1) ;
3374       IF DebugTokPos
3375       THEN
3376          MetaErrorT1 (destok, 'destok {%1Ead}', des) ;
3377          MetaErrorT1 (exptok, 'exptok {%1Ead}', exp)
3378       END ;
3379       combinedtok := MakeVirtualTok (becomesTokNo, destok, exptok) ;
3380       IF DebugTokPos
3381       THEN
3382          MetaErrorT1 (combinedtok, 'combined {%1Ead}', des)
3383       END ;
3384       IF IsBoolean (1)
3385       THEN
3386          MetaErrorT1 (combinedtok,
3387                       'cannot assign expression to a constant designator {%1Ead}', des)
3388       ELSE
3389          exp := OperandT (1) ;
3390          MetaErrorT2 (combinedtok,
3391                       'cannot assign a constant designator {%1Ead} with an expression {%2Ead}',
3392                       des, exp)
3393       END ;
3394       PopN (2)  (* Remove both parameters.  *)
3395    ELSIF IsError (des)
3396    THEN
3397       PopN (2)  (* Remove both parameters.  *)
3398    ELSE
3399       doBuildAssignment (becomesTokNo, TRUE, TRUE)
3400    END
3401 END BuildAssignment ;
3402
3403
3404 (*
3405    BuildAssignConstant - used to create constant in the CONST declaration.
3406                          The stack is expected to contain:
3407
3408        Either
3409
3410                      Entry                   Exit
3411                      =====                   ====
3412
3413               Ptr ->
3414                      +------------+
3415                      | Expression |
3416                      |------------|
3417                      | Designator |
3418                      |------------|          +------------+
3419                      |            |          |            |  <- Ptr
3420                      |------------|          |------------|
3421
3422
3423                      Quadruples Produced
3424
3425                      q     BecomesOp  Designator  _  Expression
3426
3427        OR
3428
3429                      Entry                   Exit
3430                      =====                   ====
3431
3432               Ptr ->
3433                      +------------+
3434                      | True |False|
3435                      |------------|
3436                      | Designator |
3437                      |------------|          +------------+
3438                      |            |          |            |  <- Ptr
3439                      |------------|          |------------|
3440
3441
3442                      Quadruples Produced
3443
3444                      q     BecomesOp  Designator  _  TRUE
3445                      q+1   GotoOp                    q+3
3446                      q+2   BecomesOp  Designator  _  FALSE
3447 *)
3448
3449 PROCEDURE BuildAssignConstant (equalsTokNo: CARDINAL) ;
3450 BEGIN
3451    doBuildAssignment (equalsTokNo, TRUE, TRUE)
3452 END BuildAssignConstant ;
3453
3454
3455 (*
3456    doBuildAssignment - subsiduary procedure of BuildAssignment.
3457                        It builds the assignment and optionally
3458                        checks the types are compatible.
3459 *)
3460
3461 PROCEDURE doBuildAssignment (becomesTokNo: CARDINAL; checkTypes, checkOverflow: BOOLEAN) ;
3462 VAR
3463    r, w,
3464    t, f,
3465    Array,
3466    Des, Exp      : CARDINAL ;
3467    combinedtok,
3468    destok, exptok: CARDINAL ;
3469 BEGIN
3470    DisplayStack ;
3471    IF IsBoolean (1)
3472    THEN
3473       PopBool (t, f) ;
3474       PopTtok (Des, destok) ;
3475       (* Conditional Boolean Assignment.  *)
3476       BackPatch (t, NextQuad) ;
3477       IF GetMode (Des) = RightValue
3478       THEN
3479          GenQuadO (becomesTokNo, BecomesOp, Des, NulSym, True, checkOverflow)
3480       ELSE
3481          CheckPointerThroughNil (destok, Des) ;
3482          GenQuadO (destok, XIndrOp, Des, Boolean, True, checkOverflow)
3483       END ;
3484       GenQuadO (destok, GotoOp, NulSym, NulSym, NextQuad+2, checkOverflow) ;
3485       BackPatch (f, NextQuad) ;
3486       IF GetMode (Des) = RightValue
3487       THEN
3488          GenQuadO (becomesTokNo, BecomesOp, Des, NulSym, False, checkOverflow)
3489       ELSE
3490          CheckPointerThroughNil (destok, Des) ;
3491          GenQuadO (destok, XIndrOp, Des, Boolean, False, checkOverflow)
3492       END
3493    ELSE
3494       PopTrwtok (Exp, r, exptok) ;
3495       MarkAsRead (r) ;
3496       IF Exp = NulSym
3497       THEN
3498          MetaError0 ('{%E}unknown expression found during assignment') ;
3499          FlushErrors
3500       END ;
3501       Array := OperandA (1) ;
3502       PopTrwtok (Des, w, destok) ;
3503       MarkAsWrite (w) ;
3504       CheckCompatibleWithBecomes (Des, Exp, destok, exptok) ;
3505       combinedtok := MakeVirtualTok (becomesTokNo, destok, exptok) ;
3506       IF (GetSType (Des) # NulSym) AND (NOT IsSet (GetDType (Des)))
3507       THEN
3508          (* Tell code generator to test runtime values of assignment so ensure we
3509             catch overflow and underflow.  *)
3510          BuildRange (InitAssignmentRangeCheck (combinedtok, Des, Exp))
3511       END ;
3512       IF checkTypes
3513       THEN
3514          CheckBecomesMeta (Des, Exp, combinedtok, destok, exptok)
3515       END ;
3516       (* Traditional Assignment.  *)
3517       MoveWithMode (becomesTokNo, Des, Exp, Array, destok, exptok, checkOverflow) ;
3518       IF checkTypes
3519       THEN
3520          (*
3521          IF (CannotCheckTypeInPass3 (Des) OR CannotCheckTypeInPass3 (Exp))
3522          THEN
3523             (* We must do this after the assignment to allow the Designator to be
3524                resolved (if it is a constant) before the type checking is done.  *)
3525             (* Prompt post pass 3 to check the assignment once all types are resolved.  *)
3526             BuildRange (InitTypesAssignmentCheck (combinedtok, Des, Exp))
3527          END ;
3528          *)
3529          (* BuildRange (InitTypesAssignmentCheck (combinedtok, Des, Exp)) ; *)
3530          CheckAssignCompatible (Des, Exp, combinedtok, destok, exptok)
3531       END
3532    END ;
3533    DisplayStack
3534 END doBuildAssignment ;
3535
3536
3537 (*
3538    CheckAssignCompatible - checks to see that an assignment is compatible.
3539                            It performs limited checking - thorough checking
3540                            is done in pass 3.  But we do what we can here
3541                            given knowledge so far.
3542 *)
3543
3544 PROCEDURE CheckAssignCompatible (Des, Exp: CARDINAL; combinedtok, destok, exprtok: CARDINAL) ;
3545 VAR
3546    DesT, ExpT, DesL: CARDINAL ;
3547 BEGIN
3548    DesT := GetSType(Des) ;
3549    ExpT := GetSType(Exp) ;
3550    DesL := GetLType(Des) ;
3551    IF IsProcedure(Exp) AND
3552       ((DesT#NulSym) AND (NOT IsProcType(DesT))) AND
3553       ((DesL#NulSym) AND (NOT IsProcType(DesL)))
3554    THEN
3555       MetaErrorT1 (destok,
3556                   'incorrectly assigning a procedure to a designator {%1Ead} (designator is not a procedure type, {%1ast})', Des)
3557    ELSIF IsProcedure (Exp) AND IsProcedureNested (Exp)
3558    THEN
3559       MetaErrorT1 (exprtok,
3560                    'cannot call nested procedure {%1Ead} indirectly as the outer scope will not be known', Exp)
3561    ELSIF IsConstString(Exp)
3562    THEN
3563    ELSIF (DesT#NulSym) AND (IsUnbounded(DesT))
3564    THEN
3565    ELSIF (ExpT#NulSym) AND (IsUnbounded(ExpT))
3566    THEN
3567    ELSIF (DesL#NulSym) AND IsArray(DesL)
3568    THEN
3569    ELSIF IsConstructor(Exp)
3570    THEN
3571       IF ExpT=NulSym
3572       THEN
3573          (* ignore type checking *)
3574       ELSIF (DesT=NulSym) AND IsConst(Des) AND (IsConstructor(Des) OR IsConstSet(Des))
3575       THEN
3576          PutConst(Des, ExpT)
3577       ELSIF NOT IsAssignmentCompatible(DesT, ExpT)
3578       THEN
3579          MetaErrorT1 (combinedtok,
3580                       'constructor expression is not compatible during assignment to {%1Ead}', Des)
3581       END
3582    ELSIF (DesT#NulSym) AND IsSet(DesT) AND IsConst(Exp)
3583    THEN
3584       (* We ignore checking of these types in pass 3 - but we do check them thoroughly post pass 3 *)
3585    ELSIF IsConst(Exp) AND (ExpT#Address) AND (NOT IsConst(Des)) AND
3586          (DesL#NulSym) AND ((DesL=Cardinal) OR (NOT IsSubrange(DesL))) AND
3587          (NOT IsEnumeration(DesL))
3588    THEN
3589       IF (IsBaseType(DesL) OR IsSystemType(DesL))
3590       THEN
3591          CheckAssignmentCompatible (combinedtok, ExpT, DesT)
3592       ELSE
3593          MetaErrorT2 (combinedtok,
3594                       '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)
3595       END
3596    ELSE
3597       IF (DesT#NulSym) AND IsProcType(DesT) AND IsProcedure(Exp)
3598       THEN
3599          DesT := GetSType(DesT) ; (* we can at least check RETURN values of procedure variables *)
3600          (* remember that thorough assignment checking is done post pass 3 *)
3601          CheckAssignmentCompatible (combinedtok, ExpT, DesT)
3602       END
3603    END
3604 END CheckAssignCompatible ;
3605
3606
3607 (*
3608    CheckBooleanId - Checks to see if the top operand is a boolean.
3609                     If the operand is not a boolean then it is tested
3610                     with true and a boolean is generated.
3611                     The Stack:
3612
3613
3614                     Entry                     Exit
3615              Ptr ->                                          <- Ptr
3616                     +------------+            +------------+
3617                     | Sym        |            | t   | f    |
3618                     |------------|            |------------|
3619
3620                      Quadruples
3621
3622                      q   If=      Sym   True   _
3623                      q+1 GotoOp   _     _      _
3624 *)
3625
3626 PROCEDURE CheckBooleanId ;
3627 VAR
3628    tok: CARDINAL ;
3629 BEGIN
3630    IF NOT IsBoolean (1)
3631    THEN
3632       tok := OperandTok (1) ;
3633       IF IsVar (OperandT (1))
3634       THEN
3635          IF GetSType (OperandT (1)) # Boolean
3636          THEN
3637             MetaError1 ('{%1Ua:is not a boolean expression}' +
3638                         '{!%1Ua:boolean expression expected}', OperandT (1))
3639          END
3640       END ;
3641       PushT (EqualTok) ;
3642       PushT (True) ;
3643       BuildRelOp (tok)
3644    END
3645 END CheckBooleanId ;
3646
3647
3648 (*
3649    BuildAlignment - builds an assignment to an alignment constant.
3650
3651                     The Stack is expected to contain:
3652
3653
3654                             Entry                   Exit
3655                             =====                   ====
3656
3657                     Ptr ->
3658                             +---------------+
3659                             | Expression    |
3660                             |---------------|
3661                             | bytealignment |
3662                             |---------------|       empty
3663 *)
3664
3665 PROCEDURE BuildAlignment (tokno: CARDINAL) ;
3666 VAR
3667    name : Name ;
3668    expr,
3669    align: CARDINAL ;
3670 BEGIN
3671    PopT (expr) ;
3672    PopT (name) ;
3673    IF name # MakeKey ('bytealignment')
3674    THEN
3675       MetaError1 ('expecting bytealignment identifier, rather than {%1Ea}',
3676                   MakeError (tokno, name))
3677    END ;
3678    GetConstFromFifoQueue (align) ;
3679    PushT (align) ;
3680    PushT (expr) ;
3681    BuildAssignConstant (tokno)
3682 END BuildAlignment ;
3683
3684
3685 (*
3686    BuildBitLength - builds an assignment to a bit length constant.
3687
3688                     The Stack is expected to contain:
3689
3690
3691                            Entry                   Exit
3692                            =====                   ====
3693
3694                     Ptr ->
3695                            +------------+
3696                            | Expression |
3697                            |------------|          empty
3698 *)
3699
3700 PROCEDURE BuildBitLength (tokno: CARDINAL) ;
3701 VAR
3702    expr,
3703    length: CARDINAL ;
3704 BEGIN
3705    PopT (expr) ;
3706    GetConstFromFifoQueue (length) ;
3707    PushT (length) ;
3708    PushT (expr) ;
3709    BuildAssignConstant (tokno)
3710 END BuildBitLength ;
3711
3712
3713 (*
3714    BuildDefaultFieldAlignment - builds an assignment to an alignment constant.
3715
3716                                 The Stack is expected to contain:
3717
3718
3719                                        Entry                   Exit
3720                                        =====                   ====
3721
3722                                 Ptr ->
3723                                        +------------+
3724                                        | Expression |
3725                                        |------------|          empty
3726 *)
3727
3728 PROCEDURE BuildDefaultFieldAlignment ;
3729 VAR
3730    expr,
3731    align: CARDINAL ;
3732    name : Name ;
3733 BEGIN
3734    PopT (expr) ;
3735    PopT (name) ;
3736    IF name # MakeKey ('bytealignment')
3737    THEN
3738       MetaError0 ('{%E}only allowed to use the attribute {%kbytealignment} in the default record field alignment pragma')
3739    END ;
3740    GetConstFromFifoQueue (align) ;
3741    PushT (align) ;
3742    PushT (expr) ;
3743    BuildAssignConstant (GetTokenNo ())
3744 END BuildDefaultFieldAlignment ;
3745
3746
3747 (*
3748    BuildPragmaField - builds an assignment to an alignment constant.
3749
3750                       The Stack is expected to contain:
3751
3752
3753                       Entry                   Exit
3754                       =====                   ====
3755
3756                Ptr ->
3757                       +------------+
3758                       | Expression |
3759                       |------------|          empty
3760 *)
3761
3762 PROCEDURE BuildPragmaField ;
3763 VAR
3764    expr,
3765    const: CARDINAL ;
3766    name : Name ;
3767 BEGIN
3768    PopT (expr) ;
3769    PopT (name) ;
3770    IF (name # MakeKey ('unused')) AND (name # MakeKey ('bytealignment'))
3771    THEN
3772       MetaError0 ('only allowed to use the attribute {%Ekbytealignment} in the default record field alignment pragma')
3773    END ;
3774    IF expr # NulSym
3775    THEN
3776       GetConstFromFifoQueue (const) ;
3777       PushT (const) ;
3778       PushT (expr) ;
3779       BuildAssignConstant (GetTokenNo ())
3780    END
3781 END BuildPragmaField ;
3782
3783
3784 (*
3785    BuildRepeat - Builds the repeat statement from the quad stack.
3786                  The Stack is expected to contain:
3787
3788
3789                  Entry                   Exit
3790                  =====                   ====
3791
3792
3793                  Empty
3794                                                         <- Ptr
3795                                          +------------+
3796                                          | RepeatQuad |
3797                                          |------------|
3798
3799 *)
3800
3801 PROCEDURE BuildRepeat ;
3802 BEGIN
3803    PushT(NextQuad)
3804 END BuildRepeat ;
3805
3806
3807 (*
3808    BuildUntil - Builds the until part of the repeat statement
3809                 from the quad stack.
3810                 The Stack is expected to contain:
3811
3812
3813                 Entry                   Exit
3814                 =====                   ====
3815
3816         Ptr ->
3817                 +------------+
3818                 | t   | f    |
3819                 |------------|
3820                 | RepeatQuad |          Empty
3821                 |------------|
3822 *)
3823
3824 PROCEDURE BuildUntil ;
3825 VAR
3826    t, f,
3827    Repeat: CARDINAL ;
3828 BEGIN
3829    CheckBooleanId ;
3830    PopBool(t, f) ;
3831    PopT(Repeat) ;
3832    BackPatch(f, Repeat) ;          (* If False then keep on repeating *)
3833    BackPatch(t, NextQuad) ;        (* If True then exit repeat        *)
3834 END BuildUntil ;
3835
3836
3837 (*
3838    BuildWhile - Builds the While part of the While statement
3839                 from the quad stack.
3840                 The Stack is expected to contain:
3841
3842
3843                 Entry                   Exit
3844                 =====                   ====
3845
3846                                                        <- Ptr
3847                                         |------------|
3848                 Empty                   | WhileQuad  |
3849                                         |------------|
3850 *)
3851
3852 PROCEDURE BuildWhile ;
3853 BEGIN
3854    PushT(NextQuad)
3855 END BuildWhile ;
3856
3857
3858 (*
3859    BuildDoWhile - Builds the Do part of the while statement
3860                   from the quad stack.
3861                   The Stack is expected to contain:
3862
3863
3864                   Entry                   Exit
3865                   =====                   ====
3866
3867           Ptr ->
3868                   +------------+          +------------+
3869                   | t   | f    |          | 0    | f   |
3870                   |------------|          |------------|
3871                   | WhileQuad  |          | WhileQuad  |
3872                   |------------|          |------------|
3873
3874                   Quadruples
3875
3876                   BackPatch t exit to the NextQuad
3877 *)
3878
3879 PROCEDURE BuildDoWhile ;
3880 VAR
3881    t, f: CARDINAL ;
3882 BEGIN
3883    CheckBooleanId ;
3884    PopBool(t, f) ;
3885    BackPatch(t, NextQuad) ;
3886    PushBool(0, f)
3887 END BuildDoWhile ;
3888
3889
3890 (*
3891    BuildEndWhile - Builds the end part of the while statement
3892                    from the quad stack.
3893                    The Stack is expected to contain:
3894
3895
3896                    Entry                   Exit
3897                    =====                   ====
3898
3899            Ptr ->
3900                    +------------+
3901                    | t   | f    |
3902                    |------------|
3903                    | WhileQuad  |          Empty
3904                    |------------|
3905
3906                    Quadruples
3907
3908                    q    GotoOp  WhileQuad
3909                    False exit is backpatched with q+1
3910 *)
3911
3912 PROCEDURE BuildEndWhile ;
3913 VAR
3914    While,
3915    t, f : CARDINAL ;
3916 BEGIN
3917    PopBool(t, f) ;
3918    Assert(t=0) ;
3919    PopT(While) ;
3920    GenQuad(GotoOp, NulSym, NulSym, While) ;
3921    BackPatch(f, NextQuad)
3922 END BuildEndWhile ;
3923
3924
3925 (*
3926    BuildLoop - Builds the Loop part of the Loop statement
3927                from the quad stack.
3928                The Stack is expected to contain:
3929
3930
3931                Entry                   Exit
3932                =====                   ====
3933
3934                                                       <- Ptr
3935                Empty                   +------------+
3936                                        | LoopQuad   |
3937                                        |------------|
3938 *)
3939
3940 PROCEDURE BuildLoop ;
3941 BEGIN
3942    PushT(NextQuad) ;
3943    PushExit(0)       (* Seperate Exit Stack for loop end *)
3944 END BuildLoop ;
3945
3946
3947 (*
3948    BuildExit - Builds the Exit part of the Loop statement.
3949 *)
3950
3951 PROCEDURE BuildExit ;
3952 BEGIN
3953    IF IsEmptyWord(ExitStack)
3954    THEN
3955       MetaError0 ('{%EkEXIT} is only allowed in a {%kLOOP} statement')
3956    ELSE
3957       GenQuad(GotoOp, NulSym, NulSym, 0) ;
3958       PushExit(Merge(PopExit(), NextQuad-1))
3959    END
3960 END BuildExit ;
3961
3962
3963 (*
3964    BuildEndLoop - Builds the End part of the Loop statement
3965                   from the quad stack.
3966                   The Stack is expected to contain:
3967
3968
3969                   Entry                   Exit
3970                   =====                   ====
3971
3972           Ptr ->
3973                   +------------+
3974                   | LoopQuad   |          Empty
3975                   |------------|
3976
3977                   Quadruples
3978
3979                   Goto  _  _  LoopQuad
3980 *)
3981
3982 PROCEDURE BuildEndLoop ;
3983 VAR
3984    Loop: CARDINAL ;
3985 BEGIN
3986    PopT(Loop) ;
3987    GenQuad(GotoOp, NulSym, NulSym, Loop) ;
3988    BackPatch(PopExit(), NextQuad)
3989 END BuildEndLoop ;
3990
3991
3992 (*
3993    BuildThenIf - Builds the Then part of the If statement
3994                  from the quad stack.
3995                  The Stack is expected to contain:
3996
3997
3998                  Entry                   Exit
3999                  =====                   ====
4000
4001          Ptr ->                                          <- Ptr
4002                  +------------+          +------------+
4003                  | t   | f    |          | 0    | f   |
4004                  |------------|          |------------|
4005
4006                  Quadruples
4007
4008                  The true exit is BackPatched to point to
4009                  the NextQuad.
4010 *)
4011
4012 PROCEDURE BuildThenIf ;
4013 VAR
4014    t, f: CARDINAL ;
4015 BEGIN
4016    CheckBooleanId ;
4017    PopBool(t, f) ;
4018    BackPatch(t, NextQuad) ;
4019    PushBool(0, f)
4020 END BuildThenIf ;
4021
4022
4023 (*
4024    BuildElse - Builds the Else part of the If statement
4025                from the quad stack.
4026                The Stack is expected to contain:
4027
4028
4029                Entry                   Exit
4030                =====                   ====
4031
4032        Ptr ->
4033                +------------+          +------------+
4034                | t   | f    |          | t+q  | 0   |
4035                |------------|          |------------|
4036
4037                Quadruples
4038
4039                q    GotoOp  _  _  0
4040                q+1  <- BackPatched from f
4041 *)
4042
4043 PROCEDURE BuildElse ;
4044 VAR
4045    t, f: CARDINAL ;
4046 BEGIN
4047    GenQuad(GotoOp, NulSym, NulSym, 0) ;
4048    PopBool(t, f) ;
4049    BackPatch(f, NextQuad) ;
4050    PushBool(Merge(t, NextQuad-1), 0)   (* NextQuad-1 = Goto Quad *)
4051 END BuildElse ;
4052
4053
4054 (*
4055    BuildEndIf - Builds the End part of the If statement
4056                 from the quad stack.
4057                 The Stack is expected to contain:
4058
4059
4060                 Entry                   Exit
4061                 =====                   ====
4062
4063         Ptr ->
4064                 +------------+
4065                 | t   | f    |          Empty
4066                 |------------|
4067
4068                 Quadruples
4069
4070                 Both t and f are backpatched to point to the NextQuad
4071 *)
4072
4073 PROCEDURE BuildEndIf ;
4074 VAR
4075    t, f: CARDINAL ;
4076 BEGIN
4077    PopBool(t, f) ;
4078    BackPatch(t, NextQuad) ;
4079    BackPatch(f, NextQuad)
4080 END BuildEndIf ;
4081
4082
4083 (*
4084    BuildElsif1 - Builds the Elsif part of the If statement
4085                  from the quad stack.
4086                  The Stack is expected to contain:
4087
4088
4089                  Entry                   Exit
4090                  =====                   ====
4091
4092          Ptr ->
4093                  +------------+          +------------+
4094                  | t   | f    |          | t+q  | 0   |
4095                  |------------|          |------------|
4096
4097                  Quadruples
4098
4099                  q    GotoOp  _  _  0
4100                  q+1  <- BackPatched from f
4101 *)
4102
4103 PROCEDURE BuildElsif1 ;
4104 VAR
4105    t, f: CARDINAL ;
4106 BEGIN
4107    GenQuad(GotoOp, NulSym, NulSym, 0) ;
4108    PopBool(t, f) ;
4109    BackPatch(f, NextQuad) ;
4110    PushBool(Merge(t, NextQuad-1), 0)   (* NextQuad-1 = Goto Quad *)
4111 END BuildElsif1 ;
4112
4113
4114 (*
4115    BuildElsif2 - Builds the Elsif until part of the If statement
4116                  from the quad stack.
4117                  The Stack is expected to contain:
4118
4119
4120                  Entry                   Exit
4121                  =====                   ====
4122
4123           Ptr ->
4124                  +--------------+
4125                  | 0    | f1    |                            <- Ptr
4126                  |--------------|          +---------------+
4127                  | t2   | f2    |          | t2    | f1+f2 |
4128                  |--------------|          |---------------|
4129 *)
4130
4131 PROCEDURE BuildElsif2 ;
4132 VAR
4133    t1, f1,
4134    t2, f2: CARDINAL ;
4135 BEGIN
4136    PopBool(t1, f1) ;
4137    Assert(t1=0) ;
4138    PopBool(t2, f2) ;
4139    PushBool(t2, Merge(f1, f2))
4140 END BuildElsif2 ;
4141
4142
4143 (*
4144    PushOne - pushes the value one to the stack.
4145              The Stack is changed:
4146
4147
4148                     Entry                   Exit
4149                     =====                   ====
4150
4151                                                             <- Ptr
4152                                             +------------+
4153              Ptr ->                         | 1 | type   |
4154                                             |------------|
4155 *)
4156
4157 PROCEDURE PushOne (tok: CARDINAL; type: CARDINAL; message: ARRAY OF CHAR) ;
4158 BEGIN
4159    IF type = NulSym
4160    THEN
4161       PushTF (MakeConstLit (tok, MakeKey('1'), NulSym), NulSym)
4162    ELSIF IsEnumeration (type)
4163    THEN
4164       IF NoOfElements (type) = 0
4165       THEN
4166          MetaErrorString1 (ConCat (InitString ('enumeration type only has one element {%1Dad} and therefore '),
4167                                    Mark (InitString (message))),
4168                            type) ;
4169          PushZero (tok, type)
4170       ELSE
4171          PushTF (Convert, NulSym) ;
4172          PushT (type) ;
4173          PushT (MakeConstLit (tok, MakeKey ('1'), ZType)) ;
4174          PushT (2) ;          (* Two parameters *)
4175          BuildConvertFunction
4176       END
4177    ELSE
4178       PushTF (MakeConstLit (tok, MakeKey ('1'), type), type)
4179    END
4180 END PushOne ;
4181
4182
4183 (*
4184    PushZero - pushes the value zero to the stack.
4185               The Stack is changed:
4186
4187
4188                     Entry                   Exit
4189                     =====                   ====
4190
4191                                                             <- Ptr
4192                                             +------------+
4193              Ptr ->                         | 0 | type   |
4194                                             |------------|
4195 *)
4196
4197 PROCEDURE PushZero (tok: CARDINAL; type: CARDINAL) ;
4198 BEGIN
4199    IF type = NulSym
4200    THEN
4201       PushTFtok (MakeConstLit (tok, MakeKey ('0'), NulSym), NulSym, tok)
4202    ELSIF IsEnumeration (type)
4203    THEN
4204       PushTFtok (Convert, NulSym, tok) ;
4205       PushTtok (type, tok) ;
4206       PushTtok (MakeConstLit (tok, MakeKey ('0'), ZType), tok) ;
4207       PushT (2) ;          (* Two parameters *)
4208       BuildConvertFunction
4209    ELSE
4210       PushTFtok (MakeConstLit (tok, MakeKey ('0'), type), type, tok)
4211    END
4212 END PushZero ;
4213
4214
4215 (*
4216    BuildPseudoBy - Builds the Non existant part of the By
4217                    clause of the For statement
4218                    from the quad stack.
4219                    The Stack is expected to contain:
4220
4221
4222                    Entry                   Exit
4223                    =====                   ====
4224
4225                                                            <- Ptr
4226                                            +------------+
4227             Ptr ->                         | BySym | t  |
4228                    +------------+          |------------|
4229                    | e    | t   |          | e     | t  |
4230                    |------------|          |------------|
4231 *)
4232
4233 PROCEDURE BuildPseudoBy ;
4234 VAR
4235    e, t, dotok: CARDINAL ;
4236 BEGIN
4237    PopTFtok (e, t, dotok) ;  (* as there is no BY token this position is the DO at the end of the last expression.  *)
4238    PushTFtok (e, t, dotok) ;
4239    IF t=NulSym
4240    THEN
4241       t := GetSType (e)
4242    END ;
4243    PushOne (dotok, t, 'the implied FOR loop increment will cause an overflow {%1ad}')
4244 END BuildPseudoBy ;
4245
4246
4247 (*
4248    BuildForLoopToRangeCheck - builds the range check to ensure that the id
4249                               does not exceed the limits of its type.
4250 *)
4251
4252 PROCEDURE BuildForLoopToRangeCheck ;
4253 VAR
4254    d, dt,
4255    e, et: CARDINAL ;
4256 BEGIN
4257    PopTF (e, et) ;
4258    PopTF (d, dt) ;
4259    BuildRange (InitForLoopToRangeCheck (d, e)) ;
4260    PushTF (d, dt) ;
4261    PushTF (e, et)
4262 END BuildForLoopToRangeCheck ;
4263
4264
4265 (*
4266    BuildForToByDo - Builds the For To By Do part of the For statement
4267                     from the quad stack.
4268                     The Stack is expected to contain:
4269
4270
4271                     Entry                   Exit
4272                     =====                   ====
4273
4274
4275              Ptr ->                                           <- Ptr
4276                     +----------------+      |----------------|
4277                     | BySym | ByType |      | ForQuad        |
4278                     |----------------|      |----------------|
4279                     | e2             |      | LastValue      |
4280                     |----------------|      |----------------|
4281                     | e1             |      | BySym | ByType |
4282                     |----------------|      |----------------|
4283                     | Ident          |      | IdentSym       |
4284                     |----------------|      |----------------|
4285
4286
4287                     x := e1 ;
4288                     LASTVALUE := ((e2-e1) DIV BySym) * BySym + e1
4289                     IF BySym<0
4290                     THEN
4291                        IF e1<e2
4292                        THEN
4293                           goto exit
4294                        END
4295                     ELSE
4296                        IF e1>e2
4297                        THEN
4298                           goto exit
4299                        END
4300                     END ;
4301                     LOOP
4302                        body
4303                        IF x=LASTVALUE
4304                        THEN
4305                           goto exit
4306                        END ;
4307                        INC(x, BySym)
4308                     END
4309
4310                     Quadruples:
4311
4312                     q     BecomesOp  IdentSym  _  e1
4313                     q+    LastValue  := ((e1-e2) DIV by) * by + e1
4314                     q+1   if >=      by        0  q+..2
4315                     q+2   GotoOp                  q+3
4316                     q+3   If >=      e1  e2       q+5
4317                     q+4   GotoOp                  exit
4318                     q+5   ..
4319                     q+..1 Goto                    q+..5
4320                     q+..2 If >=      e2  e1       q+..4
4321                     q+..3 GotoOp                  exit
4322                     q+..4 ..
4323
4324                     The For Loop is regarded:
4325
4326                     For ident := e1 To e2 By by Do
4327
4328                     End
4329 *)
4330
4331 PROCEDURE BuildForToByDo ;
4332 VAR
4333    l1, l2    : LineNote ;
4334    e1, e2,
4335    Id        : Name ;
4336    e1tok,
4337    e2tok,
4338    idtok,
4339    bytok     : CARDINAL ;
4340    FinalValue,
4341    exit1,
4342    IdSym,
4343    BySym,
4344    ByType,
4345    ForLoop,
4346    t, f      : CARDINAL ;
4347    etype,
4348    t1        : CARDINAL ;
4349 BEGIN
4350    l2 := PopLineNo() ;
4351    l1 := PopLineNo() ;
4352    UseLineNote(l1) ;
4353    PushFor (0) ;
4354    PopTFtok (BySym, ByType, bytok) ;
4355    PopTtok (e2, e2tok) ;
4356    PopTtok (e1, e1tok) ;
4357    PopTtok (Id, idtok) ;
4358    IdSym := RequestSym (idtok, Id) ;
4359    IF NOT IsExpressionCompatible (GetSType (e1), GetSType (e2))
4360    THEN
4361       MetaError2 ('incompatible types found in {%EkFOR} loop header, initial expression {%E1tsad} and final expression {%E2tsad}',
4362                  e1, e2) ;
4363       CheckExpressionCompatible (idtok, GetSType (e1), GetSType (e2))
4364    END ;
4365    IF NOT IsExpressionCompatible( GetSType (e1), ByType)
4366    THEN
4367       MetaError2 ('incompatible types found in {%EkFOR} loop header, initial expression {%E1tsad} and {%kBY} {%E2tsad}',
4368                   e2, BySym) ;
4369       CheckExpressionCompatible (e1tok, GetSType (e1), ByType)
4370    ELSIF NOT IsExpressionCompatible (GetSType (e2), ByType)
4371    THEN
4372       MetaError2 ('incompatible types found in {%EkFOR} loop header, final expression {%E1tsad} and {%kBY} {%E2tsad}',
4373                   e2, BySym) ;
4374       CheckExpressionCompatible (e1tok, GetSType (e2), ByType)
4375    END ;
4376    BuildRange (InitForLoopBeginRangeCheck (IdSym, e1)) ;
4377    PushTtok (IdSym, idtok) ;
4378    PushTtok (e1, e1tok) ;
4379    BuildAssignmentWithoutBounds (idtok, TRUE, TRUE) ;
4380
4381    UseLineNote (l2) ;
4382    FinalValue := MakeTemporary (e2tok,
4383                                 AreConstant (IsConst (e1) AND IsConst (e2) AND
4384                                             IsConst (BySym))) ;
4385    PutVar (FinalValue, GetSType (IdSym)) ;
4386    etype := MixTypes (GetSType (e1), GetSType (e2), e2tok) ;
4387    e1 := doConvert (etype, e1) ;
4388    e2 := doConvert (etype, e2) ;
4389
4390    PushTF (FinalValue, GetSType(FinalValue)) ;
4391    PushTFtok (e2, GetSType(e2), e2tok) ;  (* FinalValue := ((e1-e2) DIV By) * By + e1 *)
4392    PushT (MinusTok) ;
4393    PushTFtok (e1, GetSType(e1), e1tok) ;
4394    doBuildBinaryOp (TRUE, FALSE) ;
4395    PushT (DivideTok) ;
4396    PushTFtok (BySym, ByType, bytok) ;
4397    doBuildBinaryOp (FALSE, FALSE) ;
4398    PushT (TimesTok) ;
4399    PushTFtok (BySym, ByType, bytok) ;
4400    doBuildBinaryOp (FALSE, FALSE) ;
4401    PushT (PlusTok) ;
4402    PushTFtok (e1, GetSType (e1), e1tok) ;
4403    doBuildBinaryOp (FALSE, FALSE) ;
4404    BuildForLoopToRangeCheck ;
4405    BuildAssignmentWithoutBounds (e1tok, FALSE, FALSE) ;
4406
4407    (* q+1 if >=      by        0  q+..2 *)
4408    (* q+2 GotoOp                  q+3   *)
4409    PushTFtok (BySym, ByType, bytok) ;  (* BuildRelOp  1st parameter *)
4410    PushT (GreaterEqualTok) ;           (*             2nd parameter *)
4411                                        (* 3rd parameter *)
4412    PushZero (bytok, ByType) ;
4413
4414    BuildRelOp (e2tok) ;       (* choose final expression position.  *)
4415    PopBool(t, f) ;
4416    BackPatch(f, NextQuad) ;
4417    (* q+3 If >=       e1  e2      q+5  *)
4418    (* q+4 GotoOp                  Exit *)
4419    PushTFtok (e1, GetSType (e1), e1tok) ;  (* BuildRelOp  1st parameter *)
4420    PushT (GreaterEqualTok) ;               (*             2nd parameter *)
4421    PushTFtok (e2, GetSType (e2), e2tok) ;  (*             3rd parameter *)
4422    BuildRelOp (e2tok) ;           (* choose final expression position.  *)
4423    PopBool (t1, exit1) ;
4424    BackPatch (t1, NextQuad) ;
4425    PushFor (Merge (PopFor(), exit1)) ;    (* merge exit1 *)
4426
4427    GenQuad (GotoOp, NulSym, NulSym, 0) ;
4428    ForLoop := NextQuad-1 ;
4429
4430    (* ELSE *)
4431
4432    BackPatch (t, NextQuad) ;
4433    PushTFtok (e2, GetSType(e2), e2tok) ; (* BuildRelOp  1st parameter *)
4434    PushT (GreaterEqualTok) ;             (*             2nd parameter *)
4435    PushTFtok (e1, GetSType(e1), e1tok) ; (*             3rd parameter *)
4436    BuildRelOp (e2tok) ;
4437    PopBool (t1, exit1) ;
4438    BackPatch (t1, NextQuad) ;
4439    PushFor (Merge (PopFor (), exit1)) ;       (* merge exit1 *)
4440
4441    BackPatch(ForLoop, NextQuad) ; (* fixes the start of the for loop *)
4442    ForLoop := NextQuad ;
4443
4444    (* and set up the stack *)
4445
4446    PushTFtok (IdSym, GetSym (IdSym), idtok) ;
4447    PushTFtok (BySym, ByType, bytok) ;
4448    PushTFtok (FinalValue, GetSType (FinalValue), e2tok) ;
4449    PushT (ForLoop)
4450 END BuildForToByDo ;
4451
4452
4453 (*
4454    BuildEndFor - Builds the End part of the For statement
4455                  from the quad stack.
4456                  The Stack is expected to contain:
4457
4458
4459                  Entry                   Exit
4460                  =====                   ====
4461
4462          Ptr ->
4463                  +----------------+
4464                  | ForQuad        |
4465                  |----------------|
4466                  | LastValue      |
4467                  |----------------|
4468                  | BySym | ByType |
4469                  |----------------|
4470                  | IdSym          |      Empty
4471                  |----------------|
4472 *)
4473
4474 PROCEDURE BuildEndFor (endpostok: CARDINAL) ;
4475 VAR
4476    t, f,
4477    tsym,
4478    IncQuad,
4479    ForQuad: CARDINAL ;
4480    LastSym,
4481    ByType,
4482    BySym,
4483    bytok,
4484    IdSym,
4485    idtok  : CARDINAL ;
4486 BEGIN
4487    PopT (ForQuad) ;
4488    PopT (LastSym) ;
4489    PopTFtok (BySym, ByType, bytok) ;
4490    PopTtok (IdSym, idtok) ;
4491
4492    (* IF IdSym=LastSym THEN exit END *)
4493    PushTF(IdSym, GetSType (IdSym)) ;
4494    PushT (EqualTok) ;
4495    PushTF (LastSym, GetSType (LastSym)) ;
4496    BuildRelOp (endpostok) ;
4497    PopBool (t, f) ;
4498
4499    BackPatch (t, NextQuad) ;
4500    GenQuad (GotoOp, NulSym, NulSym, 0) ;
4501    PushFor (Merge (PopFor (), NextQuad-1)) ;
4502    BackPatch (f, NextQuad) ;
4503    IF GetMode (IdSym) = LeftValue
4504    THEN
4505       (* index variable is a LeftValue, therefore we must dereference it *)
4506       tsym := MakeTemporary (idtok, RightValue) ;
4507       PutVar (tsym, GetSType (IdSym)) ;
4508       CheckPointerThroughNil (idtok, IdSym) ;
4509       doIndrX (endpostok, tsym, IdSym) ;
4510       BuildRange (InitForLoopEndRangeCheck (tsym, BySym)) ;  (* --fixme-- pass endpostok.  *)
4511       IncQuad := NextQuad ;
4512       (* we have explicitly checked using the above and also
4513          this addition can legally overflow if a cardinal type
4514          is counting down.  The above test will generate a more
4515          precise error message, so we suppress overflow detection
4516          here.  *)
4517       GenQuadO (bytok, AddOp, tsym, tsym, BySym, FALSE) ;
4518       CheckPointerThroughNil (idtok, IdSym) ;
4519       GenQuadO (idtok, XIndrOp, IdSym, GetSType (IdSym), tsym, FALSE)
4520    ELSE
4521       BuildRange (InitForLoopEndRangeCheck (IdSym, BySym)) ;
4522       IncQuad := NextQuad ;
4523       (* we have explicitly checked using the above and also
4524          this addition can legally overflow if a cardinal type
4525          is counting down.  The above test will generate a more
4526          precise error message, so we suppress overflow detection
4527          here.  *)
4528       GenQuadO (idtok, AddOp, IdSym, IdSym, BySym, FALSE)
4529    END ;
4530    GenQuadO (endpostok, GotoOp, NulSym, NulSym, ForQuad, FALSE) ;
4531    BackPatch (PopFor (), NextQuad) ;
4532    AddForInfo (ForQuad, NextQuad-1, IncQuad, IdSym, idtok)
4533 END BuildEndFor ;
4534
4535
4536 (*
4537    BuildCaseStart - starts the case statement.
4538                     It initializes a backpatch list on the compile
4539                     time stack, the list is used to contain all
4540                     case break points. The list is later backpatched
4541                     and contains all positions of the case statement
4542                     which jump to the end of the case statement.
4543                     The stack also contains room for a boolean
4544                     expression, this is needed to allow , operator
4545                     in the CaseField alternatives.
4546
4547                     The Stack is expected to contain:
4548
4549
4550                     Entry                   Exit
4551                     =====                   ====
4552
4553                                                            <- Ptr
4554                                             +------------+
4555                     Empty                   | 0    | 0   |
4556                                             |------------|
4557                                             | 0    | 0   |
4558                                             |------------|
4559 *)
4560
4561 PROCEDURE BuildCaseStart ;
4562 BEGIN
4563    BuildRange (InitCaseBounds (PushCase (NulSym, NulSym))) ;
4564    PushBool (0, 0) ;  (* BackPatch list initialized *)
4565    PushBool (0, 0)    (* Room for a boolean expression *)
4566 END BuildCaseStart ;
4567
4568
4569 (*
4570    BuildCaseStartStatementSequence - starts the statement sequence
4571                                      inside a case clause.
4572                                      BackPatches the true exit to the
4573                                      NextQuad.
4574                                      The Stack:
4575
4576                                      Entry             Exit
4577
4578                               Ptr ->                                  <- Ptr
4579                                      +-----------+     +------------+
4580                                      | t   | f   |     | 0   | f    |
4581                                      |-----------|     |------------|
4582 *)
4583
4584 PROCEDURE BuildCaseStartStatementSequence ;
4585 VAR
4586    t, f: CARDINAL ;
4587 BEGIN
4588    PopBool (t, f) ;
4589    BackPatch (t, NextQuad) ;
4590    PushBool (0, f)
4591 END BuildCaseStartStatementSequence ;
4592
4593
4594 (*
4595    BuildCaseEndStatementSequence - ends the statement sequence
4596                                    inside a case clause.
4597                                    BackPatches the false exit f1 to the
4598                                    NextQuad.
4599                                    Asserts that t1 and f2 is 0
4600                                    Pushes t2+q and 0
4601
4602                                    Quadruples:
4603
4604                                    q  GotoOp  _  _  0
4605
4606                                    The Stack:
4607
4608                                    Entry             Exit
4609
4610                             Ptr ->                                  <- Ptr
4611                                    +-----------+     +------------+
4612                                    | t1  | f1  |     | 0    | 0   |
4613                                    |-----------|     |------------|
4614                                    | t2  | f2  |     | t2+q | 0   |
4615                                    |-----------|     |------------|
4616 *)
4617
4618 PROCEDURE BuildCaseEndStatementSequence ;
4619 VAR
4620    t1, f1,
4621    t2, f2: CARDINAL ;
4622 BEGIN
4623    GenQuad (GotoOp, NulSym, NulSym, 0) ;
4624    PopBool (t1, f1) ;
4625    PopBool (t2, f2) ;          (* t2 contains the break list for the case *)
4626    BackPatch (f1, NextQuad) ;  (* f1 no longer needed *)
4627    Assert (t1=0) ;
4628    Assert (f2=0) ;
4629    PushBool (Merge (t2, NextQuad-1), 0) ;  (* NextQuad-1 = Goto Quad *)
4630    PushBool (0, 0)             (* Room for boolean expression *)
4631 END BuildCaseEndStatementSequence ;
4632
4633
4634 (*
4635    BuildCaseRange - builds the range testing quaruples for
4636                     a case clause.
4637
4638                     IF (e1>=ce1) AND (e1<=ce2)
4639                     THEN
4640
4641                     ELS..
4642
4643                     The Stack:
4644
4645                     Entry             Exit
4646
4647              Ptr ->
4648                     +-----------+
4649                     | ce2       |                   <- Ptr
4650                     |-----------|     +-----------+
4651                     | ce1       |     | t   | f   |
4652                     |-----------|     |-----------|
4653                     | t1  | f1  |     | t1  | f1  |
4654                     |-----------|     |-----------|
4655                     | t2  | f2  |     | t2  | f2  |
4656                     |-----------|     |-----------|
4657                     | e1        |     | e1        |
4658                     |-----------|     |-----------|
4659 *)
4660
4661 PROCEDURE BuildCaseRange ;
4662 VAR
4663    ce1, ce2,
4664    combinedtok,
4665    ce1tok,
4666    ce2tok,
4667    e1tok,
4668    e1,
4669    t2, f2,
4670    t1, f1  : CARDINAL ;
4671 BEGIN
4672    PopTtok (ce2, ce2tok) ;
4673    PopTtok (ce1, ce1tok) ;
4674    combinedtok := MakeVirtualTok (ce2tok, ce2tok, ce1tok) ;
4675    AddRange (ce1, ce2, combinedtok) ;
4676    PopBool (t1, f1) ;
4677    PopBool (t2, f2) ;
4678    PopTtok (e1, e1tok) ;
4679    PushTtok (e1, e1tok) ;  (* leave e1 on bottom of stack when exit procedure *)
4680    PushBool (t2, f2) ;
4681    PushBool (t1, f1) ;  (* also leave t1 and f1 on the bottom of the stack *)
4682    PushTtok (e1, e1tok) ;
4683    PushT (GreaterEqualTok) ;
4684    PushTtok (ce1, ce1tok) ;
4685    BuildRelOp (combinedtok) ;
4686    PushT (AndTok) ;
4687    RecordOp ;
4688    PushTtok (e1, e1tok) ;
4689    PushT (LessEqualTok) ;
4690    PushTtok (ce2, ce2tok) ;
4691    BuildRelOp (combinedtok) ;
4692    BuildBinaryOp
4693 END BuildCaseRange ;
4694
4695
4696 (*
4697    BuildCaseEquality - builds the range testing quadruples for
4698                        a case clause.
4699
4700                        IF e1=ce1
4701                        THEN
4702
4703                        ELS..
4704
4705                        The Stack:
4706
4707                        Entry             Exit
4708
4709                 Ptr ->
4710                        +-----------+     +-----------+
4711                        | ce1       |     | t   | f   |
4712                        |-----------|     |-----------|
4713                        | t1  | f1  |     | t1  | f1  |
4714                        |-----------|     |-----------|
4715                        | t2  | f2  |     | t2  | f2  |
4716                        |-----------|     |-----------|
4717                        | e1        |     | e1        |
4718                        |-----------|     |-----------|
4719 *)
4720
4721 PROCEDURE BuildCaseEquality ;
4722 VAR
4723    ce1tok,
4724    e1tok,
4725    ce1, e1,
4726    t2, f2,
4727    t1, f1 : CARDINAL ;
4728 BEGIN
4729    PopTtok (ce1, ce1tok) ;
4730    AddRange (ce1, NulSym, ce1tok) ;
4731    PopBool (t1, f1) ;
4732    PopBool (t2, f2) ;
4733    PopTtok (e1, e1tok) ;
4734    PushTtok (e1, e1tok) ;   (* leave e1 on bottom of stack when exit procedure *)
4735    PushBool (t2, f2) ;      (* also leave t2 and f2 on the bottom of the stack *)
4736    PushBool (t1, f1) ;
4737    PushTtok (e1, e1tok) ;
4738    PushT (EqualTok) ;
4739    PushTtok (ce1, ce1tok) ;
4740    BuildRelOp (ce1tok)
4741 END BuildCaseEquality ;
4742
4743
4744 (*
4745    BuildCaseList - merges two case tests into one
4746
4747                    The Stack:
4748
4749                    Entry             Exit
4750
4751             Ptr ->
4752                    +-----------+
4753                    | t2  | f2  |
4754                    |-----------|     +-------------+
4755                    | t1  | f1  |     | t1+t2| f1+f2|
4756                    |-----------|     |-------------|
4757 *)
4758
4759 PROCEDURE BuildCaseList ;
4760 VAR
4761    t2, f2,
4762    t1, f1: CARDINAL ;
4763 BEGIN
4764    PopBool (t2, f2) ;
4765    PopBool (t1, f1) ;
4766    PushBool (Merge (t1, t2), Merge (f1, f2))
4767 END BuildCaseList ;
4768
4769
4770 (*
4771    BuildCaseOr - builds the , in the case clause.
4772
4773                  The Stack:
4774
4775                  Entry             Exit
4776
4777           Ptr ->                                  <- Ptr
4778                  +-----------+     +------------+
4779                  | t   | f   |     | t    | 0   |
4780                  |-----------|     |------------|
4781 *)
4782
4783 PROCEDURE BuildCaseOr ;
4784 VAR
4785    t, f: CARDINAL ;
4786 BEGIN
4787    PopBool (t, f) ;
4788    BackPatch (f, NextQuad) ;
4789    PushBool (t, 0)
4790 END BuildCaseOr ;
4791
4792
4793 (*
4794    BuildCaseElse - builds the else of case clause.
4795
4796                   The Stack:
4797
4798                   Entry             Exit
4799
4800            Ptr ->                                  <- Ptr
4801                   +-----------+     +------------+
4802                   | t   | f   |     | t    | 0   |
4803                   |-----------|     |------------|
4804 *)
4805
4806 PROCEDURE BuildCaseElse ;
4807 VAR
4808    t, f: CARDINAL ;
4809 BEGIN
4810    PopBool (t, f) ;
4811    BackPatch (f, NextQuad) ;
4812    PushBool (t, 0)
4813 END BuildCaseElse ;
4814
4815
4816 (*
4817    BuildCaseEnd - builds the end of case clause.
4818
4819                   The Stack:
4820
4821                   Entry             Exit
4822
4823            Ptr ->
4824                   +-----------+
4825                   | t1  | f1  |
4826                   |-----------|
4827                   | t2  | f2  |
4828                   |-----------|
4829                   | e1        |
4830                   |-----------|     Empty
4831 *)
4832
4833 PROCEDURE BuildCaseEnd ;
4834 VAR
4835    e1,
4836    t, f: CARDINAL ;
4837 BEGIN
4838    PopBool (t, f) ;
4839    BackPatch (f, NextQuad) ;
4840    BackPatch (t, NextQuad) ;
4841    PopBool (t, f) ;
4842    BackPatch (f, NextQuad) ;
4843    BackPatch (t, NextQuad) ;
4844    PopT (e1) ;
4845    PopCase
4846 END BuildCaseEnd ;
4847
4848
4849 (*
4850    BuildCaseCheck - builds the case checking code to ensure that
4851                     the program does not need an else clause at runtime.
4852                     The stack is unaltered.
4853 *)
4854
4855 PROCEDURE BuildCaseCheck ;
4856 BEGIN
4857    BuildError (InitNoElseRangeCheck ())
4858 END BuildCaseCheck ;
4859
4860
4861 (*
4862    BuildNulParam - Builds a nul parameter on the stack.
4863                    The Stack:
4864
4865                    Entry             Exit
4866
4867                                                     <- Ptr
4868                    Empty             +------------+
4869                                      | 0          |
4870                                      |------------|
4871 *)
4872
4873 PROCEDURE BuildNulParam ;
4874 BEGIN
4875    PushT (0)
4876 END BuildNulParam ;
4877
4878
4879 (*
4880    BuildSizeCheckStart - switches off all quadruple generation if the function SIZE or HIGH
4881                          is being "called".  This should be done as SIZE only requires the
4882                          actual type of the expression, not its value.  Consider the problem of
4883                          SIZE(UninitializedPointer^) which is quite legal and it must
4884                          also be safe!
4885                          ISO Modula-2 also allows HIGH(a[0]) for a two dimensional array
4886                          and there is no need to compute a[0], we just need to follow the
4887                          type and count dimensions.  However if SIZE(a) or HIGH(a) occurs
4888                          and, a, is an unbounded array then we turn on quadruple generation.
4889
4890                          The Stack is expected to contain:
4891
4892
4893                          Entry                       Exit
4894                          =====                       ====
4895
4896                  Ptr ->                                                       <- Ptr
4897                         +----------------------+     +----------------------+
4898                         | ProcSym | Type | tok |     | ProcSym | Type | tok |
4899                         |----------------------|     |----------------------|
4900 *)
4901
4902 PROCEDURE BuildSizeCheckStart ;
4903 VAR
4904    ProcSym, Type, tok: CARDINAL ;
4905 BEGIN
4906    PopTFtok (ProcSym, Type, tok) ;
4907    IF (ProcSym=Size) OR (ProcSym=TSize) OR (ProcSym=TBitSize)
4908    THEN
4909       QuadrupleGeneration := FALSE ;
4910       BuildingSize := TRUE
4911    ELSIF ProcSym=High
4912    THEN
4913       QuadrupleGeneration := FALSE ;
4914       BuildingHigh := TRUE
4915    END ;
4916    PushTFtok (ProcSym, Type, tok)
4917 END BuildSizeCheckStart ;
4918
4919
4920 (*
4921    BuildSizeCheckEnd - checks to see whether the function "called" was in fact SIZE.
4922                        If so then we restore quadruple generation.
4923 *)
4924
4925 PROCEDURE BuildSizeCheckEnd (ProcSym: CARDINAL) ;
4926 BEGIN
4927    IF (ProcSym=Size) OR (ProcSym=TSize) OR (ProcSym=TBitSize)
4928    THEN
4929       QuadrupleGeneration := TRUE ;
4930       BuildingSize := FALSE
4931    ELSIF ProcSym=High
4932    THEN
4933       QuadrupleGeneration := TRUE ;
4934       BuildingHigh := FALSE
4935    END ;
4936 END BuildSizeCheckEnd ;
4937
4938
4939 (*
4940    BuildProcedureCall - builds a procedure call.
4941                         Although this procedure does not directly
4942                         destroy the procedure parameters, it calls
4943                         routine which will manipulate the stack and
4944                         so the entry and exit states of the stack are shown.
4945
4946                         The Stack:
4947
4948
4949                         Entry                      Exit
4950
4951                  Ptr ->
4952                         +----------------+
4953                         | NoOfParam      |
4954                         |----------------|
4955                         | Param 1        |
4956                         |----------------|
4957                         | Param 2        |
4958                         |----------------|
4959                         .                .
4960                         .                .
4961                         .                .
4962                         |----------------|
4963                         | Param #        |
4964                         |----------------|
4965                         | ProcSym | Type |         Empty
4966                         |----------------|
4967 *)
4968
4969 PROCEDURE BuildProcedureCall (tokno: CARDINAL) ;
4970 VAR
4971    NoOfParam,
4972    ProcSym  : CARDINAL ;
4973 BEGIN
4974    PopT(NoOfParam) ;
4975    ProcSym := OperandT (NoOfParam+1) ;
4976    PushT (NoOfParam) ;  (* Compile time stack restored to entry state *)
4977    IF IsPseudoBaseProcedure (ProcSym) OR IsPseudoSystemProcedure (ProcSym)
4978    THEN
4979       DisplayStack ;
4980       ManipulatePseudoCallParameters ;
4981       DisplayStack ;
4982       BuildPseudoProcedureCall (tokno) ;
4983       DisplayStack
4984    ELSIF IsUnknown (ProcSym)
4985    THEN
4986       MetaError1 ('{%1Ua} is not recognised as a procedure, check declaration or import', ProcSym) ;
4987       PopN (NoOfParam + 2)
4988    ELSE
4989       DisplayStack ;
4990       BuildRealProcedureCall (tokno) ;
4991       DisplayStack ;
4992    END
4993 END BuildProcedureCall ;
4994
4995
4996 (*
4997    BuildRealProcedureCall - builds a real procedure call.
4998                             The Stack:
4999
5000
5001                             Entry                      Exit
5002
5003                      Ptr ->
5004                             +----------------+
5005                             | NoOfParam      |
5006                             |----------------|
5007                             | Param 1        |
5008                             |----------------|
5009                             | Param 2        |
5010                             |----------------|
5011                             .                .
5012                             .                .
5013                             .                .
5014                             |----------------|
5015                             | Param #        |
5016                             |----------------|
5017                             | ProcSym | Type |         Empty
5018                             |----------------|
5019 *)
5020
5021 PROCEDURE BuildRealProcedureCall (tokno: CARDINAL) ;
5022 VAR
5023    NoOfParam: CARDINAL ;
5024    ProcSym  : CARDINAL ;
5025 BEGIN
5026    PopT (NoOfParam) ;
5027    PushT (NoOfParam) ;
5028    ProcSym := OperandT (NoOfParam+2) ;
5029    ProcSym := SkipConst (ProcSym) ;
5030    (* tokno := OperandTtok (NoOfParam+2) ; *)   (* --checkme-- *)
5031    IF IsVar (ProcSym)
5032    THEN
5033       (* Procedure Variable ? *)
5034       ProcSym := SkipType (OperandF (NoOfParam+2))
5035    END ;
5036    IF IsDefImp (GetScope (ProcSym)) AND IsDefinitionForC (GetScope (ProcSym))
5037    THEN
5038       BuildRealFuncProcCall (tokno, FALSE, TRUE)
5039    ELSE
5040       BuildRealFuncProcCall (tokno, FALSE, FALSE)
5041    END
5042 END BuildRealProcedureCall ;
5043
5044
5045 (*
5046    BuildRealFuncProcCall - builds a real procedure or function call.
5047                            The Stack:
5048
5049
5050                             Entry                      Exit
5051
5052                      Ptr ->
5053                             +----------------+
5054                             | NoOfParam      |
5055                             |----------------|
5056                             | Param 1        |
5057                             |----------------|
5058                             | Param 2        |
5059                             |----------------|
5060                             .                .
5061                             .                .
5062                             .                .
5063                             |----------------|
5064                             | Param #        |
5065                             |----------------|
5066                             | ProcSym | Type |         Empty
5067                             |----------------|
5068 *)
5069
5070 PROCEDURE BuildRealFuncProcCall (tokno: CARDINAL; IsFunc, IsForC: BOOLEAN) ;
5071 VAR
5072    ForcedFunc,
5073    ParamConstant : BOOLEAN ;
5074    resulttok,
5075    paramtok,
5076    proctok,
5077    NoOfParameters,
5078    i, pi,
5079    ReturnVar,
5080    ProcSym,
5081    Proc          : CARDINAL ;
5082 BEGIN
5083    CheckProcedureParameters (IsForC) ;
5084    PopT (NoOfParameters) ;
5085    PushT (NoOfParameters) ;  (* Restore stack to original state.  *)
5086    ProcSym := OperandT (NoOfParameters+2) ;
5087    proctok := tokno ;  (* OperandTtok (NoOfParameters+2) ;  *)
5088    IF proctok = UnknownTokenNo
5089    THEN
5090       proctok := GetTokenNo ()
5091    END ;
5092    paramtok := proctok ;
5093    ProcSym := SkipConst (ProcSym) ;
5094    ForcedFunc := FALSE ;
5095    IF IsVar (ProcSym)
5096    THEN
5097       (* Procedure Variable ? *)
5098       Proc := SkipType (OperandF (NoOfParameters+2)) ;
5099       ParamConstant := FALSE
5100    ELSE
5101       Proc := ProcSym ;
5102       ParamConstant := IsProcedureBuiltin (Proc)
5103    END ;
5104    IF IsFunc
5105    THEN
5106       IF GetSType (Proc) = NulSym
5107       THEN
5108          MetaErrors1 ('procedure {%1a} cannot be used as a function',
5109                       'procedure {%1Da} does not have a return type',
5110                       Proc)
5111       END
5112    ELSE
5113       (* is being called as a procedure *)
5114       IF GetSType (Proc) # NulSym
5115       THEN
5116          (* however it was declared as a procedure function *)
5117          IF NOT IsReturnOptional (Proc)
5118          THEN
5119             MetaErrors1 ('function {%1a} is being called but its return value is ignored',
5120                          'function {%1Da} return a type {%1ta:of {%1ta}}',
5121                          Proc)
5122          END ;
5123          IsFunc := TRUE ;
5124          ForcedFunc := TRUE
5125       END
5126    END ;
5127    ManipulateParameters (IsForC) ;
5128    CheckParameterOrdinals ;
5129    PopT(NoOfParameters) ;
5130    IF IsFunc
5131    THEN
5132       GenQuad (ParamOp, 0, Proc, ProcSym)  (* Space for return value *)
5133    END ;
5134    IF (NoOfParameters+1=NoOfParam(Proc)) AND UsesOptArg(Proc)
5135    THEN
5136       GenQuad (OptParamOp, NoOfParam(Proc), Proc, Proc)
5137    END ;
5138    i := NoOfParameters ;
5139    pi := 1 ;     (* stack index referencing stacked parameter, i *)
5140    WHILE i>0 DO
5141       paramtok := OperandTtok (pi) ;
5142       GenQuadO (paramtok, ParamOp, i, Proc, OperandT (pi), TRUE) ;
5143       IF NOT IsConst (OperandT (pi))
5144       THEN
5145          ParamConstant := FALSE
5146       END ;
5147       DEC (i) ;
5148       INC (pi)
5149    END ;
5150    GenQuadO (proctok, CallOp, NulSym, NulSym, ProcSym, TRUE) ;
5151    PopN (NoOfParameters+1) ; (* Destroy arguments and procedure call *)
5152    IF IsFunc
5153    THEN
5154       (* ReturnVar - will have the type of the procedure *)
5155       resulttok := MakeVirtualTok (proctok, proctok, paramtok) ;
5156       ReturnVar := MakeTemporary (resulttok, AreConstant(ParamConstant)) ;
5157       PutVar (ReturnVar, GetSType(Proc)) ;
5158       GenQuadO (resulttok, FunctValueOp, ReturnVar, NulSym, Proc, TRUE) ;
5159       IF NOT ForcedFunc
5160       THEN
5161          PushTFtok (ReturnVar, GetSType (Proc), resulttok)
5162       END
5163    END
5164 END BuildRealFuncProcCall ;
5165
5166
5167 (*
5168    CheckProcedureParameters - Checks the parameters which are being passed to
5169                               procedure ProcSym.
5170
5171                               The Stack:
5172
5173
5174                               Entry                      Exit
5175
5176                        Ptr ->                                               <- Ptr
5177                               +----------------+         +----------------+
5178                               | NoOfParam      |         | NoOfParam      |
5179                               |----------------|         |----------------|
5180                               | Param 1        |         | Param 1        |
5181                               |----------------|         |----------------|
5182                               | Param 2        |         | Param 2        |
5183                               |----------------|         |----------------|
5184                               .                .         .                .
5185                               .                .         .                .
5186                               .                .         .                .
5187                               |----------------|         |----------------|
5188                               | Param #        |         | Param #        |
5189                               |----------------|         |----------------|
5190                               | ProcSym | Type |         | ProcSym | Type |
5191                               |----------------|         |----------------|
5192
5193 *)
5194
5195 PROCEDURE CheckProcedureParameters (IsForC: BOOLEAN) ;
5196 VAR
5197    proctok,
5198    paramtok    : CARDINAL ;
5199    n1, n2      : Name ;
5200    Dim,
5201    Actual,
5202    FormalI,
5203    ParamTotal,
5204    pi,
5205    Proc,
5206    ProcSym,
5207    i           : CARDINAL ;
5208    s           : String ;
5209 BEGIN
5210    PopT(ParamTotal) ;
5211    PushT(ParamTotal) ;  (* Restore stack to origional state *)
5212    ProcSym := OperandT(ParamTotal+1+1) ;
5213    proctok := OperandTtok(ParamTotal+1+1) ;
5214    IF IsVar(ProcSym) AND IsProcType(GetDType(ProcSym))
5215    THEN
5216       (* Procedure Variable ? *)
5217       Proc := SkipType(OperandF(ParamTotal+1+1))
5218    ELSE
5219       Proc := SkipConst(ProcSym)
5220    END ;
5221    IF NOT (IsProcedure(Proc) OR IsProcType(Proc))
5222    THEN
5223       IF IsUnknown(Proc)
5224       THEN
5225          MetaError1('{%1Ua} is not recognised as a procedure, check declaration or import', Proc)
5226       ELSE
5227          MetaErrors1('{%1a} is not recognised as a procedure, check declaration or import',
5228                      '{%1Ua} is not recognised as a procedure, check declaration or import',
5229                      Proc)
5230       END
5231    END ;
5232    IF CompilerDebugging
5233    THEN
5234       n1 := GetSymName(Proc) ;
5235       printf1('  %a ( ', n1)
5236    END ;
5237    IF DebugTokPos
5238    THEN
5239       s := InitString ('procedure') ;
5240       WarnStringAt (s, proctok)
5241    END ;
5242
5243    i := 1 ;
5244    pi := ParamTotal+1 ;   (* stack index referencing stacked parameter, i *)
5245    WHILE i<=ParamTotal DO
5246       IF i<=NoOfParam(Proc)
5247       THEN
5248          FormalI := GetParam(Proc, i) ;
5249          IF CompilerDebugging
5250          THEN
5251             n1 := GetSymName(FormalI) ;
5252             n2 := GetSymName(GetSType(FormalI)) ;
5253             printf2('%a: %a', n1, n2)
5254          END ;
5255          Actual := OperandT(pi) ;
5256          Dim := OperandD(pi) ;
5257          paramtok := OperandTtok(pi) ;
5258          IF DebugTokPos
5259          THEN
5260             s := InitString ('actual') ;
5261             WarnStringAt (s, paramtok)
5262          END ;
5263
5264          BuildRange(InitTypesParameterCheck(Proc, i, FormalI, Actual)) ;
5265          IF IsConst(Actual)
5266          THEN
5267             IF IsVarParam(Proc, i)
5268             THEN
5269                FailParameter (paramtok,
5270                               'trying to pass a constant to a VAR parameter',
5271                               Actual, FormalI, Proc, i)
5272             ELSIF IsConstString (Actual)
5273             THEN
5274                IF (GetStringLength (Actual) = 0)   (* if = 0 then it maybe unknown at this time *)
5275                THEN
5276                   (* dont check this yet *)
5277                ELSIF IsArray(GetDType(FormalI)) AND (GetSType(GetDType(FormalI))=Char)
5278                THEN
5279                   (* allow string literals to be passed to ARRAY [0..n] OF CHAR *)
5280                ELSIF (GetStringLength(Actual) = 1)   (* if = 1 then it maybe treated as a char *)
5281                THEN
5282                   CheckParameter (paramtok, Actual, Dim, FormalI, Proc, i, NIL)
5283                ELSIF NOT IsUnboundedParam(Proc, i)
5284                THEN
5285                   IF IsForC AND (GetSType(FormalI)=Address)
5286                   THEN
5287                      FailParameter (paramtok,
5288                                     'a string constant can either be passed to an ADDRESS parameter or an ARRAY OF CHAR',
5289                                     Actual, FormalI, Proc, i)
5290                   ELSE
5291                      FailParameter (paramtok,
5292                                     'cannot pass a string constant to a non unbounded array parameter',
5293                                     Actual, FormalI, Proc, i)
5294                   END
5295                END
5296             END
5297          ELSE
5298             CheckParameter (paramtok, Actual, Dim, FormalI, Proc, i, NIL)
5299          END
5300       ELSE
5301          IF IsForC AND UsesVarArgs(Proc)
5302          THEN
5303             (* these are varargs, therefore we don't check them *)
5304             i := ParamTotal
5305          ELSE
5306             MetaErrorT2 (proctok, 'too many parameters, {%2n} passed to {%1a} ', Proc, i)
5307          END
5308       END ;
5309       INC(i) ;
5310       DEC(pi) ;
5311       IF CompilerDebugging
5312       THEN
5313          IF i<=ParamTotal
5314          THEN
5315             printf0('; ')
5316          ELSE
5317             printf0(' ) ; \n')
5318          END
5319       END
5320    END
5321 END CheckProcedureParameters ;
5322
5323
5324 (*
5325    CheckProcTypeAndProcedure - checks the ProcType with the call.
5326 *)
5327
5328 PROCEDURE CheckProcTypeAndProcedure (ProcType: CARDINAL; call: CARDINAL) ;
5329 VAR
5330    n1, n2          : Name ;
5331    i, n, t         : CARDINAL ;
5332    CheckedProcedure: CARDINAL ;
5333    e               : Error ;
5334 BEGIN
5335    n := NoOfParam(ProcType) ;
5336    IF IsVar(call) OR IsTemporary(call) OR IsParameter(call)
5337    THEN
5338       CheckedProcedure := GetDType(call)
5339    ELSE
5340       CheckedProcedure := call
5341    END ;
5342    IF n#NoOfParam(CheckedProcedure)
5343    THEN
5344       e := NewError(GetDeclaredMod(ProcType)) ;
5345       n1 := GetSymName(call) ;
5346       n2 := GetSymName(ProcType) ;
5347       ErrorFormat2(e, 'procedure (%a) is a parameter being passed as variable (%a) but they are declared with different number of parameters',
5348                    n1, n2) ;
5349       e := ChainError(GetDeclaredMod(call), e) ;
5350       t := NoOfParam(CheckedProcedure) ;
5351       IF n<2
5352       THEN
5353          ErrorFormat3(e, 'procedure (%a) is being called incorrectly with (%d) parameter, declared with (%d)',
5354                       n1, n, t)
5355       ELSE
5356          ErrorFormat3(e, 'procedure (%a) is being called incorrectly with (%d) parameters, declared with (%d)',
5357                       n1, n, t)
5358       END
5359    ELSE
5360       i := 1 ;
5361       WHILE i<=n DO
5362          IF IsVarParam(ProcType, i) # IsVarParam(CheckedProcedure, i)
5363          THEN
5364             MetaError3('parameter {%3n} in {%1dD} causes a mismatch it was declared as a {%2d}', ProcType, GetNth(ProcType, i), i) ;
5365             MetaError3('parameter {%3n} in {%1dD} causes a mismatch it was declared as a {%2d}', call, GetNth(call, i), i)
5366          END ;
5367          BuildRange(InitTypesParameterCheck(CheckedProcedure, i,
5368                                             GetParam(CheckedProcedure, i),
5369                                             GetParam(ProcType, i))) ;
5370          (* CheckParameter(tokpos, GetParam(CheckedProcedure, i), 0, GetParam(ProcType, i), call, i, TypeList) ; *)
5371          INC(i)
5372       END
5373    END
5374 END CheckProcTypeAndProcedure ;
5375
5376
5377 (*
5378    IsReallyPointer - returns TRUE is sym is a pointer, address or a type declared
5379                      as a pointer or address.
5380 *)
5381
5382 PROCEDURE IsReallyPointer (Sym: CARDINAL) : BOOLEAN ;
5383 BEGIN
5384    IF IsVar(Sym)
5385    THEN
5386       Sym := GetSType(Sym)
5387    END ;
5388    Sym := SkipType(Sym) ;
5389    RETURN( IsPointer(Sym) OR (Sym=Address) )
5390 END IsReallyPointer ;
5391
5392
5393 (*
5394    LegalUnboundedParam - returns TRUE if the parameter, Actual, can legally be
5395                          passed to ProcSym, i, the, Formal, parameter.
5396 *)
5397
5398 PROCEDURE LegalUnboundedParam (tokpos: CARDINAL; ProcSym, i, ActualType, Actual, Dimension, Formal: CARDINAL) : BOOLEAN ;
5399 VAR
5400    FormalType: CARDINAL ;
5401    n, m      : CARDINAL ;
5402 BEGIN
5403    ActualType := SkipType(ActualType) ;
5404    FormalType := GetDType(Formal) ;
5405    FormalType := GetSType(FormalType) ;   (* type of the unbounded ARRAY *)
5406    IF IsArray(ActualType)
5407    THEN
5408       m := GetDimension(Formal) ;
5409       n := 0 ;
5410       WHILE IsArray(ActualType) DO
5411          INC(n) ;
5412          ActualType := GetDType(ActualType) ;
5413          IF (m=n) AND (ActualType=FormalType)
5414          THEN
5415             RETURN( TRUE )
5416          END
5417       END ;
5418       IF n=m
5419       THEN
5420          (* now we fall though and test ActualType against FormalType *)
5421       ELSE
5422          IF IsGenericSystemType(FormalType)
5423          THEN
5424             RETURN( TRUE )
5425          ELSE
5426             FailParameter(tokpos,
5427                           'attempting to pass an array with the incorrect number dimenisons to an unbounded formal parameter of different dimensions',
5428                           Actual, Formal, ProcSym, i) ;
5429             RETURN( FALSE )
5430          END
5431       END
5432    ELSIF IsUnbounded(ActualType)
5433    THEN
5434       IF (Dimension=0) AND (GetDimension(Formal)=GetDimension(Actual))
5435       THEN
5436          (* now we fall though and test ActualType against FormalType *)
5437          ActualType := GetSType(ActualType)
5438       ELSE
5439          IF IsGenericSystemType(FormalType)
5440          THEN
5441             RETURN( TRUE )
5442          ELSE
5443             IF GetDimension(Actual)-Dimension = GetDimension(Formal)
5444             THEN
5445                ActualType := GetSType(ActualType)
5446             ELSE
5447                FailParameter(tokpos,
5448                              'attempting to pass an unbounded array with the incorrect number dimenisons to an unbounded formal parameter of different dimensions',
5449                              Actual, Formal, ProcSym, i) ;
5450                RETURN( FALSE )
5451             END
5452          END
5453       END
5454    END ;
5455    IF IsGenericSystemType (FormalType) OR
5456       IsGenericSystemType (ActualType) OR
5457       IsAssignmentCompatible (FormalType, ActualType)
5458    THEN
5459       (* we think it is legal, but we ask post pass 3 to check as
5460          not all types are known at this point *)
5461       RETURN( TRUE )
5462    ELSE
5463       FailParameter(tokpos,
5464                     'identifier with an incompatible type is being passed to this procedure',
5465                     Actual, Formal, ProcSym, i) ;
5466       RETURN( FALSE )
5467    END
5468 END LegalUnboundedParam ;
5469
5470
5471 (*
5472    CheckParameter - checks that types ActualType and FormalType are compatible for parameter
5473                     passing. ProcSym is the procedure and i is the parameter number.
5474
5475                     We obey the following rules:
5476
5477                     (1)  we allow WORD, BYTE, LOC to be compitable with any like sized
5478                          type.
5479                     (2)  we allow ADDRESS to be compatible with any pointer type.
5480                     (3)  we relax INTEGER and CARDINAL checking for Temporary variables.
5481
5482                     Note that type sizes are checked during the code generation pass.
5483 *)
5484
5485 PROCEDURE CheckParameter (tokpos: CARDINAL;
5486                           Actual, Dimension, Formal, ProcSym: CARDINAL;
5487                           i: CARDINAL; TypeList: List) ;
5488 VAR
5489    NewList            : BOOLEAN ;
5490    ActualType, FormalType: CARDINAL ;
5491 BEGIN
5492    FormalType := GetDType(Formal) ;
5493    IF IsConstString(Actual) AND (GetStringLength(Actual) = 1)   (* if = 1 then it maybe treated as a char *)
5494    THEN
5495       ActualType := Char
5496    ELSIF Actual=Boolean
5497    THEN
5498       ActualType := Actual
5499    ELSE
5500       ActualType := GetDType(Actual)
5501    END ;
5502    IF TypeList=NIL
5503    THEN
5504       NewList := TRUE ;
5505       InitList(TypeList)
5506    ELSE
5507       NewList := FALSE
5508    END ;
5509    IF IsItemInList(TypeList, ActualType)
5510    THEN
5511       (* no need to check *)
5512       RETURN
5513    END ;
5514    IncludeItemIntoList(TypeList, ActualType) ;
5515    IF IsProcType(FormalType)
5516    THEN
5517       IF (NOT IsProcedure(Actual)) AND ((ActualType=NulSym) OR (NOT IsProcType(SkipType(ActualType))))
5518       THEN
5519          FailParameter(tokpos,
5520                        'expecting a procedure or procedure variable as a parameter',
5521                        Actual, Formal, ProcSym, i) ;
5522          RETURN
5523       END ;
5524       IF IsProcedure(Actual) AND IsProcedureNested(Actual)
5525       THEN
5526          MetaError2 ('cannot pass a nested procedure {%1Ea} seen in the {%2N} parameter as the outer scope will be unknown at runtime', Actual, i)
5527       END ;
5528       (* we can check the return type of both proc types *)
5529       IF (ActualType#NulSym) AND IsProcType(ActualType)
5530       THEN
5531          IF ((GetSType(ActualType)#NulSym) AND (GetSType(FormalType)=NulSym))
5532          THEN
5533             FailParameter(tokpos,
5534                           'the item being passed is a function whereas the formal procedure parameter is a procedure',
5535                           Actual, Formal, ProcSym, i) ;
5536             RETURN
5537          ELSIF ((GetSType(ActualType)=NulSym) AND (GetSType(FormalType)#NulSym))
5538          THEN
5539             FailParameter(tokpos,
5540                           'the item being passed is a procedure whereas the formal procedure parameter is a function',
5541                           Actual, Formal, ProcSym, i) ;
5542             RETURN
5543          ELSIF AssignmentRequiresWarning(GetSType(ActualType), GetSType(FormalType))
5544          THEN
5545             WarnParameter(tokpos,
5546                           'the return result of the procedure variable parameter may not be compatible on other targets with the return result of the item being passed',
5547                           Actual, Formal, ProcSym, i) ;
5548             RETURN
5549          ELSIF IsGenericSystemType (GetSType(FormalType)) OR
5550                IsGenericSystemType (GetSType(ActualType)) OR
5551                IsAssignmentCompatible(GetSType(ActualType), GetSType(FormalType))
5552          THEN
5553             (* pass *)
5554          ELSE
5555             FailParameter(tokpos,
5556                           'the return result of the procedure variable parameter is not compatible with the return result of the item being passed',
5557                           Actual, Formal, ProcSym, i) ;
5558             RETURN
5559          END
5560       END ;
5561       (* now to check each parameter of the proc type *)
5562       CheckProcTypeAndProcedure (FormalType, Actual)
5563    ELSIF (ActualType#FormalType) AND (ActualType#NulSym)
5564    THEN
5565       IF IsUnknown(FormalType)
5566       THEN
5567          FailParameter(tokpos,
5568                        'procedure parameter type is undeclared',
5569                        Actual, Formal, ProcSym, i) ;
5570          RETURN
5571       END ;
5572       IF IsUnbounded(ActualType) AND (NOT IsUnboundedParam(ProcSym, i))
5573       THEN
5574          FailParameter(tokpos,
5575                        'attempting to pass an unbounded array to a NON unbounded parameter',
5576                        Actual, Formal, ProcSym, i) ;
5577          RETURN
5578       ELSIF IsUnboundedParam(ProcSym, i)
5579       THEN
5580          IF NOT LegalUnboundedParam(tokpos, ProcSym, i, ActualType, Actual, Dimension, Formal)
5581          THEN
5582             RETURN
5583          END
5584       ELSIF ActualType#FormalType
5585       THEN
5586          IF AssignmentRequiresWarning(FormalType, ActualType)
5587          THEN
5588             WarnParameter (tokpos,
5589                            'identifier being passed to this procedure may contain a possibly incompatible type when compiling for a different target',
5590                            Actual, Formal, ProcSym, i)
5591          ELSIF IsGenericSystemType (FormalType) OR
5592                IsGenericSystemType (ActualType) OR
5593                IsAssignmentCompatible (ActualType, FormalType)
5594          THEN
5595             (* so far we know it is legal, but not all types have been resolved
5596                and so this is checked later on in another pass.  *)
5597          ELSE
5598             FailParameter (tokpos,
5599                            'identifier with an incompatible type is being passed to this procedure',
5600                            Actual, Formal, ProcSym, i)
5601          END
5602       END
5603    END ;
5604    IF NewList
5605    THEN
5606       KillList(TypeList)
5607    END
5608 END CheckParameter ;
5609
5610
5611 (*
5612    DescribeType - returns a String describing a symbol, Sym, name and its type.
5613 *)
5614
5615 PROCEDURE DescribeType (Sym: CARDINAL) : String ;
5616 VAR
5617    s, s1, s2: String ;
5618    Low, High,
5619    Subrange,
5620    Subscript,
5621    Type     : CARDINAL ;
5622 BEGIN
5623    s := NIL ;
5624    IF IsConstString(Sym)
5625    THEN
5626       IF (GetStringLength(Sym) = 1)   (* if = 1 then it maybe treated as a char *)
5627       THEN
5628          s := InitString('(constant string) or {%kCHAR}')
5629       ELSE
5630          s := InitString('(constant string)')
5631       END
5632    ELSIF IsConst(Sym)
5633    THEN
5634       s := InitString('(constant)')
5635    ELSIF IsUnknown(Sym)
5636    THEN
5637       s := InitString('(unknown)')
5638    ELSE
5639       Type := GetSType(Sym) ;
5640       IF Type=NulSym
5641       THEN
5642          s := InitString('(unknown)')
5643       ELSIF IsUnbounded(Type)
5644       THEN
5645          s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(GetSType(Type))))) ;
5646          s := Sprintf1(Mark(InitString('{%%kARRAY} {%%kOF} %s')), s1)
5647       ELSIF IsArray(Type)
5648       THEN
5649          s := InitString('{%kARRAY} [') ;
5650          Subscript := GetArraySubscript(Type) ;
5651          IF Subscript#NulSym
5652          THEN
5653             Assert(IsSubscript(Subscript)) ;
5654             Subrange := GetSType(Subscript) ;
5655             IF NOT IsSubrange(Subrange)
5656             THEN
5657                MetaError3 ('error in definition of array {%1Ead} in the {%2N} subscript which has no subrange, instead type given is {%3a}',
5658                             Sym, Subscript, Subrange)
5659             END ;
5660             Assert(IsSubrange(Subrange)) ;
5661             GetSubrange(Subrange, High, Low) ;
5662             s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Low)))) ;
5663             s2 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(High)))) ;
5664             s := ConCat(s, Mark(Sprintf2(Mark(InitString('%s..%s')),
5665                                          s1, s2)))
5666          END ;
5667          s1 := Mark(DescribeType(Type)) ;
5668          s := ConCat(ConCat(s, Mark(InitString('] OF '))), s1)
5669       ELSE
5670          IF IsUnknown(Type)
5671          THEN
5672             s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Type)))) ;
5673             s := Sprintf1(Mark(InitString('%s (currently unknown, check declaration or import)')),
5674                           s1)
5675          ELSE
5676             s := InitStringCharStar(KeyToCharStar(GetSymName(Type)))
5677          END
5678       END
5679    END ;
5680    RETURN( s )
5681 END DescribeType ;
5682
5683
5684 (*
5685    FailParameter - generates an error message indicating that a parameter
5686                    declaration has failed.
5687
5688                    The parameters are:
5689
5690                    CurrentState  - string describing the current failing state.
5691                    Given         - the token that the source code provided.
5692                    Expecting     - token or identifier that was expected.
5693                    ParameterNo   - parameter number that has failed.
5694                    ProcedureSym  - procedure symbol where parameter has failed.
5695
5696                    If any parameter is Nul then it is ignored.
5697 *)
5698
5699 PROCEDURE FailParameter (tokpos       : CARDINAL;
5700                          CurrentState : ARRAY OF CHAR;
5701                          Given        : CARDINAL;
5702                          Expecting    : CARDINAL;
5703                          ProcedureSym : CARDINAL;
5704                          ParameterNo  : CARDINAL) ;
5705 VAR
5706    First,
5707    ExpectType: CARDINAL ;
5708    s, s1, s2 : String ;
5709 BEGIN
5710    MetaError2 ('parameter mismatch between the {%2N} parameter of procedure {%1Ead}',
5711                ProcedureSym, ParameterNo) ;
5712    s := InitString ('{%kPROCEDURE} {%1Eau} (') ;
5713    IF NoOfParam(ProcedureSym)>=ParameterNo
5714    THEN
5715       IF ParameterNo>1
5716       THEN
5717          s := ConCat(s, Mark(InitString('.., ')))
5718       END ;
5719       IF IsVarParam(ProcedureSym, ParameterNo)
5720       THEN
5721          s := ConCat(s, Mark(InitString('{%kVAR} ')))
5722       END ;
5723
5724       First := GetDeclaredMod(GetNthParam(ProcedureSym, ParameterNo)) ;
5725       ExpectType := GetSType(Expecting) ;
5726       IF IsUnboundedParam(ProcedureSym, ParameterNo)
5727       THEN
5728          s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Expecting)))) ;
5729          s2 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(GetSType(ExpectType))))) ;
5730          s := ConCat(s, Mark(Sprintf2(Mark(InitString('%s: {%%kARRAY} {%%kOF} %s')),
5731                                       s1, s2)))
5732       ELSE
5733          s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Expecting)))) ;
5734          s2 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(ExpectType)))) ;
5735          s := ConCat(s, Mark(Sprintf2(Mark(InitString('%s: %s')), s1, s2)))
5736       END ;
5737       IF ParameterNo<NoOfParam(ProcedureSym)
5738       THEN
5739          s := ConCat(s, Mark(InitString('; ... ')))
5740       END
5741    ELSE
5742       First := GetDeclaredMod(ProcedureSym) ;
5743       IF NoOfParam(ProcedureSym)>0
5744       THEN
5745          s := ConCat(s, Mark(InitString('..')))
5746       END
5747    END ;
5748    s := ConCat (s, Mark (InitString ('){%1Tau:% : {%1Tau}} ;'))) ;
5749    MetaErrorStringT1 (First, Dup (s), ProcedureSym) ;
5750    MetaErrorStringT1 (tokpos, s, ProcedureSym) ;
5751    MetaError1 ('item being passed is {%1EDda} {%1Dad} of type {%1Dtsd}', Given)
5752 END FailParameter ;
5753
5754
5755 (*
5756    WarnParameter - generates a warning message indicating that a parameter
5757                    use might cause problems on another target.
5758
5759                    The parameters are:
5760
5761                    CurrentState  - string describing the current failing state.
5762                    Given         - the token that the source code provided.
5763                    Expecting     - token or identifier that was expected.
5764                    ParameterNo   - parameter number that has failed.
5765                    ProcedureSym  - procedure symbol where parameter has failed.
5766
5767                    If any parameter is Nul then it is ignored.
5768 *)
5769
5770 PROCEDURE WarnParameter (tokpos       : CARDINAL;
5771                          CurrentState : ARRAY OF CHAR;
5772                          Given        : CARDINAL;
5773                          Expecting    : CARDINAL;
5774                          ProcedureSym : CARDINAL;
5775                          ParameterNo  : CARDINAL) ;
5776 VAR
5777    First,
5778    ExpectType,
5779    ReturnType: CARDINAL ;
5780    s, s1, s2 : String ;
5781 BEGIN
5782    s := InitString('{%W}') ;
5783    IF CompilingImplementationModule()
5784    THEN
5785       s := ConCat(s, Sprintf0(Mark(InitString('warning issued while compiling the implementation module\n'))))
5786    ELSIF CompilingProgramModule()
5787    THEN
5788       s := ConCat(s, Sprintf0(Mark(InitString('warning issued while compiling the program module\n'))))
5789    END ;
5790    s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(ProcedureSym)))) ;
5791    s := ConCat(s, Mark(Sprintf2(Mark(InitString('problem in parameter %d, PROCEDURE %s (')),
5792                                 ParameterNo,
5793                                 s1))) ;
5794    IF NoOfParam(ProcedureSym)>=ParameterNo
5795    THEN
5796       IF ParameterNo>1
5797       THEN
5798          s := ConCat(s, Mark(InitString('.., ')))
5799       END ;
5800       IF IsVarParam(ProcedureSym, ParameterNo)
5801       THEN
5802          s := ConCat(s, Mark(InitString('{%kVAR} ')))
5803       END ;
5804
5805       First := GetDeclaredMod(GetNthParam(ProcedureSym, ParameterNo)) ;
5806       ExpectType := GetSType(Expecting) ;
5807       IF IsUnboundedParam(ProcedureSym, ParameterNo)
5808       THEN
5809          s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Expecting)))) ;
5810          s2 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(GetSType(ExpectType))))) ;
5811          s := ConCat(s, Mark(Sprintf2(Mark(InitString('%s: {%%kARRAY} {%%kOF} %s')),
5812                                       s1, s2)))
5813       ELSE
5814          s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Expecting)))) ;
5815          s2 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(ExpectType)))) ;
5816          s := ConCat(s, Mark(Sprintf2(Mark(InitString('%s: %s')), s1, s2)))
5817       END ;
5818       IF ParameterNo<NoOfParam(ProcedureSym)
5819       THEN
5820          s := ConCat(s, Mark(InitString('; ... ')))
5821       END
5822    ELSE
5823       First := GetDeclaredMod(ProcedureSym) ;
5824       IF NoOfParam(ProcedureSym)>0
5825       THEN
5826          s := ConCat(s, Mark(InitString('..')))
5827       END
5828    END ;
5829    ReturnType := GetSType(ProcedureSym) ;
5830    IF ReturnType=NulSym
5831    THEN
5832       s := ConCat(s, Sprintf0(Mark(InitString(') ;\n'))))
5833    ELSE
5834       s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(ReturnType)))) ;
5835       s := ConCat(s, Mark(Sprintf1(Mark(InitString(') : %s ;\n')), s1)))
5836    END ;
5837    IF IsConstString(Given)
5838    THEN
5839       s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Given)))) ;
5840       s := ConCat(s, Mark(Sprintf1(Mark(InitString("item being passed is '%s'")),
5841                                    s1)))
5842    ELSIF IsTemporary(Given)
5843    THEN
5844       s := ConCat(s, Mark(InitString("item being passed has type")))
5845    ELSE
5846       s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Given)))) ;
5847       s := ConCat(s, Mark(Sprintf1(Mark(InitString("item being passed is '%s'")),
5848                                    s1)))
5849    END ;
5850    s1 := DescribeType(Given) ;
5851    s2 := Mark(InitString(CurrentState)) ;
5852    s := ConCat(s, Mark(Sprintf2(Mark(InitString(': %s\nparameter mismatch: %s')),
5853                                 s1, s2))) ;
5854    MetaErrorStringT0 (tokpos, Dup (s)) ;
5855    MetaErrorStringT0 (First, Dup (s))
5856 END WarnParameter ;
5857
5858
5859 (*
5860    ExpectVariable - checks to see whether, sym, is declared as a variable.
5861                     If not then it generates an error message.
5862 *)
5863
5864 (*
5865 PROCEDURE ExpectVariable (a: ARRAY OF CHAR; sym: CARDINAL) ;
5866 VAR
5867    e         : Error ;
5868    s1, s2, s3: String ;
5869 BEGIN
5870    IF NOT IsVar(sym)
5871    THEN
5872       e := NewError(GetTokenNo()) ;
5873       IF IsUnknown(sym)
5874       THEN
5875          s1 := ConCat (InitString (a),
5876                        Mark (InitString ('but was given an undeclared symbol {%E1a}'))) ;
5877
5878          ErrorString(e, Sprintf2(Mark(InitString('%s but was given an undeclared symbol %s')), s1, s2))
5879       ELSE
5880          s1 := Mark(InitString(a)) ;
5881          s2 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(sym)))) ;
5882          s3 := Mark(DescribeType(sym)) ;
5883          ErrorString(e, Sprintf3(Mark(InitString('%s but was given %s: %s')),
5884                                  s1, s2, s3))
5885       END
5886    END
5887 END ExpectVariable ;
5888 *)
5889
5890
5891 (*
5892    doIndrX - perform des = *exp with a conversion if necessary.
5893 *)
5894
5895 PROCEDURE doIndrX (tok: CARDINAL;
5896                    des, exp: CARDINAL) ;
5897 VAR
5898    t: CARDINAL ;
5899 BEGIN
5900    IF GetDType(des)=GetDType(exp)
5901    THEN
5902       GenQuadO (tok, IndrXOp, des, GetSType(des), exp, TRUE)
5903    ELSE
5904       t := MakeTemporary (tok, RightValue) ;
5905       PutVar (t, GetSType (exp)) ;
5906       GenQuadO (tok, IndrXOp, t, GetSType (exp), exp, TRUE) ;
5907       GenQuadO (tok, BecomesOp, des, NulSym, doVal (GetSType(des), t), TRUE)
5908    END
5909 END doIndrX ;
5910
5911
5912 (*
5913    MakeRightValue - returns a temporary which will have the RightValue of symbol, Sym.
5914                     If Sym is a right value and has type, type, then no quadruples are
5915                     generated and Sym is returned. Otherwise a new temporary is created
5916                     and an IndrX quadruple is generated.
5917 *)
5918
5919 PROCEDURE MakeRightValue (tok: CARDINAL;
5920                           Sym: CARDINAL; type: CARDINAL) : CARDINAL ;
5921 VAR
5922    t: CARDINAL ;
5923 BEGIN
5924    IF GetMode (Sym) = RightValue
5925    THEN
5926       IF GetSType(Sym) = type
5927       THEN
5928          RETURN Sym    (* already a RightValue with desired type *)
5929       ELSE
5930          (*
5931             type change or mode change, type changes are a pain, but I've
5932             left them here as it is perhaps easier to remove them later.
5933          *)
5934          t := MakeTemporary (tok, RightValue) ;
5935          PutVar (t, type) ;
5936          GenQuadO (tok, BecomesOp, t, NulSym, doVal(type, Sym), TRUE) ;
5937          RETURN t
5938       END
5939    ELSE
5940       t := MakeTemporary (tok, RightValue) ;
5941       PutVar (t, type) ;
5942       CheckPointerThroughNil (tok, Sym) ;
5943       doIndrX (tok, t, Sym) ;
5944       RETURN t
5945    END
5946 END MakeRightValue ;
5947
5948
5949 (*
5950    MakeLeftValue - returns a temporary coresponding to the LeftValue of
5951                    symbol, Sym. No quadruple is generated if Sym is already
5952                    a LeftValue and has the same type.
5953 *)
5954
5955 PROCEDURE MakeLeftValue (tok: CARDINAL;
5956                          Sym: CARDINAL; with: ModeOfAddr; type: CARDINAL) : CARDINAL ;
5957 VAR
5958    t: CARDINAL ;
5959 BEGIN
5960    IF GetMode (Sym) = LeftValue
5961    THEN
5962       IF GetSType (Sym) = type
5963       THEN
5964          RETURN Sym
5965       ELSE
5966          (*
5967             type change or mode change, type changes are a pain, but I've
5968             left them here as it is perhaps easier to remove them later
5969          *)
5970          t := MakeTemporary (tok, with) ;
5971          PutVar (t, type) ;
5972          GenQuadO (tok, BecomesOp, t, NulSym, Sym, TRUE) ;
5973          RETURN t
5974       END
5975    ELSE
5976       t := MakeTemporary (tok, with) ;
5977       PutVar (t, type) ;
5978       GenQuadO (tok, AddrOp, t, NulSym, Sym, TRUE) ;
5979       RETURN t
5980    END
5981 END MakeLeftValue ;
5982
5983
5984 (*
5985    ManipulatePseudoCallParameters - manipulates the parameters to a pseudo function or
5986                                     procedure. It dereferences all LeftValue parameters
5987                                     and Boolean parameters.
5988                                     The Stack:
5989
5990
5991                                     Entry                      Exit
5992
5993                              Ptr ->                            exactly the same
5994                                     +----------------+
5995                                     | NoOfParameters |
5996                                     |----------------|
5997                                     | Param 1        |
5998                                     |----------------|
5999                                     | Param 2        |
6000                                     |----------------|
6001                                     .                .
6002                                     .                .
6003                                     .                .
6004                                     |----------------|
6005                                     | Param #        |
6006                                     |----------------|
6007                                     | ProcSym | Type |
6008                                     |----------------|
6009
6010 *)
6011
6012 PROCEDURE ManipulatePseudoCallParameters ;
6013 VAR
6014    NoOfParameters,
6015    ProcSym, Proc,
6016    i, pi         : CARDINAL ;
6017    f             : BoolFrame ;
6018 BEGIN
6019    PopT(NoOfParameters) ;
6020    PushT(NoOfParameters) ;    (* restored to original state *)
6021    (* Ptr points to the ProcSym *)
6022    ProcSym := OperandT(NoOfParameters+1+1) ;
6023    IF IsVar(ProcSym)
6024    THEN
6025       InternalError ('expecting a pseudo procedure or a type')
6026    ELSE
6027       Proc := ProcSym
6028    END ;
6029    i := 1 ;
6030    pi := NoOfParameters+1 ;
6031    WHILE i<=NoOfParameters DO
6032       IF (GetMode(OperandT(pi))=LeftValue) AND
6033          (Proc#Adr) AND (Proc#Size) AND (Proc#TSize) AND (Proc#High) AND
6034          (* procedures which have first parameter as a VAR param *)
6035          (((Proc#Inc) AND (Proc#Incl) AND (Proc#Dec) AND (Proc#Excl) AND (Proc#New) AND (Proc#Dispose)) OR (i>1))
6036       THEN
6037          (* must dereference LeftValue *)
6038          f := PeepAddress(BoolStack, pi) ;
6039          f^.TrueExit := MakeRightValue (GetTokenNo(), OperandT(pi), GetSType(OperandT(pi)))
6040       END ;
6041       INC(i) ;
6042       DEC(pi)
6043    END
6044 END ManipulatePseudoCallParameters ;
6045
6046
6047 (*
6048    ManipulateParameters - manipulates the procedure parameters in
6049                           preparation for a procedure call.
6050                           Prepares Boolean, Unbounded and VAR parameters.
6051                           The Stack:
6052
6053
6054                           Entry                      Exit
6055
6056                    Ptr ->                            exactly the same
6057                           +----------------+
6058                           | NoOfParameters |
6059                           |----------------|
6060                           | Param 1        |
6061                           |----------------|
6062                           | Param 2        |
6063                           |----------------|
6064                           .                .
6065                           .                .
6066                           .                .
6067                           |----------------|
6068                           | Param #        |
6069                           |----------------|
6070                           | ProcSym | Type |
6071                           |----------------|
6072 *)
6073
6074 PROCEDURE ManipulateParameters (IsForC: BOOLEAN) ;
6075 VAR
6076    tokpos,
6077    np           : CARDINAL ;
6078    s            : String ;
6079    ArraySym,
6080    UnboundedType,
6081    ParamType,
6082    NoOfParameters,
6083    i, pi,
6084    ProcSym, rw,
6085    Proc,
6086    t            : CARDINAL ;
6087    f            : BoolFrame ;
6088 BEGIN
6089    PopT(NoOfParameters) ;
6090    ProcSym := OperandT(NoOfParameters+1) ;
6091    tokpos := OperandTtok(NoOfParameters+1) ;
6092    IF IsVar(ProcSym)
6093    THEN
6094       (* Procedure Variable ? *)
6095       Proc := SkipType(OperandF(NoOfParameters+1))
6096    ELSE
6097       Proc := SkipConst(ProcSym)
6098    END ;
6099
6100    IF IsForC AND UsesVarArgs(Proc)
6101    THEN
6102       IF NoOfParameters<NoOfParam(Proc)
6103       THEN
6104          s := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Proc)))) ;
6105          np := NoOfParam(Proc) ;
6106          ErrorStringAt2(Sprintf3(Mark(InitString('attempting to pass (%d) parameters to procedure (%s) which was declared with varargs but contains at least (%d) parameters')),
6107                                  NoOfParameters, s, np),
6108                         tokpos, GetDeclaredMod(ProcSym))
6109       END
6110    ELSIF UsesOptArg(Proc)
6111    THEN
6112       IF NOT ((NoOfParameters=NoOfParam(Proc)) OR (NoOfParameters+1=NoOfParam(Proc)))
6113       THEN
6114          s := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Proc)))) ;
6115          np := NoOfParam(Proc) ;
6116          ErrorStringAt2(Sprintf3(Mark(InitString('attempting to pass (%d) parameters to procedure (%s) which was declared with an optarg with a maximum of (%d) parameters')),
6117                                  NoOfParameters, s, np),
6118                         tokpos, GetDeclaredMod(ProcSym))
6119       END
6120    ELSIF NoOfParameters#NoOfParam(Proc)
6121    THEN
6122       s := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Proc)))) ;
6123       np := NoOfParam(Proc) ;
6124       ErrorStringAt2(Sprintf3(Mark(InitString('attempting to pass (%d) parameters to procedure (%s) which was declared with (%d) parameters')),
6125                               NoOfParameters, s, np),
6126                      tokpos, GetDeclaredMod(ProcSym))
6127    END ;
6128    i := 1 ;
6129    pi := NoOfParameters ;
6130    WHILE i<=NoOfParameters DO
6131       f := PeepAddress(BoolStack, pi) ;
6132       rw := OperandMergeRW(pi) ;
6133       Assert(IsLegal(rw)) ;
6134       IF i>NoOfParam(Proc)
6135       THEN
6136          IF IsForC AND UsesVarArgs(Proc)
6137          THEN
6138             IF (GetSType(OperandT(pi))#NulSym) AND IsArray(GetDType(OperandT(pi)))
6139             THEN
6140                f^.TrueExit := MakeLeftValue(OperandTok(pi), OperandT(pi), RightValue, Address) ;
6141                MarkAsReadWrite(rw)
6142             ELSIF IsConstString (OperandT (pi))
6143             THEN
6144                f^.TrueExit := MakeLeftValue (OperandTok (pi),
6145                                              MakeConstStringCnul (OperandTok (pi), OperandT (pi)), RightValue, Address) ;
6146                MarkAsReadWrite(rw)
6147             ELSIF (GetSType(OperandT(pi))#NulSym) AND IsUnbounded(GetSType(OperandT(pi)))
6148             THEN
6149                MarkAsReadWrite(rw) ;
6150                (* pass the address field of an unbounded variable *)
6151                PushTF(Adr, Address) ;
6152                PushTFAD (f^.TrueExit, f^.FalseExit, f^.Unbounded, f^.Dimension) ;
6153                PushT(1) ;
6154                BuildAdrFunction ;
6155                PopT(f^.TrueExit)
6156             ELSIF GetMode(OperandT(pi))=LeftValue
6157             THEN
6158                MarkAsReadWrite(rw) ;
6159                (* must dereference LeftValue (even if we are passing variable as a vararg) *)
6160                t := MakeTemporary (OperandTok (pi), RightValue) ;
6161                PutVar(t, GetSType (OperandT (pi))) ;
6162                CheckPointerThroughNil (tokpos, OperandT (pi)) ;
6163                doIndrX (OperandTok(pi), t, OperandT (pi)) ;
6164                f^.TrueExit := t
6165             END
6166          ELSE
6167             MetaErrorT2 (tokpos,
6168                          'attempting to pass too many parameters to procedure {%1a}, the {%2N} parameter does not exist',
6169                          Proc, i)
6170          END
6171       ELSIF IsForC AND IsUnboundedParam(Proc, i) AND
6172             (GetSType(OperandT(pi))#NulSym) AND IsArray(GetDType(OperandT(pi)))
6173       THEN
6174          f^.TrueExit := MakeLeftValue(OperandTok(pi), OperandT(pi), RightValue, Address) ;
6175          MarkAsReadWrite(rw)
6176       ELSIF IsForC AND IsUnboundedParam(Proc, i) AND
6177             (GetSType(OperandT(pi))#NulSym) AND IsUnbounded(GetDType(OperandT(pi)))
6178       THEN
6179          MarkAsReadWrite(rw) ;
6180          (* pass the address field of an unbounded variable *)
6181          PushTF(Adr, Address) ;
6182          PushTFAD (f^.TrueExit, f^.FalseExit, f^.Unbounded, f^.Dimension) ;
6183          PushT(1) ;
6184          BuildAdrFunction ;
6185          PopT(f^.TrueExit)
6186       ELSIF IsForC AND IsConstString(OperandT(pi)) AND
6187                         (IsUnboundedParam(Proc, i) OR (GetDType(GetParam(Proc, i))=Address))
6188       THEN
6189          f^.TrueExit := MakeLeftValue (OperandTok (pi),
6190                                        MakeConstStringCnul (OperandTok (pi), OperandT (pi)),
6191                                        RightValue, Address) ;
6192          MarkAsReadWrite (rw)
6193       ELSIF IsUnboundedParam(Proc, i)
6194       THEN
6195          (* always pass constant strings with a nul terminator, but leave the HIGH as before.  *)
6196          IF IsConstString (OperandT(pi))
6197          THEN
6198             (* this is a Modula-2 string which must be nul terminated.  *)
6199             f^.TrueExit := MakeConstStringM2nul (OperandTok (pi), OperandT (pi))
6200          END ;
6201          t := MakeTemporary (OperandTok (pi), RightValue) ;
6202          UnboundedType := GetSType(GetParam(Proc, i)) ;
6203          PutVar(t, UnboundedType) ;
6204          ParamType := GetSType(UnboundedType) ;
6205          IF OperandD(pi)=0
6206          THEN
6207             ArraySym := OperandT(pi)
6208          ELSE
6209             ArraySym := OperandA(pi)
6210          END ;
6211          IF IsVarParam(Proc, i)
6212          THEN
6213             MarkArrayWritten (OperandT (pi)) ;
6214             MarkArrayWritten (OperandA (pi)) ;
6215             MarkAsReadWrite(rw) ;
6216             AssignUnboundedVar (OperandTtok (pi), OperandT (pi), ArraySym, t, ParamType, OperandD (pi))
6217          ELSE
6218             MarkAsRead(rw) ;
6219             AssignUnboundedNonVar (OperandTtok (pi), OperandT (pi), ArraySym, t, ParamType, OperandD (pi))
6220          END ;
6221          f^.TrueExit := t
6222       ELSIF IsVarParam(Proc, i)
6223       THEN
6224          (* must reference by address, but we contain the type of the referenced entity *)
6225          MarkArrayWritten(OperandT(pi)) ;
6226          MarkArrayWritten(OperandA(pi)) ;
6227          MarkAsReadWrite(rw) ;
6228          f^.TrueExit := MakeLeftValue(OperandTok(pi), OperandT(pi), LeftValue, GetSType(GetParam(Proc, i)))
6229       ELSIF (NOT IsVarParam(Proc, i)) AND (GetMode(OperandT(pi))=LeftValue)
6230       THEN
6231          (* must dereference LeftValue *)
6232          t := MakeTemporary (OperandTok (pi), RightValue) ;
6233          PutVar(t, GetSType(OperandT(pi))) ;
6234          CheckPointerThroughNil (tokpos, OperandT (pi)) ;
6235          doIndrX (OperandTok(pi), t, OperandT(pi)) ;
6236          f^.TrueExit := t ;
6237          MarkAsRead(rw)
6238       ELSE
6239          MarkAsRead(rw)
6240       END ;
6241       INC(i) ;
6242       DEC(pi)
6243    END ;
6244    PushT(NoOfParameters)
6245 END ManipulateParameters ;
6246
6247
6248 (*
6249    CheckParameterOrdinals - check that ordinal values are within type range.
6250 *)
6251
6252 PROCEDURE CheckParameterOrdinals ;
6253 VAR
6254    Proc,
6255    ProcSym   : CARDINAL ;
6256    Actual,
6257    FormalI   : CARDINAL ;
6258    ParamTotal,
6259    pi, i     : CARDINAL ;
6260 BEGIN
6261    PopT (ParamTotal) ;
6262    PushT (ParamTotal) ;  (* Restore stack to origional state *)
6263    ProcSym := OperandT (ParamTotal+1+1) ;
6264    IF IsVar(ProcSym) AND IsProcType(GetDType(ProcSym))
6265    THEN
6266       (* Indirect procedure call.  *)
6267       Proc := SkipType(OperandF(ParamTotal+1+1))
6268    ELSE
6269       Proc := SkipConst(ProcSym)
6270    END ;
6271    i := 1 ;
6272    pi := ParamTotal+1 ;   (* stack index referencing stacked parameter, i *)
6273    WHILE i<=ParamTotal DO
6274       IF i<=NoOfParam(Proc)
6275       THEN
6276          FormalI := GetParam (Proc, i) ;
6277          Actual := OperandT (pi) ;
6278          IF IsOrdinalType (GetLType (FormalI))
6279          THEN
6280             IF NOT IsSet (GetDType (FormalI))
6281             THEN
6282                (* tell code generator to test runtime values of assignment so ensure we
6283                   catch overflow and underflow *)
6284                BuildRange (InitParameterRangeCheck (Proc, i, FormalI, Actual))
6285             END
6286          END
6287       END ;
6288       INC (i) ;
6289       DEC (pi)
6290    END
6291 END CheckParameterOrdinals ;
6292
6293
6294 (*
6295    IsSameUnbounded - returns TRUE if unbounded types, t1, and, t2,
6296                      are compatible.
6297 *)
6298
6299 PROCEDURE IsSameUnbounded (t1, t2: CARDINAL) : BOOLEAN ;
6300 BEGIN
6301    Assert(IsUnbounded(t1)) ;
6302    Assert(IsUnbounded(t2)) ;
6303    RETURN( GetDType(t1)=GetDType(t2) )
6304 END IsSameUnbounded ;
6305
6306
6307 (*
6308    AssignUnboundedVar - assigns an Unbounded symbol fields,
6309                         ArrayAddress and ArrayHigh, from an array symbol.
6310                         UnboundedSym is not a VAR parameter and therefore
6311                         this procedure can complete both of the fields.
6312                         Sym can be a Variable with type Unbounded.
6313                         Sym can be a Variable with type Array.
6314                         Sym can be a String Constant.
6315
6316                         ParamType is the TYPE of the parameter
6317 *)
6318
6319 PROCEDURE AssignUnboundedVar (tok: CARDINAL;
6320                               Sym, ArraySym, UnboundedSym, ParamType: CARDINAL; dim: CARDINAL) ;
6321 VAR
6322    Type: CARDINAL ;
6323 BEGIN
6324    IF IsConst(Sym)
6325    THEN
6326       MetaErrorT1 (tok, '{%1ad} cannot be passed to a VAR formal parameter', Sym)
6327    ELSIF IsVar(Sym)
6328    THEN
6329       Type := GetDType(Sym) ;
6330       IF IsUnbounded(Type)
6331       THEN
6332          IF Type = GetSType (UnboundedSym)
6333          THEN
6334             (* Copy Unbounded Symbol ie. UnboundedSym := Sym *)
6335             PushT (UnboundedSym) ;
6336             PushT (Sym) ;
6337             BuildAssignmentWithoutBounds (tok, FALSE, TRUE)
6338          ELSIF IsSameUnbounded (Type, GetSType (UnboundedSym)) OR
6339                IsGenericSystemType (ParamType)
6340          THEN
6341             UnboundedVarLinkToArray (tok, Sym, ArraySym, UnboundedSym, ParamType, dim)
6342          ELSE
6343             MetaErrorT1 (tok, '{%1ad} cannot be passed to a VAR formal parameter', Sym)
6344          END
6345       ELSIF IsArray (Type) OR IsGenericSystemType (ParamType)
6346       THEN
6347          UnboundedVarLinkToArray (tok, Sym, ArraySym, UnboundedSym, ParamType, dim)
6348       ELSE
6349          MetaErrorT1 (tok, '{%1ad} cannot be passed to a VAR formal parameter', Sym)
6350       END
6351    ELSE
6352       MetaErrorT1 (tok, '{%1ad} cannot be passed to a VAR formal parameter', Sym)
6353    END
6354 END AssignUnboundedVar ;
6355
6356
6357 (*
6358    AssignUnboundedNonVar - assigns an Unbounded symbol fields,
6359                            The difference between this procedure and
6360                            AssignUnboundedVar is that this procedure cannot
6361                            set the Unbounded.Address since the data from
6362                            Sym will be copied because parameter is NOT a VAR
6363                            parameter.
6364                            UnboundedSym is not a VAR parameter and therefore
6365                            this procedure can only complete the HIGH field
6366                            and not the ADDRESS field.
6367                            Sym can be a Variable with type Unbounded.
6368                            Sym can be a Variable with type Array.
6369                            Sym can be a String Constant.
6370
6371                            ParamType is the TYPE of the paramater
6372 *)
6373
6374 PROCEDURE AssignUnboundedNonVar (tok: CARDINAL;
6375                                  Sym, ArraySym, UnboundedSym, ParamType: CARDINAL; dim: CARDINAL) ;
6376 VAR
6377    Type: CARDINAL ;
6378 BEGIN
6379    IF IsConst (Sym)  (* was IsConstString(Sym) *)
6380    THEN
6381       UnboundedNonVarLinkToArray (tok, Sym, ArraySym, UnboundedSym, ParamType, dim)
6382    ELSIF IsVar (Sym)
6383    THEN
6384       Type := GetDType (Sym) ;
6385       IF IsUnbounded (Type)
6386       THEN
6387          UnboundedNonVarLinkToArray (tok, Sym, ArraySym, UnboundedSym, ParamType, dim)
6388       ELSIF IsArray (Type) OR IsGenericSystemType (ParamType)
6389       THEN
6390          UnboundedNonVarLinkToArray (tok, Sym, ArraySym, UnboundedSym, ParamType, dim)
6391       ELSE
6392          MetaErrorT1 (tok, 'illegal type parameter {%1Ead} expecting array or dynamic array', Sym)
6393       END
6394    ELSE
6395       MetaErrorT1 (tok, 'illegal parameter {%1Ead} which cannot be passed as {%kVAR} {%kARRAY} {%kOF} {%1tsad}', Sym)
6396    END
6397 END AssignUnboundedNonVar ;
6398
6399
6400 (*
6401    GenHigh - generates a HighOp but it checks if op3 is a
6402              L value and if so it dereferences it.  This
6403              is inefficient, however it is clean and we let the gcc
6404              backend detect these as common subexpressions.
6405              It will also detect that a R value -> L value -> R value
6406              via indirection and eleminate these.
6407 *)
6408
6409 PROCEDURE GenHigh (tok: CARDINAL;
6410                    op1, op2, op3: CARDINAL) ;
6411 VAR
6412    sym: CARDINAL ;
6413 BEGIN
6414    IF (GetMode(op3)=LeftValue) AND IsUnbounded(GetSType(op3))
6415    THEN
6416       sym := MakeTemporary (tok, RightValue) ;
6417       PutVar (sym, GetSType (op3)) ;
6418       doIndrX (tok, sym, op3) ;
6419       GenQuadO (tok, HighOp, op1, op2, sym, TRUE)
6420    ELSE
6421       GenQuadO (tok, HighOp, op1, op2, op3, TRUE)
6422    END
6423 END GenHigh ;
6424
6425
6426 (*
6427    AssignHighField -
6428 *)
6429
6430 PROCEDURE AssignHighField (tok: CARDINAL;
6431                            Sym, ArraySym, UnboundedSym, ParamType: CARDINAL;
6432                            actuali, formali: CARDINAL) ;
6433 VAR
6434    ReturnVar,
6435    ArrayType,
6436    Field    : CARDINAL ;
6437 BEGIN
6438    (* Unbounded.ArrayHigh := HIGH(ArraySym) *)
6439    PushTFtok (UnboundedSym, GetSType (UnboundedSym), tok) ;
6440    Field := GetUnboundedHighOffset (GetSType (UnboundedSym), formali) ;
6441    PushTFtok (Field, GetSType (Field), tok) ;
6442    PushT (1) ;
6443    BuildDesignatorRecord (tok) ;
6444    IF IsGenericSystemType (ParamType)
6445    THEN
6446       IF IsConstString (Sym)
6447       THEN
6448          PushTtok (MakeLengthConst (tok, Sym), tok)
6449       ELSE
6450          ArrayType := GetSType (Sym) ;
6451          IF IsUnbounded (ArrayType)
6452          THEN
6453             (*
6454              *  SIZE(parameter) DIV TSIZE(ParamType)
6455              *  however in this case parameter
6456              *  is an unbounded symbol and therefore we must use
6457              *  (HIGH(parameter)+1)*SIZE(unbounded type) DIV TSIZE(ParamType)
6458              *
6459              *  we call upon the function SIZE(ArraySym)
6460              *  remember SIZE doubles as
6461              *  (HIGH(a)+1) * SIZE(ArrayType) for unbounded symbols
6462              *)
6463             PushTFtok (calculateMultipicand (tok, ArraySym, ArrayType, actuali-1), Cardinal, tok) ;
6464             PushT (DivideTok) ;        (* Divide by                    *)
6465             PushTFtok (TSize, Cardinal, tok) ; (* TSIZE(ParamType)     *)
6466             PushTtok (ParamType, tok) ;
6467             PushT (1) ;                (* 1 parameter for TSIZE()      *)
6468             BuildFunctionCall ;
6469             BuildBinaryOp
6470          ELSE
6471             (* SIZE(parameter) DIV TSIZE(ParamType)                    *)
6472             PushTFtok (TSize, Cardinal, tok) ;  (* TSIZE(ArrayType)    *)
6473             PushTtok (ArrayType, tok) ;
6474             PushT (1) ;                (* 1 parameter for TSIZE()      *)
6475             BuildFunctionCall ;
6476             PushT (DivideTok) ;        (* Divide by                    *)
6477             PushTFtok (TSize, Cardinal, tok) ; (* TSIZE(ParamType)     *)
6478             PushTtok (ParamType, tok) ;
6479             PushT (1) ;                (* 1 parameter for TSIZE()      *)
6480             BuildFunctionCall ;
6481             BuildBinaryOp
6482          END ;
6483          (* now convert from no of elements into HIGH by subtracting 1 *)
6484          PushT (MinusTok) ;           (* -1                            *)
6485          PushTtok (MakeConstLit (tok, MakeKey('1'), Cardinal), tok) ;
6486          BuildBinaryOp
6487       END
6488    ELSE
6489       ReturnVar := MakeTemporary (tok, RightValue) ;
6490       PutVar (ReturnVar, Cardinal) ;
6491       IF (actuali # formali) AND (ArraySym # NulSym) AND IsUnbounded (GetSType (ArraySym))
6492       THEN
6493          GenHigh (tok, ReturnVar, actuali, ArraySym)
6494       ELSE
6495          GenHigh (tok, ReturnVar, formali, Sym)
6496       END ;
6497       PushTFtok (ReturnVar, GetSType(ReturnVar), tok)
6498    END ;
6499    BuildAssignmentWithoutBounds (tok, FALSE, TRUE)
6500 END AssignHighField ;
6501
6502
6503 (*
6504    AssignHighFields -
6505 *)
6506
6507 PROCEDURE AssignHighFields (tok: CARDINAL;
6508                             Sym, ArraySym, UnboundedSym, ParamType: CARDINAL; dim: CARDINAL) ;
6509 VAR
6510    type            : CARDINAL ;
6511    actuali, formali,
6512    actualn, formaln: CARDINAL ;
6513 BEGIN
6514    type := GetDType (Sym) ;
6515    actualn := 1 ;
6516    IF (type # NulSym) AND (IsUnbounded (type) OR IsArray (type))
6517    THEN
6518       actualn := GetDimension (type)
6519    END ;
6520    actuali := dim + 1 ;
6521    formali := 1 ;
6522    formaln := GetDimension (GetDType (UnboundedSym)) ;
6523    WHILE (actuali < actualn) AND (formali < formaln) DO
6524       AssignHighField (tok, Sym, ArraySym, UnboundedSym, NulSym, actuali, formali) ;
6525       INC (actuali) ;
6526       INC (formali)
6527    END ;
6528    AssignHighField (tok, Sym, ArraySym, UnboundedSym, ParamType, actuali, formali)
6529 END AssignHighFields ;
6530
6531
6532 (*
6533    UnboundedNonVarLinkToArray - links an array, ArraySym, to an unbounded
6534                                 array, UnboundedSym. The parameter is a
6535                                 NON VAR variety.
6536 *)
6537
6538 PROCEDURE UnboundedNonVarLinkToArray (tok: CARDINAL;
6539                                       Sym, ArraySym, UnboundedSym, ParamType: CARDINAL; dim: CARDINAL) ;
6540 VAR
6541    Field,
6542    AddressField: CARDINAL ;
6543 BEGIN
6544    (* Unbounded.ArrayAddress := to be assigned at runtime.  *)
6545    PushTFtok (UnboundedSym, GetSType (UnboundedSym), tok) ;
6546
6547    Field := GetUnboundedAddressOffset(GetSType(UnboundedSym)) ;
6548    PushTFtok (Field, GetSType(Field), tok) ;
6549    PushT (1) ;
6550    BuildDesignatorRecord (tok) ;
6551    PopT (AddressField) ;
6552
6553    (* caller saves non var unbounded array contents.  *)
6554    GenQuadO (tok, UnboundedOp, AddressField, NulSym, Sym, FALSE) ;
6555
6556    AssignHighFields (tok, Sym, ArraySym, UnboundedSym, ParamType, dim)
6557 END UnboundedNonVarLinkToArray ;
6558
6559
6560 (*
6561    UnboundedVarLinkToArray - links an array, ArraySym, to an unbounded array,
6562                              UnboundedSym. The parameter is a VAR variety.
6563 *)
6564
6565 PROCEDURE UnboundedVarLinkToArray (tok: CARDINAL;
6566                                    Sym, ArraySym, UnboundedSym, ParamType: CARDINAL; dim: CARDINAL) ;
6567 VAR
6568    SymType,
6569    Field  : CARDINAL ;
6570 BEGIN
6571    SymType := GetSType (Sym) ;
6572    (* Unbounded.ArrayAddress := ADR(Sym) *)
6573    PushTFtok (UnboundedSym, GetSType (UnboundedSym), tok) ;
6574    Field := GetUnboundedAddressOffset (GetSType (UnboundedSym)) ;
6575    PushTFtok (Field, GetSType (Field), tok) ;
6576    PushT (1) ;
6577    BuildDesignatorRecord (tok) ;
6578    PushTFtok (Adr, Address, tok) ;   (* ADR(Sym)                     *)
6579    IF IsUnbounded (SymType) AND (dim = 0)
6580    THEN
6581       PushTFADtok (Sym, SymType, UnboundedSym, dim, tok)
6582    ELSE
6583       PushTFADtok (Sym, SymType, ArraySym, dim, tok)
6584    END ;
6585    PushT (1) ;               (* 1 parameter for ADR()        *)
6586    BuildFunctionCall ;
6587    BuildAssignmentWithoutBounds (tok, FALSE, TRUE) ;
6588
6589    AssignHighFields (tok, Sym, ArraySym, UnboundedSym, ParamType, dim)
6590 END UnboundedVarLinkToArray ;
6591
6592
6593 (*
6594    BuildPseudoProcedureCall - builds a pseudo procedure call.
6595                               This procedure does not directly alter the
6596                               stack, but by calling routines the stack
6597                               will change in the following way when this
6598                               procedure returns.
6599
6600                               The Stack:
6601
6602
6603                               Entry                      Exit
6604
6605                        Ptr ->
6606                               +----------------+
6607                               | NoOfParam      |
6608                               |----------------|
6609                               | Param 1        |
6610                               |----------------|
6611                               | Param 2        |
6612                               |----------------|
6613                               .                .
6614                               .                .
6615                               .                .
6616                               |----------------|
6617                               | Param #        |
6618                               |----------------|
6619                               | ProcSym | Type |         Empty
6620                               |----------------|
6621 *)
6622
6623 PROCEDURE BuildPseudoProcedureCall (tokno: CARDINAL) ;
6624 VAR
6625    NoOfParam,
6626    ProcSym  : CARDINAL ;
6627 BEGIN
6628    PopT (NoOfParam) ;
6629    ProcSym := OperandT (NoOfParam + 1) ;
6630    PushT (NoOfParam) ;
6631    (* Compile time stack restored to entry state *)
6632    IF ProcSym = New
6633    THEN
6634       BuildNewProcedure (tokno)
6635    ELSIF ProcSym = Dispose
6636    THEN
6637       BuildDisposeProcedure (tokno)
6638    ELSIF ProcSym = Inc
6639    THEN
6640       BuildIncProcedure
6641    ELSIF ProcSym = Dec
6642    THEN
6643       BuildDecProcedure
6644    ELSIF ProcSym = Incl
6645    THEN
6646       BuildInclProcedure
6647    ELSIF ProcSym = Excl
6648    THEN
6649       BuildExclProcedure
6650    ELSIF ProcSym = Throw
6651    THEN
6652       BuildThrowProcedure
6653    ELSE
6654       InternalError  ('pseudo procedure not implemented yet')
6655    END
6656 END BuildPseudoProcedureCall ;
6657
6658
6659 (*
6660    GetItemPointedTo - returns the symbol type that is being pointed to
6661                       by Sym.
6662 *)
6663
6664 PROCEDURE GetItemPointedTo (Sym: CARDINAL) : CARDINAL ;
6665 BEGIN
6666    IF IsPointer (Sym)
6667    THEN
6668       RETURN GetSType (Sym)
6669    ELSIF IsVar (Sym) OR IsType (Sym)
6670    THEN
6671       RETURN GetItemPointedTo (GetSType (Sym))
6672    END
6673 END GetItemPointedTo ;
6674
6675
6676 (*
6677    BuildThrowProcedure - builds the pseudo procedure call M2RTS.Throw.
6678                          The Stack:
6679
6680
6681                          Entry                      Exit
6682
6683                 Ptr ->
6684                          +----------------+
6685                          | NoOfParam      |
6686                          |----------------|
6687                          | Param 1        |
6688                          |----------------|
6689                          | Param 2        |
6690                          |----------------|
6691                          .                .
6692                          .                .
6693                          .                .
6694                          |----------------|
6695                          | Param #        |
6696                          |----------------|
6697                          | ProcSym | Type |         Empty
6698                          |----------------|
6699 *)
6700
6701 PROCEDURE BuildThrowProcedure ;
6702 VAR
6703    functok  : CARDINAL ;
6704    op       : CARDINAL ;
6705    NoOfParam: CARDINAL ;
6706 BEGIN
6707    PopT (NoOfParam) ;
6708    functok  := OperandTtok (NoOfParam + 1) ;
6709    IF NoOfParam = 1
6710    THEN
6711       op := OperandT (NoOfParam) ;
6712       GenQuadO (functok, ThrowOp, NulSym, NulSym, op, FALSE)
6713    ELSE
6714       MetaErrorT1 (functok, 'the pseudo procedure %{1Ea} takes one INTEGER parameter', Throw)
6715    END ;
6716    PopN (NoOfParam+1)
6717 END BuildThrowProcedure ;
6718
6719
6720 (*
6721    BuildReThrow - creates a ThrowOp _ _ NulSym, indicating that
6722                   the exception needs to be rethrown.  The stack
6723                   is unaltered.
6724 *)
6725
6726 PROCEDURE BuildReThrow (tokenno: CARDINAL) ;
6727 BEGIN
6728    GenQuadO (tokenno, ThrowOp, NulSym, NulSym, NulSym, FALSE)
6729 END BuildReThrow ;
6730
6731
6732 (*
6733    BuildNewProcedure - builds the pseudo procedure call NEW.
6734                        This procedure is traditionally a "macro" for
6735                        NEW(x, ...) --> ALLOCATE(x, TSIZE(x^, ...))
6736                        One method of implementation is to emulate a "macro"
6737                        processor by pushing the relevant input tokens
6738                        back onto the input stack.
6739                        However this causes two problems:
6740
6741                        (i)  Unnecessary code is produced for x^
6742                        (ii) SIZE must be imported from SYSTEM
6743                        Therefore we chose an alternative method of
6744                        implementation;
6745                        generate quadruples for ALLOCATE(x, TSIZE(x^, ...))
6746                        this, although slightly more efficient,
6747                        is more complex and circumvents problems (i) and (ii).
6748
6749                        The Stack:
6750
6751
6752                        Entry                      Exit
6753
6754                 Ptr ->
6755                        +----------------+
6756                        | NoOfParam      |
6757                        |----------------|
6758                        | Param 1        |
6759                        |----------------|
6760                        | Param 2        |
6761                        |----------------|
6762                        .                .
6763                        .                .
6764                        .                .
6765                        |----------------|
6766                        | Param #        |
6767                        |----------------|
6768                        | ProcSym | Type |         Empty
6769                        |----------------|
6770 *)
6771
6772 PROCEDURE BuildNewProcedure (functok: CARDINAL) ;
6773 VAR
6774    NoOfParam,
6775    SizeSym,
6776    PtrSym,
6777    ProcSym    : CARDINAL ;
6778    paramtok,
6779    combinedtok: CARDINAL ;
6780 BEGIN
6781    PopT(NoOfParam) ;
6782    IF NoOfParam>=1
6783    THEN
6784       ProcSym := RequestSym (functok, MakeKey('ALLOCATE')) ;
6785       IF (ProcSym#NulSym) AND IsProcedure(ProcSym)
6786       THEN
6787          PtrSym := OperandT (NoOfParam) ;
6788          paramtok := OperandTtok (1) ;
6789          IF IsReallyPointer(PtrSym)
6790          THEN
6791             combinedtok := MakeVirtualTok (functok, functok, paramtok) ;
6792             (*
6793                Build macro: ALLOCATE( PtrSym, SIZE(PtrSym^) )
6794             *)
6795             PushTFtok (TSize, Cardinal, paramtok) ;(* Procedure      *)
6796                                       (* x^             *)
6797             PushTtok (GetItemPointedTo (PtrSym), paramtok) ;
6798             PushT (1) ;               (* One parameter  *)
6799             BuildFunctionCall ;
6800             PopT (SizeSym) ;
6801
6802             PushTtok (ProcSym, combinedtok) ;  (* ALLOCATE       *)
6803             PushTtok (PtrSym, paramtok) ;      (* x              *)
6804             PushTtok (SizeSym, paramtok) ;     (* TSIZE(x^)      *)
6805             PushT (2) ;                        (* Two parameters *)
6806             BuildProcedureCall (combinedtok)
6807          ELSE
6808             MetaErrorT0 (paramtok, 'parameter to {%EkNEW} must be a pointer')
6809          END
6810       ELSE
6811          MetaErrorT0 (functok, '{%E}ALLOCATE procedure not found for NEW substitution')
6812       END
6813    ELSE
6814       MetaErrorT0 (functok, 'the pseudo procedure {%EkNEW} has one or more parameters')
6815    END ;
6816    PopN (NoOfParam+1)
6817 END BuildNewProcedure ;
6818
6819
6820 (*
6821    BuildDisposeProcedure - builds the pseudo procedure call DISPOSE.
6822                            This procedure is traditionally a "macro" for
6823                            DISPOSE(x) --> DEALLOCATE(x, TSIZE(x^))
6824                            One method of implementation is to emulate a "macro"
6825                            processor by pushing the relevant input tokens
6826                            back onto the input stack.
6827                            However this causes two problems:
6828
6829                            (i)  Unnecessary code is produced for x^
6830                            (ii) TSIZE must be imported from SYSTEM
6831                            Therefore we chose an alternative method of
6832                            implementation;
6833                            generate quadruples for DEALLOCATE(x, TSIZE(x^))
6834                            this, although slightly more efficient,
6835                            is more complex and circumvents problems (i)
6836                            and (ii).
6837
6838                            The Stack:
6839
6840
6841                            Entry                      Exit
6842
6843                     Ptr ->
6844                            +----------------+
6845                            | NoOfParam      |
6846                            |----------------|
6847                            | Param 1        |
6848                            |----------------|
6849                            | Param 2        |
6850                            |----------------|
6851                            .                .
6852                            .                .
6853                            .                .
6854                            |----------------|
6855                            | Param #        |
6856                            |----------------|
6857                            | ProcSym | Type |         Empty
6858                            |----------------|
6859 *)
6860
6861 PROCEDURE BuildDisposeProcedure (functok: CARDINAL) ;
6862 VAR
6863    NoOfParam,
6864    SizeSym,
6865    PtrSym,
6866    ProcSym    : CARDINAL ;
6867    combinedtok,
6868    paramtok   : CARDINAL ;
6869 BEGIN
6870    PopT (NoOfParam) ;
6871    IF NoOfParam>=1
6872    THEN
6873       ProcSym := RequestSym (functok, MakeKey ('DEALLOCATE')) ;
6874       IF (ProcSym # NulSym) AND IsProcedure (ProcSym)
6875       THEN
6876          PtrSym := OperandT (NoOfParam) ;
6877          paramtok := OperandTtok (1) ;
6878          IF IsReallyPointer (PtrSym)
6879          THEN
6880             combinedtok := MakeVirtualTok (functok, functok, paramtok) ;
6881             (*
6882                Build macro: DEALLOCATE( PtrSym, TSIZE(PtrSym^) )
6883             *)
6884             PushTFtok (TSize, Cardinal, paramtok) ;(* Procedure      *)
6885                                       (* x^             *)
6886             PushTtok (GetItemPointedTo(PtrSym), paramtok) ;
6887             PushT (1) ;               (* One parameter  *)
6888             BuildFunctionCall ;
6889             PopT (SizeSym) ;
6890
6891             PushTtok (ProcSym, combinedtok) ;         (* DEALLOCATE     *)
6892             PushTtok (PtrSym, paramtok) ;             (* x              *)
6893             PushTtok (SizeSym, paramtok) ;            (* TSIZE(x^)      *)
6894             PushT (2) ;                               (* Two parameters *)
6895             BuildProcedureCall (combinedtok)
6896          ELSE
6897             MetaErrorT0 (paramtok, 'argument to {%EkDISPOSE} must be a pointer')
6898          END
6899       ELSE
6900          MetaErrorT0 (functok, '{%E}DEALLOCATE procedure not found for DISPOSE substitution')
6901       END
6902    ELSE
6903       MetaErrorT0 (functok, 'the pseudo procedure {%EkDISPOSE} has one or more parameters')
6904    END ;
6905    PopN (NoOfParam+1)
6906 END BuildDisposeProcedure ;
6907
6908
6909 (*
6910    CheckRangeIncDec - performs des := des <tok> expr
6911                       with range checking (if enabled).
6912
6913                                Stack
6914                       Entry              Exit
6915
6916                                      +------------+
6917                       empty          | des + expr |
6918                                      |------------|
6919 *)
6920
6921 PROCEDURE CheckRangeIncDec (tokenpos: CARDINAL; des, expr: CARDINAL; tok: Name) ;
6922 VAR
6923    dtype, etype: CARDINAL ;
6924 BEGIN
6925    dtype := GetDType(des) ;
6926    etype := GetDType(expr) ;
6927    IF WholeValueChecking AND (NOT MustNotCheckBounds)
6928    THEN
6929       IF tok=PlusTok
6930       THEN
6931          BuildRange (InitIncRangeCheck (des, expr))
6932       ELSE
6933          BuildRange (InitDecRangeCheck (des, expr))
6934       END
6935    END ;
6936
6937    IF IsExpressionCompatible (dtype, etype)
6938    THEN
6939       (* the easy case simulate a straightforward macro *)
6940       PushTF(des, dtype) ;
6941       PushT(tok) ;
6942       PushTF(expr, etype) ;
6943       doBuildBinaryOp(FALSE, TRUE)
6944    ELSE
6945       IF (IsOrdinalType(dtype) OR (dtype=Address) OR IsPointer(dtype)) AND
6946          (IsOrdinalType(etype) OR (etype=Address) OR IsPointer(etype))
6947       THEN
6948          PushTF (des, dtype) ;
6949          PushT (tok) ;
6950          PushTF (Convert, NulSym) ;
6951          PushT (dtype) ;
6952          PushT (expr) ;
6953          PushT (2) ;          (* Two parameters *)
6954          BuildConvertFunction ;
6955          doBuildBinaryOp (FALSE, TRUE)
6956       ELSE
6957          IF tok=PlusTok
6958          THEN
6959             MetaError0 ('cannot perform {%EkINC} using non ordinal types')
6960          ELSE
6961             MetaError0 ('cannot perform {%EkDEC} using non ordinal types')
6962          END ;
6963          PushTFtok (MakeConstLit (tokenpos, MakeKey ('0'), NulSym), NulSym, tokenpos)
6964       END
6965    END
6966 END CheckRangeIncDec ;
6967
6968
6969 (*
6970    BuildIncProcedure - builds the pseudo procedure call INC.
6971                        INC is a procedure which increments a variable.
6972                        It takes one or two parameters:
6973                        INC(a, b)  or  INC(a)
6974                        a := a+b   or  a := a+1
6975
6976                        The Stack:
6977
6978
6979                        Entry                      Exit
6980
6981                 Ptr ->
6982                        +----------------+
6983                        | NoOfParam      |
6984                        |----------------|
6985                        | Param 1        |
6986                        |----------------|
6987                        | Param 2        |
6988                        |----------------|
6989                        .                .
6990                        .                .
6991                        .                .
6992                        |----------------|
6993                        | Param #        |
6994                        |----------------|
6995                        | ProcSym | Type |         Empty
6996                        |----------------|
6997 *)
6998
6999 PROCEDURE BuildIncProcedure ;
7000 VAR
7001    proctok   : CARDINAL ;
7002    NoOfParam,
7003    dtype,
7004    OperandSym,
7005    VarSym,
7006    TempSym   : CARDINAL ;
7007 BEGIN
7008    PopT (NoOfParam) ;
7009    proctok := OperandTtok (NoOfParam + 1) ;
7010    IF (NoOfParam = 1) OR (NoOfParam = 2)
7011    THEN
7012       VarSym := OperandT (NoOfParam) ;  (* bottom/first parameter *)
7013       IF IsVar (VarSym)
7014       THEN
7015          dtype := GetDType (VarSym) ;
7016          IF NoOfParam = 2
7017          THEN
7018             OperandSym := DereferenceLValue (OperandTok (1), OperandT (1))
7019          ELSE
7020             PushOne (proctok, dtype, 'the {%EkINC} will cause an overflow {%1ad}') ;
7021             PopT (OperandSym)
7022          END ;
7023
7024          PushT (VarSym) ;
7025          TempSym := DereferenceLValue (OperandTok (NoOfParam), VarSym) ;
7026          CheckRangeIncDec (proctok, TempSym, OperandSym, PlusTok) ;  (* TempSym + OperandSym *)
7027          BuildAssignmentWithoutBounds (proctok, FALSE, TRUE)   (* VarSym := TempSym + OperandSym *)
7028       ELSE
7029          MetaErrorT1 (proctok,
7030                       'base procedure {%EkINC} expects a variable as a parameter but was given {%1Ed}',
7031                       VarSym)
7032       END
7033    ELSE
7034       MetaErrorT0 (proctok,
7035                    'the base procedure {%EkINC} expects 1 or 2 parameters')
7036    END ;
7037    PopN (NoOfParam + 1)
7038 END BuildIncProcedure ;
7039
7040
7041 (*
7042    BuildDecProcedure - builds the pseudo procedure call DEC.
7043                        DEC is a procedure which decrements a variable.
7044                        It takes one or two parameters:
7045                        DEC(a, b)  or  DEC(a)
7046                        a := a-b   or  a := a-1
7047
7048                        The Stack:
7049
7050
7051                        Entry                      Exit
7052
7053                 Ptr ->
7054                        +----------------+
7055                        | NoOfParam      |
7056                        |----------------|
7057                        | Param 1        |
7058                        |----------------|
7059                        | Param 2        |
7060                        |----------------|
7061                        .                .
7062                        .                .
7063                        .                .
7064                        |----------------|
7065                        | Param #        |
7066                        |----------------|
7067                        | ProcSym | Type |         Empty
7068                        |----------------|
7069 *)
7070
7071 PROCEDURE BuildDecProcedure ;
7072 VAR
7073    proctok,
7074    NoOfParam,
7075    dtype,
7076    OperandSym,
7077    VarSym,
7078    TempSym   : CARDINAL ;
7079 BEGIN
7080    PopT (NoOfParam) ;
7081    proctok := OperandTtok (NoOfParam + 1) ;
7082    IF (NoOfParam = 1) OR (NoOfParam = 2)
7083    THEN
7084       VarSym := OperandT (NoOfParam) ;  (* bottom/first parameter *)
7085       IF IsVar (VarSym)
7086       THEN
7087          dtype := GetDType (VarSym) ;
7088          IF NoOfParam = 2
7089          THEN
7090             OperandSym := DereferenceLValue (OperandTok (1), OperandT (1))
7091          ELSE
7092             PushOne (proctok, dtype, 'the {%EkDEC} will cause an overflow {%1ad}') ;
7093             PopT (OperandSym)
7094          END ;
7095
7096          PushT (VarSym) ;
7097          TempSym := DereferenceLValue (OperandTok (NoOfParam), VarSym) ;
7098          CheckRangeIncDec (proctok, TempSym, OperandSym, MinusTok) ;  (* TempSym - OperandSym *)
7099          BuildAssignmentWithoutBounds (proctok, FALSE, TRUE)   (* VarSym := TempSym - OperandSym *)
7100       ELSE
7101          MetaErrorT1 (proctok,
7102                       'base procedure {%EkDEC} expects a variable as a parameter but was given {%1Ed}',
7103                       VarSym)
7104       END
7105    ELSE
7106       MetaErrorT0 (proctok,
7107                    'the base procedure {%EkDEC} expects 1 or 2 parameters')
7108    END ;
7109    PopN (NoOfParam + 1)
7110 END BuildDecProcedure ;
7111
7112
7113 (*
7114    DereferenceLValue - checks to see whether, operand, is declare as an LValue
7115                        and if so it dereferences it.
7116 *)
7117
7118 PROCEDURE DereferenceLValue (tok: CARDINAL; operand: CARDINAL) : CARDINAL ;
7119 VAR
7120    sym: CARDINAL ;
7121 BEGIN
7122    IF GetMode (operand) = LeftValue
7123    THEN
7124       (* dereference the pointer *)
7125       sym := MakeTemporary (tok, AreConstant(IsConst(operand))) ;
7126       PutVar(sym, GetSType (operand)) ;
7127
7128       PushTtok (sym, tok) ;
7129       PushTtok (operand, tok) ;
7130       BuildAssignmentWithoutBounds (tok, FALSE, TRUE) ;
7131       RETURN sym
7132    ELSE
7133       RETURN operand
7134    END
7135 END DereferenceLValue ;
7136
7137
7138 (*
7139    BuildInclProcedure - builds the pseudo procedure call INCL.
7140                         INCL is a procedure which adds bit b into a BITSET a.
7141                         It takes two parameters:
7142                         INCL(a, b)
7143
7144                         a := a + {b}
7145
7146                         The Stack:
7147
7148
7149                         Entry                      Exit
7150
7151                  Ptr ->
7152                         +----------------+
7153                         | NoOfParam      |
7154                         |----------------|
7155                         | Param 1        |
7156                         |----------------|
7157                         | Param 2        |
7158                         |----------------|
7159                         | ProcSym | Type |         Empty
7160                         |----------------|
7161 *)
7162
7163 PROCEDURE BuildInclProcedure ;
7164 VAR
7165    proctok,
7166    optok     : CARDINAL ;
7167    NoOfParam,
7168    DerefSym,
7169    OperandSym,
7170    VarSym    : CARDINAL ;
7171 BEGIN
7172    PopT (NoOfParam) ;
7173    proctok := OperandTtok (NoOfParam + 1) ;
7174    IF NoOfParam = 2
7175    THEN
7176       VarSym := OperandT (2) ;
7177       MarkArrayWritten (OperandA (2)) ;
7178       OperandSym := OperandT (1) ;
7179       optok := OperandTok (1) ;
7180       IF IsVar (VarSym)
7181       THEN
7182          IF IsSet (GetDType (VarSym))
7183          THEN
7184             DerefSym := DereferenceLValue (optok, OperandSym) ;
7185             BuildRange (InitInclCheck (VarSym, DerefSym)) ;
7186             GenQuadO (proctok, InclOp, VarSym, NulSym, DerefSym, FALSE)
7187          ELSE
7188             MetaErrorT1 (proctok,
7189                          'the first parameter to {%EkINCL} must be a set variable but is {%E1d}',
7190                          VarSym)
7191          END
7192       ELSE
7193          MetaErrorT1 (proctok,
7194                       'base procedure {%EkINCL} expects a variable as a parameter but is {%E1d}',
7195                       VarSym)
7196       END
7197    ELSE
7198       MetaErrorT0 (proctok, 'the base procedure {%EkINCL} expects 1 or 2 parameters')
7199    END ;
7200    PopN (NoOfParam + 1)
7201 END BuildInclProcedure ;
7202
7203
7204 (*
7205    BuildExclProcedure - builds the pseudo procedure call EXCL.
7206                         INCL is a procedure which removes bit b from SET a.
7207                         It takes two parameters:
7208                         EXCL(a, b)
7209
7210                         a := a - {b}
7211
7212                         The Stack:
7213
7214
7215                         Entry                      Exit
7216
7217                  Ptr ->
7218                         +----------------+
7219                         | NoOfParam      |
7220                         |----------------|
7221                         | Param 1        |
7222                         |----------------|
7223                         | Param 2        |
7224                         |----------------|
7225                         | ProcSym | Type |         Empty
7226                         |----------------|
7227 *)
7228
7229 PROCEDURE BuildExclProcedure ;
7230 VAR
7231    proctok,
7232    optok     : CARDINAL ;
7233    NoOfParam,
7234    DerefSym,
7235    OperandSym,
7236    VarSym    : CARDINAL ;
7237 BEGIN
7238    PopT (NoOfParam) ;
7239    proctok := OperandTtok (NoOfParam + 1) ;
7240    IF NoOfParam=2
7241    THEN
7242       VarSym := OperandT (2) ;
7243       MarkArrayWritten (OperandA(2)) ;
7244       OperandSym := OperandT (1) ;
7245       optok := OperandTok (1) ;
7246       IF IsVar (VarSym)
7247       THEN
7248          IF IsSet (GetDType (VarSym))
7249          THEN
7250             DerefSym := DereferenceLValue (optok, OperandSym) ;
7251             BuildRange (InitExclCheck (VarSym, DerefSym)) ;
7252             GenQuadO (proctok, ExclOp, VarSym, NulSym, DerefSym, FALSE)
7253          ELSE
7254             MetaErrorT1 (proctok,
7255                          'the first parameter to {%EkEXCL} must be a set variable but is {%E1d}',
7256                          VarSym)
7257          END
7258       ELSE
7259          MetaErrorT1 (proctok,
7260                       'base procedure {%EkEXCL} expects a variable as a parameter but is {%E1d}',
7261                       VarSym)
7262       END
7263    ELSE
7264       MetaErrorT0 (proctok,
7265                    'the base procedure {%EkEXCL} expects 1 or 2 parameters')
7266    END ;
7267    PopN (NoOfParam + 1)
7268 END BuildExclProcedure ;
7269
7270
7271 (*
7272    CheckBuildFunction - checks to see whether ProcSym is a function
7273                         and if so it adds a TempSym value which will
7274                         hold the return value once the function finishes.
7275                         This procedure also generates an error message
7276                         if the user is calling a function and ignoring
7277                         the return result.  The additional TempSym
7278                         is not created if ProcSym is a procedure
7279                         and the stack is unaltered.
7280
7281                         The Stack:
7282
7283
7284                        Entry                      Exit
7285
7286                 Ptr ->
7287
7288                                                   +----------------+
7289                                                   | ProcSym | Type |
7290                        +----------------+         |----------------|
7291                        | ProcSym | Type |         | TempSym | Type |
7292                        |----------------|         |----------------|
7293 *)
7294
7295 PROCEDURE CheckBuildFunction () : BOOLEAN ;
7296 VAR
7297    n            : Name ;
7298    tokpos,
7299    TempSym,
7300    ProcSym, Type: CARDINAL ;
7301 BEGIN
7302    PopTFtok(ProcSym, Type, tokpos) ;
7303    IF IsVar(ProcSym) AND IsProcType(Type)
7304    THEN
7305       IF GetSType(Type)#NulSym
7306       THEN
7307          TempSym := MakeTemporary (tokpos, RightValue) ;
7308          PutVar(TempSym, GetSType(Type)) ;
7309          PushTFtok(TempSym, GetSType(Type), tokpos) ;
7310          PushTFtok(ProcSym, Type, tokpos) ;
7311          IF NOT IsReturnOptional(Type)
7312          THEN
7313             IF IsTemporary(ProcSym)
7314             THEN
7315                ErrorFormat0 (NewError (tokpos),
7316                              'function is being called but its return value is ignored')
7317             ELSE
7318                n := GetSymName (ProcSym) ;
7319                ErrorFormat1 (NewError (tokpos),
7320                             'function (%a) is being called but its return value is ignored', n)
7321             END
7322          END ;
7323          RETURN TRUE
7324       END
7325    ELSIF IsProcedure(ProcSym) AND (Type#NulSym)
7326    THEN
7327       TempSym := MakeTemporary (tokpos, RightValue) ;
7328       PutVar(TempSym, Type) ;
7329       PushTFtok(TempSym, Type, tokpos) ;
7330       PushTFtok(ProcSym, Type, tokpos) ;
7331       IF NOT IsReturnOptional(ProcSym)
7332       THEN
7333          n := GetSymName(ProcSym) ;
7334          ErrorFormat1(NewError(tokpos),
7335                       'function (%a) is being called but its return value is ignored', n)
7336       END ;
7337       RETURN TRUE
7338    END ;
7339    PushTFtok (ProcSym, Type, tokpos) ;
7340    RETURN FALSE
7341 END CheckBuildFunction ;
7342
7343
7344 (*
7345    BuildFunctionCall - builds a function call.
7346                        The Stack:
7347
7348
7349                        Entry                      Exit
7350
7351                 Ptr ->
7352                        +----------------+
7353                        | NoOfParam      |
7354                        |----------------|
7355                        | Param 1        |
7356                        |----------------|
7357                        | Param 2        |
7358                        |----------------|
7359                        .                .
7360                        .                .
7361                        .                .
7362                        |----------------|
7363                        | Param #        |                        <- Ptr
7364                        |----------------|         +------------+
7365                        | ProcSym | Type |         | ReturnVar  |
7366                        |----------------|         |------------|
7367 *)
7368
7369 PROCEDURE BuildFunctionCall ;
7370 VAR
7371    paramtok,
7372    combinedtok,
7373    functok,
7374    NoOfParam,
7375    ProcSym    : CARDINAL ;
7376 BEGIN
7377    PopT (NoOfParam) ;
7378    functok  := OperandTtok (NoOfParam + 1) ;
7379    ProcSym := OperandT (NoOfParam + 1) ;
7380    ProcSym := SkipConst (ProcSym) ;
7381    PushT (NoOfParam) ;
7382    (* Compile time stack restored to entry state *)
7383    IF IsUnknown (ProcSym)
7384    THEN
7385       paramtok := OperandTtok (1) ;
7386       combinedtok := MakeVirtualTok (functok, functok, paramtok) ;
7387       MetaErrorT1 (functok, 'procedure function {%1Ea} is undefined', ProcSym) ;
7388       PopN (NoOfParam + 2) ;
7389       PushT (MakeConstLit (combinedtok, MakeKey ('0'), NulSym))   (* fake return value to continue compiling *)
7390    ELSIF IsAModula2Type (ProcSym)
7391    THEN
7392       ManipulatePseudoCallParameters ;
7393       BuildTypeCoercion
7394    ELSIF IsPseudoSystemFunction (ProcSym) OR
7395          IsPseudoBaseFunction (ProcSym)
7396    THEN
7397       ManipulatePseudoCallParameters ;
7398       BuildPseudoFunctionCall
7399    ELSE
7400       BuildRealFunctionCall (functok)
7401    END
7402 END BuildFunctionCall ;
7403
7404
7405 (*
7406    BuildConstFunctionCall - builds a function call and checks that this function can be
7407                             called inside a ConstExpression.
7408
7409                             The Stack:
7410
7411
7412                             Entry                      Exit
7413
7414                      Ptr ->
7415                             +----------------+
7416                             | NoOfParam      |
7417                             |----------------|
7418                             | Param 1        |
7419                             |----------------|
7420                             | Param 2        |
7421                             |----------------|
7422                             .                .
7423                             .                .
7424                             .                .
7425                             |----------------|
7426                             | Param #        |                        <- Ptr
7427                             |----------------|         +------------+
7428                             | ProcSym | Type |         | ReturnVar  |
7429                             |----------------|         |------------|
7430
7431 *)
7432
7433 PROCEDURE BuildConstFunctionCall ;
7434 VAR
7435    functok,
7436    combinedtok,
7437    paramtok,
7438    ConstExpression,
7439    NoOfParam,
7440    ProcSym        : CARDINAL ;
7441 BEGIN
7442    DisplayStack ;
7443    PopT(NoOfParam) ;
7444    ProcSym := OperandT (NoOfParam + 1) ;
7445    functok := OperandTtok (NoOfParam + 1) ;
7446    IF CompilerDebugging
7447    THEN
7448       printf2 ('procsym = %d  token = %d\n', ProcSym, functok) ;
7449       ErrorStringAt (InitString ('constant function'), functok)
7450    END ;
7451    PushT (NoOfParam) ;
7452    IF (ProcSym # Convert) AND
7453       (IsPseudoBaseFunction (ProcSym) OR
7454        IsPseudoSystemFunctionConstExpression (ProcSym) OR
7455        (IsProcedure (ProcSym) AND IsProcedureBuiltin (ProcSym)))
7456    THEN
7457       BuildFunctionCall
7458    ELSE
7459       IF IsAModula2Type (ProcSym)
7460       THEN
7461          (* type conversion *)
7462          IF NoOfParam = 1
7463          THEN
7464             ConstExpression := OperandT (NoOfParam + 1) ;
7465             paramtok := OperandTtok (NoOfParam + 1) ;
7466             PopN (NoOfParam + 2) ;
7467             (*
7468                Build macro: CONVERT( ProcSym, ConstExpression )
7469             *)
7470             PushTFtok (Convert, NulSym, functok) ;
7471             PushTtok (ProcSym, functok) ;
7472             PushTtok (ConstExpression, paramtok) ;
7473             PushT (2) ;          (* Two parameters *)
7474             BuildConvertFunction
7475          ELSE
7476             MetaErrorT0 (functok, '{%E}a constant type conversion can only have one argument')
7477          END
7478       ELSE
7479          (* error issue message and fake return stack *)
7480          IF Iso
7481          THEN
7482             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')
7483          ELSE
7484             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')
7485          END ;
7486          IF NoOfParam > 0
7487          THEN
7488             paramtok := OperandTtok (NoOfParam + 1) ;
7489             combinedtok := MakeVirtualTok (functok, functok, paramtok)
7490          ELSE
7491             combinedtok := functok
7492          END ;
7493          PopN (NoOfParam+2) ;
7494          PushT (MakeConstLit (combinedtok, MakeKey('0'), NulSym))   (* fake return value to continue compiling *)
7495       END
7496    END
7497 END BuildConstFunctionCall ;
7498
7499
7500 (*
7501    BuildTypeCoercion - builds the type coersion.
7502                        MODULA-2 allows types to be coersed with no runtime
7503                        penility.
7504                        It insists that the TSIZE(t1)=TSIZE(t2) where
7505                        t2 variable := t2(variable of type t1).
7506                        The ReturnVar on the stack is of type t2.
7507
7508                        The Stack:
7509
7510
7511                        Entry                      Exit
7512
7513                 Ptr ->
7514                        +----------------+
7515                        | NoOfParam      |
7516                        |----------------|
7517                        | Param 1        |
7518                        |----------------|
7519                        | Param 2        |
7520                        |----------------|
7521                        .                .
7522                        .                .
7523                        .                .
7524                        |----------------|
7525                        | Param #        |                        <- Ptr
7526                        |----------------|         +------------+
7527                        | ProcSym | Type |         | ReturnVar  |
7528                        |----------------|         |------------|
7529
7530                        Quadruples:
7531
7532                        CoerceOp  ReturnVar  Type  Param1
7533
7534                        A type coercion will only be legal if the different
7535                        types have exactly the same size.
7536                        Since we can only decide this after M2Eval has processed
7537                        the symbol table then we create a quadruple explaining
7538                        the coercion taking place, the code generator can test
7539                        this assertion and report an error if the type sizes
7540                        differ.
7541 *)
7542
7543 PROCEDURE BuildTypeCoercion ;
7544 VAR
7545    resulttok,
7546    proctok,
7547    exptok   : CARDINAL ;
7548    r,
7549    exp,
7550    NoOfParam,
7551    ReturnVar,
7552    ProcSym  : CARDINAL ;
7553 BEGIN
7554    PopT(NoOfParam) ;
7555    ProcSym := OperandT (NoOfParam+1) ;
7556    proctok := OperandTok (NoOfParam+1) ;
7557    IF NOT IsAModula2Type (ProcSym)
7558    THEN
7559       MetaError1 ('coersion expecting a type, seen {%1Ea} which is {%1Ed}', ProcSym)
7560    END ;
7561    IF NoOfParam = 1
7562    THEN
7563       PopTrwtok (exp, r, exptok) ;
7564       MarkAsRead (r) ;
7565       resulttok := MakeVirtualTok (proctok, proctok, exptok) ;
7566       ReturnVar := MakeTemporary (resulttok, RightValue) ;
7567       PutVar (ReturnVar, ProcSym) ;  (* Set ReturnVar's TYPE *)
7568       PopN (1) ;   (* pop procedure.  *)
7569       IF IsConst (exp) OR IsVar (exp)
7570       THEN
7571          GenQuad (CoerceOp, ReturnVar, ProcSym, exp)
7572       ELSE
7573          MetaError2 ('trying to coerse {%1EMRad} which is not a variable or constant into {%2ad}',
7574                      exp, ProcSym) ;
7575          MetaError2 ('trying to coerse {%1ECad} which is not a variable or constant into {%2ad}',
7576                      exp, ProcSym)
7577       END ;
7578       PushTFtok (ReturnVar, ProcSym, resulttok)
7579    ELSE
7580       MetaError0 ('{%E}only one parameter expected in a TYPE coersion')
7581    END
7582 END BuildTypeCoercion ;
7583
7584
7585 (*
7586    BuildRealFunctionCall - builds a function call.
7587                            The Stack:
7588
7589
7590                            Entry                      Exit
7591
7592                     Ptr ->
7593                            +----------------+
7594                            | NoOfParam      |
7595                            |----------------|
7596                            | Param 1        |
7597                            |----------------|
7598                            | Param 2        |
7599                            |----------------|
7600                            .                .
7601                            .                .
7602                            .                .
7603                            |----------------|
7604                            | Param #        |                        <- Ptr
7605                            |----------------|         +------------+
7606                            | ProcSym | Type |         | ReturnVar  |
7607                            |----------------|         |------------|
7608 *)
7609
7610 PROCEDURE BuildRealFunctionCall (tokno: CARDINAL) ;
7611 VAR
7612    NoOfParam,
7613    ProcSym  : CARDINAL ;
7614 BEGIN
7615    PopT(NoOfParam) ;
7616    PushT(NoOfParam) ;
7617    ProcSym := OperandT (NoOfParam+2) ;
7618    ProcSym := SkipConst (ProcSym) ;
7619    IF IsVar(ProcSym)
7620    THEN
7621       (* Procedure Variable ? *)
7622       ProcSym := SkipType(OperandF(NoOfParam+2))
7623    END ;
7624    IF IsDefImp (GetScope (ProcSym)) AND IsDefinitionForC (GetScope(ProcSym))
7625    THEN
7626       BuildRealFuncProcCall (tokno, TRUE, TRUE)
7627    ELSE
7628       BuildRealFuncProcCall (tokno, TRUE, FALSE)
7629    END
7630 END BuildRealFunctionCall ;
7631
7632
7633 (*
7634    BuildPseudoFunctionCall - builds the pseudo function
7635                              The Stack:
7636
7637
7638                              Entry                      Exit
7639
7640                       Ptr ->
7641                              +----------------+
7642                              | NoOfParam      |
7643                              |----------------|
7644                              | Param 1        |
7645                              |----------------|
7646                              | Param 2        |
7647                              |----------------|
7648                              .                .
7649                              .                .
7650                              .                .
7651                              |----------------|
7652                              | Param #        |                        <- Ptr
7653                              |----------------|         +------------+
7654                              | ProcSym | Type |         | ReturnVar  |
7655                              |----------------|         |------------|
7656
7657 *)
7658
7659 PROCEDURE BuildPseudoFunctionCall ;
7660 VAR
7661    NoOfParam,
7662    ProcSym  : CARDINAL ;
7663 BEGIN
7664    PopT (NoOfParam) ;
7665    ProcSym := OperandT (NoOfParam+1) ;
7666    ProcSym := SkipConst (ProcSym) ;
7667    PushT (NoOfParam) ;
7668    (* Compile time stack restored to entry state *)
7669    IF ProcSym = High
7670    THEN
7671       BuildHighFunction
7672    ELSIF ProcSym = LengthS
7673    THEN
7674       BuildLengthFunction
7675    ELSIF ProcSym = Adr
7676    THEN
7677       BuildAdrFunction
7678    ELSIF ProcSym = Size
7679    THEN
7680       BuildSizeFunction
7681    ELSIF ProcSym = TSize
7682    THEN
7683       BuildTSizeFunction
7684    ELSIF ProcSym = TBitSize
7685    THEN
7686       BuildTBitSizeFunction
7687    ELSIF ProcSym = Convert
7688    THEN
7689       BuildConvertFunction
7690    ELSIF ProcSym = Odd
7691    THEN
7692       BuildOddFunction
7693    ELSIF ProcSym = Abs
7694    THEN
7695       BuildAbsFunction
7696    ELSIF ProcSym = Cap
7697    THEN
7698       BuildCapFunction
7699    ELSIF ProcSym = Val
7700    THEN
7701       BuildValFunction
7702    ELSIF ProcSym = Chr
7703    THEN
7704       BuildChrFunction
7705    ELSIF IsOrd (ProcSym)
7706    THEN
7707       BuildOrdFunction (ProcSym)
7708    ELSIF IsInt (ProcSym)
7709    THEN
7710       BuildIntFunction (ProcSym)
7711    ELSIF IsTrunc (ProcSym)
7712    THEN
7713       BuildTruncFunction (ProcSym)
7714    ELSIF IsFloat (ProcSym)
7715    THEN
7716       BuildFloatFunction (ProcSym)
7717    ELSIF ProcSym = Min
7718    THEN
7719       BuildMinFunction
7720    ELSIF ProcSym = Max
7721    THEN
7722       BuildMaxFunction
7723    ELSIF ProcSym = AddAdr
7724    THEN
7725       BuildAddAdrFunction
7726    ELSIF ProcSym = SubAdr
7727    THEN
7728       BuildSubAdrFunction
7729    ELSIF ProcSym = DifAdr
7730    THEN
7731       BuildDifAdrFunction
7732    ELSIF ProcSym = Cast
7733    THEN
7734       BuildCastFunction
7735    ELSIF ProcSym = Shift
7736    THEN
7737       BuildShiftFunction
7738    ELSIF ProcSym = Rotate
7739    THEN
7740       BuildRotateFunction
7741    ELSIF ProcSym = MakeAdr
7742    THEN
7743       BuildMakeAdrFunction
7744    ELSIF ProcSym = Re
7745    THEN
7746       BuildReFunction
7747    ELSIF ProcSym = Im
7748    THEN
7749       BuildImFunction
7750    ELSIF ProcSym = Cmplx
7751    THEN
7752       BuildCmplxFunction
7753    ELSE
7754       InternalError  ('pseudo function not implemented yet')
7755    END
7756 END BuildPseudoFunctionCall ;
7757
7758
7759 (*
7760    BuildAddAdrFunction - builds the pseudo procedure call ADDADR.
7761
7762                          PROCEDURE ADDADR (addr: ADDRESS; offset: CARDINAL): ADDRESS ;
7763
7764                          Which returns address given by (addr + offset),
7765                          [ the standard says that it _may_
7766                            "raise an exception if this address is not valid."
7767                            currently we do not generate any exception code ]
7768
7769                          The Stack:
7770
7771                          Entry                      Exit
7772
7773                   Ptr ->
7774                          +----------------+
7775                          | NoOfParam      |
7776                          |----------------|
7777                          | Param 1        |
7778                          |----------------|
7779                          | Param 2        |                        <- Ptr
7780                          |----------------|         +------------+
7781                          | ProcSym | Type |         | ReturnVar  |
7782                          |----------------|         |------------|
7783 *)
7784
7785 PROCEDURE BuildAddAdrFunction ;
7786 VAR
7787    combinedtok,
7788    functok,
7789    optok      : CARDINAL ;
7790    ReturnVar,
7791    NoOfParam,
7792    OperandSym,
7793    VarSym     : CARDINAL ;
7794 BEGIN
7795    PopT (NoOfParam) ;
7796    functok := OperandTtok (NoOfParam + 1) ;
7797    IF NoOfParam=2
7798    THEN
7799       VarSym := OperandT (2) ;
7800       OperandSym := OperandT (1) ;
7801       optok := OperandTok (1) ;
7802       combinedtok := MakeVirtualTok (functok, functok, optok) ;
7803       PopN (NoOfParam + 1) ;
7804       IF IsVar (VarSym)
7805       THEN
7806          IF IsReallyPointer (VarSym) OR (GetSType (VarSym) = Address)
7807          THEN
7808             ReturnVar := MakeTemporary (combinedtok, RightValue) ;
7809             PutVar (ReturnVar, Address) ;
7810             GenQuad (AddOp, ReturnVar, VarSym, DereferenceLValue (optok, OperandSym)) ;
7811             PushTFtok (ReturnVar, Address, combinedtok)
7812          ELSE
7813             MetaErrorT1 (functok,
7814                          'the first parameter to ADDADR {%1Ea} must be a variable of type ADDRESS or a {%EkPOINTER}, rather than a {%1Etsd}',
7815                          VarSym) ;
7816             PushTFtok (MakeConstLit (combinedtok, MakeKey('0'), Address), Address, combinedtok)
7817          END
7818       ELSE
7819          MetaErrorT0 (functok, '{%E}SYSTEM procedure ADDADR expects a variable of type ADDRESS or POINTER as its first parameter') ;
7820          PushTFtok (MakeConstLit (combinedtok, MakeKey('0'), Address), Address, combinedtok)
7821       END
7822    ELSE
7823       MetaErrorT0 (functok, '{%E}SYSTEM procedure ADDADR expects 2 parameters') ;
7824       PopN (NoOfParam + 1) ;
7825       PushTFtok (MakeConstLit (functok, MakeKey ('0'), Address), Address, functok)
7826    END
7827 END BuildAddAdrFunction ;
7828
7829
7830 (*
7831    BuildSubAdrFunction - builds the pseudo procedure call ADDADR.
7832
7833                          PROCEDURE SUBADR (addr: ADDRESS; offset: CARDINAL): ADDRESS ;
7834
7835                          Which returns address given by (addr - offset),
7836                          [ the standard says that it _may_
7837                            "raise an exception if this address is not valid."
7838                            currently we do not generate any exception code ]
7839
7840                          The Stack:
7841
7842                          Entry                      Exit
7843
7844                   Ptr ->
7845                          +----------------+
7846                          | NoOfParam      |
7847                          |----------------|
7848                          | Param 1        |
7849                          |----------------|
7850                          | Param 2        |                        <- Ptr
7851                          |----------------|         +------------+
7852                          | ProcSym | Type |         | ReturnVar  |
7853                          |----------------|         |------------|
7854 *)
7855
7856 PROCEDURE BuildSubAdrFunction ;
7857 VAR
7858    functok,
7859    combinedtok,
7860    optok,
7861    vartok     : CARDINAL ;
7862    ReturnVar,
7863    NoOfParam,
7864    OperandSym,
7865    VarSym     : CARDINAL ;
7866 BEGIN
7867    PopT (NoOfParam) ;
7868    functok := OperandTtok (NoOfParam + 1) ;
7869    OperandSym := OperandT (1) ;
7870    optok := OperandTok (1) ;
7871    IF NoOfParam = 2
7872    THEN
7873       VarSym := OperandT (2) ;
7874       vartok := OperandTok (2) ;
7875       combinedtok := MakeVirtualTok (functok, functok, optok) ;
7876       PopN (NoOfParam + 1) ;
7877       IF IsVar (VarSym)
7878       THEN
7879          IF IsReallyPointer (VarSym) OR (GetSType (VarSym) = Address)
7880          THEN
7881             ReturnVar := MakeTemporary (combinedtok, RightValue) ;
7882             PutVar (ReturnVar, Address) ;
7883             GenQuad (SubOp, ReturnVar, VarSym, DereferenceLValue (optok, OperandSym)) ;
7884             PushTFtok (ReturnVar, Address, combinedtok)
7885          ELSE
7886             MetaErrorT1 (functok,
7887                          'the first parameter to {%EkSUBADR} {%1Ea} must be a variable of type ADDRESS or a {%EkPOINTER}, rather than a {%1Etsd}',
7888                          VarSym) ;
7889             PushTFtok (MakeConstLit (vartok, MakeKey('0'), Address), Address, vartok)
7890          END
7891       ELSE
7892          combinedtok := MakeVirtualTok (functok, functok, optok) ;
7893          MetaErrorT0 (combinedtok,
7894                       '{%E}SYSTEM procedure {%EkSUBADR} expects a variable of type ADDRESS or POINTER as its first parameter') ;
7895          PushTFtok (MakeConstLit (combinedtok, MakeKey ('0'), Address), Address, combinedtok)
7896       END
7897    ELSE
7898       combinedtok := MakeVirtualTok (functok, functok, optok) ;
7899       MetaErrorT0 (functok,
7900                    '{%E}SYSTEM procedure {%EkSUBADR} expects 2 parameters') ;
7901       PopN (NoOfParam+1) ;
7902       PushTFtok (MakeConstLit (combinedtok, MakeKey('0'), Address), Address, combinedtok)
7903    END
7904 END BuildSubAdrFunction ;
7905
7906
7907 (*
7908    BuildDifAdrFunction - builds the pseudo procedure call DIFADR.
7909
7910                          PROCEDURE DIFADR (addr1, addr2: ADDRESS): INTEGER ;
7911
7912                          Which returns address given by (addr1 - addr2),
7913                          [ the standard says that it _may_
7914                            "raise an exception if this address is invalid or
7915                             address space is non-contiguous."
7916                            currently we do not generate any exception code ]
7917
7918                          The Stack:
7919
7920                          Entry                      Exit
7921
7922                   Ptr ->
7923                          +----------------+
7924                          | NoOfParam      |
7925                          |----------------|
7926                          | Param 1        |
7927                          |----------------|
7928                          | Param 2        |                        <- Ptr
7929                          |----------------|         +------------+
7930                          | ProcSym | Type |         | ReturnVar  |
7931                          |----------------|         |------------|
7932 *)
7933
7934 PROCEDURE BuildDifAdrFunction ;
7935 VAR
7936    functok,
7937    optok,
7938    vartok,
7939    combinedtok: CARDINAL ;
7940    TempVar,
7941    NoOfParam,
7942    OperandSym,
7943    VarSym     : CARDINAL ;
7944 BEGIN
7945    PopT (NoOfParam) ;
7946    functok := OperandTtok (NoOfParam + 1) ;
7947    OperandSym := OperandT (1) ;
7948    optok := OperandTok (1) ;
7949    IF NoOfParam = 2
7950    THEN
7951       VarSym := OperandT (2) ;
7952       vartok := OperandTok (2) ;
7953       combinedtok := MakeVirtualTok (functok, functok, optok) ;
7954       PopN (NoOfParam + 1) ;
7955       IF IsVar (VarSym)
7956       THEN
7957          IF IsReallyPointer (VarSym) OR (GetSType (VarSym) = Address)
7958          THEN
7959             IF IsReallyPointer (OperandSym) OR (GetSType (OperandSym) = Address)
7960             THEN
7961                TempVar := MakeTemporary (vartok, RightValue) ;
7962                PutVar (TempVar, Address) ;
7963                GenQuad (SubOp, TempVar, VarSym, DereferenceLValue (optok, OperandSym)) ;
7964                (*
7965                   Build macro: CONVERT( INTEGER, TempVar )
7966                *)
7967                PushTFtok (Convert, NulSym, functok) ;
7968                PushTtok (Integer, functok) ;
7969                PushTtok (TempVar, vartok) ;
7970                PushT (2) ;          (* Two parameters *)
7971                BuildConvertFunction
7972             ELSE
7973                MetaError1 ('the second parameter to {%EkDIFADR } {%1Ea} must be a variable of type ADDRESS or a {%EkPOINTER}, rather than a {%1Etsd}',
7974                            OperandSym) ;
7975                PushTFtok (MakeConstLit (combinedtok, MakeKey ('0'), Integer), Integer, combinedtok)
7976             END
7977          ELSE
7978             MetaError1 ('the first parameter to {%EkDIFADR } {%1Ea} must be a variable of type ADDRESS or a {%EkPOINTER}, rather than a {%1Etsd}',
7979                         VarSym) ;
7980             PushTFtok (MakeConstLit (combinedtok, MakeKey ('0'), Integer), Integer, combinedtok)
7981          END
7982       ELSE
7983          MetaError0 ('{%E}SYSTEM procedure {%EkDIFADR } expects a variable of type ADDRESS or POINTER as its first parameter') ;
7984          PushTFtok (MakeConstLit (combinedtok, MakeKey('0'), Integer), Integer, combinedtok)
7985       END
7986    ELSE
7987       combinedtok := MakeVirtualTok (functok, functok, optok) ;
7988       MetaErrorT0 (functok, '{%E}SYSTEM procedure {%EkDIFADR } expects 2 parameters') ;
7989       PopN (NoOfParam+1) ;
7990       PushTFtok (MakeConstLit (combinedtok, MakeKey('0'), Integer), Integer, combinedtok)
7991    END
7992 END BuildDifAdrFunction ;
7993
7994
7995 (*
7996    BuildHighFunction - checks the stack in preparation for generating
7997                        quadruples which perform HIGH.
7998                        This procedure does not alter the stack but
7999                        determines whether, a, in HIGH(a) is an ArraySym
8000                        or UnboundedSym.
8001                        Both cases are different and appropriate quadruple
8002                        generating routines are called.
8003
8004                        The Stack:
8005
8006
8007                        Entry                      Exit
8008
8009                 Ptr ->
8010                        +----------------+
8011                        | NoOfParam      |
8012                        |----------------|
8013                        | Param 1        |
8014                        |----------------|
8015                        | Param 2        |
8016                        |----------------|
8017                        .                .
8018                        .                .
8019                        .                .
8020                        |----------------|
8021                        | Param #        |                        <- Ptr
8022                        |----------------|         +------------+
8023                        | ProcSym | Type |         | ReturnVar  |
8024                        |----------------|         |------------|
8025
8026 *)
8027
8028 PROCEDURE BuildHighFunction ;
8029 VAR
8030    functok,
8031    combinedtok,
8032    paramtok   : CARDINAL ;
8033    ProcSym,
8034    Type,
8035    NoOfParam,
8036    Param      : CARDINAL ;
8037 BEGIN
8038    PopT (NoOfParam) ;
8039    ProcSym := OperandT (NoOfParam+1) ;
8040    functok := OperandTok (NoOfParam + 1) ;
8041    BuildSizeCheckEnd (ProcSym) ;   (* quadruple generation now on *)
8042    IF NoOfParam = 1
8043    THEN
8044       Param := OperandT (1) ;
8045       paramtok := OperandTok (1) ;
8046       combinedtok := MakeVirtualTok (paramtok, functok, paramtok) ;
8047       Type := GetDType (Param) ;
8048       (* Restore stack to original form *)
8049       PushT (NoOfParam) ;
8050       IF (NOT IsVar(Param)) AND (NOT IsConstString(Param)) AND (NOT IsConst(Param))
8051       THEN
8052          (* we cannot test for IsConst(Param) AND (GetSType(Param)=Char)  as the type might not be assigned yet *)
8053          MetaError1 ('base procedure {%EkHIGH} expects a variable or string constant as its parameter {%1d:rather than {%1d}} {%1asa}', Param)
8054       ELSIF IsUnbounded(Type)
8055       THEN
8056          BuildHighFromUnbounded (combinedtok)
8057       ELSE
8058          BuildConstHighFromSym (combinedtok)
8059       END
8060    ELSE
8061       MetaError0 ('base procedure {%EkHIGH} requires one parameter') ;
8062       PopN (2) ;
8063       PushTFtok (MakeConstLit (functok, MakeKey ('0'), Cardinal), Cardinal, functok)
8064    END
8065 END BuildHighFunction ;
8066
8067
8068 (*
8069    BuildConstHighFromSym - builds the pseudo function HIGH from an Sym.
8070                            Sym is a constant or an array which has constant bounds
8071                            and therefore it can be calculated at compile time.
8072
8073                            The Stack:
8074
8075
8076                            Entry                      Exit
8077
8078                    Ptr ->
8079                            +----------------+
8080                            | NoOfParam      |
8081                            |----------------|
8082                            | Param 1        |
8083                            |----------------|
8084                            | Param 2        |
8085                            |----------------|
8086                            .                .
8087                            .                .
8088                            .                .
8089                            |----------------|
8090                            | Param #        |                        <- Ptr
8091                            |----------------|         +------------+
8092                            | ProcSym | Type |         | ReturnVar  |
8093                            |----------------|         |------------|
8094 *)
8095
8096 PROCEDURE BuildConstHighFromSym (tok: CARDINAL) ;
8097 VAR
8098    Dim,
8099    NoOfParam,
8100    ReturnVar: CARDINAL ;
8101 BEGIN
8102    PopT (NoOfParam) ;
8103    ReturnVar := MakeTemporary (tok, ImmediateValue) ;
8104    Dim := OperandD (1) ;
8105    INC (Dim) ;
8106    GenHigh (tok, ReturnVar, 1, OperandT (1)) ;
8107    PopN (NoOfParam+1) ;
8108    PushTtok (ReturnVar, tok)
8109 END BuildConstHighFromSym ;
8110
8111
8112 (*
8113    BuildHighFromUnbounded - builds the pseudo function HIGH from an
8114                             UnboundedSym.
8115
8116                             The Stack:
8117
8118
8119                             Entry                      Exit
8120
8121                      Ptr ->
8122                             +----------------+
8123                             | NoOfParam      |
8124                             |----------------|
8125                             | Param #        |                        <- Ptr
8126                             |----------------|         +------------+
8127                             | ProcSym | Type |         | ReturnVar  |
8128                             |----------------|         |------------|
8129
8130 *)
8131
8132 PROCEDURE BuildHighFromUnbounded (tok: CARDINAL) ;
8133 VAR
8134    Dim,
8135    NoOfParam,
8136    ReturnVar: CARDINAL ;
8137 BEGIN
8138    PopT (NoOfParam) ;
8139    Assert (NoOfParam=1) ;
8140    ReturnVar := MakeTemporary (tok, RightValue) ;
8141    PutVar (ReturnVar, Cardinal) ;
8142    Dim := OperandD (1) ;
8143    INC (Dim) ;
8144    IF Dim > 1
8145    THEN
8146       GenHigh (tok, ReturnVar, Dim, OperandA(1))
8147    ELSE
8148       GenHigh (tok, ReturnVar, Dim, OperandT(1))
8149    END ;
8150    PopN (2) ;
8151    PushTFtok (ReturnVar, GetSType(ReturnVar), tok)
8152 END BuildHighFromUnbounded ;
8153
8154
8155 (*
8156    GetQualidentImport - returns the symbol as if it were qualified from, module.n.
8157                         This is used to reference runtime support procedures and an
8158                         error is generated if the symbol cannot be obtained.
8159 *)
8160
8161 PROCEDURE GetQualidentImport (tokno: CARDINAL;
8162                               n: Name; module: Name) : CARDINAL ;
8163 VAR
8164    ModSym: CARDINAL ;
8165 BEGIN
8166    ModSym := MakeDefinitionSource (tokno, module) ;
8167    IF ModSym=NulSym
8168    THEN
8169       MetaErrorNT2 (tokno,
8170                     'module %a cannot be found and is needed to import %a', module, n) ;
8171       FlushErrors ;
8172       RETURN NulSym
8173    END ;
8174    Assert(IsDefImp(ModSym)) ;
8175    IF (GetExported (tokno, ModSym, n)=NulSym) OR IsUnknown (GetExported (tokno, ModSym, n))
8176    THEN
8177       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',
8178                    module, n) ;
8179       FlushErrors ;
8180       RETURN NulSym
8181    END ;
8182    RETURN GetExported (tokno, MakeDefinitionSource (tokno, module), n)
8183 END GetQualidentImport ;
8184
8185
8186 (*
8187    MakeLengthConst - creates a constant which contains the length of string, sym.
8188 *)
8189
8190 PROCEDURE MakeLengthConst (tok: CARDINAL; sym: CARDINAL) : CARDINAL ;
8191 BEGIN
8192    RETURN MakeConstant (tok, GetStringLength (sym))
8193 END MakeLengthConst ;
8194
8195
8196 (*
8197    BuildLengthFunction - builds the inline standard function LENGTH.
8198
8199                          The Stack:
8200
8201
8202                          Entry                      Exit
8203
8204                   Ptr ->
8205                          +----------------+
8206                          | NoOfParam      |
8207                          |----------------|
8208                          | Param 1        |                        <- Ptr
8209                          |----------------|         +------------+
8210                          | ProcSym | Type |         | ReturnVar  |
8211                          |----------------|         |------------|
8212
8213 *)
8214
8215 PROCEDURE BuildLengthFunction ;
8216 VAR
8217    combinedtok,
8218    paramtok,
8219    functok    : CARDINAL ;
8220    ProcSym,
8221    Type,
8222    NoOfParam,
8223    Param,
8224    ReturnVar  : CARDINAL ;
8225 BEGIN
8226    PopT (NoOfParam) ;
8227    Param := OperandT (1) ;
8228    paramtok := OperandTok (1) ;
8229    functok := OperandTok (NoOfParam + 1) ;
8230    (* Restore stack to origional form *)
8231    PushT (NoOfParam) ;
8232    Type := GetSType (Param) ;  (* get the type from the symbol, not the stack *)
8233    IF NoOfParam # 1
8234    THEN
8235       MetaErrorT1 (functok, 'base procedure {%E1kLENGTH} expects 1 parameter, seen {%1En} parameters', NoOfParam)
8236    END ;
8237    IF NoOfParam >= 1
8238    THEN
8239       combinedtok := MakeVirtualTok (paramtok, functok, paramtok) ;
8240       IF IsConst (Param) AND (GetSType (Param) = Char)
8241       THEN
8242          PopT (NoOfParam) ;
8243          PopN (NoOfParam + 1) ;
8244          ReturnVar := MakeConstLit (combinedtok, MakeKey ('1'), Cardinal) ;
8245          PushTtok (ReturnVar, combinedtok)
8246       ELSIF IsConstString (Param)
8247       THEN
8248          PopT (NoOfParam) ;
8249          ReturnVar := MakeLengthConst (combinedtok, OperandT (1)) ;
8250          PopN (NoOfParam + 1) ;
8251          PushTtok (ReturnVar, combinedtok)
8252       ELSE
8253          ProcSym := GetQualidentImport (functok, MakeKey ('Length'), MakeKey ('M2RTS')) ;
8254          IF (ProcSym # NulSym) AND IsProcedure (ProcSym)
8255          THEN
8256             PopT (NoOfParam) ;
8257             IF IsConst (OperandT (1))
8258             THEN
8259                (* we can fold this in M2GenGCC.  *)
8260                ReturnVar := MakeTemporary (combinedtok, ImmediateValue) ;
8261                PutVar (ReturnVar, Cardinal) ;
8262                GenQuad (StandardFunctionOp, ReturnVar, ProcSym, OperandT (1)) ;
8263                PopN (NoOfParam + 1) ;
8264                PushTtok (ReturnVar, combinedtok)
8265             ELSE
8266                (* no we must resolve this at runtime or in the GCC optimizer.  *)
8267                PopTF (Param, Type);
8268                PopN (NoOfParam) ;
8269                PushTtok (ProcSym, functok) ;
8270                PushTFtok (Param, Type, paramtok) ;
8271                PushT (NoOfParam) ;
8272                BuildRealFunctionCall (functok)
8273             END
8274          ELSE
8275             PopT (NoOfParam) ;
8276             PopN (NoOfParam + 1) ;
8277             PushTtok (MakeConstLit (combinedtok, MakeKey ('0'), Cardinal), combinedtok) ;
8278             MetaErrorT0 (functok, 'no procedure Length found for substitution to the standard function {%E1kLENGTH} which is required to calculate non constant string lengths')
8279          END
8280       END
8281    ELSE
8282       (* NoOfParam is _very_ wrong, we flush all outstanding errors *)
8283       FlushErrors
8284    END
8285 END BuildLengthFunction ;
8286
8287
8288 (*
8289    BuildOddFunction - builds the pseudo procedure call ODD.
8290                       This procedure is actually a "macro" for
8291                       ORD(x) --> VAL(BOOLEAN, x MOD 2)
8292                       However we cannot push tokens back onto the input stack
8293                       because the compiler is currently building a function
8294                       call and expecting a ReturnVar on the stack.
8295                       Hence we manipulate the stack and call
8296                       BuildConvertFunction.
8297
8298                       The Stack:
8299
8300
8301                       Entry                      Exit
8302
8303                Ptr ->
8304                       +----------------+
8305                       | NoOfParam      |
8306                       |----------------|
8307                       | Param 1        |
8308                       |----------------|
8309                       | Param 2        |
8310                       |----------------|
8311                       .                .
8312                       .                .
8313                       .                .
8314                       |----------------|
8315                       | Param #        |
8316                       |----------------|
8317                       | ProcSym | Type |         Empty
8318                       |----------------|
8319 *)
8320
8321 PROCEDURE BuildOddFunction ;
8322 VAR
8323    combinedtok,
8324    optok,
8325    functok    : CARDINAL ;
8326    NoOfParam,
8327    Res, Var   : CARDINAL ;
8328 BEGIN
8329    PopT (NoOfParam) ;
8330    functok := OperandTok (NoOfParam + 1) ;
8331    IF NoOfParam=1
8332    THEN
8333       Var := OperandT (1) ;
8334       optok := OperandTok (1) ;
8335       combinedtok := MakeVirtualTok (functok, functok, optok) ;
8336       IF IsVar(Var) OR IsConst(Var)
8337       THEN
8338          PopN (NoOfParam + 1) ;
8339          (*
8340             Build macro: VAL(BOOLEAN, (x MOD 2))
8341          *)
8342
8343          (* compute (x MOD 2) *)
8344          PushTFtok (Var, GetSType (Var), optok) ;
8345          PushT (ModTok) ;
8346          PushTFtok (MakeConstLit (optok, MakeKey ('2'), ZType), ZType, optok) ;
8347          BuildBinaryOp ;
8348          PopT (Res) ;
8349
8350          (* compute IF ...=0 *)
8351          PushTtok (Res, optok) ;
8352          PushT (EqualTok) ;
8353          PushTFtok (MakeConstLit (optok, MakeKey ('0'), ZType), ZType, optok) ;
8354          BuildRelOp (combinedtok) ;
8355          BuildThenIf ;
8356
8357          Res := MakeTemporary (combinedtok, RightValue) ;
8358          PutVar (Res, Boolean) ;
8359
8360          PushTtok (Res, combinedtok) ;
8361          PushTtok (False, combinedtok) ;
8362          BuildAssignment (combinedtok) ;
8363          BuildElse ;
8364          PushTtok (Res, combinedtok) ;
8365          PushTtok (True, combinedtok) ;
8366          BuildAssignment (combinedtok) ;
8367          BuildEndIf ;
8368
8369          PushTtok (Res, combinedtok)
8370       ELSE
8371          MetaErrorT1 (combinedtok,
8372                       'the parameter to {%E1kODD} must be a variable or constant, seen {%E1ad}',
8373                       Var) ;
8374          PushTtok (False, combinedtok)
8375       END
8376    ELSE
8377       MetaErrorT1 (functok,
8378                    'the pseudo procedure {%E1kODD} only has one parameter, seen {%E1n} parameters',
8379                    NoOfParam) ;
8380       PushTtok (False, functok)
8381    END
8382 END BuildOddFunction ;
8383
8384
8385 (*
8386    BuildAbsFunction - builds a call to the standard function ABS.
8387
8388                       We cannot implement it as a macro or inline an
8389                       IF THEN statement as the IF THEN ELSE requires
8390                       we write the value to the same variable (or constant)
8391                       twice. The macro implementation will fail as
8392                       the compiler maybe building a function
8393                       call and expecting a ReturnVar on the stack.
8394                       The only method to implement this is to pass it to the
8395                       gcc backend.
8396
8397                       The Stack:
8398
8399
8400                       Entry                      Exit
8401
8402                Ptr ->
8403                       +----------------+
8404                       | NoOfParam      |
8405                       |----------------|
8406                       | Param 1        |
8407                       |----------------|
8408                       | Param 2        |
8409                       |----------------|
8410                       .                .
8411                       .                .
8412                       .                .
8413                       |----------------|
8414                       | Param #        |
8415                       |----------------|
8416                       | ProcSym | Type |         Empty
8417                       |----------------|
8418 *)
8419
8420 PROCEDURE BuildAbsFunction ;
8421 VAR
8422    functok,
8423    combinedtok: CARDINAL ;
8424    NoOfParam,
8425    ProcSym,
8426    Res, Var : CARDINAL ;
8427 BEGIN
8428    PopT (NoOfParam) ;
8429    functok := OperandTok (NoOfParam + 1) ;
8430    IF NoOfParam = 1
8431    THEN
8432       Var := OperandT (1) ;
8433       combinedtok := MakeVirtualTok (functok, functok, vartok) ;
8434       IF IsVar(Var) OR IsConst(Var)
8435       THEN
8436          ProcSym := OperandT (NoOfParam + 1) ;
8437          PopN (NoOfParam + 1) ;
8438
8439          Res := MakeTemporary (combinedtok, AreConstant (IsConst (Var))) ;
8440          PutVar (Res, GetSType (Var)) ;
8441
8442          GenQuadO (combinedtok, StandardFunctionOp, Res, ProcSym, Var, FALSE) ;
8443          PushTFtok (Res, GetSType (Var), combinedtok)
8444       ELSE
8445          MetaErrorT1 (combinedtok,
8446                       'the parameter to {%A1kABS} must be a variable or constant, seen {%E1ad}',
8447                       Var)
8448       END
8449    ELSE
8450       MetaErrorT1 (functok,
8451                    'the pseudo procedure {%A1kABS} only has one parameter, seen {%E1n} parameters',
8452                    NoOfParam)
8453    END
8454 END BuildAbsFunction ;
8455
8456
8457 (*
8458    BuildCapFunction - builds the pseudo procedure call CAP.
8459                       We generate a the following quad:
8460
8461
8462                       StandardFunctionOp  ReturnVal  Cap  Param1
8463
8464                       The Stack:
8465
8466
8467                       Entry                      Exit
8468
8469                Ptr ->
8470                       +----------------+
8471                       | NoOfParam = 1  |
8472                       |----------------|
8473                       | Param 1        |
8474                       |----------------|         +-------------+
8475                       | ProcSym | Type |         | ReturnVal   |
8476                       |----------------|         |-------------|
8477 *)
8478
8479 PROCEDURE BuildCapFunction ;
8480 VAR
8481    optok,
8482    functok,
8483    combinedtok: CARDINAL ;
8484    NoOfParam,
8485    ProcSym,
8486    Res, Var : CARDINAL ;
8487 BEGIN
8488    PopT (NoOfParam) ;
8489    functok := OperandTok (NoOfParam + 1) ;
8490    IF NoOfParam = 1
8491    THEN
8492       Var := OperandT (1) ;
8493       optok := OperandTok (1) ;
8494       IF IsVar (Var) OR IsConst (Var)
8495       THEN
8496          ProcSym := OperandT (NoOfParam + 1) ;
8497          PopN (NoOfParam + 1) ;
8498
8499          combinedtok := MakeVirtualTok (functok, functok, optok) ;
8500          Res := MakeTemporary (combinedtok, AreConstant (IsConst (Var))) ;
8501          PutVar (Res, Char) ;
8502          GenQuadO (combinedtok, StandardFunctionOp, Res, ProcSym, Var, FALSE) ;
8503          PushTFtok (Res, Char, combinedtok)
8504       ELSE
8505          MetaErrorT1 (functok,
8506                       'the parameter to {%A1kCAP} must be a variable or constant, seen {%E1ad}',
8507                       Var)
8508       END
8509    ELSE
8510       MetaErrorT1 (functok,
8511                    'the pseudo procedure {%A1kCAP} only has one parameter, seen {%E1n} parameters',
8512                    NoOfParam)
8513    END
8514 END BuildCapFunction ;
8515
8516
8517 (*
8518    BuildChrFunction - builds the pseudo procedure call CHR.
8519                       This procedure is actually a "macro" for
8520                       CHR(x) --> CONVERT(CHAR, x)
8521                       However we cannot push tokens back onto the input stack
8522                       because the compiler is currently building a function
8523                       call and expecting a ReturnVar on the stack.
8524                       Hence we manipulate the stack and call
8525                       BuildConvertFunction.
8526
8527                       The Stack:
8528
8529
8530                       Entry                      Exit
8531
8532                Ptr ->
8533                       +----------------+
8534                       | NoOfParam      |
8535                       |----------------|
8536                       | Param 1        |
8537                       |----------------|
8538                       | Param 2        |
8539                       |----------------|
8540                       .                .
8541                       .                .
8542                       .                .
8543                       |----------------|
8544                       | Param #        |
8545                       |----------------|
8546                       | ProcSym | Type |         Empty
8547                       |----------------|
8548 *)
8549
8550 PROCEDURE BuildChrFunction ;
8551 VAR
8552    functok,
8553    optok      : CARDINAL ;
8554    NoOfParam,
8555    Var        : CARDINAL ;
8556 BEGIN
8557    PopT (NoOfParam) ;
8558    functok := OperandTok (NoOfParam + 1) ;
8559    IF NoOfParam = 1
8560    THEN
8561       Var := OperandT (1) ;
8562       optok := OperandTok (1) ;
8563       IF IsVar (Var) OR IsConst (Var)
8564       THEN
8565          PopN (NoOfParam + 1) ;
8566          (*
8567             Build macro: CONVERT( CHAR, Var )
8568          *)
8569          PushTFtok (Convert, NulSym, functok) ;
8570          PushTtok (Char, functok) ;
8571          PushTtok (Var, optok) ;
8572          PushT (2) ;          (* Two parameters *)
8573          BuildConvertFunction
8574       ELSE
8575          MetaErrorT1 (functok,
8576                       'the parameter to {%A1kCHR} must be a variable or constant, seen {%E1ad}',
8577                       Var)
8578       END
8579    ELSE
8580       MetaErrorT1 (functok,
8581                    'the pseudo procedure {%A1kCHR} only has one parameter, seen {%E1n} parameters',
8582                    NoOfParam)
8583    END
8584 END BuildChrFunction ;
8585
8586
8587 (*
8588    BuildOrdFunction - builds the pseudo procedure call ORD.
8589                       This procedure is actually a "macro" for
8590                       ORD(x) --> CONVERT(GetSType(sym), x)
8591                       However we cannot push tokens back onto the input stack
8592                       because the compiler is currently building a function
8593                       call and expecting a ReturnVar on the stack.
8594                       Hence we manipulate the stack and call
8595                       BuildConvertFunction.
8596
8597                       The Stack:
8598
8599
8600                       Entry                      Exit
8601
8602                Ptr ->
8603                       +----------------+
8604                       | NoOfParam      |
8605                       |----------------|
8606                       | Param 1        |
8607                       |----------------|
8608                       | Param 2        |
8609                       |----------------|
8610                       .                .
8611                       .                .
8612                       .                .
8613                       |----------------|
8614                       | Param #        |
8615                       |----------------|
8616                       | ProcSym | Type |         Empty
8617                       |----------------|
8618 *)
8619
8620 PROCEDURE BuildOrdFunction (Sym: CARDINAL) ;
8621 VAR
8622    functok,
8623    optok    : CARDINAL ;
8624    NoOfParam,
8625    Type, Var: CARDINAL ;
8626 BEGIN
8627    PopT (NoOfParam) ;
8628    functok := OperandTok (NoOfParam + 1) ;
8629    IF NoOfParam = 1
8630    THEN
8631       Var := OperandT (1) ;
8632       optok := OperandTok (1) ;
8633       IF IsVar (Var) OR IsConst (Var)
8634       THEN
8635          Type := GetSType (Sym) ;
8636          PopN (NoOfParam + 1) ;
8637          (*
8638             Build macro: CONVERT( CARDINAL, Var )
8639          *)
8640          PushTFtok (Convert, NulSym, functok) ;
8641          PushTtok (Type, optok) ;
8642          PushTtok (Var, optok) ;
8643          PushT (2) ;          (* Two parameters *)
8644          BuildConvertFunction
8645       ELSE
8646          MetaErrorT2 (functok,
8647                       'the parameter to {%A1k%a} must be a variable or constant, seen {%2ad}',
8648                       Sym, Var)
8649       END
8650    ELSE
8651       MetaErrorT2 (functok,
8652                    'the pseudo procedure {%A1k%a} only has one parameter, seen {%2n} parameters',
8653                    Sym, NoOfParam)
8654    END
8655 END BuildOrdFunction ;
8656
8657
8658 (*
8659    BuildIntFunction - builds the pseudo procedure call INT.
8660                       This procedure is actually a "macro" for
8661                       INT(x) --> CONVERT(INTEGER, x)
8662                       However we cannot push tokens back onto the input stack
8663                       because the compiler is currently building a function
8664                       call and expecting a ReturnVar on the stack.
8665                       Hence we manipulate the stack and call
8666                       BuildConvertFunction.
8667
8668                       The Stack:
8669
8670
8671                       Entry                      Exit
8672
8673                Ptr ->
8674                       +----------------+
8675                       | NoOfParam      |
8676                       |----------------|
8677                       | Param 1        |
8678                       |----------------|
8679                       | Param 2        |
8680                       |----------------|
8681                       .                .
8682                       .                .
8683                       .                .
8684                       |----------------|
8685                       | Param #        |
8686                       |----------------|
8687                       | ProcSym | Type |         Empty
8688                       |----------------|
8689 *)
8690
8691 PROCEDURE BuildIntFunction (Sym: CARDINAL) ;
8692 VAR
8693    combinedtok,
8694    functok,
8695    optok      : CARDINAL ;
8696    NoOfParam,
8697    Type, Var  : CARDINAL ;
8698 BEGIN
8699    PopT (NoOfParam) ;
8700    functok := OperandTok (NoOfParam + 1) ;
8701    IF NoOfParam = 1
8702    THEN
8703       Var := OperandT (1) ;
8704       optok := OperandTok (1) ;
8705       IF IsVar (Var) OR IsConst (Var)
8706       THEN
8707          Type := GetSType (Sym) ;  (* return type of function *)
8708          PopN (NoOfParam + 1) ;
8709          (* Build macro: CONVERT( CARDINAL, Var ).  *)
8710          PushTFtok (Convert, NulSym, functok) ;
8711          PushTtok (Type, functok) ;
8712          PushTtok (Var, optok) ;
8713          PushT (2) ;          (* Two parameters *)
8714          BuildConvertFunction
8715       ELSE
8716          combinedtok := MakeVirtualTok (functok, optok, optok) ;
8717          MetaErrorT2 (combinedtok,
8718                       'the parameter to {%E1k%a} must be a variable or constant, seen {%2ad}',
8719                       Sym, Var) ;
8720          PushTtok (combinedtok, MakeConstLit (combinedtok, MakeKey ('0'), ZType))
8721       END
8722    ELSE
8723       MetaErrorT2 (functok,
8724                    'the pseudo procedure {%E1k%a} only has one parameter, seen {%2n} parameters',
8725                    Sym, NoOfParam) ;
8726       PushTtok (functok, MakeConstLit (functok, MakeKey ('0'), ZType))
8727    END
8728 END BuildIntFunction ;
8729
8730
8731 (*
8732    BuildMakeAdrFunction - builds the pseudo procedure call MAKEADR.
8733
8734                           The Stack:
8735
8736
8737                           Entry                      Exit
8738
8739                    Ptr ->
8740                           +----------------+
8741                           | NoOfParam      |
8742                           |----------------|
8743                           | Param 1        |
8744                           |----------------|
8745                           | Param 2        |
8746                           |----------------|
8747                           .                .
8748                           .                .
8749                           .                .
8750                           |----------------|
8751                           | Param #        |
8752                           |----------------|
8753                           | ProcSym | Type |         Empty
8754                           |----------------|
8755 *)
8756
8757 PROCEDURE BuildMakeAdrFunction ;
8758 VAR
8759    functok,
8760    starttok,
8761    endtok,
8762    resulttok     : CARDINAL ;
8763    AreConst      : BOOLEAN ;
8764    i, pi,
8765    NoOfParameters: CARDINAL ;
8766    ReturnVar     : CARDINAL ;
8767 BEGIN
8768    PopT (NoOfParameters) ;
8769    functok := OperandTok (NoOfParameters + 1) ;
8770    IF NoOfParameters>0
8771    THEN
8772       starttok := OperandTok (NoOfParameters + 1) ;  (* ADR token.  *)
8773       endtok := OperandTok (1) ;  (* last parameter.  *)
8774       GenQuad (ParamOp, 0, MakeAdr, MakeAdr) ;
8775       i := NoOfParameters ;
8776       (* stack index referencing stacked parameter, i *)
8777       pi := 1 ;
8778       WHILE i > 0 DO
8779          GenQuadO (OperandTok (pi), ParamOp, i, MakeAdr, OperandT (pi), TRUE) ;
8780          DEC (i) ;
8781          INC (pi)
8782       END ;
8783       AreConst := TRUE ;
8784       i := 1 ;
8785       WHILE i <= NoOfParameters DO
8786          IF IsVar (OperandT (i))
8787          THEN
8788             AreConst := FALSE ;
8789          ELSIF NOT IsConst (OperandT (i))
8790          THEN
8791             MetaError1 ('problem in the {%E1N} argument for {%EkMAKEADR}, all arguments to {%EkMAKEADR} must be either variables or constants', i)
8792          END ;
8793          INC (i)
8794       END ;
8795       (* ReturnVar - will have the type of the procedure *)
8796       resulttok := MakeVirtualTok (starttok, starttok, endtok) ;
8797       ReturnVar := MakeTemporary (resulttok, AreConstant(AreConst)) ;
8798       PutVar (ReturnVar, GetSType(MakeAdr)) ;
8799       GenQuadO (resulttok, FunctValueOp, ReturnVar, NulSym, MakeAdr, TRUE) ;
8800       PopN (NoOfParameters+1) ;
8801       PushTFtok (ReturnVar, GetSType (MakeAdr), resulttok)
8802    ELSE
8803       MetaError1 ('the pseudo procedure {%EkMAKEADR} requires at least one parameter, seen {%E1n}', NoOfParameters) ;
8804       PopN (1) ;
8805       PushTFtok (Nil, GetSType (MakeAdr), functok)
8806    END
8807 END BuildMakeAdrFunction ;
8808
8809
8810 (*
8811    BuildShiftFunction - builds the pseudo procedure call SHIFT.
8812
8813                         PROCEDURE SHIFT (val: <any type>;
8814                                          num: INTEGER): <any type> ;
8815
8816                        "Returns a bit sequence obtained from val by
8817                         shifting up or down (left or right) by the
8818                         absolute value of num, introducing
8819                         zeros as necessary.  The direction is down if
8820                         the sign of num is negative, otherwise the
8821                         direction is up."
8822
8823                         The Stack:
8824
8825                         Entry                      Exit
8826
8827                  Ptr ->
8828                         +----------------+
8829                         | NoOfParam      |
8830                         |----------------|
8831                         | Param 1        |
8832                         |----------------|
8833                         | Param 2        |                        <- Ptr
8834                         |----------------|         +------------+
8835                         | ProcSym | Type |         | ReturnVar  |
8836                         |----------------|         |------------|
8837 *)
8838
8839 PROCEDURE BuildShiftFunction ;
8840 VAR
8841    combinedtok,
8842    paramtok,
8843    functok,
8844    vartok,
8845    exptok     : CARDINAL ;
8846    r,
8847    procSym,
8848    returnVar,
8849    NoOfParam,
8850    derefExp,
8851    Exp,
8852    varSet     : CARDINAL ;
8853 BEGIN
8854    PopT (NoOfParam) ;
8855    paramtok := OperandTok (1) ;
8856    functok := OperandTok (NoOfParam + 1) ;
8857    IF NoOfParam=2
8858    THEN
8859       PopTrwtok (Exp, r, exptok) ;
8860       MarkAsRead (r) ;
8861       PopTtok (varSet, vartok) ;
8862       PopT (procSym) ;
8863       combinedtok := MakeVirtualTok (functok, exptok, vartok) ;
8864       IF (GetSType (varSet) # NulSym) AND IsSet (GetDType (varSet))
8865       THEN
8866          derefExp := DereferenceLValue (exptok, Exp) ;
8867          BuildRange (InitShiftCheck (varSet, derefExp)) ;
8868          returnVar := MakeTemporary (combinedtok, RightValue) ;
8869          PutVar (returnVar, GetSType (varSet)) ;
8870          GenQuad (LogicalShiftOp, returnVar, varSet, derefExp) ;
8871          PushTFtok (returnVar, GetSType (varSet), combinedtok)
8872       ELSE
8873          MetaError1 ('SYSTEM procedure {%E1kSHIFT} expects a constant or variable which has a type of SET as its first parameter, seen {%E1ad}',
8874                      varSet) ;
8875          PushTFtok (MakeConstLit (combinedtok, MakeKey ('0'), Cardinal), Cardinal, combinedtok)
8876       END
8877    ELSE
8878       combinedtok := MakeVirtualTok (functok, functok, paramtok) ;
8879       MetaErrorT1 (functok,
8880                    'the pseudo procedure {%EkSHIFT} requires at least two parameters, seen {%E1n}',
8881                    NoOfParam) ;
8882       PopN (NoOfParam + 1) ;
8883       PushTFtok (MakeConstLit (combinedtok, MakeKey ('0'), Cardinal), Cardinal, combinedtok)
8884    END
8885 END BuildShiftFunction ;
8886
8887
8888 (*
8889    BuildRotateFunction - builds the pseudo procedure call ROTATE.
8890
8891                          PROCEDURE ROTATE (val: <any type>;
8892                                            num: INTEGER): <any type> ;
8893
8894                         "Returns a bit sequence obtained from val
8895                          by rotating up or down (left or right) by
8896                          the absolute value of num.  The direction is
8897                          down if the sign of num is negative, otherwise
8898                          the direction is up."
8899
8900                          The Stack:
8901
8902                          Entry                      Exit
8903
8904                   Ptr ->
8905                          +----------------+
8906                          | NoOfParam      |
8907                          |----------------|
8908                          | Param 1        |
8909                          |----------------|
8910                          | Param 2        |                        <- Ptr
8911                          |----------------|         +------------+
8912                          | ProcSym | Type |         | ReturnVar  |
8913                          |----------------|         |------------|
8914 *)
8915
8916 PROCEDURE BuildRotateFunction ;
8917 VAR
8918    combinedtok,
8919    functok,
8920    vartok,
8921    exptok     : CARDINAL ;
8922    r,
8923    procSym,
8924    returnVar,
8925    NoOfParam,
8926    derefExp,
8927    Exp,
8928    varSet     : CARDINAL ;
8929 BEGIN
8930    PopT (NoOfParam) ;
8931    functok := OperandTok (NoOfParam + 1) ;
8932    IF NoOfParam = 2
8933    THEN
8934       PopTrwtok (Exp, r, exptok) ;
8935       MarkAsRead (r) ;
8936       PopTtok (varSet, vartok) ;
8937       PopT (procSym) ;
8938       IF (GetSType (varSet) # NulSym) AND IsSet (GetDType (varSet))
8939       THEN
8940          combinedtok := MakeVirtualTok (functok, functok, exptok) ;
8941          derefExp := DereferenceLValue (exptok, Exp) ;
8942          BuildRange (InitRotateCheck (varSet, derefExp)) ;
8943          returnVar := MakeTemporary (combinedtok, RightValue) ;
8944          PutVar (returnVar, GetSType (varSet)) ;
8945          GenQuadO (combinedtok, LogicalRotateOp, returnVar, varSet, derefExp, TRUE) ;
8946          PushTFtok (returnVar, GetSType (varSet), combinedtok)
8947       ELSE
8948          MetaErrorT0 (functok,
8949                       'SYSTEM procedure {%EkROTATE} expects a constant or variable which has a type of SET as its first parameter') ;
8950          PushTFtok (MakeConstLit (functok, MakeKey('0'), Cardinal), Cardinal, functok)
8951       END
8952    ELSE
8953       MetaErrorT1 (functok,
8954                    'SYSTEM procedure {%EkROTATE} expects 2 parameters and was given {%1n} parameters',
8955                    NoOfParam) ;
8956       PopN (NoOfParam + 1) ;
8957       PushTFtok (MakeConstLit (functok, MakeKey ('0'), Cardinal), Cardinal, functok)
8958    END
8959 END BuildRotateFunction ;
8960
8961
8962 (*
8963    BuildValFunction - builds the pseudo procedure call VAL.
8964                       This procedure is actually a "macro" for
8965                       VAL(Type, x) --> CONVERT(Type, x)
8966                       However we cannot push tokens back onto the input stack
8967                       because the compiler is currently building a function
8968                       call and expecting a ReturnVar on the stack.
8969                       Hence we manipulate the stack and call
8970                       BuildConvertFunction.
8971
8972                       The Stack:
8973
8974
8975                       Entry                      Exit
8976
8977                Ptr ->
8978                       +----------------+
8979                       | NoOfParam      |
8980                       |----------------|
8981                       | Param 1        |
8982                       |----------------|
8983                       | Param 2        |
8984                       |----------------|
8985                       .                .
8986                       .                .
8987                       .                .
8988                       |----------------|
8989                       | Param #        |
8990                       |----------------|
8991                       | ProcSym | Type |         Empty
8992                       |----------------|
8993 *)
8994
8995 PROCEDURE BuildValFunction ;
8996 VAR
8997    functok  : CARDINAL ;
8998    NoOfParam,
8999    ProcSym,
9000    Exp, Type: CARDINAL ;
9001    tok, r,
9002    typetok,
9003    exptok   : CARDINAL ;
9004 BEGIN
9005    PopT (NoOfParam) ;
9006    functok := OperandTok (NoOfParam + 1) ;
9007    IF NoOfParam = 2
9008    THEN
9009       PopTrwtok (Exp, r, exptok) ;
9010       MarkAsRead (r) ;
9011       PopTtok (Type, typetok) ;
9012       PopTtok (ProcSym, tok) ;
9013       IF IsUnknown (Type)
9014       THEN
9015          (* not sensible to try and recover when we dont know the return type.  *)
9016          MetaErrorT1 (typetok,
9017                       'undeclared type found in builtin procedure function {%AkVAL} {%A1ad}',
9018                       Type)
9019          (* non recoverable error.  *)
9020       ELSIF (IsSet (Type) OR IsEnumeration (Type) OR IsSubrange (Type) OR
9021              IsType (Type) OR IsPointer (Type) OR IsProcType (Type)) AND
9022              (IsVar (Exp) OR IsConst (Exp) OR IsProcedure (Exp))
9023       THEN
9024          (*
9025             Build macro: CONVERT( Type, Var )
9026          *)
9027          PushTFtok (Convert, NulSym, tok) ;
9028          PushTtok (Type, typetok) ;
9029          PushTtok (Exp, exptok) ;
9030          PushT (2) ;          (* Two parameters *)
9031          BuildConvertFunction
9032       ELSE
9033          (* not sensible to try and recover when we dont know the return type.  *)
9034          MetaErrorT0 (functok,
9035                       'the builtin procedure {%AkVAL} has thw following formal parameter declaration {%kVAL} (type, expression)')
9036          (* non recoverable error.  *)
9037       END
9038    ELSE
9039       (* not sensible to try and recover when we dont know the return type.  *)
9040       MetaErrorT1 (functok,
9041                    'the builtin procedure {%AkVAL} expects 2 parameters, a type and an expression, but was given {%1n} parameters', NoOfParam)
9042       (* non recoverable error.  *)
9043    END
9044 END BuildValFunction ;
9045
9046
9047 (*
9048    BuildCastFunction - builds the pseudo procedure call CAST.
9049                        This procedure is actually a "macro" for
9050                        CAST(Type, x) --> Type(x)
9051                        However we cannot push tokens back onto the input stack
9052                        because the compiler is currently building a function
9053                        call and expecting a ReturnVar on the stack.
9054                        Hence we manipulate the stack and call
9055                        BuildConvertFunction.
9056
9057                        The Stack:
9058
9059
9060                        Entry                      Exit
9061
9062                 Ptr ->
9063                        +----------------+
9064                        | NoOfParam      |
9065                        |----------------|
9066                        | Param 1        |
9067                        |----------------|
9068                        | Param 2        |
9069                        |----------------|
9070                        .                .
9071                        .                .
9072                        .                .
9073                        |----------------|
9074                        | Param #        |
9075                        |----------------|
9076                        | ProcSym | Type |         Empty
9077                        |----------------|
9078 *)
9079
9080 PROCEDURE BuildCastFunction ;
9081 VAR
9082    combinedtok,
9083    typetok,
9084    functok,
9085    vartok     : CARDINAL ;
9086    n          : Name ;
9087    ReturnVar,
9088    NoOfParam,
9089    Var, Type  : CARDINAL ;
9090 BEGIN
9091    PopT (NoOfParam) ;
9092    functok := OperandTok (NoOfParam + 1) ;
9093    IF NoOfParam = 2
9094    THEN
9095       Type := OperandT (2) ;
9096       typetok := OperandTok (2) ;
9097       Var := OperandT (1) ;
9098       vartok := OperandTok (1) ;
9099       IF IsUnknown (Type)
9100       THEN
9101          n := GetSymName (Type) ;
9102          WriteFormat1 ('undeclared type found in CAST (%a)', n)
9103       ELSIF IsSet (Type) OR IsEnumeration (Type) OR IsSubrange (Type) OR IsType (Type) OR
9104             IsPointer (Type) OR IsArray (Type) OR IsProcType (Type)
9105       THEN
9106          IF IsConst (Var)
9107          THEN
9108             PopN (NoOfParam+1) ;
9109             (*
9110                Build macro: Type( Var )
9111             *)
9112             PushTFtok (Type, NulSym, typetok) ;
9113             PushTtok (Var, vartok) ;
9114             PushT (1) ;          (* one parameter *)
9115             BuildTypeCoercion
9116          ELSIF IsVar (Var) OR IsProcedure (Var)
9117          THEN
9118             PopN (NoOfParam + 1) ;
9119             combinedtok := MakeVirtualTok (functok, functok, vartok) ;
9120             ReturnVar := MakeTemporary (combinedtok, RightValue) ;
9121             PutVar (ReturnVar, Type) ;
9122             GenQuadO (combinedtok, CastOp, ReturnVar, Type, Var, FALSE) ;
9123             PushTFtok (ReturnVar, Type, combinedtok)
9124          ELSE
9125             (* not sensible to try and recover when we dont know the return type.  *)
9126             MetaErrorT0 (functok,
9127                          'the second parameter to the builtin procedure {%AkCAST} must either be a variable, constant or a procedure.  The formal parameters to cast are CAST(type, variable or constant or procedure)')
9128             (* non recoverable error.  *)
9129          END
9130       ELSE
9131          (* not sensible to try and recover when we dont know the return type.  *)
9132          MetaErrorT0 (functok,
9133                       'the builtin procedure {%AkCAST} has the following formal parameter declaration {%kCAST} (type, expression)')
9134          (* non recoverable error.  *)
9135       END
9136    ELSE
9137       (* not sensible to try and recover when we dont know the return type.  *)
9138       MetaErrorT1 (functok,
9139                    'the builtin procedure {%AkCAST} `expects 2 parameters, a type and an expression, but was given {%1n} parameters', NoOfParam)
9140       (* non recoverable error.  *)
9141    END
9142 END BuildCastFunction ;
9143
9144
9145 (*
9146    BuildConvertFunction - builds the pseudo function CONVERT.
9147                           CONVERT( Type, Variable ) ;
9148
9149                           The Stack:
9150
9151
9152                           Entry                      Exit
9153
9154                    Ptr ->
9155                           +----------------+
9156                           | NoOfParam      |
9157                           |----------------|
9158                           | Param 1        |
9159                           |----------------|
9160                           | Param 2        |
9161                           |----------------|
9162                           .                .
9163                           .                .
9164                           .                .
9165                           |----------------|
9166                           | Param #        |                                 <- Ptr
9167                           |----------------|         +---------------------+
9168                           | ProcSym | Type |         | ReturnVar | Param1  |
9169                           |----------------|         |---------------------|
9170
9171                           Quadruples:
9172
9173                           ConvertOp  ReturnVar  Param1  Param2
9174
9175                           Converts variable Param2 into a variable Param1
9176                           with a type Param1.
9177 *)
9178
9179 PROCEDURE BuildConvertFunction ;
9180 VAR
9181    combinedtok,
9182    functok,
9183    typetok,
9184    exptok     : CARDINAL ;
9185    t, r,
9186    Exp, Type,
9187    ProcSym,
9188    NoOfParam,
9189    ReturnVar  : CARDINAL ;
9190 BEGIN
9191    PopT (NoOfParam) ;
9192    functok := OperandTok (NoOfParam + 1) ;
9193    IF NoOfParam = 2
9194    THEN
9195       PopTrwtok (Exp, r, exptok) ;
9196       MarkAsRead (r) ;
9197       PopTtok (Type, typetok) ;
9198       PopT (ProcSym) ;
9199       IF IsUnknown (Type)
9200       THEN
9201          (* we cannot recover if we dont have a type.  *)
9202          MetaErrorT1 (typetok, 'undeclared type {%A1ad} found in {%kCONVERT}', Type)
9203          (* non recoverable error.  *)
9204       ELSIF IsUnknown (Exp)
9205       THEN
9206          (* we cannot recover if we dont have a type.  *)
9207          MetaErrorT1 (typetok, 'unknown {%A1d} {%1ad} found in {%kCONVERT}', Exp)
9208          (* non recoverable error.  *)
9209       ELSIF (IsSet (Type) OR IsEnumeration (Type) OR IsSubrange (Type) OR
9210              IsType (Type) OR IsPointer (Type) OR IsProcType (Type) OR IsRecord (Type)) AND
9211             (IsVar (Exp) OR IsConst (Exp) OR IsProcedure (Exp))
9212       THEN
9213          (* firstly dereference Var *)
9214          IF GetMode (Exp) = LeftValue
9215          THEN
9216             t := MakeTemporary (exptok, RightValue) ;
9217             PutVar (t, GetSType (Exp)) ;
9218             CheckPointerThroughNil (exptok, Exp) ;
9219             doIndrX (exptok, t, Exp) ;
9220             Exp := t
9221          END ;
9222
9223          combinedtok := MakeVirtualTok (functok, functok, exptok) ;
9224          ReturnVar := MakeTemporary (combinedtok, AreConstant (IsConst (Exp))) ;
9225          PutVar (ReturnVar, Type) ;
9226          GenQuadO (combinedtok, ConvertOp, ReturnVar, Type, Exp, TRUE) ;
9227          PushTFtok (ReturnVar, Type, combinedtok)
9228       ELSE
9229          (* not sensible to try and recover when we dont know the return type.  *)
9230          MetaErrorT0 (functok,
9231                       'the builtin procedure {%AkCONVERT} has the following formal parameter declaration {%kCONVERT} (type, expression)')
9232          (* non recoverable error.  *)
9233       END
9234    ELSE
9235       (* not sensible to try and recover when we dont know the return type.  *)
9236       MetaErrorT1 (functok,
9237                    'the builtin procedure {%AkCONVERT} expects 2 parameters, a type and an expression, but was given {%1n} parameters', NoOfParam)
9238       (* non recoverable error.  *)
9239    END
9240 END BuildConvertFunction ;
9241
9242
9243 (*
9244    CheckBaseTypeValue - checks to see whether the value, min, really exists.
9245 *)
9246
9247 PROCEDURE CheckBaseTypeValue (tok: CARDINAL;
9248                               type: CARDINAL;
9249                               min: CARDINAL;
9250                               func: CARDINAL) : CARDINAL ;
9251 BEGIN
9252    IF (type = Real) OR (type = LongReal) OR (type = ShortReal)
9253    THEN
9254       PushValue (min) ;
9255       IF NOT IsValueAndTreeKnown ()
9256       THEN
9257          MetaErrorT2 (tok,
9258                       '{%1Ead} ({%2ad}) cannot be calculated at compile time for the target architecture', func, type) ;
9259          RETURN MakeConstLit (tok, MakeKey ('1.0'), RType)
9260       END
9261    END ;
9262    RETURN min
9263 END CheckBaseTypeValue ;
9264
9265
9266 (*
9267    GetTypeMin - returns the minimium value of type.
9268 *)
9269
9270 PROCEDURE GetTypeMin (tok: CARDINAL; func, type: CARDINAL) : CARDINAL ;
9271 VAR
9272    min, max: CARDINAL ;
9273 BEGIN
9274    IF IsSubrange (type)
9275    THEN
9276       min := MakeTemporary (tok, ImmediateValue) ;
9277       PutVar (min, type) ;
9278       GenQuad (SubrangeLowOp, min, NulSym, type) ;
9279       RETURN min
9280    ELSIF IsSet (SkipType (type))
9281    THEN
9282       RETURN GetTypeMin (tok, func, GetSType (SkipType (type)))
9283    ELSIF IsBaseType (type) OR IsEnumeration (type)
9284    THEN
9285       GetBaseTypeMinMax (type, min, max) ;
9286       min := CheckBaseTypeValue (tok, type, min, func) ;
9287       RETURN min
9288    ELSIF IsSystemType (type)
9289    THEN
9290       GetSystemTypeMinMax (type, min, max) ;
9291       RETURN min
9292    ELSIF GetSType (type) = NulSym
9293    THEN
9294       MetaErrorT1 (tok,
9295                    'unable to obtain the {%AkMIN} value for type {%1Aad}', type)
9296       (* non recoverable error.  *)
9297    ELSE
9298       RETURN GetTypeMin (tok, func, GetSType (type))
9299    END
9300 END GetTypeMin ;
9301
9302
9303 (*
9304    GetTypeMax - returns the maximum value of type.
9305 *)
9306
9307 PROCEDURE GetTypeMax (tok: CARDINAL; func, type: CARDINAL) : CARDINAL ;
9308 VAR
9309    min, max: CARDINAL ;
9310 BEGIN
9311    IF IsSubrange (type)
9312    THEN
9313       max := MakeTemporary (tok, ImmediateValue) ;
9314       PutVar (max, type) ;
9315       GenQuad (SubrangeHighOp, max, NulSym, type) ;
9316       RETURN max
9317    ELSIF IsSet (SkipType (type))
9318    THEN
9319       RETURN GetTypeMax (tok, func, GetSType (SkipType (type)))
9320    ELSIF IsBaseType (type) OR IsEnumeration (type)
9321    THEN
9322       GetBaseTypeMinMax (type, min, max) ;
9323       min := CheckBaseTypeValue (tok, type, min, func) ;
9324       RETURN max
9325    ELSIF IsSystemType (type)
9326    THEN
9327       GetSystemTypeMinMax (type, min, max) ;
9328       RETURN max
9329    ELSIF GetSType (type) = NulSym
9330    THEN
9331       MetaErrorT1 (tok,
9332                    'unable to obtain the {%AkMAX} value for type {%1Aad}', type)
9333       (* non recoverable error.  *)
9334    ELSE
9335       RETURN GetTypeMax (tok, func, GetSType (type))
9336    END
9337 END GetTypeMax ;
9338
9339
9340 (*
9341    BuildMinFunction - builds the pseudo function call Min.
9342
9343                       The Stack:
9344
9345                       Entry                      Exit
9346
9347                Ptr ->
9348                       +----------------+
9349                       | NoOfParam=1    |
9350                       |----------------|
9351                       | Param 1        |
9352                       |----------------|
9353                       | ProcSym | Type |         Empty
9354                       |----------------|
9355 *)
9356
9357 PROCEDURE BuildMinFunction ;
9358 VAR
9359    combinedtok,
9360    functok,
9361    vartok     : CARDINAL ;
9362    func,
9363    min,
9364    NoOfParam,
9365    Var        : CARDINAL ;
9366 BEGIN
9367    PopT (NoOfParam) ;
9368    func := OperandT (NoOfParam + 1) ;
9369    functok := OperandTtok (NoOfParam + 1) ;
9370    IF NoOfParam = 1
9371    THEN
9372       Var := OperandT (1) ;
9373       vartok := OperandTok (1) ;
9374       PopN (NoOfParam+1) ;    (* destroy arguments to this function *)
9375       combinedtok := MakeVirtualTok (functok, functok, vartok) ;
9376       IF IsAModula2Type (Var)
9377       THEN
9378          min := GetTypeMin (vartok, func, Var) ;
9379          PushTFtok (min, GetSType (min), combinedtok)
9380       ELSIF IsVar (Var)
9381       THEN
9382          min := GetTypeMin (vartok, func, GetSType (Var)) ;
9383          PushTFtok (min, GetSType (Var), combinedtok)
9384       ELSE
9385          (* we dont know the type therefore cannot fake a return.  *)
9386          MetaErrorT1 (vartok,
9387                       'parameter to {%AkMIN} must be a type or a variable, seen {%1Aad}',
9388                       Var)
9389          (* non recoverable error.  *)
9390       END
9391    ELSE
9392       (* we dont know the type therefore cannot fake a return.  *)
9393       MetaErrorT1 (functok,
9394                    'the pseudo builtin procedure function {%AkMIN} only has one parameter, seen  {%1An}',
9395                    NoOfParam)
9396       (* non recoverable error.  *)
9397    END
9398 END BuildMinFunction ;
9399
9400
9401 (*
9402    BuildMaxFunction - builds the pseudo function call Max.
9403
9404                       The Stack:
9405
9406                       Entry                      Exit
9407
9408                Ptr ->
9409                       +----------------+
9410                       | NoOfParam=1    |
9411                       |----------------|
9412                       | Param 1        |
9413                       |----------------|
9414                       | ProcSym | Type |         Empty
9415                       |----------------|
9416 *)
9417
9418 PROCEDURE BuildMaxFunction ;
9419 VAR
9420    combinedtok,
9421    functok,
9422    vartok     : CARDINAL ;
9423    func,
9424    max,
9425    NoOfParam,
9426    Var        : CARDINAL ;
9427 BEGIN
9428    PopT (NoOfParam) ;
9429    func := OperandT (NoOfParam + 1) ;
9430    functok := OperandTtok (NoOfParam + 1) ;
9431    IF NoOfParam = 1
9432    THEN
9433       Var := OperandT (1) ;
9434       vartok := OperandTok (1) ;
9435       PopN (NoOfParam + 1) ;    (* destroy arguments to this function *)
9436       combinedtok := MakeVirtualTok (functok, functok, vartok) ;
9437       IF IsAModula2Type (Var)
9438       THEN
9439          max := GetTypeMax (vartok, func, Var) ;
9440          PushTFtok (max, GetSType (max), combinedtok)
9441       ELSIF IsVar(Var)
9442       THEN
9443          max := GetTypeMax (vartok, func, GetSType (Var)) ;
9444          PushTFtok (max, GetSType (Var), combinedtok)
9445       ELSE
9446          (* we dont know the type therefore cannot fake a return.  *)
9447          MetaErrorT1 (vartok,
9448                       'parameter to {%AkMAX} must be a type or a variable, seen {%1Aad}',
9449                       Var)
9450          (* non recoverable error.  *)
9451       END
9452    ELSE
9453       (* we dont know the type therefore cannot fake a return.  *)
9454       MetaErrorT1 (functok,
9455                    'the pseudo builtin procedure function {%AkMAX} only has one parameter, seen {%1An}',
9456                    NoOfParam)
9457       (* non recoverable error.  *)
9458    END
9459 END BuildMaxFunction ;
9460
9461
9462 (*
9463    BuildTruncFunction - builds the pseudo procedure call TRUNC.
9464                         This procedure is actually a "macro" for
9465                         TRUNC(x) --> CONVERT(INTEGER, x)
9466                         However we cannot push tokens back onto the input stack
9467                         because the compiler is currently building a function
9468                         call and expecting a ReturnVar on the stack.
9469                         Hence we manipulate the stack and call
9470                         BuildConvertFunction.
9471
9472                         The Stack:
9473
9474
9475                         Entry                      Exit
9476
9477                  Ptr ->
9478                         +----------------+
9479                         | NoOfParam      |
9480                         |----------------|
9481                         | Param 1        |
9482                         |----------------|
9483                         | Param 2        |
9484                         |----------------|
9485                         .                .
9486                         .                .
9487                         .                .
9488                         |----------------|
9489                         | Param #        |
9490                         |----------------|
9491                         | ProcSym | Type |         Empty
9492                         |----------------|
9493 *)
9494
9495 PROCEDURE BuildTruncFunction (Sym: CARDINAL) ;
9496 VAR
9497    vartok,
9498    functok  : CARDINAL ;
9499    NoOfParam: CARDINAL ;
9500    ProcSym,
9501    Type,
9502    Var      : CARDINAL ;
9503 BEGIN
9504    PopT (NoOfParam) ;
9505    Assert (IsTrunc (OperandT (NoOfParam+1))) ;
9506    functok := OperandTtok (NoOfParam + 1) ;
9507    IF NoOfParam = 1
9508    THEN
9509       ProcSym := RequestSym (functok, MakeKey ('CONVERT')) ;
9510       IF (ProcSym # NulSym) AND IsProcedure (ProcSym)
9511       THEN
9512          Var := OperandT (1) ;
9513          vartok := OperandTtok (1) ;
9514          Type := GetSType (Sym) ;
9515          PopN (NoOfParam + 1) ;    (* destroy arguments to this function *)
9516          IF IsVar (Var) OR IsConst (Var)
9517          THEN
9518             IF IsRealType (GetSType (Var))
9519             THEN
9520                (* build macro: CONVERT( INTEGER, Var ).  *)
9521                PushTFtok (ProcSym, NulSym, functok) ;
9522                PushTtok (Type, functok) ;
9523                PushTtok (Var, vartok) ;
9524                PushT (2) ;          (* two parameters *)
9525                BuildConvertFunction
9526             ELSE
9527                MetaErrorT1 (functok,
9528                             'argument to {%1E%ad} must be a float point type', Sym) ;
9529                PushTFtok (MakeConstLit (functok, MakeKey('0'), Type), Type, functok)
9530             END
9531          ELSE
9532             MetaErrorT2 (functok,
9533                          'argument to {%1E%ad} must be a variable or constant, seen {%2ad}',
9534                          Sym, Var) ;
9535             PushTFtok (MakeConstLit (functok, MakeKey('0'), Type), Type, functok)
9536          END
9537       ELSE
9538          InternalError  ('CONVERT procedure not found for TRUNC substitution')
9539       END
9540    ELSE
9541       (* we dont know the type therefore cannot fake a return.  *)
9542       MetaErrorT1 (functok,
9543                    'the pseudo builtin procedure function {%AkTRUNC} only has one parameter, seen  {%1An}', NoOfParam)
9544       (* non recoverable error.  *)
9545    END
9546 END BuildTruncFunction ;
9547
9548
9549 (*
9550    BuildFloatFunction - builds the pseudo procedure call FLOAT.
9551                         This procedure is actually a "macro" for
9552                         FLOAT(x) --> CONVERT(REAL, x)
9553                         However we cannot push tokens back onto the input stack
9554                         because the compiler is currently building a function
9555                         call and expecting a ReturnVar on the stack.
9556                         Hence we manipulate the stack and call
9557                         BuildConvertFunction.
9558
9559                         The Stack:
9560
9561
9562                         Entry                      Exit
9563
9564                  Ptr ->
9565                         +----------------+
9566                         | NoOfParam      |
9567                         |----------------|
9568                         | Param 1        |
9569                         |----------------|
9570                         | Param 2        |
9571                         |----------------|
9572                         .                .
9573                         .                .
9574                         .                .
9575                         |----------------|
9576                         | Param #        |
9577                         |----------------|
9578                         | ProcSym | Type |         Empty
9579                         |----------------|
9580 *)
9581
9582 PROCEDURE BuildFloatFunction (Sym: CARDINAL) ;
9583 VAR
9584    vartok,
9585    functok  : CARDINAL ;
9586    NoOfParam: CARDINAL ;
9587    Type,
9588    Var,
9589    ProcSym  : CARDINAL ;
9590 BEGIN
9591    PopT (NoOfParam) ;
9592    functok := OperandTtok (NoOfParam + 1) ;
9593    Type := GetSType (Sym) ;
9594    IF NoOfParam = 1
9595    THEN
9596       ProcSym := RequestSym (functok, MakeKey ('CONVERT')) ;
9597       IF (ProcSym # NulSym) AND IsProcedure (ProcSym)
9598       THEN
9599          Var := OperandT (1) ;
9600          vartok := OperandTtok (1) ;
9601          IF IsVar (Var) OR IsConst (Var)
9602          THEN
9603             PopN (NoOfParam + 1) ;    (* destroy arguments to this function.  *)
9604             (* build macro: CONVERT (REAL, Var).  *)
9605             PushTFtok (ProcSym, NulSym, functok) ;
9606             PushTtok (Type, functok) ;
9607             PushTtok (Var, vartok) ;
9608             PushT(2) ;          (* two parameters.  *)
9609             BuildConvertFunction
9610          ELSE
9611             MetaErrorT1 (functok,
9612                          'argument to {%1E%ad} must be a variable or constant', ProcSym) ;
9613             PushTFtok (MakeConstLit (functok, MakeKey('0.0'), Type), Type, functok)
9614          END
9615       ELSE
9616          InternalError  ('CONVERT procedure not found for FLOAT substitution')
9617       END
9618    ELSE
9619       MetaErrorT1 (functok,
9620                    'the builtin procedure function {%1Ead} only has one parameter',
9621                    Sym) ;
9622       PushTFtok (MakeConstLit (functok, MakeKey('0.0'), Type), Type, functok)
9623    END
9624 END BuildFloatFunction ;
9625
9626
9627 (*
9628    BuildReFunction - builds the pseudo procedure call RE.
9629
9630                      The Stack:
9631
9632
9633                          Entry                      Exit
9634
9635                  Ptr ->
9636                         +----------------+
9637                         | NoOfParam      |
9638                         |----------------|
9639                         | Param 1        |
9640                         |----------------|
9641                         | Param 2        |
9642                         |----------------|
9643                         .                .
9644                         .                .
9645                         .                .
9646                         |----------------|
9647                         | Param #        |
9648                         |----------------|
9649                         | ProcSym | Type |         Empty
9650                         |----------------|
9651 *)
9652
9653 PROCEDURE BuildReFunction ;
9654 VAR
9655    func,
9656    combinedtok,
9657    vartok,
9658    functok    : CARDINAL ;
9659    NoOfParam  : CARDINAL ;
9660    ReturnVar,
9661    Var        : CARDINAL ;
9662 BEGIN
9663    PopT (NoOfParam) ;
9664    functok := OperandTtok (NoOfParam + 1) ;
9665    func := OperandT (NoOfParam + 1) ;
9666    IF NoOfParam=1
9667    THEN
9668       Var := OperandT (1) ;
9669       vartok := OperandTok (1) ;
9670       combinedtok := MakeVirtualTok (functok, functok, vartok) ;
9671       IF IsVar(Var) OR IsConst(Var)
9672       THEN
9673          ReturnVar := MakeTemporary (combinedtok, AreConstant (IsConst (Var))) ;
9674          PutVar (ReturnVar, ComplexToScalar (GetSType (Var))) ;
9675          GenQuadO (combinedtok, StandardFunctionOp, ReturnVar, Re, Var, FALSE) ;
9676          PopN (NoOfParam+1) ;  (* destroy arguments to this function *)
9677          PushTFtok (ReturnVar, GetSType (ReturnVar), combinedtok)
9678       ELSE
9679          PopN (NoOfParam+1) ;  (* destroy arguments to this function *)
9680          PushTFtok (MakeConstLit (combinedtok, MakeKey ('1.0'), RType), RType, combinedtok) ;
9681          MetaErrorT2 (functok,
9682                       'the parameter to the builtin procedure function {%1Ead} must be a constant or a variable, seen {%2ad}',
9683                       func, Var)
9684       END
9685    ELSE
9686       PopN (NoOfParam+1) ;  (* destroy arguments to this function *)
9687       PushTFtok (MakeConstLit (functok, MakeKey ('1.0'), RType), RType, functok) ;
9688       MetaErrorT2 (functok,
9689                    'the builtin procedure function {%1Ead} only has one parameter, seen {%2n}',
9690                    func, NoOfParam)
9691    END
9692 END BuildReFunction ;
9693
9694
9695 (*
9696    BuildImFunction - builds the pseudo procedure call IM.
9697
9698                      The Stack:
9699
9700
9701                          Entry                      Exit
9702
9703                  Ptr ->
9704                         +----------------+
9705                         | NoOfParam      |
9706                         |----------------|
9707                         | Param 1        |
9708                         |----------------|
9709                         | Param 2        |
9710                         |----------------|
9711                         .                .
9712                         .                .
9713                         .                .
9714                         |----------------|
9715                         | Param #        |
9716                         |----------------|
9717                         | ProcSym | Type |         Empty
9718                         |----------------|
9719 *)
9720
9721 PROCEDURE BuildImFunction ;
9722 VAR
9723    func,
9724    combinedtok,
9725    vartok,
9726    functok    : CARDINAL ;
9727    NoOfParam  : CARDINAL ;
9728    ReturnVar,
9729    Var        : CARDINAL ;
9730 BEGIN
9731    PopT (NoOfParam) ;
9732    functok := OperandTtok (NoOfParam + 1) ;
9733    func := OperandT (NoOfParam + 1) ;
9734    IF NoOfParam=1
9735    THEN
9736       Var := OperandT (1) ;
9737       vartok := OperandTok (1) ;
9738       combinedtok := MakeVirtualTok (functok, functok, vartok) ;
9739       IF IsVar(Var) OR IsConst(Var)
9740       THEN
9741          ReturnVar := MakeTemporary (combinedtok, AreConstant (IsConst (Var))) ;
9742          PutVar (ReturnVar, ComplexToScalar (GetSType (Var))) ;
9743          GenQuadO (combinedtok, StandardFunctionOp, ReturnVar, Im, Var, FALSE) ;
9744          PopN (NoOfParam+1) ;  (* destroy arguments to this function *)
9745          PushTFtok (ReturnVar, GetSType (ReturnVar), combinedtok)
9746       ELSE
9747          PopN (NoOfParam+1) ;  (* destroy arguments to this function *)
9748          PushTFtok (MakeConstLit (combinedtok, MakeKey ('1.0'), RType), RType, combinedtok) ;
9749          MetaErrorT2 (functok,
9750                       'the parameter to the builtin procedure function {%1Ead} must be a constant or a variable, seen {%2ad}',
9751                       func, Var)
9752       END
9753    ELSE
9754       PopN (NoOfParam+1) ;  (* destroy arguments to this function *)
9755       PushTFtok (MakeConstLit (functok, MakeKey ('1.0'), RType), RType, functok) ;
9756       MetaErrorT2 (functok,
9757                    'the builtin procedure function {%1Ead} only has one parameter, seen {%2n}',
9758                    func, NoOfParam)
9759    END
9760 END BuildImFunction ;
9761
9762
9763 (*
9764    BuildCmplxFunction - builds the pseudo procedure call CMPLX.
9765
9766                         The Stack:
9767
9768
9769                         Entry                      Exit
9770
9771                  Ptr ->
9772                         +----------------+
9773                         | NoOfParam      |
9774                         |----------------|
9775                         | Param 1        |
9776                         |----------------|
9777                         | Param 2        |
9778                         |----------------|
9779                         .                .
9780                         .                .
9781                         .                .
9782                         |----------------|
9783                         | Param #        |
9784                         |----------------|
9785                         | ProcSym | Type |         Empty
9786                         |----------------|
9787 *)
9788
9789 PROCEDURE BuildCmplxFunction ;
9790 VAR
9791    functok,
9792    endtok,
9793    combinedtok: CARDINAL ;
9794    NoOfParam  : CARDINAL ;
9795    func,
9796    ReturnVar,
9797    l, r       : CARDINAL ;
9798 BEGIN
9799    PopT (NoOfParam) ;
9800    functok := OperandTtok (NoOfParam + 1) ;
9801    func := OperandT (NoOfParam + 1) ;
9802    IF NoOfParam = 2
9803    THEN
9804       l := OperandT (2) ;
9805       r := OperandT (1) ;
9806       endtok := OperandTok (1) ;
9807       combinedtok := MakeVirtualTok (functok, functok, endtok) ;
9808       IF (IsVar(l) OR IsConst(l)) AND
9809          (IsVar(r) OR IsConst(r))
9810       THEN
9811          CheckExpressionCompatible (combinedtok, GetSType(l), GetSType(r)) ;
9812          ReturnVar := MakeTemporary (combinedtok, AreConstant (IsConst (l) AND IsConst (r))) ;
9813          PutVar (ReturnVar, GetCmplxReturnType (GetDType (l), GetDType (r))) ;
9814          GenQuadO (combinedtok, StandardFunctionOp, ReturnVar, Cmplx, Make2Tuple (l, r), TRUE) ;
9815          PopN (NoOfParam+1) ;   (* destroy arguments to this function *)
9816          PushTFtok (ReturnVar, GetSType (ReturnVar), combinedtok)
9817       ELSE
9818          IF IsVar (l) OR IsConst (l)
9819          THEN
9820             MetaErrorT2 (functok,
9821                       'the builtin procedure {%1Ead} requires two parameters, both must be variables or constants but the second parameter is {%2d}',
9822                       func, r)
9823          ELSE
9824             MetaErrorT2 (functok,
9825                          'the builtin procedure {%1Ead} requires two parameters, both must be variables or constants but the first parameter is {%2d}',
9826                       func, l)
9827          END ;
9828          PopN (NoOfParam+1) ;  (* destroy arguments to this function *)
9829          PushTFtok (MakeConstLit (combinedtok, MakeKey ('1.0'), CType), CType, combinedtok)
9830       END
9831    ELSE
9832       MetaErrorT2 (functok,
9833                    'the builtin procedure {%1Ead} requires two parameters, seen {%2n}',
9834                    func, NoOfParam) ;
9835       PopN (NoOfParam + 1) ;  (* destroy arguments to this function *)
9836       PushTFtok (MakeConstLit (functok, MakeKey ('1.0'), CType), CType, functok)
9837    END
9838 END BuildCmplxFunction ;
9839
9840
9841 (*
9842    BuildAdrFunction - builds the pseudo function ADR
9843                       The Stack:
9844
9845
9846                       Entry                      Exit
9847
9848                Ptr ->
9849                       +----------------+
9850                       | NoOfParam      |
9851                       |----------------|
9852                       | Param 1        |
9853                       |----------------|
9854                       | Param 2        |
9855                       |----------------|
9856                       .                .
9857                       .                .
9858                       .                .
9859                       |----------------|
9860                       | Param #        |                        <- Ptr
9861                       |----------------|         +------------+
9862                       | ProcSym | Type |         | ReturnVar  |
9863                       |----------------|         |------------|
9864
9865 *)
9866
9867 PROCEDURE BuildAdrFunction ;
9868 VAR
9869    endtok,
9870    combinedTok,
9871    procTok,
9872    t,
9873    UnboundedSym,
9874    Dim,
9875    Field,
9876    noOfParameters,
9877    procSym,
9878    returnVar,
9879    Type, rw    : CARDINAL ;
9880 BEGIN
9881    DisplayStack ;
9882    PopT (noOfParameters) ;
9883    procSym := OperandT (noOfParameters + 1) ;
9884    procTok := OperandTok (noOfParameters + 1) ;  (* token of procedure ADR.  *)
9885    endtok := OperandTok (1) ;  (* last parameter.  *)
9886    combinedTok := MakeVirtualTok (procTok, procTok, endtok) ;
9887    IF noOfParameters # 1
9888    THEN
9889       MetaErrorNT0 (combinedTok,
9890                     'SYSTEM procedure ADR expects 1 parameter') ;
9891       PopN (noOfParameters + 1) ;    (* destroy the arguments and function *)
9892       PushTF (Nil, Address)
9893    ELSIF IsConstString (OperandT (1))
9894    THEN
9895       returnVar := MakeLeftValue (combinedTok, OperandT (1), RightValue,
9896                                   GetSType (procSym)) ;
9897       PopN (noOfParameters + 1) ;    (* destroy the arguments and function *)
9898       PushTFtok (returnVar, GetSType (returnVar), combinedTok)
9899    ELSIF (NOT IsVar(OperandT(1))) AND (NOT IsProcedure(OperandT(1)))
9900    THEN
9901       MetaErrorNT0 (combinedTok,
9902                     'SYSTEM procedure ADR expects a variable, procedure or a constant string as its parameter') ;
9903       PopN (noOfParameters + 1) ;    (* destroy the arguments and function *)
9904       PushTFtok (Nil, Address, combinedTok)
9905    ELSIF IsProcedure (OperandT (1))
9906    THEN
9907       returnVar := MakeLeftValue (combinedTok, OperandT (1), RightValue,
9908                                   GetSType (procSym)) ;
9909       PopN (noOfParameters + 1) ;    (* destroy the arguments and function *)
9910       PushTFtok (returnVar, GetSType (returnVar), combinedTok)
9911    ELSE
9912       Type := GetSType (OperandT (1)) ;
9913       Dim := OperandD (1) ;
9914       MarkArrayWritten (OperandT (1)) ;
9915       MarkArrayWritten (OperandA (1)) ;
9916       (* if the operand is an unbounded which has not been indexed
9917          then we will lookup its address from the unbounded record.
9918          Otherwise we obtain the address of the operand.
9919       *)
9920       IF IsUnbounded (Type) AND (Dim = 0)
9921       THEN
9922          (* we will reference the address field of the unbounded structure *)
9923          UnboundedSym := OperandT (1) ;
9924          rw := OperandRW (1) ;
9925          PushTFrw (UnboundedSym, GetSType (UnboundedSym), rw) ;
9926          Field := GetUnboundedAddressOffset (GetSType (UnboundedSym)) ;
9927          PushTF (Field, GetSType (Field)) ;
9928          PushT (1) ;
9929          BuildDesignatorRecord (combinedTok) ;
9930          PopTrw (returnVar, rw) ;
9931          IF GetMode (returnVar) = LeftValue
9932          THEN
9933             t := MakeTemporary (combinedTok, RightValue) ;
9934             PutVar (t, GetSType (procSym)) ;
9935             doIndrX (combinedTok, t, returnVar) ;
9936             returnVar := t
9937          ELSE
9938             (* we need to cast returnVar into ADDRESS *)
9939             t := MakeTemporary (combinedTok, RightValue) ;
9940             PutVar (t, GetSType (procSym)) ;
9941             GenQuadO (combinedTok, ConvertOp, t, GetSType (procSym), returnVar, FALSE) ;
9942             returnVar := t
9943          END
9944       ELSE
9945          returnVar := MakeTemporary (combinedTok, RightValue) ;
9946          PutVar (returnVar, GetSType (procSym)) ;
9947          IF GetMode (OperandT (1)) = LeftValue
9948          THEN
9949             PutVar (returnVar, GetSType (procSym)) ;
9950             GenQuadO (combinedTok, ConvertOp, returnVar, GetSType (procSym), OperandT (1), FALSE)
9951          ELSE
9952             GenQuadO (combinedTok, AddrOp, returnVar, NulSym, OperandT (1), FALSE)
9953          END ;
9954          rw := OperandMergeRW (1) ;
9955          Assert (IsLegal (rw))
9956       END ;
9957       PopN (noOfParameters + 1) ;    (* destroy the arguments and function *)
9958       PushTFrwtok (returnVar, GetSType (returnVar), rw, combinedTok)
9959    END
9960 END BuildAdrFunction ;
9961
9962
9963 (*
9964    BuildSizeFunction - builds the pseudo function SIZE
9965                        The Stack:
9966
9967
9968                        Entry                      Exit
9969
9970                 Ptr ->
9971                        +----------------+
9972                        | NoOfParam      |
9973                        |----------------|
9974                        | Param 1        |
9975                        |----------------|
9976                        | Param 2        |
9977                        |----------------|
9978                        .                .
9979                        .                .
9980                        .                .
9981                        |----------------|
9982                        | Param #        |                        <- Ptr
9983                        |----------------|         +------------+
9984                        | ProcSym | Type |         | ReturnVar  |
9985                        |----------------|         |------------|
9986 *)
9987
9988 PROCEDURE BuildSizeFunction ;
9989 VAR
9990    resulttok,
9991    paramtok,
9992    functok     : CARDINAL ;
9993    dim         : CARDINAL ;
9994    Type,
9995    NoOfParam,
9996    ProcSym,
9997    ReturnVar   : CARDINAL ;
9998 BEGIN
9999    PopT (NoOfParam) ;
10000    ProcSym := OperandT (NoOfParam + 1) ;
10001    functok := OperandTtok (NoOfParam + 1) ;
10002    IF NoOfParam # 1
10003    THEN
10004       MetaErrorT1 (functok,
10005                    '{%E} SYSTEM procedure function {%kSIZE} requires one parameter, seen {%1n}',
10006                    NoOfParam) ;
10007       resulttok := functok ;
10008       ReturnVar := MakeConstLit (resulttok, MakeKey('0'), Cardinal)
10009    ELSIF IsAModula2Type (OperandT (1))
10010    THEN
10011       paramtok := OperandTok (1) ;
10012       resulttok := MakeVirtualTok (functok, functok, paramtok) ;
10013       BuildSizeCheckEnd (ProcSym) ;   (* quadruple generation now on *)
10014       ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
10015       GenQuadO (resulttok, SizeOp, ReturnVar, NulSym, OperandT(1), TRUE)
10016    ELSIF IsVar (OperandT (1))
10017    THEN
10018       BuildSizeCheckEnd (ProcSym) ;   (* quadruple generation now on *)
10019       Type := GetSType (OperandT (1)) ;
10020       paramtok := OperandTok (1) ;
10021       resulttok := MakeVirtualTok (functok, functok, paramtok) ;
10022       IF IsUnbounded (Type)
10023       THEN
10024          (* eg. SIZE(a)  ; where a is unbounded dereference HIGH and multiply by the TYPE *)
10025          dim := OperandD (1) ;
10026          IF dim = 0
10027          THEN
10028             ReturnVar := calculateMultipicand (resulttok, OperandT (1), Type, dim)
10029          ELSE
10030             ReturnVar := calculateMultipicand (resulttok, OperandA (1), Type, dim)
10031          END
10032       ELSE
10033          ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
10034          IF Type = NulSym
10035          THEN
10036             MetaErrorT1 (resulttok,
10037                          'cannot get the type and size of {%E1ad}', OperandT (1))
10038          END ;
10039          GenQuadO (resulttok, SizeOp, ReturnVar, NulSym, Type, TRUE)
10040       END
10041    ELSE
10042       resulttok := functok ;
10043       MetaErrorT1 (resulttok,
10044                    '{%E}SYSTEM procedure {%kSIZE} expects a variable as its parameter, seen {%E1d}',
10045                    OperandT (1)) ;
10046       ReturnVar := MakeConstLit (resulttok, MakeKey('0'), Cardinal)
10047    END ;
10048    PopN (NoOfParam+1) ;       (* destroy the arguments and function *)
10049    PushTFtok (ReturnVar, GetSType(ProcSym), resulttok)
10050 END BuildSizeFunction ;
10051
10052
10053 (*
10054    BuildTSizeFunction - builds the pseudo function TSIZE
10055                         The Stack:
10056
10057
10058                         Entry                      Exit
10059
10060                  Ptr ->
10061                         +----------------+
10062                         | NoOfParam      |
10063                         |----------------|
10064                         | Param 1        |
10065                         |----------------|
10066                         | Param 2        |
10067                         |----------------|
10068                         .                .
10069                         .                .
10070                         .                .
10071                         |----------------|
10072                         | Param #        |                        <- Ptr
10073                         |----------------|         +------------+
10074                         | ProcSym | Type |         | ReturnVar  |
10075                         |----------------|         |------------|
10076
10077 *)
10078
10079 PROCEDURE BuildTSizeFunction ;
10080 VAR
10081    resulttok,
10082    paramtok,
10083    functok  : CARDINAL ;
10084    NoOfParam: CARDINAL ;
10085    ProcSym,
10086    Record,
10087    ReturnVar: CARDINAL ;
10088 BEGIN
10089    PopT (NoOfParam) ;
10090    ProcSym := OperandT (NoOfParam + 1) ;
10091    functok := OperandTtok (NoOfParam) ;
10092    BuildSizeCheckEnd (ProcSym) ;   (* quadruple generation now on *)
10093    IF NoOfParam = 1
10094    THEN
10095       paramtok := OperandTtok (1) ;
10096       resulttok := MakeVirtualTok (functok, functok, paramtok) ;
10097       IF IsAModula2Type (OperandT (1))
10098       THEN
10099          ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
10100          GenQuadO (resulttok, SizeOp, ReturnVar, NulSym, OperandT (1), FALSE)
10101       ELSIF IsVar (OperandT (1))
10102       THEN
10103          ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
10104          GenQuadO (resulttok, SizeOp, ReturnVar, NulSym, GetSType (OperandT (1)), FALSE)
10105       ELSE
10106          MetaErrorT1 (resulttok,
10107                       '{%E}SYSTEM procedure function {%kTSIZE} expects a variable as its first parameter, seen {%E1d}',
10108                       OperandT (1)) ;
10109          ReturnVar := MakeConstLit (resulttok, MakeKey ('0'), Cardinal)
10110       END
10111    ELSIF NoOfParam = 0
10112    THEN
10113       resulttok := functok ;
10114       MetaErrorT0 (resulttok,
10115                    '{%E}SYSTEM procedure function {%kTSIZE} expects either one or two parameters, seen none') ;
10116       ReturnVar := MakeConstLit (resulttok, MakeKey ('0'), Cardinal)
10117    ELSE
10118       Record := OperandT (NoOfParam) ;
10119       paramtok := OperandTtok (1) ;
10120       resulttok := OperandTtok (NoOfParam) ;
10121       IF IsRecord (Record)
10122       THEN
10123          paramtok := OperandTtok (1) ;
10124          resulttok := MakeVirtualTok (functok, functok, paramtok) ;
10125          ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
10126          GenQuadO (resulttok, SizeOp, ReturnVar, NulSym, Record, FALSE)
10127       ELSE
10128          resulttok := MakeVirtualTok (functok, functok, paramtok) ;
10129          MetaErrorT1 (resulttok,
10130                       '{%E}SYSTEM procedure function {%kTSIZE} expects the first parameter to be a record type, seen {%E1d}',
10131                       Record) ;
10132          ReturnVar := MakeConstLit (resulttok, MakeKey ('0'), Cardinal)
10133       END
10134    END ;
10135    PopN (NoOfParam+1) ;       (* destroy the arguments and function *)
10136    PushTFtok (ReturnVar, GetSType (ProcSym), resulttok)
10137 END BuildTSizeFunction ;
10138
10139
10140 (*
10141    BuildTBitSizeFunction - builds the pseudo function TBITSIZE
10142                            The Stack:
10143
10144
10145                            Entry                      Exit
10146
10147                    Ptr ->
10148                            +----------------+
10149                            | NoOfParam      |
10150                            |----------------|
10151                            | Param 1        |
10152                            |----------------|
10153                            | Param 2        |
10154                            |----------------|
10155                            .                .
10156                            .                .
10157                            .                .
10158                            |----------------|
10159                            | Param #        |                        <- Ptr
10160                            |----------------|         +------------+
10161                            | ProcSym | Type |         | ReturnVar  |
10162                            |----------------|         |------------|
10163
10164 *)
10165
10166 PROCEDURE BuildTBitSizeFunction ;
10167 VAR
10168    resulttok,
10169    paramtok,
10170    functok  : CARDINAL ;
10171    NoOfParam: CARDINAL ;
10172    ProcSym,
10173    Record,
10174    ReturnVar: CARDINAL ;
10175 BEGIN
10176    PopT (NoOfParam) ;
10177    ProcSym := OperandT (NoOfParam + 1) ;
10178    functok := OperandTtok (NoOfParam) ;
10179    BuildSizeCheckEnd (ProcSym) ;   (* quadruple generation now on *)
10180    IF NoOfParam = 1
10181    THEN
10182       paramtok := OperandTtok (1) ;
10183       resulttok := MakeVirtualTok (functok, functok, paramtok) ;
10184       IF IsAModula2Type (OperandT (1))
10185       THEN
10186          ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
10187          GenQuadO (resulttok, StandardFunctionOp, ReturnVar, ProcSym, OperandT (1), FALSE)
10188       ELSIF IsVar (OperandT (1))
10189       THEN
10190          ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
10191          GenQuadO (resulttok, StandardFunctionOp, ReturnVar, ProcSym, OperandT(1), FALSE)
10192       ELSE
10193          MetaErrorT1 (resulttok,
10194                       '{%E}SYSTEM procedure function {%kTBITSIZE} expects a variable as its first parameter, seen {%E1d}',
10195                       OperandT (1)) ;
10196          ReturnVar := MakeConstLit (resulttok, MakeKey ('0'), Cardinal)
10197       END
10198    ELSIF NoOfParam = 0
10199    THEN
10200       resulttok := functok ;
10201       MetaErrorT0 (functok,
10202                    '{%E}SYSTEM procedure function {%kTBITSIZE} expects either one or two parameters, seen none') ;
10203       ReturnVar := MakeConstLit (functok, MakeKey ('0'), Cardinal)
10204    ELSE
10205       Record := OperandT (NoOfParam) ;
10206       paramtok := OperandTtok (1) ;
10207       resulttok := OperandTtok (NoOfParam) ;
10208       IF IsRecord (Record)
10209       THEN
10210          paramtok := OperandTtok (1) ;
10211          resulttok := MakeVirtualTok (functok, functok, paramtok) ;
10212          ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
10213          GenQuad(StandardFunctionOp, ReturnVar, ProcSym, OperandT(1)) ;
10214       ELSE
10215          resulttok := MakeVirtualTok (functok, functok, paramtok) ;
10216          MetaErrorT1 (resulttok,
10217                       '{%E}SYSTEM procedure function {%kTBITSIZE} expects the first parameter to be a record type, seen {%E1d}',
10218                       Record) ;
10219          ReturnVar := MakeConstLit (resulttok, MakeKey ('0'), Cardinal)
10220       END
10221    END ;
10222    PopN (NoOfParam + 1) ;       (* destroy the arguments and function *)
10223    PushTFtok (ReturnVar, GetSType (ProcSym), resulttok)
10224 END BuildTBitSizeFunction ;
10225
10226
10227 (*
10228    ExpectingParameterType -
10229 *)
10230
10231 PROCEDURE ExpectingParameterType (BlockSym, Type: CARDINAL) ;
10232 BEGIN
10233    IF NOT IsAModula2Type (Type)
10234    THEN
10235       IF (Type = NulSym) OR IsPartialUnbounded (Type) OR IsUnknown (Type)
10236       THEN
10237          MetaError1 ('the type used in the formal parameter declaration in {%1Md} {%1a} is unknown',
10238                      BlockSym)
10239       ELSE
10240          MetaError2 ('the type {%1Ead} used in the formal parameter declaration in {%2Md} {%2a} was not declared as a type',
10241                      Type, BlockSym)
10242       END
10243    END
10244 END ExpectingParameterType ;
10245
10246
10247 (*
10248    ExpectingVariableType -
10249 *)
10250
10251 PROCEDURE ExpectingVariableType (BlockSym, Type: CARDINAL) ;
10252 BEGIN
10253    IF NOT IsAModula2Type(Type)
10254    THEN
10255       IF Type=NulSym
10256       THEN
10257          MetaError1 ('the type used during the variable declaration section in procedure {%1EMad} is unknown',
10258                      BlockSym) ;
10259          MetaError1 ('the type used during the variable declaration section in procedure {%1Ead} is unknown',
10260                      BlockSym)
10261       ELSIF IsPartialUnbounded(Type) OR IsUnknown(Type)
10262       THEN
10263          MetaError2 ('the type {%1EMad} used during variable declaration section in procedure {%2ad} is unknown',
10264                      Type, BlockSym) ;
10265          MetaError2 ('the type {%1Ead} used during variable declaration section in procedure {%2Mad} is unknown',
10266                      Type, BlockSym)
10267       ELSE
10268          MetaError2 ('the {%1d} {%1Ea} is not a type and therefore cannot be used to declare a variable in {%2d} {%2a}',
10269                      Type, BlockSym)
10270       END
10271    END
10272 END ExpectingVariableType ;
10273
10274
10275 (*
10276    CheckVariablesAndParameterTypesInBlock - checks to make sure that block, BlockSym, has
10277                                             parameters types and variable types which are legal.
10278 *)
10279
10280 PROCEDURE CheckVariablesAndParameterTypesInBlock (BlockSym: CARDINAL) ;
10281 VAR
10282    i, n,
10283    ParamNo: CARDINAL ;
10284 BEGIN
10285    IF IsProcedure(BlockSym)
10286    THEN
10287       ParamNo := NoOfParam(BlockSym)
10288    ELSE
10289       ParamNo := 0
10290    END ;
10291    i := 1 ;
10292    REPEAT
10293       n := GetNth(BlockSym, i) ;
10294       IF (n#NulSym) AND (NOT IsTemporary(n)) AND
10295          (IsProcedure(BlockSym) OR ((IsDefImp(BlockSym) AND (GetMainModule()=BlockSym)) OR IsModule(BlockSym)))
10296       THEN
10297          IF i<=ParamNo
10298          THEN
10299             (* n is a parameter *)
10300             ExpectingParameterType(BlockSym, GetSType(n))
10301          ELSE
10302             (* n is a local variable *)
10303             ExpectingVariableType(BlockSym, GetSType(n))
10304          END
10305       END ;
10306       INC(i)
10307    UNTIL n=NulSym ;
10308 END CheckVariablesAndParameterTypesInBlock ;
10309
10310
10311 (*
10312    BuildProcedureStart - Builds start of the procedure. Generates a
10313                          quadruple which indicated the start of
10314                          this procedure declarations scope.
10315                          The Stack is expected to contain:
10316
10317
10318                          Entry                   Exit
10319                          =====                   ====
10320
10321                  Ptr ->                                       <- Ptr
10322                         +------------+          +-----------+
10323                         | ProcSym    |          | ProcSym   |
10324                         |------------|          |-----------|
10325                         | Name       |          | Name      |
10326                         |------------|          |-----------|
10327
10328
10329                         Quadruples:
10330
10331                         q   ProcedureScopeOp  Line#  Scope  ProcSym
10332 *)
10333
10334 PROCEDURE BuildProcedureStart ;
10335 VAR
10336    ProcSym: CARDINAL ;
10337 BEGIN
10338    PopT(ProcSym) ;
10339    Assert(IsProcedure(ProcSym)) ;
10340    PutProcedureScopeQuad(ProcSym, NextQuad) ;
10341    GenQuad(ProcedureScopeOp, GetPreviousTokenLineNo(), GetScope(ProcSym), ProcSym) ;
10342    PushT(ProcSym)
10343 END BuildProcedureStart ;
10344
10345
10346 (*
10347    BuildProcedureBegin - determines the start of the BEGIN END block of
10348                          the procedure.
10349                          The Stack is expected to contain:
10350
10351
10352                          Entry                   Exit
10353                          =====                   ====
10354
10355                  Ptr ->                                       <- Ptr
10356                         +------------+          +-----------+
10357                         | ProcSym    |          | ProcSym   |
10358                         |------------|          |-----------|
10359                         | Name       |          | Name      |
10360                         |------------|          |-----------|
10361
10362
10363                         Quadruples:
10364
10365                         q   NewLocalVarOp  TokenNo(BEGIN)  _  ProcSym
10366 *)
10367
10368 PROCEDURE BuildProcedureBegin ;
10369 VAR
10370    ProcSym: CARDINAL ;
10371 BEGIN
10372    PopT(ProcSym) ;
10373    Assert(IsProcedure(ProcSym)) ;
10374    PutProcedureStartQuad(ProcSym, NextQuad) ;
10375    PutProcedureBegin(ProcSym, GetTokenNo()) ;
10376    GenQuad(NewLocalVarOp, GetTokenNo(), GetScope(ProcSym), ProcSym) ;
10377    CurrentProc := ProcSym ;
10378    PushWord(ReturnStack, 0) ;
10379    PushT(ProcSym) ;
10380    CheckVariablesAt(ProcSym) ;
10381    CheckNeedPriorityBegin(GetTokenNo(), ProcSym, GetCurrentModule()) ;
10382    PushWord(TryStack, NextQuad) ;
10383    PushWord(CatchStack, 0) ;
10384    IF HasExceptionBlock(ProcSym)
10385    THEN
10386       GenQuad(TryOp, NulSym, NulSym, 0)
10387    END
10388 END BuildProcedureBegin ;
10389
10390
10391 (*
10392    BuildProcedureEnd - Builds end of the procedure. Destroys space for
10393                        the local variables.
10394                        The Stack is expected to contain:
10395
10396
10397                        Entry                   Exit
10398                        =====                   ====
10399
10400                 Ptr ->                                       <- Ptr
10401                        +------------+          +-----------+
10402                        | ProcSym    |          | ProcSym   |
10403                        |------------|          |-----------|
10404                        | Name       |          | Name      |
10405                        |------------|          |-----------|
10406
10407
10408                        Quadruples:
10409
10410                        q   KillLocalVarOp  TokenNo(END)  _  ProcSym
10411 *)
10412
10413 PROCEDURE BuildProcedureEnd ;
10414 VAR
10415    tok    : CARDINAL ;
10416    ProcSym: CARDINAL ;
10417 BEGIN
10418    PopTtok(ProcSym, tok) ;
10419    IF HasExceptionBlock(ProcSym)
10420    THEN
10421       BuildRTExceptLeave(tok, TRUE) ;
10422       GenQuad(CatchEndOp, NulSym, NulSym, NulSym)
10423    END ;
10424    IF GetSType(ProcSym)#NulSym
10425    THEN
10426       BuildError(InitNoReturnRangeCheck())
10427    END ;
10428    BackPatch(PopWord(ReturnStack), NextQuad) ;
10429    CheckNeedPriorityEnd(tok, ProcSym, GetCurrentModule()) ;
10430    CurrentProc := NulSym ;
10431    PutProcedureEnd(ProcSym, GetTokenNo()-1) ;   (* --fixme-- *)
10432    GenQuad(KillLocalVarOp, GetTokenNo()-1, NulSym, ProcSym) ;
10433    PutProcedureEndQuad(ProcSym, NextQuad) ;
10434    GenQuad(ReturnOp, NulSym, NulSym, ProcSym) ;
10435    CheckFunctionReturn(ProcSym) ;
10436    CheckVariablesInBlock(ProcSym) ;
10437    RemoveTop (CatchStack) ;
10438    RemoveTop (TryStack) ;
10439    PushT(ProcSym)
10440 END BuildProcedureEnd ;
10441
10442
10443 (*
10444    CheckReadBeforeInitialized -
10445 *)
10446
10447 PROCEDURE CheckReadBeforeInitialized (ProcSym: CARDINAL; End: CARDINAL) ;
10448 VAR
10449    s1, s2              : String ;
10450    i, n, ParamNo,
10451    ReadStart, ReadEnd,
10452    WriteStart, WriteEnd: CARDINAL ;
10453 BEGIN
10454    ParamNo := NoOfParam(ProcSym) ;
10455    i := 1 ;
10456    REPEAT
10457       n := GetNth(ProcSym, i) ;
10458       IF (n#NulSym) AND (NOT IsTemporary(n))
10459       THEN
10460          GetReadQuads(n, RightValue, ReadStart, ReadEnd) ;
10461          GetWriteQuads(n, RightValue, WriteStart, WriteEnd) ;
10462          IF i>ParamNo
10463          THEN
10464             (* n is a not a parameter thus we can check *)
10465             IF (ReadStart>0) AND (ReadStart<End)
10466             THEN
10467                (* it is read in the first basic block *)
10468                IF ReadStart<WriteStart
10469                THEN
10470                   (* read before written, this is a problem which must be fixed *)
10471                   s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(n)))) ;
10472                   s2 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(ProcSym)))) ;
10473                   ErrorStringAt2(Sprintf2(Mark(InitString('reading from a variable (%s) before it is initialized in procedure (%s)')),
10474                                           s1, s2),
10475                                  GetDeclaredMod(n), GetDeclaredMod(n))
10476                END
10477             END
10478          END
10479       END ;
10480       INC(i)
10481    UNTIL n=NulSym
10482 END CheckReadBeforeInitialized ;
10483
10484
10485 (*
10486    VariableAnalysis - checks to see whether a variable is:
10487
10488                       read before it has been initialized
10489 *)
10490
10491 PROCEDURE VariableAnalysis (Start, End: CARDINAL) ;
10492 VAR
10493    Op           : QuadOperator ;
10494    Op1, Op2, Op3: CARDINAL ;
10495 BEGIN
10496    IF Pedantic
10497    THEN
10498       GetQuad(Start, Op, Op1, Op2, Op3) ;
10499       CASE Op OF
10500
10501       NewLocalVarOp:  CheckReadBeforeInitialized(Op3, End)
10502
10503       ELSE
10504       END
10505    END
10506 END VariableAnalysis ;
10507
10508
10509 (*
10510    IsNeverAltered - returns TRUE if variable, sym, is never altered
10511                     between quadruples: Start..End
10512 *)
10513
10514 PROCEDURE IsNeverAltered (sym: CARDINAL; Start, End: CARDINAL) : BOOLEAN ;
10515 VAR
10516    WriteStart, WriteEnd: CARDINAL ;
10517 BEGIN
10518    GetWriteLimitQuads(sym, GetMode(sym), Start, End, WriteStart, WriteEnd) ;
10519    RETURN( (WriteStart=0) AND (WriteEnd=0) )
10520 END IsNeverAltered ;
10521
10522
10523 (*
10524    IsConditionVariable - returns TRUE if the condition at quadruple, q, is variable.
10525 *)
10526
10527 PROCEDURE IsConditionVariable (q: CARDINAL; Start, End: CARDINAL) : BOOLEAN ;
10528 VAR
10529    op           : QuadOperator ;
10530    op1, op2, op3: CARDINAL ;
10531    LeftFixed,
10532    RightFixed   : BOOLEAN ;
10533 BEGIN
10534    GetQuad(q, op, op1, op2, op3) ;
10535    IF op=GotoOp
10536    THEN
10537       RETURN( FALSE )
10538    ELSE
10539       LeftFixed  := IsConst(op1) ;
10540       RightFixed := IsConst(op2) ;
10541       IF NOT LeftFixed
10542       THEN
10543          LeftFixed := IsNeverAltered(op1, Start, End)
10544       END ;
10545       IF NOT RightFixed
10546       THEN
10547          RightFixed := IsNeverAltered(op2, Start, End)
10548       END ;
10549       RETURN( NOT (LeftFixed AND RightFixed) )
10550    END
10551 END IsConditionVariable ;
10552
10553
10554 (*
10555    IsInfiniteLoop - returns TRUE if an infinite loop is found.
10556                     Given a backwards jump at, End, it returns a BOOLEAN which depends on
10557                     whether a jump is found to jump beyond, End. If a conditonal jump is found
10558                     to pass over, End, the condition is tested for global variables, procedure variables and
10559                     constants.
10560
10561                          constant        - ignored
10562                          variables       - tested to see whether they are altered inside the loop
10563                          global variable - the procedure tests to see whether it is altered as above
10564                                            but will also test to see whether this loop calls a procedure
10565                                            in which case it believes the loop NOT to be infinite
10566                                            (as this procedure call might alter the global variable)
10567
10568                     Note that this procedure can easily be fooled by the user altering variables
10569                     with pointers.
10570 *)
10571
10572 PROCEDURE IsInfiniteLoop (End: CARDINAL) : BOOLEAN ;
10573 VAR
10574    SeenCall,
10575    IsGlobal     : BOOLEAN ;
10576    Current,
10577    Start        : CARDINAL ;
10578    op           : QuadOperator ;
10579    op1, op2, op3: CARDINAL ;
10580 BEGIN
10581    SeenCall := FALSE ;
10582    IsGlobal := FALSE ;
10583    GetQuad(End, op, op1, op2, Start) ;
10584    Current := Start ;
10585    WHILE Current#End DO
10586       GetQuad(Current, op, op1, op2, op3) ;
10587       (* remember that this function is only called once we have optimized the redundant gotos and conditionals *)
10588       IF IsConditional(Current) AND (NOT IsGlobal)
10589       THEN
10590          IsGlobal := (IsVar(op1) AND (NOT IsProcedure(GetVarScope(op1)))) OR
10591                      (IsVar(op2) AND (NOT IsProcedure(GetVarScope(op2))))
10592       END ;
10593       IF op=CallOp
10594       THEN
10595          SeenCall := TRUE
10596       END ;
10597       IF (op=GotoOp) OR (IsConditional(Current) AND IsConditionVariable(Current, Start, End))
10598       THEN
10599          IF (op3>End) OR (op3<Start)
10600          THEN
10601             RETURN( FALSE )    (* may jump out of this loop, good *)
10602          END
10603       END ;
10604       Current := GetNextQuad(Current)
10605    END ;
10606    GetQuad(End, op, op1, op2, op3) ;
10607    IF IsConditional(End)
10608    THEN
10609       IF IsConditionVariable(End, Start, End)
10610       THEN
10611          RETURN( FALSE )
10612       ELSE
10613          IF NOT IsGlobal
10614          THEN
10615             IsGlobal := (IsVar(op1) AND (NOT IsProcedure(GetVarScope(op1)))) OR
10616                         (IsVar(op2) AND (NOT IsProcedure(GetVarScope(op2))))
10617          END
10618       END
10619    END ;
10620    (* we have found a likely infinite loop if no conditional uses a global and no procedure call was seen *)
10621    RETURN( NOT (IsGlobal AND SeenCall) )
10622 END IsInfiniteLoop ;
10623
10624
10625 (*
10626    LoopAnalysis - checks whether an infinite loop exists.
10627 *)
10628
10629 PROCEDURE LoopAnalysis (Current, End: CARDINAL) ;
10630 VAR
10631    op           : QuadOperator ;
10632    op1, op2, op3: CARDINAL ;
10633 BEGIN
10634    IF Pedantic
10635    THEN
10636       WHILE (Current<=End) AND (Current#0) DO
10637          GetQuad(Current, op, op1, op2, op3) ;
10638          IF (op=GotoOp) OR IsConditional(Current)
10639          THEN
10640             IF op3<=Current
10641             THEN
10642                (* found a loop - ie a branch which goes back in quadruple numbers *)
10643                IF IsInfiniteLoop(Current)
10644                THEN
10645                   WarnStringAt(InitString('it is very likely (although not absolutely certain) that the top of an infinite loop is here'),
10646                                QuadToTokenNo(op3)) ;
10647                   WarnStringAt(InitString('and the bottom of the infinite loop is ends here or alternatively a component of this loop is never executed'),
10648                                QuadToTokenNo(Current))
10649                END
10650             END
10651          END ;
10652          Current := GetNextQuad(Current)
10653       END
10654    END
10655 END LoopAnalysis ;
10656
10657
10658 (*
10659    CheckUninitializedVariablesAreUsed - checks to see whether uninitialized variables are used.
10660 *)
10661
10662 PROCEDURE CheckUninitializedVariablesAreUsed (BlockSym: CARDINAL) ;
10663 VAR
10664    i, n,
10665    ParamNo   : CARDINAL ;
10666    ReadStart,
10667    ReadEnd,
10668    WriteStart,
10669    WriteEnd  : CARDINAL ;
10670 BEGIN
10671    IF IsProcedure(BlockSym)
10672    THEN
10673       ParamNo := NoOfParam(BlockSym)
10674    ELSE
10675       ParamNo := 0
10676    END ;
10677    i := 1 ;
10678    REPEAT
10679       n := GetNth(BlockSym, i) ;
10680       IF (n#NulSym) AND (NOT IsTemporary(n)) AND
10681          (IsProcedure(BlockSym) OR (((IsDefImp(BlockSym) AND (GetMainModule()=BlockSym)) OR IsModule(BlockSym)) AND
10682                                     (NOT IsExported(BlockSym, n))))
10683       THEN
10684          GetReadQuads(n, RightValue, ReadStart, ReadEnd) ;
10685          GetWriteQuads(n, RightValue, WriteStart, WriteEnd) ;
10686          IF i<=ParamNo
10687          THEN
10688             (* n is a parameter *)
10689             IF UnusedParameterChecking
10690             THEN
10691                IF ReadStart = 0
10692                THEN
10693                   IF WriteStart = 0
10694                   THEN
10695                      MetaError2 ('unused parameter {%1WMad} in procedure {%2ad}', n, BlockSym)
10696                   ELSE
10697                      IF NOT IsVarParam (BlockSym, i)
10698                      THEN
10699                         (* --fixme-- reconsider this.  *)
10700                         (* MetaError2 ('writing to a non var parameter {%1WMad} and never reading from it in procedure {%2ad}',
10701                                     n, BlockSym) *)
10702                      END
10703                   END
10704                END
10705             END
10706          ELSE
10707             (* n is a local variable *)
10708             IF UnusedVariableChecking
10709             THEN
10710                IF ReadStart=0
10711                THEN
10712                   IF WriteStart=0
10713                   THEN
10714                      MetaError2 ('unused variable {%1WMad} in {%2d} {%2ad}', n, BlockSym)
10715                   ELSE
10716                      (* --fixme-- reconsider this.  *)
10717                      (* MetaError2 ('writing to a variable {%1WMad} and never reading from it in {%2d} {%2ad}', n, BlockSym) *)
10718                   END
10719                ELSE
10720                   IF WriteStart=0
10721                   THEN
10722                      MetaError2 ('variable {%1WMad} is being used but it is never initialized in {%2d} {%2ad}', n, BlockSym)
10723                   END
10724                END
10725             END
10726          END
10727       END ;
10728       INC(i)
10729    UNTIL n=NulSym
10730 END CheckUninitializedVariablesAreUsed ;
10731
10732
10733 (*
10734    IsInlineWithinBlock - returns TRUE if an InlineOp is found
10735                          within start..end.
10736 *)
10737
10738 PROCEDURE IsInlineWithinBlock (start, end: CARDINAL) : BOOLEAN ;
10739 VAR
10740    op           : QuadOperator ;
10741    op1, op2, op3: CARDINAL ;
10742 BEGIN
10743    WHILE (start#end) AND (start#0) DO
10744       GetQuad(start, op, op1, op2, op3) ;
10745       IF op=InlineOp
10746       THEN
10747          RETURN( TRUE )
10748       END ;
10749       start := GetNextQuad(start)
10750    END ;
10751    RETURN( FALSE )
10752 END IsInlineWithinBlock ;
10753
10754
10755 (*
10756    AsmStatementsInBlock - returns TRUE if an ASM statement is found within a block, BlockSym.
10757 *)
10758
10759 PROCEDURE AsmStatementsInBlock (BlockSym: CARDINAL) : BOOLEAN ;
10760 VAR
10761    Scope,
10762    StartInit,
10763    EndInit,
10764    StartFinish,
10765    EndFinish    : CARDINAL ;
10766 BEGIN
10767    IF IsProcedure(BlockSym)
10768    THEN
10769       GetProcedureQuads(BlockSym, Scope, StartInit, EndInit) ;
10770       RETURN( IsInlineWithinBlock(StartInit, EndInit) )
10771    ELSE
10772       GetModuleQuads(BlockSym, StartInit, EndInit, StartFinish, EndFinish) ;
10773       RETURN( IsInlineWithinBlock(StartInit, EndInit) OR
10774               IsInlineWithinBlock(StartFinish, EndFinish) )
10775    END
10776 END AsmStatementsInBlock ;
10777
10778
10779 (*
10780    CheckVariablesInBlock - given a block, BlockSym, check whether all variables are used.
10781 *)
10782
10783 PROCEDURE CheckVariablesInBlock (BlockSym: CARDINAL) ;
10784 BEGIN
10785    CheckVariablesAndParameterTypesInBlock (BlockSym) ;
10786    IF UnusedVariableChecking OR UnusedParameterChecking
10787    THEN
10788       IF (NOT AsmStatementsInBlock (BlockSym))
10789       THEN
10790          CheckUninitializedVariablesAreUsed (BlockSym)
10791       END
10792    END
10793 END CheckVariablesInBlock ;
10794
10795
10796 (*
10797    CheckFunctionReturn - checks to see that a RETURN statement was present in a function.
10798 *)
10799
10800 PROCEDURE CheckFunctionReturn (ProcSym: CARDINAL) ;
10801 VAR
10802    Op           : QuadOperator ;
10803    Op1, Op2, Op3,
10804    Scope,
10805    Start, End   : CARDINAL ;
10806 BEGIN
10807    IF GetSType(ProcSym)#NulSym
10808    THEN
10809       (* yes it is a function *)
10810       GetProcedureQuads(ProcSym, Scope, Start, End) ;
10811       GetQuad(Start, Op, Op1, Op2, Op3) ;
10812       IF Start=0
10813       THEN
10814          InternalError ('incorrect start quad')
10815       END ;
10816       WHILE (Start#End) AND (Op#ReturnValueOp) AND (Op#InlineOp) DO
10817          Start := GetNextQuad(Start) ;
10818          GetQuad(Start, Op, Op1, Op2, Op3)
10819       END ;
10820       IF (Op#ReturnValueOp) AND (Op#InlineOp)
10821       THEN
10822          (* an InlineOp can always be used to emulate a RETURN *)
10823          MetaError1 ('procedure function {%1Ea} does not RETURN a value', ProcSym)
10824       END
10825    END
10826 END CheckFunctionReturn ;
10827
10828
10829 (*
10830    CheckReturnType - checks to see that the return type from currentProc is
10831                      assignment compatible with actualType.
10832 *)
10833
10834 PROCEDURE CheckReturnType (tokno: CARDINAL; currentProc, actualVal, actualType: CARDINAL) ;
10835 VAR
10836    procType: CARDINAL ;
10837    s1, s2  : String ;
10838    n1, n2  : Name ;
10839 BEGIN
10840    procType := GetSType (currentProc) ;
10841    IF procType = NulSym
10842    THEN
10843       MetaError1 ('attempting to RETURN a value from procedure {%1Ea} which was not a declared as a procedure function', currentProc)
10844    ELSIF AssignmentRequiresWarning (actualType, GetSType (currentProc))
10845    THEN
10846       MetaError2 ('attempting to RETURN a value {%1Wa} with an incompatible type {%1Wtsa} from a procedure function {%1a} which returns {%1tsa}', actualVal, currentProc)
10847    ELSIF NOT IsAssignmentCompatible (actualType, procType)
10848    THEN
10849       n1 := GetSymName(actualType) ;
10850       n2 := GetSymName(procType) ;
10851       WriteFormat2('attempting to RETURN a value with an incompatible type (%a) from a function which returns (%a)',
10852                    n1, n2)
10853    ELSIF IsProcedure(actualVal) AND (NOT IsAssignmentCompatible(actualVal, procType))
10854    THEN
10855 (*
10856       MetaWarnings2('attempting to RETURN a value with an incompatible type {%1ad} from function {%2a} which returns {%2ta}',
10857                     actualVal, currentProc)
10858
10859       --fixme--  introduce MetaWarning, MetaWarning2, MetaWarning3 into M2MetaError
10860 *)
10861       s1 := InitStringCharStar(KeyToCharStar(GetSymName(actualVal))) ;
10862       s2 := InitStringCharStar(KeyToCharStar(GetSymName(procType))) ;
10863       ErrorString(NewWarning(GetTokenNo()),
10864                   Sprintf2(Mark(InitString('attempting to RETURN a value with a (possibly on other targets) incompatible type (%s) from a function which returns (%s)')),
10865                            s1, s2))
10866    ELSIF IsProcedure(actualVal) AND (NOT IsAssignmentCompatible(actualVal, GetSType(CurrentProc)))
10867    THEN
10868       n1 := GetSymName(actualVal) ;
10869       n2 := GetSymName(GetSType(currentProc)) ;
10870       WriteFormat2('attempting to RETURN a value with an incompatible type (%a) from a function which returns (%a)',
10871                    n1, n2)
10872    ELSE
10873       (* this checks the types are compatible, not the data contents.  *)
10874       BuildRange (InitTypesAssignmentCheck (tokno, currentProc, actualVal))
10875    END
10876 END CheckReturnType ;
10877
10878
10879 (*
10880    BuildReturn - Builds the Return part of the procedure.
10881                  tokno is the location of the RETURN keyword.
10882                  The Stack is expected to contain:
10883
10884
10885                  Entry                   Exit
10886                  =====                   ====
10887
10888          Ptr ->
10889                  +------------+
10890                  | e1         |          Empty
10891                  |------------|
10892 *)
10893
10894 PROCEDURE BuildReturn (tokno: CARDINAL) ;
10895 VAR
10896    e2, t2,
10897    e1, t1,
10898    t, f,
10899    Des   : CARDINAL ;
10900 BEGIN
10901    IF IsBoolean (1)
10902    THEN
10903       PopBool(t, f) ;
10904       (* Des will be a boolean type *)
10905       Des := MakeTemporary (tokno, RightValue) ;
10906       PutVar (Des, Boolean) ;
10907       PushTF (Des, Boolean) ;
10908       PushBool (t, f) ;
10909       BuildAssignmentWithoutBounds (tokno, FALSE, TRUE) ;
10910       PushTF (Des, Boolean)
10911    END ;
10912    PopTF (e1, t1) ;
10913    IF e1 # NulSym
10914    THEN
10915       (* this will check that the type returned is compatible with
10916          the formal return type of the procedure.  *)
10917       CheckReturnType (tokno, CurrentProc, e1, t1) ;
10918       (* dereference LeftValue if necessary *)
10919       IF GetMode (e1) = LeftValue
10920       THEN
10921          t2 := GetSType (CurrentProc) ;
10922          e2 := MakeTemporary (tokno, RightValue) ;
10923          PutVar(e2, t2) ;
10924          CheckPointerThroughNil (tokno, e1) ;
10925          doIndrX (tokno, e2, e1) ;
10926          (* here we check the data contents to ensure no overflow.  *)
10927          BuildRange (InitReturnRangeCheck (tokno, CurrentProc, e2)) ;
10928          GenQuadO (tokno, ReturnValueOp, e2, NulSym, CurrentProc, FALSE)
10929       ELSE
10930          (* here we check the data contents to ensure no overflow.  *)
10931          BuildRange (InitReturnRangeCheck (tokno, CurrentProc, e1)) ;
10932          GenQuadO (tokno, ReturnValueOp, e1, NulSym, CurrentProc, FALSE)
10933       END
10934    END ;
10935    GenQuadO (tokno, GotoOp, NulSym, NulSym, PopWord(ReturnStack), FALSE) ;
10936    PushWord (ReturnStack, NextQuad-1)
10937 END BuildReturn ;
10938
10939
10940 (*
10941    IsReadOnly - a helper procedure function to detect constants.
10942 *)
10943
10944 PROCEDURE IsReadOnly (sym: CARDINAL) : BOOLEAN ;
10945 BEGIN
10946    RETURN IsConst (sym) OR (IsVar (sym) AND IsVarConst (sym))
10947 END IsReadOnly ;
10948
10949
10950 (*
10951    BuildDesignatorRecord - Builds the record referencing.
10952                            The Stack is expected to contain:
10953
10954
10955                            Entry                   Exit
10956                            =====                   ====
10957
10958                    Ptr ->
10959                            +--------------+
10960                            | n            |
10961                            |--------------|
10962                            | fld1 | type1 |
10963                            |--------------|
10964                            .              .
10965                            .              .
10966                            .              .
10967                            |--------------|
10968                            | fldn | typen |                        <- Ptr
10969                            |--------------|        +-------------+
10970                            | Sym  | Type  |        | S    | type1|
10971                            |--------------|        |-------------|
10972 *)
10973
10974 PROCEDURE BuildDesignatorRecord (dottok: CARDINAL) ;
10975 VAR
10976    RecordTok,
10977    FieldTok,
10978    combinedtok: CARDINAL ;
10979    n, rw,
10980    Field,
10981    FieldType,
10982    RecordSym,
10983    Res        : CARDINAL ;
10984 BEGIN
10985    PopT(n) ;
10986    RecordSym := OperandT (n+1) ;
10987    (* RecordType could be found by:  SkipType (OperandF (n+1)).  *)
10988    RecordTok := OperandTok (n+1) ;
10989    rw := OperandMergeRW (n+1) ;
10990    Assert (IsLegal (rw)) ;
10991    Field := OperandT (n) ;
10992    FieldType := SkipType (OperandF (n)) ;
10993    FieldTok := OperandTok (n) ;
10994    combinedtok := MakeVirtualTok (dottok, RecordTok, FieldTok) ;
10995    IF n>1
10996    THEN
10997       InternalError ('not expecting to see n>1')
10998    END ;
10999    IF IsUnused (Field)
11000    THEN
11001       MetaErrors1 ('record field {%1Dad} was declared as unused by a pragma',
11002                    'record field {%1ad} is being used after being declared as unused by a pragma', Field)
11003    END ;
11004    Res := MakeComponentRef (MakeComponentRecord (combinedtok,
11005                                                  RightValue, RecordSym), Field) ;
11006    PutVarConst (Res, IsReadOnly (RecordSym)) ;
11007    GenQuadO (combinedtok, RecordFieldOp, Res, RecordSym, Field, FALSE) ;
11008    PopN (n+1) ;
11009    PushTFrwtok (Res, FieldType, rw, combinedtok)
11010 END BuildDesignatorRecord ;
11011
11012
11013 (*
11014    BuildDesignatorError - removes the designator from the stack and replaces
11015                           it with an error symbol.
11016 *)
11017
11018 PROCEDURE BuildDesignatorError (message: ARRAY OF CHAR) ;
11019 VAR
11020    combinedTok,
11021    arrayTok,
11022    exprTok    : CARDINAL ;
11023    e, d, error,
11024    Sym,
11025    Type       : CARDINAL ;
11026 BEGIN
11027    PopTtok (e, exprTok) ;
11028    PopTFDtok (Sym, Type, d, arrayTok) ;
11029    combinedTok := MakeVirtualTok (arrayTok, arrayTok, exprTok) ;
11030    error := MakeError (combinedTok, MakeKey (message)) ;
11031    PushTFDtok (error, Type, d, arrayTok)
11032 END BuildDesignatorError ;
11033
11034
11035
11036 (*
11037    BuildDesignatorArray - Builds the array referencing.
11038                           The purpose of this procedure is to work out
11039                           whether the DesignatorArray is a static or
11040                           dynamic array and to call the appropriate
11041                           BuildRoutine.
11042
11043                           The Stack is expected to contain:
11044
11045
11046                           Entry                   Exit
11047                           =====                   ====
11048
11049                   Ptr ->
11050                           +--------------+
11051                           | e            |                        <- Ptr
11052                           |--------------|        +------------+
11053                           | Sym  | Type  |        | S    | T   |
11054                           |--------------|        |------------|
11055 *)
11056
11057 PROCEDURE BuildDesignatorArray ;
11058 VAR
11059    combinedTok,
11060    arrayTok,
11061    exprTok    : CARDINAL ;
11062    e, t, d,
11063    Sym,
11064    Type       : CARDINAL ;
11065 BEGIN
11066    IF IsConst (OperandT (2)) AND IsConstructor (OperandT (2))
11067    THEN
11068       t := GetDType (OperandT (2)) ;
11069       IF t = NulSym
11070       THEN
11071          InternalError ('constructor type should have been resolved')
11072       ELSIF IsArray (t)
11073       THEN
11074          PopTtok (e, exprTok) ;
11075          PopTFDtok (Sym, Type, d, arrayTok) ;
11076          t := MakeTemporary (exprTok, RightValue) ;
11077          PutVar (t, Type) ;
11078          PushTFtok (t, GetSType(t), exprTok) ;
11079          PushTtok (Sym, arrayTok) ;
11080          combinedTok := MakeVirtualTok (arrayTok, arrayTok, exprTok) ;
11081          PutVarConst (t, TRUE) ;
11082          BuildAssignConstant (combinedTok) ;
11083          PushTFDtok (t, GetDType(t), d, arrayTok) ;
11084          PushTtok (e, exprTok)
11085       END
11086    END ;
11087    IF (NOT IsVar (OperandT (2))) AND (NOT IsTemporary (OperandT (2)))
11088    THEN
11089       MetaErrorT1 (OperandTtok (2),
11090                    'can only access arrays using variables or formal parameters not {%1Ead}',
11091                    OperandT (2)) ;
11092       BuildDesignatorError ('bad array access')
11093    END ;
11094    Sym := OperandT (2) ;
11095    Type := GetDType (Sym) ;
11096    arrayTok := OperandTtok (2) ;
11097    IF Type = NulSym
11098    THEN
11099       IF (arrayTok = UnknownTokenNo) OR (arrayTok = BuiltinTokenNo)
11100       THEN
11101          arrayTok := GetTokenNo ()
11102       END ;
11103       MetaErrorT0 (arrayTok, "type of array is undefined") ;
11104       BuildDesignatorError ('bad array access')
11105    ELSIF IsUnbounded (Type)
11106    THEN
11107       BuildDynamicArray
11108    ELSIF IsArray (Type)
11109    THEN
11110       BuildStaticArray
11111    ELSE
11112       MetaErrorT1 (arrayTok,
11113                    'can only index static or dynamic arrays, {%1Ead} is not an array but a {%tad}',
11114                    Sym) ;
11115       BuildDesignatorError ('bad array access')
11116    END
11117 END BuildDesignatorArray ;
11118
11119
11120 (*
11121    BuildStaticArray - Builds the array referencing for static arrays.
11122                       The Stack is expected to contain:
11123
11124
11125                       Entry                   Exit
11126                       =====                   ====
11127
11128               Ptr ->
11129                       +--------------+
11130                       | e            |                       <- Ptr
11131                       |--------------|        +------------+
11132                       | Sym  | Type  |        | S    | T   |
11133                       |--------------|        |------------|
11134 *)
11135
11136 PROCEDURE BuildStaticArray ;
11137 VAR
11138    combinedTok,
11139    indexTok,
11140    arrayTok   : CARDINAL ;
11141    rw,
11142    Dim,
11143    Array,
11144    Index,
11145    BackEndType,
11146    Type, Adr  : CARDINAL ;
11147 BEGIN
11148    Index := OperandT (1) ;
11149    indexTok := OperandTtok (1) ;
11150    Array  := OperandT (2) ;
11151    arrayTok := OperandTtok (2) ;
11152    Type := SkipType (OperandF (2)) ;
11153    rw := OperandMergeRW (2) ;
11154    Assert (IsLegal (rw)) ;
11155    Dim := OperandD (2) ;
11156    INC (Dim) ;
11157    IF GetMode (Index)=LeftValue
11158    THEN
11159       Index := MakeRightValue (indexTok, Index, GetSType (Index))
11160    END ;
11161    BuildRange (InitStaticArraySubscriptRangeCheck (GetArraySubscript (Type), Index, Dim)) ;
11162
11163    (* now make Adr point to the address of the indexed element *)
11164    combinedTok := MakeVirtualTok (arrayTok, arrayTok, indexTok) ;
11165    Adr := MakeTemporary (combinedTok, LeftValue) ;
11166    IF IsVar (Array)
11167    THEN
11168       (* BuildDesignatorArray may have detected des is a constant.  *)
11169       PutVarConst (Adr, IsVarConst (Array))
11170    END ;
11171    (*
11172       From now on it must reference the array element by its lvalue
11173       - so we create the type of the referenced entity
11174    *)
11175
11176    BackEndType := MakePointer (combinedTok, NulName) ;
11177    PutPointer (BackEndType, GetDType (Type)) ;
11178    (* PutVar(Adr, BackEndType) ; *)
11179    PutLeftValueFrontBackType (Adr, GetDType (Type), BackEndType) ;
11180
11181    GenQuadO (combinedTok, ArrayOp, Adr, Index, Array, TRUE) ;
11182    PopN (2) ;   (* remove all parameters to this procedure *)
11183    PushTFDrwtok (Adr, GetSType (Adr), Dim, rw, combinedTok)
11184 END BuildStaticArray ;
11185
11186
11187 (*
11188    calculateMultipicand - generates quadruples which calculate the
11189                           multiplicand for the array at dimension, dim.
11190 *)
11191
11192 PROCEDURE calculateMultipicand (tok: CARDINAL;
11193                                 arraySym, arrayType: CARDINAL; dim: CARDINAL) : CARDINAL ;
11194 VAR
11195    ti, tj, tk, tl: CARDINAL ;
11196 BEGIN
11197    IF dim = GetDimension (arrayType)
11198    THEN
11199       (* ti has no type since constant *)
11200       ti := MakeTemporary (tok, ImmediateValue) ;
11201       PutVar(ti, Cardinal) ;
11202       GenQuadO (tok, ElementSizeOp, ti, arrayType, 1, TRUE)
11203    ELSE
11204       INC(dim) ;
11205       tk := MakeTemporary (tok, RightValue) ;
11206       PutVar(tk, Cardinal) ;
11207       GenHigh (tok, tk, dim, arraySym) ;
11208       tl := MakeTemporary (tok, RightValue) ;
11209       PutVar(tl, Cardinal) ;
11210       GenQuadO (tok, AddOp, tl, tk, MakeConstLit (tok, MakeKey ('1'), Cardinal), TRUE) ;
11211       tj := calculateMultipicand (tok, arraySym, arrayType, dim) ;
11212       ti := MakeTemporary (tok, RightValue) ;
11213       PutVar (ti, Cardinal) ;
11214       GenQuadO (tok, MultOp, ti, tj, tl, TRUE)
11215    END ;
11216    RETURN ti
11217 END calculateMultipicand ;
11218
11219
11220 (*
11221    BuildDynamicArray - Builds the array referencing for dynamic arrays.
11222                        The Stack is expected to contain:
11223
11224
11225                        Entry                          Exit
11226                        =====                          ====
11227
11228                Ptr ->
11229                        +-----------------------+
11230                        | Index                 |                                    <- Ptr
11231                        |-----------------------|      +---------------------------+
11232                        | ArraySym | Type | Dim |      | S  | T | ArraySym | Dim+1 |
11233                        |-----------------------|      |---------------------------|
11234
11235
11236    if Dim=1
11237    then
11238       S := base of ArraySym + TSIZE(Type)*Index
11239    else
11240       S := S + TSIZE(Type)*Index
11241    fi
11242 *)
11243
11244 PROCEDURE BuildDynamicArray ;
11245 VAR
11246    combinedTok,
11247    arrayTok,
11248    indexTok     : CARDINAL ;
11249    Sym, idx,
11250    Type, Adr,
11251    ArraySym,
11252    BackEndType,
11253    UnboundedType,
11254    PtrToBase,
11255    Base,
11256    Dim, rw,
11257    ti, tj, tk   : CARDINAL ;
11258 BEGIN
11259    DisplayStack ;
11260    Sym  := OperandT (2) ;
11261    Type := SkipType (OperandF (2)) ;
11262    arrayTok := OperandTok (2) ;
11263    indexTok := OperandTok (1) ;
11264    combinedTok := MakeVirtualTok (arrayTok, arrayTok, indexTok) ;
11265    Dim := OperandD (2) ;
11266    rw := OperandMergeRW (2) ;
11267    Assert (IsLegal (rw)) ;
11268    INC (Dim) ;
11269    IF Dim = 1
11270    THEN
11271       (*
11272          Base has type address since
11273          BuildDesignatorRecord references by address.
11274
11275          Build a record for retrieving the address of dynamic array.
11276          BuildDesignatorRecord will generate the required quadruples,
11277          therefore build sets up the stack for BuildDesignatorRecord
11278          which will generate the quads to access the record.
11279       *)
11280       ArraySym := Sym ;
11281       UnboundedType := GetUnboundedRecordType (GetSType (Sym)) ;
11282       PushTFrwtok (Sym, UnboundedType, rw, arrayTok) ;
11283       PushTF (GetUnboundedAddressOffset (GetSType (Sym)),
11284               GetSType (GetUnboundedAddressOffset (GetSType (Sym)))) ;
11285       PushT (1) ;  (* One record field to dereference *)
11286       BuildDesignatorRecord (combinedTok) ;
11287       PopT (PtrToBase) ;
11288       DisplayStack ;
11289       (* Now actually copy Unbounded.ArrayAddress into base *)
11290       IF GetMode(PtrToBase) = LeftValue
11291       THEN
11292          Base := MakeTemporary (arrayTok, RightValue) ;
11293          PutVar (Base, Address) ;           (* has type ADDRESS *)
11294          CheckPointerThroughNil (arrayTok, PtrToBase) ;
11295          GenQuad (IndrXOp, Base, Address, PtrToBase)           (* Base = *PtrToBase *)
11296       ELSE
11297          Assert (GetMode (PtrToBase) # ImmediateValue) ;
11298          Base := PtrToBase
11299       END
11300    ELSE
11301       (* Base already calculated previously and pushed to stack *)
11302       UnboundedType := SkipType (OperandF (2)) ;
11303       Base := Sym ;
11304       ArraySym := OperandA (2)
11305    END ;
11306    Assert (GetSType (Sym) = Type) ;
11307    ti := calculateMultipicand (indexTok, Sym, Type, Dim) ;
11308    idx := OperandT (1) ;
11309    IF IsConst (idx)
11310    THEN
11311       (* tj has no type since constant *)
11312       tj := MakeTemporary (indexTok, ImmediateValue) ;
11313       tk := MakeTemporary (indexTok, ImmediateValue) ;
11314       PutVar (tj, Cardinal) ;
11315       PutVar (tk, Cardinal)
11316    ELSE
11317       (* tj has Cardinal type since we have multiplied array indices *)
11318       tj := MakeTemporary (indexTok, RightValue) ;
11319       IF GetSType (idx) # Cardinal
11320       THEN
11321          PushTF (RequestSym (indexTok, MakeKey ('CONVERT')), NulSym) ;
11322          PushT (Cardinal) ;
11323          PushTtok (idx, indexTok) ;
11324          PushT(2) ;          (* Two parameters *)
11325          BuildConvertFunction ;
11326          PopT (idx)
11327       END ;
11328       PutVar (tj, Cardinal) ;
11329       tk := MakeTemporary (indexTok, RightValue) ;
11330       PutVar (tk, Cardinal)
11331    END ;
11332    BuildRange (InitDynamicArraySubscriptRangeCheck (ArraySym, idx, Dim)) ;
11333
11334    PushTtok (tj, indexTok) ;
11335    PushTtok (idx, indexTok) ;
11336    BuildAssignmentWithoutBounds (indexTok, FALSE, TRUE) ;
11337
11338    GenQuad (MultOp, tk, ti, tj) ;
11339    Adr := MakeTemporary (combinedTok, LeftValue) ;
11340    (*
11341       Ok must reference by address
11342       - but we contain the type of the referenced entity
11343    *)
11344    BackEndType := MakePointer (combinedTok, NulName) ;
11345    PutPointer (BackEndType, GetSType (Type)) ;
11346
11347    IF Dim = GetDimension (Type)
11348    THEN
11349       PutLeftValueFrontBackType (Adr, GetSType(Type), BackEndType) ;
11350
11351       GenQuad (AddOp, Adr, Base, tk) ;
11352       PopN (2) ;
11353       PushTFADrwtok (Adr, GetSType(Adr), ArraySym, Dim, rw, combinedTok)
11354    ELSE
11355       (* more to index *)
11356       PutLeftValueFrontBackType (Adr, Type, BackEndType) ;
11357
11358       GenQuad (AddOp, Adr, Base, tk) ;
11359       PopN (2) ;
11360       PushTFADrwtok (Adr, GetSType(Adr), ArraySym, Dim, rw, combinedTok)
11361    END
11362 END BuildDynamicArray ;
11363
11364
11365 (*
11366    BuildDesignatorPointer - Builds a pointer reference.
11367                             The Stack is expected to contain:
11368
11369
11370                             Entry                   Exit
11371                             =====                   ====
11372
11373                     Ptr ->                                           <- Ptr
11374                             +--------------+        +--------------+
11375                             | Sym1  | Type1|        | Sym2  | Type2|
11376                             |--------------|        |--------------|
11377 *)
11378
11379 PROCEDURE BuildDesignatorPointer (ptrtok: CARDINAL) ;
11380 VAR
11381    combinedtok,
11382    exprtok    : CARDINAL ;
11383    rw,
11384    Sym1, Type1,
11385    Sym2, Type2: CARDINAL ;
11386 BEGIN
11387    PopTFrwtok (Sym1, Type1, rw, exprtok) ;
11388    Type1 := SkipType (Type1) ;
11389    IF IsUnknown (Sym1)
11390    THEN
11391       MetaError1 ('{%1EMad} is undefined and therefore {%1ad}^ cannot be resolved', Sym1)
11392    ELSIF IsPointer (Type1)
11393    THEN
11394       Type2 := GetSType (Type1) ;
11395       Sym2 := MakeTemporary (ptrtok, LeftValue) ;
11396       (*
11397          Ok must reference by address
11398          - but we contain the type of the referenced entity
11399       *)
11400       MarkAsRead (rw) ;
11401       PutVarPointerCheck (Sym1, TRUE) ;
11402       CheckPointerThroughNil (ptrtok, Sym1) ;
11403       IF GetMode (Sym1) = LeftValue
11404       THEN
11405          rw := NulSym ;
11406          PutLeftValueFrontBackType (Sym2, Type2, Type1) ;
11407          GenQuad (IndrXOp, Sym2, Type1, Sym1)            (* Sym2 := *Sym1 *)
11408       ELSE
11409          PutLeftValueFrontBackType (Sym2, Type2, NulSym) ;
11410          GenQuad (BecomesOp, Sym2, NulSym, Sym1)         (* Sym2 :=  Sym1 *)
11411       END ;
11412       PutVarPointerCheck (Sym2, TRUE) ;       (* we should check this for *)
11413                                      (* Sym2 later on (pointer via NIL)   *)
11414       combinedtok := MakeVirtualTok (exprtok, exprtok, ptrtok) ;
11415       PushTFrwtok (Sym2, Type2, rw, combinedtok)
11416    ELSE
11417       MetaError2 ('{%1ad} is not a pointer type but a {%2d}', Sym1, Type1)
11418    END
11419 END BuildDesignatorPointer ;
11420
11421
11422 (*
11423    StartBuildWith - performs the with statement.
11424                     The Stack:
11425
11426                     Entry                    Exit
11427
11428                     +------------+
11429                     | Sym | Type |           Empty
11430                     |------------|
11431 *)
11432
11433 PROCEDURE StartBuildWith (withTok: CARDINAL) ;
11434 VAR
11435    tok      : CARDINAL ;
11436    Sym, Type,
11437    Ref      : CARDINAL ;
11438 BEGIN
11439    DisplayStack ;
11440    PopTFtok (Sym, Type, tok) ;
11441    Type := SkipType (Type) ;
11442
11443    Ref := MakeTemporary (tok, LeftValue) ;
11444    PutVar (Ref, Type) ;
11445    IF GetMode (Sym) = LeftValue
11446    THEN
11447       (* copy LeftValue *)
11448       GenQuadO (tok, BecomesOp, Ref, NulSym, Sym, TRUE)
11449    ELSE
11450       (* calculate the address of Sym *)
11451       GenQuadO (tok, AddrOp, Ref, NulSym, Sym, TRUE)
11452    END ;
11453
11454    PushWith (Sym, Type, Ref, tok) ;
11455    IF Type = NulSym
11456    THEN
11457       MetaError1 ('{%1Ea} {%1d} has a no type, the {%kWITH} statement requires a variable or parameter of a {%kRECORD} type',
11458                   Sym)
11459    ELSIF NOT IsRecord(Type)
11460    THEN
11461       MetaError1 ('the {%kWITH} statement requires that {%1Ea} {%1d} be of a {%kRECORD} {%1tsa:type rather than {%1tsa}}',
11462                    Sym)
11463    END ;
11464    StartScope (Type)
11465  ; DisplayStack ;
11466 END StartBuildWith ;
11467
11468
11469 (*
11470    EndBuildWith - terminates the innermost with scope.
11471 *)
11472
11473 PROCEDURE EndBuildWith ;
11474 BEGIN
11475    DisplayStack ;
11476    EndScope ;
11477    PopWith
11478  ; DisplayStack ;
11479 END EndBuildWith ;
11480
11481
11482 (*
11483    PushWith - pushes sym and type onto the with stack. It checks for
11484               previous declaration of this record type.
11485 *)
11486
11487 PROCEDURE PushWith (Sym, Type, Ref, Tok: CARDINAL) ;
11488 VAR
11489    i, n: CARDINAL ;
11490    f   : WithFrame ;
11491 BEGIN
11492    IF Pedantic
11493    THEN
11494       n := NoOfItemsInStackAddress(WithStack) ;
11495       i := 1 ;  (* top of the stack *)
11496       WHILE i <= n DO
11497          (* Search for other declarations of the with using Type *)
11498          f := PeepAddress(WithStack, i) ;
11499          IF f^.RecordSym=Type
11500          THEN
11501             MetaErrorT1 (Tok,
11502                          'cannot have nested {%kWITH} statements referencing the same {%kRECORD} {%1Ead}',
11503                          Sym) ;
11504             MetaErrorT1 (f^.RecordTokPos,
11505                          'cannot have nested {%kWITH} statements referencing the same {%kRECORD} {%1Ead}',
11506                          f^.RecordSym)
11507          END ;
11508          INC (i)
11509       END
11510    END ;
11511    NEW (f) ;
11512    WITH f^ DO
11513       RecordSym    := Sym ;
11514       RecordType   := Type ;
11515       RecordRef    := Ref ;
11516       rw           := Sym ;
11517       RecordTokPos := Tok
11518    END ;
11519    PushAddress (WithStack, f)
11520 END PushWith ;
11521
11522
11523 PROCEDURE PopWith ;
11524 VAR
11525    f: WithFrame ;
11526 BEGIN
11527    f := PopAddress (WithStack) ;
11528    DISPOSE (f)
11529 END PopWith ;
11530
11531
11532 (*
11533    CheckWithReference - performs the with statement.
11534                         The Stack:
11535
11536                         Entry                    Exit
11537
11538                         +------------+           +------------+
11539                         | Sym | Type |           | Sym | Type |
11540                         |------------|           |------------|
11541 *)
11542
11543 PROCEDURE CheckWithReference ;
11544 VAR
11545    f        : WithFrame ;
11546    tokpos,
11547    i, n, rw,
11548    Sym, Type: CARDINAL ;
11549 BEGIN
11550    n := NoOfItemsInStackAddress(WithStack) ;
11551    IF (n>0) AND (NOT SuppressWith)
11552    THEN
11553       PopTFrwtok (Sym, Type, rw, tokpos) ;
11554       Assert (tokpos # UnknownTokenNo) ;
11555       (* inner WITH always has precidence *)
11556       i := 1 ;  (* top of stack *)
11557       WHILE i<=n DO
11558          (* WriteString('Checking for a with') ; *)
11559          f := PeepAddress (WithStack, i) ;
11560          WITH f^ DO
11561             IF IsRecordField (Sym) AND (GetRecord (GetParent (Sym)) = RecordType)
11562             THEN
11563                IF IsUnused (Sym)
11564                THEN
11565                   MetaError1('record field {%1Dad} was declared as unused by a pragma', Sym)
11566                END ;
11567                (* Fake a RecordSym.op *)
11568                PushTFrwtok (RecordRef, RecordType, rw, RecordTokPos) ;
11569                PushTFtok (Sym, Type, tokpos) ;
11570                BuildAccessWithField ;
11571                PopTFrw (Sym, Type, rw) ;
11572                i := n+1  (* Finish loop.  *)
11573             ELSE
11574                INC (i)
11575             END
11576          END
11577       END ;
11578       PushTFrwtok (Sym, Type, rw, tokpos)
11579    END
11580 END CheckWithReference ;
11581
11582
11583 (*
11584    BuildAccessWithField - similar to BuildDesignatorRecord except it
11585                           does not perform the address operation.
11586                           The address will have been computed at the
11587                           beginning of the WITH statement.
11588                           It also stops the GenQuad procedure from examining the
11589                           with stack.
11590
11591                           The Stack
11592
11593                           Entry
11594
11595                    Ptr ->
11596                           +--------------+
11597                           | Field | Type1|                          <- Ptr
11598                           |-------|------|          +-------------+
11599                           | Adr   | Type2|          | Sym  | Type1|
11600                           |--------------|          |-------------|
11601 *)
11602
11603 PROCEDURE BuildAccessWithField ;
11604 VAR
11605    rectok, fieldtok  : CARDINAL ;
11606    OldSuppressWith   : BOOLEAN ;
11607    rw,
11608    Field, FieldType,
11609    Record, RecordType,
11610    Ref               : CARDINAL ;
11611 BEGIN
11612    OldSuppressWith := SuppressWith ;
11613    SuppressWith := TRUE ;
11614    (*
11615       now the WITH cannot look at the stack of outstanding WITH records.
11616    *)
11617    PopTFtok (Field, FieldType, fieldtok) ;
11618    PopTFrwtok (Record, RecordType, rw, rectok) ;
11619
11620    Ref := MakeComponentRef (MakeComponentRecord (fieldtok,
11621                                                  RightValue, Record), Field) ;
11622    PutVarConst (Ref, IsReadOnly (Record)) ;
11623    GenQuadO (fieldtok,
11624              RecordFieldOp, Ref, Record, Field, TRUE) ;
11625
11626    PushTFrwtok (Ref, FieldType, rw, fieldtok) ;
11627    SuppressWith := OldSuppressWith
11628 END BuildAccessWithField ;
11629
11630
11631 (*
11632    BuildNulExpression - Builds a nul expression on the stack.
11633                         The Stack:
11634
11635                         Entry             Exit
11636
11637                                                          <- Ptr
11638                         Empty             +------------+
11639                                           | NulSym     |
11640                                           |------------|
11641 *)
11642
11643 PROCEDURE BuildNulExpression ;
11644 BEGIN
11645    PushT(NulSym)
11646 END BuildNulExpression ;
11647
11648
11649 (*
11650    BuildTypeForConstructor - pushes the type implied by the current constructor.
11651                              If no constructor is currently being built then
11652                              it Pushes a Bitset type.
11653 *)
11654
11655 PROCEDURE BuildTypeForConstructor ;
11656 VAR
11657    c: ConstructorFrame ;
11658 BEGIN
11659    IF NoOfItemsInStackAddress(ConstructorStack)=0
11660    THEN
11661       PushT(Bitset)
11662    ELSE
11663       c := PeepAddress(ConstructorStack, 1) ;
11664       WITH c^ DO
11665          IF IsArray(type) OR IsSet(type)
11666          THEN
11667             PushT(GetSType(type))
11668          ELSIF IsRecord(type)
11669          THEN
11670             PushT(GetSType(GetNth(type, index)))
11671          ELSE
11672             MetaError1('{%1ad} is not a set, record or array type which is expected when constructing an aggregate entity',
11673                        type)
11674          END
11675       END
11676    END
11677 END BuildTypeForConstructor ;
11678
11679
11680 (*
11681    BuildSetStart - Pushes a Bitset type on the stack.
11682
11683                       The Stack:
11684
11685                       Entry             Exit
11686
11687                Ptr ->                                        <- Ptr
11688
11689                       Empty             +--------------+
11690                                         | Bitset       |
11691                                         |--------------|
11692 *)
11693
11694 PROCEDURE BuildSetStart ;
11695 BEGIN
11696    PushT(Bitset)
11697 END BuildSetStart ;
11698
11699
11700 (*
11701    BuildSetEnd - pops the set value and type from the stack
11702                  and pushes the value,type pair.
11703
11704                     Entry                   Exit
11705
11706              Ptr ->
11707                     +--------------+
11708                     | Set Value    |                         <- Ptr
11709                     |--------------|        +--------------+
11710                     | Set Type     |        | Value | Type |
11711                     |--------------|        |--------------|
11712 *)
11713
11714 PROCEDURE BuildSetEnd ;
11715 VAR
11716    v, t: CARDINAL ;
11717 BEGIN
11718    PopT(v) ;
11719    PopT(t) ;
11720    PushTF(v, t) ;
11721    Assert(IsSet(t))
11722 END BuildSetEnd ;
11723
11724
11725 (*
11726    BuildEmptySet - Builds an empty set on the stack.
11727                    The Stack:
11728
11729                    Entry             Exit
11730
11731                                                      <- Ptr
11732                                      +-------------+
11733             Ptr ->                   | Value       |
11734                    +-----------+     |-------------|
11735                    | SetType   |     | SetType     |
11736                    |-----------|     |-------------|
11737
11738 *)
11739
11740 PROCEDURE BuildEmptySet ;
11741 VAR
11742    n     : Name ;
11743    Type  : CARDINAL ;
11744    NulSet: CARDINAL ;
11745    tok   : CARDINAL ;
11746 BEGIN
11747    PopT(Type) ;  (* type of set we are building *)
11748    tok := GetTokenNo () ;
11749    IF (Type=NulSym) AND Pim
11750    THEN
11751       (* allowed generic {} in PIM Modula-2 *)
11752    ELSIF IsUnknown(Type)
11753    THEN
11754       n := GetSymName(Type) ;
11755       WriteFormat1('set type %a is undefined', n) ;
11756       Type := Bitset
11757    ELSIF NOT IsSet(SkipType(Type))
11758    THEN
11759       n := GetSymName(Type) ;
11760       WriteFormat1('expecting a set type %a', n) ;
11761       Type := Bitset
11762    ELSE
11763       Type := SkipType(Type) ;
11764       Assert((Type#NulSym))
11765    END ;
11766    NulSet := MakeTemporary(tok, ImmediateValue) ;
11767    PutVar(NulSet, Type) ;
11768    PutConstSet(NulSet) ;
11769    IF CompilerDebugging
11770    THEN
11771       n := GetSymName(Type) ;
11772       printf1('set type = %a\n', n)
11773    END ;
11774    PushNulSet(Type) ;   (* onto the ALU stack  *)
11775    PopValue(NulSet) ;   (* ALU -> symbol table *)
11776
11777    (* and now construct the M2Quads stack as defined by the comments above *)
11778    PushT(Type) ;
11779    PushT(NulSet) ;
11780    IF CompilerDebugging
11781    THEN
11782       n := GetSymName(Type) ;
11783       printf2('Type = %a  (%d)  built empty set\n', n, Type) ;
11784       DisplayStack    (* Debugging info *)
11785    END
11786 END BuildEmptySet ;
11787
11788
11789 (*
11790    BuildInclRange - includes a set range with a set.
11791
11792
11793                           Entry                   Exit
11794                           =====                   ====
11795
11796
11797                    Ptr ->
11798                           +------------+
11799                           | El2        |
11800                           |------------|
11801                           | El1        |                                 <- Ptr
11802                           |------------|           +-------------------+
11803                           | Set Value  |           | Value + {El1..El2}|
11804                           |------------|           |-------------------|
11805
11806                    No quadruples produced as the range info is contained within
11807                    the set value.
11808 *)
11809
11810 PROCEDURE BuildInclRange ;
11811 VAR
11812    n       : Name ;
11813    el1, el2,
11814    value   : CARDINAL ;
11815 BEGIN
11816    PopT(el2) ;
11817    PopT(el1) ;
11818    PopT(value) ;
11819    IF NOT IsConstSet(value)
11820    THEN
11821       n := GetSymName(el1) ;
11822       WriteFormat1('can only add bit ranges to a constant set, %a is not a constant set', n)
11823    END ;
11824    IF IsConst(el1) AND IsConst(el2)
11825    THEN
11826       PushValue(value) ;  (* onto ALU stack *)
11827       AddBitRange(GetTokenNo(), el1, el2) ;
11828       PopValue(value)     (* ALU -> symboltable *)
11829    ELSE
11830       IF NOT IsConst(el1)
11831       THEN
11832          n := GetSymName(el1) ;
11833          WriteFormat1('must use constants as ranges when defining a set constant, problem with the low value %a', n)
11834       END ;
11835       IF NOT IsConst(el2)
11836       THEN
11837          n := GetSymName(el2) ;
11838          WriteFormat1('must use constants as ranges when defining a set constant, problem with the high value %a', n)
11839       END
11840    END ;
11841    PushT(value)
11842 END BuildInclRange ;
11843
11844
11845 (*
11846    BuildInclBit - includes a bit into the set.
11847
11848                          Entry                   Exit
11849                          =====                   ====
11850
11851
11852                   Ptr ->
11853                          +------------+
11854                          | Element    |                         <- Ptr
11855                          |------------|          +------------+
11856                          | Value      |          | Value      |
11857                          |------------|          |------------|
11858
11859 *)
11860
11861 PROCEDURE BuildInclBit ;
11862 VAR
11863    tok         : CARDINAL ;
11864    el, value, t: CARDINAL ;
11865 BEGIN
11866    PopT(el) ;
11867    PopT(value) ;
11868    tok := GetTokenNo () ;
11869    IF IsConst(el)
11870    THEN
11871       PushValue(value) ;  (* onto ALU stack *)
11872       AddBit(tok, el) ;
11873       PopValue(value)    (* ALU -> symboltable *)
11874    ELSE
11875       IF GetMode(el)=LeftValue
11876       THEN
11877          t := MakeTemporary(tok, RightValue) ;
11878          PutVar(t, GetSType(el)) ;
11879          CheckPointerThroughNil (tok, el) ;
11880          doIndrX(tok, t, el) ;
11881          el := t
11882       END ;
11883       IF IsConst(value)
11884       THEN
11885          (* move constant into a variable to achieve the include *)
11886          t := MakeTemporary(tok, RightValue) ;
11887          PutVar(t, GetSType(value)) ;
11888          GenQuad(BecomesOp, t, NulSym, value) ;
11889          value := t
11890       END ;
11891       GenQuad(InclOp, value, NulSym, el)
11892    END ;
11893    PushT(value)
11894 END BuildInclBit ;
11895
11896
11897 (*
11898    PushConstructor -
11899 *)
11900
11901 PROCEDURE PushConstructor (sym: CARDINAL) ;
11902 VAR
11903    c: ConstructorFrame ;
11904 BEGIN
11905    NEW(c) ;
11906    WITH c^ DO
11907       type := SkipType(sym) ;
11908       index := 1
11909    END ;
11910    PushAddress(ConstructorStack, c)
11911 END PushConstructor ;
11912
11913
11914 (*
11915    PopConstructor - removes the top constructor from the top of stack.
11916 *)
11917
11918 PROCEDURE PopConstructor ;
11919 VAR
11920    c: ConstructorFrame ;
11921 BEGIN
11922    c := PopAddress (ConstructorStack) ;
11923    DISPOSE(c)
11924 END PopConstructor ;
11925
11926
11927 (*
11928    NextConstructorField - increments the top of constructor stacks index by one.
11929 *)
11930
11931 PROCEDURE NextConstructorField ;
11932 VAR
11933    c: ConstructorFrame ;
11934 BEGIN
11935    c := PeepAddress(ConstructorStack, 1) ;
11936    INC(c^.index)
11937 END NextConstructorField ;
11938
11939
11940 (*
11941    SilentBuildConstructor - places NulSym into the constructor fifo queue.
11942 *)
11943
11944 PROCEDURE SilentBuildConstructor ;
11945 BEGIN
11946    PutConstructorIntoFifoQueue (NulSym)
11947 END SilentBuildConstructor ;
11948
11949
11950 (*
11951    BuildConstructor - builds a constructor.
11952                       Stack
11953
11954                       Entry                 Exit
11955
11956                Ptr ->
11957                       +------------+
11958                       | Type       |                <- Ptr
11959                       |------------+
11960 *)
11961
11962 PROCEDURE BuildConstructor (tokcbrpos: CARDINAL) ;
11963 VAR
11964    tok       : CARDINAL ;
11965    constValue,
11966    type      : CARDINAL ;
11967 BEGIN
11968    PopTtok (type, tok) ;
11969    constValue := MakeTemporary (tok, ImmediateValue) ;
11970    PutVar (constValue, type) ;
11971    PutConstructor (constValue) ;
11972    PushValue (constValue) ;
11973    IF type = NulSym
11974    THEN
11975       MetaErrorT0 (tokcbrpos,
11976                    '{%E}constructor requires a type before the opening {')
11977    ELSE
11978       ChangeToConstructor (tok, type) ;
11979       PutConstructorFrom (constValue, type) ;
11980       PopValue (constValue) ;
11981       PutConstructorIntoFifoQueue (constValue)
11982    END ;
11983    PushConstructor (type)
11984 END BuildConstructor ;
11985
11986
11987 (*
11988    SilentBuildConstructorStart - removes an entry from the constructor fifo queue.
11989 *)
11990
11991 PROCEDURE SilentBuildConstructorStart ;
11992 VAR
11993    constValue: CARDINAL ;
11994 BEGIN
11995    GetConstructorFromFifoQueue (constValue)
11996 END SilentBuildConstructorStart ;
11997
11998
11999 (*
12000    BuildConstructorStart - builds a constructor.
12001                            Stack
12002
12003                            Entry                 Exit
12004
12005                     Ptr ->                                          <- Ptr
12006                            +------------+        +----------------+
12007                            | Type       |        | ConstructorSym |
12008                            |------------+        |----------------|
12009 *)
12010
12011 PROCEDURE BuildConstructorStart (cbratokpos: CARDINAL) ;
12012 VAR
12013    constValue,
12014    type      : CARDINAL ;
12015 BEGIN
12016    PopT (type) ;   (* we ignore the type as we already have the constructor symbol from pass C *)
12017    GetConstructorFromFifoQueue (constValue) ;
12018    Assert (type = GetSType (constValue)) ;
12019    PushTtok (constValue, cbratokpos) ;
12020    PushConstructor (type)
12021 END BuildConstructorStart ;
12022
12023
12024 (*
12025    BuildConstructorEnd - removes the current constructor frame from the
12026                          constructor stack (it does not effect the quad
12027                          stack)
12028
12029                          Entry                 Exit
12030
12031                   Ptr ->                                      <- Ptr
12032                          +------------+        +------------+
12033                          | const      |        | const      |
12034                          |------------|        |------------|
12035 *)
12036
12037 PROCEDURE BuildConstructorEnd (cbratokpos: CARDINAL) ;
12038 VAR
12039    typetok,
12040    value, valtok: CARDINAL ;
12041 BEGIN
12042    PopTtok (value, valtok) ;
12043    IF IsBoolean (1)
12044    THEN
12045       typetok := valtok
12046    ELSE
12047       typetok := OperandTtok (1)
12048    END ;
12049    valtok := MakeVirtualTok (typetok, typetok, cbratokpos) ;
12050    PutDeclared (valtok, value) ;
12051    PushTtok (value, valtok) ;   (* Use valtok as we now know it was a constructor.  *)
12052    PopConstructor
12053    (* ; ErrorStringAt (Mark (InitString ('aggregate constant')), valtok) *)
12054 END BuildConstructorEnd ;
12055
12056
12057 (*
12058    AddFieldTo - adds field, e, to, value.
12059 *)
12060
12061 PROCEDURE AddFieldTo (value, e: CARDINAL) : CARDINAL ;
12062 BEGIN
12063    IF IsSet(GetDType(value))
12064    THEN
12065       PutConstSet(value) ;
12066       PushT(value) ;
12067       PushT(e) ;
12068       BuildInclBit ;
12069       PopT(value)
12070    ELSE
12071       PushValue(value) ;
12072       AddField(GetTokenNo(), e) ;
12073       PopValue(value)
12074    END ;
12075    RETURN( value )
12076 END AddFieldTo ;
12077
12078
12079 (*
12080    BuildComponentValue -  builds a component value.
12081
12082                           Entry                 Exit
12083
12084                    Ptr ->                                      <- Ptr
12085
12086
12087                           +------------+        +------------+
12088                           | const      |        | const      |
12089                           |------------|        |------------|
12090 *)
12091
12092 PROCEDURE BuildComponentValue ;
12093 VAR
12094    const,
12095    e1, e2   : CARDINAL ;
12096    nuldotdot,
12097    nulby    : Name ;
12098 BEGIN
12099    PopT(nulby) ;
12100    IF nulby=NulTok
12101    THEN
12102       PopT(nuldotdot) ;
12103       IF nuldotdot=NulTok
12104       THEN
12105          PopT(e1) ;
12106          PopT(const) ;
12107          PushT(AddFieldTo(const, e1))
12108       ELSE
12109          PopT(e2) ;
12110          PopT(e1) ;
12111          PopT(const) ;
12112          PushValue(const) ;
12113          AddBitRange(GetTokenNo(), e1, e2) ;
12114          PopValue(const) ;
12115          PushT(const)
12116       END
12117    ELSE
12118       PopT(e1) ;
12119       PopT(nuldotdot) ;
12120       IF nuldotdot=NulTok
12121       THEN
12122          PopT(e2) ;
12123          PopT(const) ;
12124          PushValue(const) ;
12125          AddElements(GetTokenNo(), e2, e1) ;
12126          PopValue(const) ;
12127          PushT(const)
12128       ELSE
12129          PopT(e2) ;
12130          PopT(e1) ;
12131          PopT(const) ;
12132          WriteFormat0('the constant must be an array constructor or a set constructor but not both') ;
12133          PushT(const)
12134       END
12135    END
12136 END BuildComponentValue ;
12137
12138
12139 (*
12140    RecordOp - Records the operator passed on the stack.
12141               Checks for AND operator or OR operator
12142               if either of these operators are found then BackPatching
12143               takes place.
12144               The Expected Stack:
12145
12146               Entry                        Exit
12147
12148        Ptr ->                                               <- Ptr
12149               +-------------+               +-------------+
12150               | OperatorTok |               | OperatorTok |
12151               |-------------|               |-------------|
12152               | t    | f    |               | t    | f    |
12153               |-------------|               |-------------|
12154
12155
12156               If OperatorTok=AndTok
12157               Then
12158                  BackPatch(f, NextQuad)
12159               Elsif OperatorTok=OrTok
12160               Then
12161                  BackPatch(t, NextQuad)
12162               End
12163 *)
12164
12165 PROCEDURE RecordOp ;
12166 VAR
12167    Op   : Name ;
12168    tokno: CARDINAL ;
12169    t, f : CARDINAL ;
12170 BEGIN
12171    PopTtok(Op, tokno) ;
12172    IF (Op=AndTok) OR (Op=AmbersandTok)
12173    THEN
12174       CheckBooleanId ;
12175       PopBool(t, f) ;
12176       BackPatch(t, NextQuad) ;
12177       PushBool(0, f)
12178    ELSIF Op=OrTok
12179    THEN
12180       CheckBooleanId ;
12181       PopBool(t, f) ;
12182       BackPatch(f, NextQuad) ;
12183       PushBool(t, 0)
12184    END ;
12185    PushTtok(Op, tokno)
12186 END RecordOp ;
12187
12188
12189 (*
12190    CheckLogicalOperator - returns a logical operator if the operands imply
12191                           a logical operation should be performed.
12192 *)
12193
12194 PROCEDURE CheckLogicalOperator (Tok: Name; left, lefttype: CARDINAL) : Name ;
12195 BEGIN
12196    IF (Tok=PlusTok) OR (Tok=TimesTok) OR (Tok=DivideTok) OR (Tok=MinusTok)
12197    THEN
12198       (* --fixme-- when we add complex arithmetic, we must check constructor is not a complex constant.  *)
12199       IF ((lefttype#NulSym) AND IsSet(SkipType(lefttype))) OR
12200          IsConstSet(left) OR IsConstructor(left)
12201       THEN
12202          IF Tok=PlusTok
12203          THEN
12204             RETURN( LogicalOrTok )
12205          ELSIF Tok=DivideTok
12206          THEN
12207             RETURN( LogicalXorTok )
12208          ELSIF Tok=TimesTok
12209          THEN
12210             RETURN( LogicalAndTok )
12211          ELSIF Tok=MinusTok
12212          THEN
12213             RETURN( LogicalDifferenceTok )
12214          END
12215       END
12216    END ;
12217    RETURN( Tok )
12218 END CheckLogicalOperator ;
12219
12220
12221 (*
12222    doCheckGenericNulSet - checks to see whether e1 is a generic nul set and if so it alters it
12223                           to the nul set of t2.
12224 *)
12225
12226 (*
12227 PROCEDURE doCheckGenericNulSet (e1: CARDINAL; VAR t1: CARDINAL; t2: CARDINAL) ;
12228 BEGIN
12229    IF IsConstSet (e1)
12230    THEN
12231       IF NOT IsSet (t2)
12232       THEN
12233          MetaError2 ('incompatibility between a set constant {%1Ea} of type {%1tsa} and an object of type {%2sa}',
12234                      e1, t2)
12235       END ;
12236       PushValue (e1) ;
12237       IF IsGenericNulSet ()
12238       THEN
12239          PopValue (e1) ;
12240          PushNulSet (t2) ;
12241          t1 := t2
12242       END ;
12243       PopValue (e1)
12244    END
12245 END doCheckGenericNulSet ;
12246 *)
12247
12248
12249 (*
12250    CheckGenericNulSet - if e1 or e2 is the generic nul set then
12251                         alter it to the nul set of the other operands type.
12252 *)
12253
12254 (*
12255 PROCEDURE CheckGenericNulSet (e1, e2: CARDINAL; VAR t1, t2: CARDINAL) ;
12256 BEGIN
12257    IF t1#t2
12258    THEN
12259       doCheckGenericNulSet(e1, t1, t2) ;
12260       doCheckGenericNulSet(e2, t2, t1)
12261    END
12262 END CheckGenericNulSet ;
12263 *)
12264
12265
12266 (*
12267    CheckDivModRem - initiates calls to check the divisor for DIV, MOD, REM
12268                     expressions.
12269 *)
12270
12271 PROCEDURE CheckDivModRem (TokPos: CARDINAL; tok: Name; d, e: CARDINAL) ;
12272 BEGIN
12273    IF tok=DivTok
12274    THEN
12275       BuildRange (InitWholeZeroDivisionCheck (TokPos, d, e))
12276    ELSIF tok=ModTok
12277    THEN
12278       BuildRange (InitWholeZeroDivisionCheck (TokPos, d, e))
12279    ELSIF tok=RemTok
12280    THEN
12281       BuildRange (InitWholeZeroRemainderCheck (TokPos, d, e))
12282    END
12283 END CheckDivModRem ;
12284
12285
12286 (*
12287    doConvert - convert, sym, to a new symbol with, type.
12288                Return the new symbol.
12289 *)
12290
12291 PROCEDURE doConvert (type: CARDINAL; sym: CARDINAL) : CARDINAL ;
12292 BEGIN
12293    IF GetSType(sym)#type
12294    THEN
12295       PushTF(Convert, NulSym) ;
12296       PushT(type) ;
12297       PushT(sym) ;
12298       PushT(2) ;          (* Two parameters *)
12299       BuildConvertFunction ;
12300       PopT(sym)
12301    END ;
12302    RETURN( sym )
12303 END doConvert ;
12304
12305
12306 (*
12307    BuildBinaryOp   - Builds a binary operation from the quad stack.
12308                      Be aware that this procedure will check for
12309                      the overloading of the bitset operators + - \ *.
12310                      So do NOT call this procedure if you are building
12311                      a reference to an array which has a bitset type or
12312                      the address arithmetic will be wrongly coersed into
12313                      logical ORs.
12314
12315                      The Stack is expected to contain:
12316
12317
12318                      Entry                   Exit
12319                      =====                   ====
12320
12321               Ptr ->
12322                      +------------+
12323                      | Sym1       |
12324                      |------------|
12325                      | Operator   |                          <- Ptr
12326                      |------------|          +------------+
12327                      | Sym2       |          | Temporary  |
12328                      |------------|          |------------|
12329
12330
12331                      Quadruples Produced
12332
12333                      q     Operator  Temporary  Sym1  Sym2
12334
12335
12336                 OR
12337
12338
12339                      Entry                   Exit
12340                      =====                   ====
12341
12342               Ptr ->
12343                      +------------+
12344                      | T1   | F1  |
12345                      |------------|
12346                      | OrTok      |                          <- Ptr
12347                      |------------|          +------------+
12348                      | T2   | F2  |          | T1+T2| F1  |
12349                      |------------|          |------------|
12350
12351
12352                      Quadruples Produced
12353
12354 *)
12355
12356 PROCEDURE BuildBinaryOp ;
12357 BEGIN
12358    doBuildBinaryOp (TRUE, TRUE)
12359 END BuildBinaryOp ;
12360
12361
12362 (*
12363    doBuildBinaryOp - build the binary op, with or without type
12364                      checking.
12365 *)
12366
12367 PROCEDURE doBuildBinaryOp (checkTypes, checkOverflow: BOOLEAN) ;
12368 VAR
12369    s                  : String ;
12370    NewOp,
12371    Operator           : Name ;
12372    OperatorPos,
12373    OldPos,
12374    leftrw, rightrw,
12375    t1, f1,
12376    t2, f2,
12377    lefttype, righttype,
12378    left, right,
12379    leftpos, rightpos  : CARDINAL ;
12380    value              : CARDINAL ;
12381 BEGIN
12382    Operator := OperandT(2) ;
12383    IF Operator = OrTok
12384    THEN
12385       CheckBooleanId ;
12386       PopBool (t1, f1) ;
12387       PopTtok (Operator, OperatorPos) ;
12388       PopBool (t2, f2) ;
12389       Assert (f2=0) ;
12390       PushBool (Merge (t1, t2), f1)
12391    ELSIF (Operator = AndTok) OR (Operator = AmbersandTok)
12392    THEN
12393       CheckBooleanId ;
12394       PopBool (t1, f1) ;
12395       PopTtok (Operator, OperatorPos) ;
12396       PopBool (t2, f2) ;
12397       Assert (t2=0) ;
12398       PushBool (t1, Merge (f1, f2))
12399    ELSE
12400       PopTFrwtok (right, righttype, rightrw, rightpos) ;
12401       PopTtok (Operator, OperatorPos) ;
12402       PopTFrwtok (left, lefttype, leftrw, leftpos) ;
12403       MarkAsRead (rightrw) ;
12404       MarkAsRead (leftrw) ;
12405       NewOp := CheckLogicalOperator (Operator, (* right, righttype, *) left, lefttype) ;
12406       IF NewOp = Operator
12407       THEN
12408          (*
12409             BinaryOps and UnaryOps only work with immediate and
12410             offset addressing.  This is fine for calculating
12411             array and record offsets but we need to get the real
12412             values to perform normal arithmetic. Not address
12413             arithmetic.
12414
12415             However the set operators will dereference LValues
12416             (to optimize large set arithemetic)
12417          *)
12418          IF GetMode (right) = LeftValue
12419          THEN
12420             value := MakeTemporary (rightpos, RightValue) ;
12421             PutVar (value, righttype) ;
12422             CheckPointerThroughNil (rightpos, right) ;
12423             doIndrX (rightpos, value, right) ;
12424             right := value
12425          END ;
12426          IF GetMode (left) = LeftValue
12427          THEN
12428             value := MakeTemporary (leftpos, RightValue) ;
12429             PutVar (value, lefttype) ;
12430             CheckPointerThroughNil (leftpos, left) ;
12431             doIndrX (leftpos, value, left) ;
12432             left := value
12433          END
12434       ELSE
12435          (* CheckForGenericNulSet(e1, e2, t1, t2) *)
12436       END ;
12437       IF (Operator = PlusTok) AND IsConstString(left) AND IsConstString(right)
12438       THEN
12439          (* handle special addition for constant strings *)
12440          s := InitStringCharStar (KeyToCharStar (GetString (left))) ;
12441          s := ConCat (s, Mark (InitStringCharStar (KeyToCharStar (GetString (right))))) ;
12442          value := MakeConstLitString (OperatorPos, makekey (string (s))) ;
12443          s := KillString (s)
12444       ELSE
12445          OldPos := OperatorPos ;
12446          OperatorPos := MakeVirtualTok (OperatorPos, leftpos, rightpos) ;
12447          IF checkTypes
12448          THEN
12449             BuildRange (InitTypesExpressionCheck (OperatorPos, left, right, FALSE, FALSE))
12450          END ;
12451          value := MakeTemporaryFromExpressions (OperatorPos,
12452                                                 right, left,
12453                                                 AreConstant (IsConst (left) AND IsConst (right))) ;
12454
12455          CheckDivModRem (OperatorPos, NewOp, value, right) ;
12456
12457          IF DebugTokPos
12458          THEN
12459             s := InitStringCharStar (KeyToCharStar (GetTokenName (Operator))) ;
12460             WarnStringAt (s, OldPos) ;
12461             s := InitString ('left') ;
12462             WarnStringAt (s, leftpos) ;
12463             s := InitString ('right') ;
12464             WarnStringAt (s, rightpos) ;
12465             s := InitString ('caret') ;
12466             WarnStringAt (s, OldPos) ;
12467             s := InitString ('combined') ;
12468             WarnStringAt (s, OperatorPos) ;
12469             (* MetaErrorT1 (GetDeclaredMod (t), 'in binary with a {%1a}', t) *)
12470          END ;
12471          GenQuadOtok (OperatorPos, MakeOp (NewOp), value, left, right, checkOverflow,
12472                       OperatorPos, leftpos, rightpos)
12473       END ;
12474       PushTFtok (value, GetSType (value), OperatorPos)
12475    END
12476 END doBuildBinaryOp ;
12477
12478
12479 (*
12480    BuildUnaryOp   - Builds a unary operation from the quad stack.
12481                     The Stack is expected to contain:
12482
12483
12484                     Entry                   Exit
12485                     =====                   ====
12486
12487              Ptr ->
12488                     +------------+
12489                     | Sym        |
12490                     |------------|          +------------+
12491                     | Operator   |          | Temporary  | <- Ptr
12492                     |------------|          |------------|
12493
12494
12495                     Quadruples Produced
12496
12497                     q     Operator  Temporary  _ Sym
12498
12499 *)
12500
12501 PROCEDURE BuildUnaryOp ;
12502 VAR
12503    sympos,
12504    tokpos    : CARDINAL ;
12505    Tok       : Name ;
12506    type,
12507    Sym,
12508    SymT, r, t: CARDINAL ;
12509 BEGIN
12510    PopTrwtok (Sym, r, sympos) ;
12511    PopTtok (Tok, tokpos) ;
12512    IF Tok=MinusTok
12513    THEN
12514       MarkAsRead(r) ;
12515       type := NegateType (GetSType (Sym) (* , sympos *) ) ;
12516       tokpos := MakeVirtualTok (tokpos, tokpos, sympos) ;
12517
12518       t := MakeTemporary (tokpos, AreConstant(IsConst(Sym))) ;
12519       PutVar(t, type) ;
12520
12521       (*
12522          variables must have a type and REAL/LONGREAL constants must
12523          be typed
12524       *)
12525
12526       IF NOT IsConst(Sym)
12527       THEN
12528          IF (type#NulSym) AND IsSet(SkipType(type))
12529          THEN
12530             (* do not dereference set variables *)
12531          ELSIF GetMode(Sym)=LeftValue
12532          THEN
12533             (* dereference symbols which are not sets and which are variables *)
12534
12535             SymT := MakeTemporary (sympos, RightValue) ;
12536             PutVar (SymT, GetSType (Sym)) ;
12537             CheckPointerThroughNil (sympos, Sym) ;
12538             doIndrX (sympos, SymT, Sym) ;
12539             Sym := SymT
12540          END
12541       END ;
12542       GenQuadO (tokpos, NegateOp, t, NulSym, Sym, TRUE) ;
12543       PushTtok (t, tokpos)
12544    ELSIF Tok=PlusTok
12545    THEN
12546       tokpos := MakeVirtualTok (tokpos, tokpos, sympos) ;
12547       PushTrwtok (Sym, r, tokpos)
12548    ELSE
12549       MetaErrorNT1 (tokpos,
12550                     'expecting an unary operator, seen {%Ek%a}', Tok)
12551    END
12552 END BuildUnaryOp ;
12553
12554
12555 (*
12556    AreConstant - returns immediate addressing mode if b is true else
12557                  offset mode is returned. b determines whether the
12558                  operands are all constant - in which case we can use
12559                  a constant temporary variable.
12560 *)
12561
12562 PROCEDURE AreConstant (b: BOOLEAN) : ModeOfAddr ;
12563 BEGIN
12564    IF b
12565    THEN
12566       RETURN ImmediateValue
12567    ELSE
12568       RETURN RightValue
12569    END
12570 END AreConstant ;
12571
12572
12573 (*
12574    ConvertBooleanToVariable - converts a BoolStack(i) from a Boolean True|False
12575                               exit pair into a variable containing the value TRUE or
12576                               FALSE. The parameter, i, is relative to the top
12577                               of the stack.
12578 *)
12579
12580 PROCEDURE ConvertBooleanToVariable (tok: CARDINAL; i: CARDINAL) ;
12581 VAR
12582    Des: CARDINAL ;
12583    f  : BoolFrame ;
12584 BEGIN
12585    Assert (IsBoolean (i)) ;
12586    (*
12587       need to convert it to a variable containing the result.
12588       Des will be a boolean type
12589    *)
12590    Des := MakeTemporary (tok, RightValue) ;
12591    PutVar (Des, Boolean) ;
12592    PushTtok (Des, tok) ;   (* we have just increased the stack so we must use i+1 *)
12593    f := PeepAddress (BoolStack, i+1) ;
12594    PushBool (f^.TrueExit, f^.FalseExit) ;
12595    BuildAssignmentWithoutBounds (tok, FALSE, TRUE) ;  (* restored stack *)
12596    f := PeepAddress (BoolStack, i) ;
12597    WITH f^ DO
12598       TrueExit := Des ;  (* alter Stack(i) to contain the variable *)
12599       FalseExit := Boolean ;
12600       BooleanOp := FALSE ; (* no longer a Boolean True|False pair    *)
12601       Unbounded := NulSym ;
12602       Dimension := 0 ;
12603       ReadWrite := NulSym ;
12604       tokenno := tok ;
12605       Annotation := KillString (Annotation) ;
12606       Annotation := InitString ('%1s(%1d)|%2s(%2d)||boolean var|type')
12607    END
12608 END ConvertBooleanToVariable ;
12609
12610
12611 (*
12612    BuildBooleanVariable - tests to see whether top of stack is a boolean
12613                           conditional and if so it converts it into a boolean
12614                           variable.
12615 *)
12616
12617 PROCEDURE BuildBooleanVariable ;
12618 BEGIN
12619    IF IsBoolean (1)
12620    THEN
12621       ConvertBooleanToVariable (OperandTtok (1), 1)
12622    END
12623 END BuildBooleanVariable ;
12624
12625
12626 (*
12627    BuildRelOpFromBoolean - builds a relational operator sequence of quadruples
12628                            instead of using a temporary boolean variable.
12629                            This function can only be used when we perform
12630                            the following translation:
12631
12632                            (a=b) # (c=d)  alternatively   (a=b) = (c=d)
12633                                  ^                              ^
12634
12635                            it only allows # = to be used as >= <= > < all
12636                            assume a particular value for TRUE and FALSE.
12637                            (In which case the user should specify ORD)
12638
12639
12640                            before
12641
12642                            q    if r1      op1     op2     t2
12643                            q+1  Goto                       f2
12644                            q+2  if r2      op3     op4     t1
12645                            q+3  Goto                       f1
12646
12647                            after (in case of =)
12648
12649                            q    if r1      op1     op2     q+2
12650                            q+1  Goto                       q+4
12651                            q+2  if r2      op3     op4     t
12652                            q+3  Goto                       f
12653                            q+4  if r2      op3     op4     f
12654                            q+5  Goto                       t
12655
12656                            after (in case of #)
12657
12658                            q    if r1      op1     op2     q+2
12659                            q+1  Goto                       q+4
12660                            q+2  if r2      op3     op4     f
12661                            q+3  Goto                       t
12662                            q+4  if r2      op3     op4     t
12663                            q+5  Goto                       f
12664
12665                            The Stack is expected to contain:
12666
12667
12668                            Entry                   Exit
12669                            =====                   ====
12670
12671                     Ptr ->
12672                            +------------+
12673                            | t1 | f1    |
12674                            |------------|
12675                            | Operator   |                          <- Ptr
12676                            |------------|          +------------+
12677                            | t2 | f2    |          | t    | f   |
12678                            |------------|          |------------|
12679
12680
12681 *)
12682
12683 PROCEDURE BuildRelOpFromBoolean (tokpos: CARDINAL) ;
12684 VAR
12685    Tok,
12686    t1, f1,
12687    t2, f2: CARDINAL ;
12688    f     : QuadFrame ;
12689 BEGIN
12690    Assert (IsBoolean (1) AND IsBoolean (3)) ;
12691    IF OperandT (2) = EqualTok
12692    THEN
12693       (* are the two boolean expressions the same? *)
12694       PopBool (t1, f1) ;
12695       PopT (Tok) ;
12696       PopBool (t2, f2) ;
12697       (* give the false exit a second chance *)
12698       BackPatch (t2, t1) ;        (* q    if   _     _    q+2 *)
12699       BackPatch (f2, NextQuad) ;  (* q+1  if   _     _    q+4 *)
12700       Assert (NextQuad = f1+1) ;
12701       f := GetQF (t1) ;
12702       WITH f^ DO
12703          GenQuadO (tokpos, Operator, Operand1, Operand2, 0, FALSE)
12704       END ;
12705       GenQuadO (tokpos, GotoOp, NulSym, NulSym, 0, FALSE) ;
12706       PushBool (Merge (NextQuad-1, t1), Merge (NextQuad-2, f1))
12707    ELSIF (OperandT (2) = HashTok) OR (OperandT (2) = LessGreaterTok)
12708    THEN
12709       (* are the two boolean expressions the different? *)
12710       PopBool (t1, f1) ;
12711       PopT (Tok) ;
12712       PopBool (t2, f2) ;
12713       (* give the false exit a second chance *)
12714       BackPatch (t2, t1) ;        (* q    if   _     _    q+2 *)
12715       BackPatch (f2, NextQuad) ;  (* q+1  if   _     _    q+4 *)
12716       Assert (NextQuad = f1+1) ;
12717       f := GetQF (t1) ;
12718       WITH f^ DO
12719          GenQuadO (tokpos, Operator, Operand1, Operand2, 0, FALSE)
12720       END ;
12721       GenQuadO (tokpos, GotoOp, NulSym, NulSym, 0, FALSE) ;
12722       PushBool (Merge (NextQuad-2, f1), Merge (NextQuad-1, t1))
12723    ELSE
12724       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}')
12725    END
12726 END BuildRelOpFromBoolean ;
12727
12728
12729 (*
12730    CheckVariableOrConstantOrProcedure - checks to make sure sym is a variable, constant or procedure.
12731 *)
12732
12733 PROCEDURE CheckVariableOrConstantOrProcedure (tokpos: CARDINAL; sym: CARDINAL) ;
12734 VAR
12735    type: CARDINAL ;
12736 BEGIN
12737    type := GetSType (sym) ;
12738    IF IsUnknown (sym)
12739    THEN
12740       MetaErrorT1 (tokpos, '{%1EUad} has not been declared', sym) ;
12741       UnknownReported (sym)
12742    ELSIF IsPseudoSystemFunction (sym) OR IsPseudoBaseFunction (sym)
12743    THEN
12744       MetaErrorT1 (tokpos,
12745                    '{%1Ead} expected a variable, procedure, constant or expression, not an intrinsic procedure function',
12746                    sym)
12747    ELSIF (NOT IsConst(sym)) AND (NOT IsVar(sym)) AND
12748          (NOT IsProcedure(sym)) AND
12749          (NOT IsTemporary(sym)) AND (NOT MustNotCheckBounds)
12750    THEN
12751       MetaErrorsT1 (tokpos,
12752                     '{%1Ead} expected a variable, procedure, constant or expression',
12753                     'and it was declared as a {%1Dd}', sym) ;
12754    ELSIF (type#NulSym) AND IsArray(type)
12755    THEN
12756       MetaErrorsT1 (tokpos,
12757                     '{%1EU} not expecting an array variable as an operand for either comparison or binary operation',
12758                     'it was declared as a {%1Dd}', sym)
12759    ELSIF IsConstString(sym) AND (GetStringLength(sym)>1)
12760    THEN
12761       MetaErrorT1 (tokpos,
12762                    '{%1EU} not expecting a string constant as an operand for either comparison or binary operation',
12763                    sym)
12764    END
12765 END CheckVariableOrConstantOrProcedure ;
12766
12767
12768 (*
12769    BuildRelOp   - Builds a relative operation from the quad stack.
12770                   The Stack is expected to contain:
12771
12772
12773                   Entry                   Exit
12774                   =====                   ====
12775
12776            Ptr ->
12777                   +------------+
12778                   | e1         |
12779                   |------------|                          <- Ptr
12780                   | Operator   |
12781                   |------------|          +------------+
12782                   | e2         |          | t    | f   |
12783                   |------------|          |------------|
12784
12785
12786                     Quadruples Produced
12787
12788                     q     IFOperator  e2  e1  TrueExit    ; e2  e1 since
12789                     q+1   GotoOp              FalseExit   ; relation > etc
12790                                                           ; requires order.
12791 *)
12792
12793 PROCEDURE BuildRelOp (optokpos: CARDINAL) ;
12794 VAR
12795    combinedTok,
12796    rightpos,
12797    leftpos            : CARDINAL ;
12798    Op                 : Name ;
12799    t,
12800    rightType, leftType,
12801    right, left        : CARDINAL ;
12802 BEGIN
12803    IF CompilerDebugging
12804    THEN
12805       DisplayStack    (* Debugging info *)
12806    END ;
12807    IF IsBoolean (1) AND IsBoolean (3)
12808    THEN
12809       (*
12810          we allow # and = to be used with Boolean expressions.
12811          we do not allow >  <  >=  <=  though
12812       *)
12813       BuildRelOpFromBoolean (optokpos)
12814    ELSE
12815       IF IsBoolean (1)
12816       THEN
12817          ConvertBooleanToVariable (OperandTtok (1), 1)
12818       END ;
12819       IF IsBoolean (3)
12820       THEN
12821          ConvertBooleanToVariable (OperandTtok (3), 3)
12822       END ;
12823       PopTFtok (right, rightType, rightpos) ;
12824       PopT (Op) ;
12825       PopTFtok (left, leftType, leftpos) ;
12826
12827       CheckVariableOrConstantOrProcedure (rightpos, right) ;
12828       CheckVariableOrConstantOrProcedure (leftpos, left) ;
12829
12830       IF (left#NulSym) AND (right#NulSym)
12831       THEN
12832          (* BuildRange will check the expression later on once gcc knows about all data types.  *)
12833          BuildRange (InitTypesExpressionCheck (optokpos, left, right, TRUE, Op = InTok))
12834       END ;
12835
12836       (* Must dereference LeftValue operands.  *)
12837       IF GetMode(right) = LeftValue
12838       THEN
12839          t := MakeTemporary (rightpos, RightValue) ;
12840          PutVar(t, GetSType(right)) ;
12841          CheckPointerThroughNil (rightpos, right) ;
12842          doIndrX (rightpos, t, right) ;
12843          right := t
12844       END ;
12845       IF GetMode(left) = LeftValue
12846       THEN
12847          t := MakeTemporary (leftpos, RightValue) ;
12848          PutVar (t, GetSType (left)) ;
12849          CheckPointerThroughNil (leftpos, left) ;
12850          doIndrX (leftpos, t, left) ;
12851          left := t
12852       END ;
12853       combinedTok := MakeVirtualTok (optokpos, leftpos, rightpos) ;
12854       GenQuadO (combinedTok, MakeOp(Op), left, right, 0, FALSE) ;  (* True  Exit *)
12855       GenQuadO (combinedTok, GotoOp, NulSym, NulSym, 0, FALSE) ;  (* False Exit *)
12856       PushBool (NextQuad-2, NextQuad-1)
12857    END
12858 END BuildRelOp ;
12859
12860
12861 (*
12862    BuildNot   - Builds a NOT operation from the quad stack.
12863                 The Stack is expected to contain:
12864
12865
12866                   Entry                   Exit
12867                   =====                   ====
12868
12869            Ptr ->                                        <- Ptr
12870                   +------------+          +------------+
12871                   | t    | f   |          | f    | t   |
12872                   |------------|          |------------|
12873 *)
12874
12875 PROCEDURE BuildNot (notTokPos: CARDINAL) ;
12876 VAR
12877    combinedTok,
12878    exprTokPos : CARDINAL ;
12879    t, f       : CARDINAL ;
12880 BEGIN
12881    CheckBooleanId ;
12882    PopBooltok (t, f, exprTokPos) ;
12883    combinedTok := MakeVirtualTok (notTokPos, notTokPos, exprTokPos) ;
12884    PushBooltok (f, t, combinedTok)
12885 END BuildNot ;
12886
12887
12888 (*
12889    MakeOp - returns the equalent quadruple operator to a token, t.
12890 *)
12891
12892 PROCEDURE MakeOp (t: Name) : QuadOperator ;
12893 BEGIN
12894    IF t=PlusTok
12895    THEN
12896       RETURN( AddOp )
12897    ELSIF t=MinusTok
12898    THEN
12899       RETURN( SubOp )
12900    ELSIF t=DivTok
12901    THEN
12902       RETURN( DivM2Op )
12903    ELSIF t=DivideTok
12904    THEN
12905       RETURN( DivTruncOp )
12906    ELSIF t=RemTok
12907    THEN
12908       RETURN( ModTruncOp )
12909    ELSIF t=ModTok
12910    THEN
12911       RETURN( ModM2Op )
12912    ELSIF t=TimesTok
12913    THEN
12914       RETURN( MultOp )
12915    ELSIF t=HashTok
12916    THEN
12917       RETURN( IfNotEquOp )
12918    ELSIF t=LessGreaterTok
12919    THEN
12920       RETURN( IfNotEquOp )
12921    ELSIF t=GreaterEqualTok
12922    THEN
12923       RETURN( IfGreEquOp )
12924    ELSIF t=LessEqualTok
12925    THEN
12926       RETURN( IfLessEquOp )
12927    ELSIF t=EqualTok
12928    THEN
12929       RETURN( IfEquOp )
12930    ELSIF t=LessTok
12931    THEN
12932       RETURN( IfLessOp )
12933    ELSIF t=GreaterTok
12934    THEN
12935       RETURN( IfGreOp )
12936    ELSIF t=InTok
12937    THEN
12938       RETURN( IfInOp )
12939    ELSIF t=LogicalOrTok
12940    THEN
12941       RETURN( LogicalOrOp )
12942    ELSIF t=LogicalAndTok
12943    THEN
12944       RETURN( LogicalAndOp )
12945    ELSIF t=LogicalXorTok
12946    THEN
12947       RETURN( LogicalXorOp )
12948    ELSIF t=LogicalDifferenceTok
12949    THEN
12950       RETURN( LogicalDiffOp )
12951    ELSE
12952       InternalError('binary operation not implemented yet')
12953    END
12954 END MakeOp ;
12955
12956
12957 (*
12958    GenQuadO - generate a quadruple with Operation, Op1, Op2, Op3, overflow.
12959 *)
12960
12961 PROCEDURE GenQuadO (TokPos: CARDINAL;
12962                     Operation: QuadOperator;
12963                     Op1, Op2, Op3: CARDINAL; overflow: BOOLEAN) ;
12964 VAR
12965    f: QuadFrame ;
12966 BEGIN
12967    (* WriteString('Potential Quad: ') ; *)
12968    IF QuadrupleGeneration
12969    THEN
12970       IF NextQuad # Head
12971       THEN
12972          f := GetQF (NextQuad-1) ;
12973          f^.Next := NextQuad
12974       END ;
12975       PutQuadO (NextQuad, Operation, Op1, Op2, Op3, overflow) ;
12976       f := GetQF (NextQuad) ;
12977       WITH f^ DO
12978          Next := 0 ;
12979          LineNo := GetLineNo () ;
12980          IF TokPos = UnknownTokenNo
12981          THEN
12982             TokenNo := GetTokenNo ()
12983          ELSE
12984             TokenNo := TokPos
12985          END
12986       END ;
12987       IF NextQuad=BreakAtQuad
12988       THEN
12989          stop
12990       END ;
12991       (* DisplayQuad(NextQuad) ; *)
12992       NewQuad (NextQuad)
12993    END
12994 END GenQuadO ;
12995
12996
12997 (*
12998    GenQuad - Generate a quadruple with Operation, Op1, Op2, Op3.
12999 *)
13000
13001 PROCEDURE GenQuad (Operation: QuadOperator;
13002                    Op1, Op2, Op3: CARDINAL) ;
13003 BEGIN
13004    GenQuadO (UnknownTokenNo, Operation, Op1, Op2, Op3, TRUE)
13005 END GenQuad ;
13006
13007
13008 (*
13009    GenQuadOtok - generate a quadruple with Operation, Op1, Op2, Op3, overflow.
13010 *)
13011
13012 PROCEDURE GenQuadOtok (TokPos: CARDINAL;
13013                        Operation: QuadOperator;
13014                        Op1, Op2, Op3: CARDINAL; overflow: BOOLEAN;
13015                        Op1Pos, Op2Pos, Op3Pos: CARDINAL) ;
13016 VAR
13017    f: QuadFrame ;
13018 BEGIN
13019    (* WriteString('Potential Quad: ') ; *)
13020    IF QuadrupleGeneration
13021    THEN
13022       IF NextQuad # Head
13023       THEN
13024          f := GetQF (NextQuad-1) ;
13025          f^.Next := NextQuad
13026       END ;
13027       PutQuadO (NextQuad, Operation, Op1, Op2, Op3, overflow) ;
13028       f := GetQF (NextQuad) ;
13029       WITH f^ DO
13030          Next := 0 ;
13031          LineNo := GetLineNo () ;
13032          IF TokPos = UnknownTokenNo
13033          THEN
13034             TokenNo := GetTokenNo ()
13035          ELSE
13036             TokenNo := TokPos
13037          END ;
13038          op1pos := Op1Pos ;
13039          op2pos := Op2Pos ;
13040          op3pos := Op3Pos
13041       END ;
13042       IF NextQuad=BreakAtQuad
13043       THEN
13044          stop
13045       END ;
13046       (* DisplayQuad(NextQuad) ; *)
13047       NewQuad (NextQuad)
13048    END
13049 END GenQuadOtok ;
13050
13051
13052 (*
13053    DisplayQuadList - displays all quads.
13054 *)
13055
13056 PROCEDURE DisplayQuadList ;
13057 VAR
13058    i: CARDINAL ;
13059    f: QuadFrame ;
13060 BEGIN
13061    printf0('Quadruples:\n') ;
13062    i := Head ;
13063    WHILE i#0 DO
13064       DisplayQuad(i) ;
13065       f := GetQF(i) ;
13066       i := f^.Next
13067    END
13068 END DisplayQuadList ;
13069
13070
13071 (*
13072    DisplayQuadRange - displays all quads in list range, start..end.
13073 *)
13074
13075 PROCEDURE DisplayQuadRange (start, end: CARDINAL) ;
13076 VAR
13077    f: QuadFrame ;
13078 BEGIN
13079    printf0('Quadruples:\n') ;
13080    WHILE (start<=end) AND (start#0) DO
13081       DisplayQuad(start) ;
13082       f := GetQF(start) ;
13083       start := f^.Next
13084    END
13085 END DisplayQuadRange ;
13086
13087
13088 (*
13089    BackPatch - Makes each of the quadruples on the list pointed to by
13090                StartQuad, take quadruple Value as a target.
13091 *)
13092
13093 PROCEDURE BackPatch (QuadNo, Value: CARDINAL) ;
13094 VAR
13095    i: CARDINAL ;
13096    f: QuadFrame ;
13097 BEGIN
13098    IF QuadrupleGeneration
13099    THEN
13100       WHILE QuadNo#0 DO
13101          f := GetQF(QuadNo) ;
13102          WITH f^ DO
13103             i := Operand3 ;                       (* Next Link along the BackPatch *)
13104             ManipulateReference(QuadNo, Value)    (* Filling in the BackPatch.     *)
13105          END ;
13106          QuadNo := i
13107       END
13108    END
13109 END BackPatch ;
13110
13111
13112 (*
13113    Merge - joins two quad lists, QuadList2 to the end of QuadList1.
13114            A QuadList of value zero is a nul list.
13115 *)
13116
13117 PROCEDURE Merge (QuadList1, QuadList2: CARDINAL) : CARDINAL ;
13118 VAR
13119    i, j: CARDINAL ;
13120    f   : QuadFrame ;
13121 BEGIN
13122    IF QuadList1=0
13123    THEN
13124       RETURN( QuadList2 )
13125    ELSIF QuadList2=0
13126    THEN
13127       RETURN( QuadList1 )
13128    ELSE
13129       i := QuadList1 ;
13130       REPEAT
13131          j := i ;
13132          f := GetQF(i) ;
13133          i := f^.Operand3
13134       UNTIL i=0 ;
13135       ManipulateReference(j, QuadList2) ;
13136       RETURN( QuadList1 )
13137    END
13138 END Merge ;
13139
13140
13141 (*
13142    Annotate - annotate the top of stack.
13143 *)
13144
13145 PROCEDURE Annotate (a: ARRAY OF CHAR) ;
13146 VAR
13147    f: BoolFrame ;
13148 BEGIN
13149    IF DebugStackOn AND CompilerDebugging AND (NoOfItemsInStackAddress(BoolStack)>0)
13150    THEN
13151       f := PeepAddress(BoolStack, 1) ;    (* top of stack *)
13152       WITH f^ DO
13153          IF Annotation#NIL
13154          THEN
13155             Annotation := KillString(Annotation)
13156          END ;
13157          Annotation := InitString(a)
13158       END
13159    END
13160 END Annotate ;
13161
13162
13163 (*
13164    OperandAnno - returns the annotation string associated with the
13165                  position, n, on the stack.
13166 *)
13167
13168 PROCEDURE OperandAnno (n: CARDINAL) : String ;
13169 VAR
13170    f: BoolFrame ;
13171 BEGIN
13172    f := PeepAddress (BoolStack, n) ;
13173    RETURN f^.Annotation
13174 END OperandAnno ;
13175
13176
13177 (*
13178    DisplayStack - displays the compile time symbol stack.
13179 *)
13180
13181 PROCEDURE DisplayStack ;
13182 BEGIN
13183    IF DebugStackOn AND CompilerDebugging
13184    THEN
13185       DebugStack (NoOfItemsInStackAddress (BoolStack),
13186                   OperandTno, OperandFno, OperandA,
13187                   OperandD, OperandRW, OperandTok, OperandAnno)
13188    END
13189 END DisplayStack ;
13190
13191
13192 (*
13193    ds - tiny procedure name, useful for calling from the gdb shell.
13194 *)
13195
13196 (*
13197 PROCEDURE ds ;
13198 BEGIN
13199    DisplayStack
13200 END ds ;
13201 *)
13202
13203
13204 (*
13205    DisplayQuad - displays a quadruple, QuadNo.
13206 *)
13207
13208 PROCEDURE DisplayQuad (QuadNo: CARDINAL) ;
13209 BEGIN
13210    DSdbEnter ;
13211    printf1('%4d  ', QuadNo) ; WriteQuad(QuadNo) ; printf0('\n') ;
13212    DSdbExit
13213 END DisplayQuad ;
13214
13215
13216 (*
13217    DisplayProcedureAttributes -
13218 *)
13219
13220 PROCEDURE DisplayProcedureAttributes (proc: CARDINAL) ;
13221 BEGIN
13222    IF IsCtor (proc)
13223    THEN
13224       printf0 (" (ctor)")
13225    END ;
13226    IF IsPublic (proc)
13227    THEN
13228       printf0 (" (public)")
13229    END ;
13230    IF IsExtern (proc)
13231    THEN
13232       printf0 (" (extern)")
13233    END ;
13234    IF IsMonoName (proc)
13235    THEN
13236       printf0 (" (mononame)")
13237    END
13238 END DisplayProcedureAttributes ;
13239
13240
13241 (*
13242    WriteQuad - Writes out the Quad BufferQuad.
13243 *)
13244
13245 PROCEDURE WriteQuad (BufferQuad: CARDINAL) ;
13246 VAR
13247    n1, n2: Name ;
13248    f     : QuadFrame ;
13249    n     : Name ;
13250    l     : CARDINAL ;
13251 BEGIN
13252    f := GetQF(BufferQuad) ;
13253    WITH f^ DO
13254       WriteOperator(Operator) ;
13255       printf1('  [%d]    ', NoOfTimesReferenced) ;
13256       CASE Operator OF
13257
13258       HighOp           : WriteOperand(Operand1) ;
13259                          printf1('  %4d  ', Operand2) ;
13260                          WriteOperand(Operand3) |
13261       InitAddressOp,
13262       SavePriorityOp,
13263       RestorePriorityOp,
13264       SubrangeLowOp,
13265       SubrangeHighOp,
13266       BecomesOp,
13267       InclOp,
13268       ExclOp,
13269       UnboundedOp,
13270       ReturnValueOp,
13271       FunctValueOp,
13272       NegateOp,
13273       AddrOp            : WriteOperand(Operand1) ;
13274                           printf0('  ') ;
13275                           WriteOperand(Operand3) |
13276       ElementSizeOp,
13277       IfInOp,
13278       IfNotInOp,
13279       IfNotEquOp,
13280       IfEquOp,
13281       IfLessOp,
13282       IfGreOp,
13283       IfLessEquOp,
13284       IfGreEquOp        : WriteOperand(Operand1) ;
13285                           printf0('  ') ;
13286                           WriteOperand(Operand2) ;
13287                           printf1('  %4d', Operand3) |
13288
13289       InlineOp,
13290       RetryOp,
13291       TryOp,
13292       GotoOp            : printf1('%4d', Operand3) |
13293
13294       StatementNoteOp   : l := TokenToLineNo(Operand3, 0) ;
13295                           n := GetTokenName (Operand3) ;
13296                           printf4('%a:%d:%a (tokenno %d)', Operand1, l, n, Operand3) |
13297       LineNumberOp      : printf2('%a:%d', Operand1, Operand3) |
13298
13299       EndFileOp         : n1 := GetSymName(Operand3) ;
13300                           printf1('%a', n1) |
13301
13302       ThrowOp,
13303       ReturnOp,
13304       CallOp,
13305       KillLocalVarOp    : WriteOperand(Operand3) |
13306
13307       ProcedureScopeOp  : n1 := GetSymName(Operand2) ;
13308                           n2 := GetSymName(Operand3) ;
13309                           printf3('  %4d  %a  %a', Operand1, n1, n2) ;
13310                           DisplayProcedureAttributes (Operand3) |
13311       NewLocalVarOp,
13312       FinallyStartOp,
13313       FinallyEndOp,
13314       InitEndOp,
13315       InitStartOp       : n1 := GetSymName(Operand2) ;
13316                           n2 := GetSymName(Operand3) ;
13317                           printf3('  %4d  %a  %a', Operand1, n1, n2) |
13318
13319       ModuleScopeOp,
13320       StartModFileOp    : n1 := GetSymName(Operand3) ;
13321                           printf4('%a:%d  %a(%d)', Operand2, Operand1, n1, Operand3) |
13322
13323       StartDefFileOp    : n1 := GetSymName(Operand3) ;
13324                           printf2('  %4d  %a', Operand1, n1) |
13325
13326       OptParamOp,
13327       ParamOp           : printf1('%4d  ', Operand1) ;
13328                           WriteOperand(Operand2) ;
13329                           printf0('  ') ;
13330                           WriteOperand(Operand3) |
13331       SizeOp,
13332       RecordFieldOp,
13333       IndrXOp,
13334       XIndrOp,
13335       ArrayOp,
13336       LogicalShiftOp,
13337       LogicalRotateOp,
13338       LogicalOrOp,
13339       LogicalAndOp,
13340       LogicalXorOp,
13341       LogicalDiffOp,
13342       CoerceOp,
13343       ConvertOp,
13344       CastOp,
13345       AddOp,
13346       SubOp,
13347       MultOp,
13348       DivM2Op,
13349       ModM2Op,
13350       ModFloorOp,
13351       DivCeilOp,
13352       ModCeilOp,
13353       DivFloorOp,
13354       ModTruncOp,
13355       DivTruncOp        : WriteOperand(Operand1) ;
13356                           printf0('  ') ;
13357                           WriteOperand(Operand2) ;
13358                           printf0('  ') ;
13359                           WriteOperand(Operand3) |
13360       DummyOp,
13361       CodeOnOp,
13362       CodeOffOp,
13363       ProfileOnOp,
13364       ProfileOffOp,
13365       OptimizeOnOp,
13366       OptimizeOffOp     : |
13367       BuiltinConstOp    : WriteOperand(Operand1) ;
13368                           printf1('   %a', Operand3) |
13369       BuiltinTypeInfoOp : WriteOperand(Operand1) ;
13370                           printf1('   %a', Operand2) ;
13371                           printf1('   %a', Operand3) |
13372       StandardFunctionOp: WriteOperand(Operand1) ;
13373                           printf0('  ') ;
13374                           WriteOperand(Operand2) ;
13375                           printf0('  ') ;
13376                           WriteOperand(Operand3) |
13377       CatchBeginOp,
13378       CatchEndOp        : |
13379
13380       RangeCheckOp,
13381       ErrorOp           : WriteRangeCheck(Operand3) |
13382       SaveExceptionOp,
13383       RestoreExceptionOp: WriteOperand(Operand1) ;
13384                           printf0('  ') ;
13385                           WriteOperand(Operand3)
13386
13387       ELSE
13388          InternalError ('quadruple not recognised')
13389       END
13390    END
13391 END WriteQuad ;
13392
13393
13394 (*
13395    WriteOperator - writes the name of the quadruple operator.
13396 *)
13397
13398 PROCEDURE WriteOperator (Operator: QuadOperator) ;
13399 BEGIN
13400    CASE Operator OF
13401
13402    InitAddressOp            : printf0('InitAddress       ') |
13403    LogicalOrOp              : printf0('Or                ') |
13404    LogicalAndOp             : printf0('And               ') |
13405    LogicalXorOp             : printf0('Xor               ') |
13406    LogicalDiffOp            : printf0('Ldiff             ') |
13407    LogicalShiftOp           : printf0('Shift             ') |
13408    LogicalRotateOp          : printf0('Rotate            ') |
13409    BecomesOp                : printf0('Becomes           ') |
13410    IndrXOp                  : printf0('IndrX             ') |
13411    XIndrOp                  : printf0('XIndr             ') |
13412    ArrayOp                  : printf0('Array             ') |
13413    ElementSizeOp            : printf0('ElementSize       ') |
13414    RecordFieldOp            : printf0('RecordField       ') |
13415    AddrOp                   : printf0('Addr              ') |
13416    SizeOp                   : printf0('Size              ') |
13417    IfInOp                   : printf0('If IN             ') |
13418    IfNotInOp                : printf0('If NOT IN         ') |
13419    IfNotEquOp               : printf0('If <>             ') |
13420    IfEquOp                  : printf0('If =              ') |
13421    IfLessEquOp              : printf0('If <=             ') |
13422    IfGreEquOp               : printf0('If >=             ') |
13423    IfGreOp                  : printf0('If >              ') |
13424    IfLessOp                 : printf0('If <              ') |
13425    GotoOp                   : printf0('Goto              ') |
13426    DummyOp                  : printf0('Dummy             ') |
13427    ModuleScopeOp            : printf0('ModuleScopeOp     ') |
13428    StartDefFileOp           : printf0('StartDefFile      ') |
13429    StartModFileOp           : printf0('StartModFile      ') |
13430    EndFileOp                : printf0('EndFileOp         ') |
13431    InitStartOp              : printf0('InitStart         ') |
13432    InitEndOp                : printf0('InitEnd           ') |
13433    FinallyStartOp           : printf0('FinallyStart      ') |
13434    FinallyEndOp             : printf0('FinallyEnd        ') |
13435    RetryOp                  : printf0('Retry             ') |
13436    TryOp                    : printf0('Try               ') |
13437    ThrowOp                  : printf0('Throw             ') |
13438    CatchBeginOp             : printf0('CatchBegin        ') |
13439    CatchEndOp               : printf0('CatchEnd          ') |
13440    AddOp                    : printf0('+                 ') |
13441    SubOp                    : printf0('-                 ') |
13442    DivM2Op                  : printf0('DIV M2            ') |
13443    ModM2Op                  : printf0('MOD M2            ') |
13444    DivCeilOp                : printf0('DIV ceil          ') |
13445    ModCeilOp                : printf0('MOD ceil          ') |
13446    DivFloorOp               : printf0('DIV floor         ') |
13447    ModFloorOp               : printf0('MOD floor         ') |
13448    DivTruncOp               : printf0('DIV trunc         ') |
13449    ModTruncOp               : printf0('MOD trunc         ') |
13450    MultOp                   : printf0('*                 ') |
13451    NegateOp                 : printf0('Negate            ') |
13452    InclOp                   : printf0('Incl              ') |
13453    ExclOp                   : printf0('Excl              ') |
13454    ReturnOp                 : printf0('Return            ') |
13455    ReturnValueOp            : printf0('ReturnValue       ') |
13456    FunctValueOp             : printf0('FunctValue        ') |
13457    CallOp                   : printf0('Call              ') |
13458    ParamOp                  : printf0('Param             ') |
13459    OptParamOp               : printf0('OptParam          ') |
13460    NewLocalVarOp            : printf0('NewLocalVar       ') |
13461    KillLocalVarOp           : printf0('KillLocalVar      ') |
13462    ProcedureScopeOp         : printf0('ProcedureScope    ') |
13463    UnboundedOp              : printf0('Unbounded         ') |
13464    CoerceOp                 : printf0('Coerce            ') |
13465    ConvertOp                : printf0('Convert           ') |
13466    CastOp                   : printf0('Cast              ') |
13467    HighOp                   : printf0('High              ') |
13468    CodeOnOp                 : printf0('CodeOn            ') |
13469    CodeOffOp                : printf0('CodeOff           ') |
13470    ProfileOnOp              : printf0('ProfileOn         ') |
13471    ProfileOffOp             : printf0('ProfileOff        ') |
13472    OptimizeOnOp             : printf0('OptimizeOn        ') |
13473    OptimizeOffOp            : printf0('OptimizeOff       ') |
13474    InlineOp                 : printf0('Inline            ') |
13475    StatementNoteOp          : printf0('StatementNote     ') |
13476    LineNumberOp             : printf0('LineNumber        ') |
13477    BuiltinConstOp           : printf0('BuiltinConst      ') |
13478    BuiltinTypeInfoOp        : printf0('BuiltinTypeInfo   ') |
13479    StandardFunctionOp       : printf0('StandardFunction  ') |
13480    SavePriorityOp           : printf0('SavePriority      ') |
13481    RestorePriorityOp        : printf0('RestorePriority   ') |
13482    RangeCheckOp             : printf0('RangeCheck        ') |
13483    ErrorOp                  : printf0('Error             ') |
13484    SaveExceptionOp          : printf0('SaveException     ') |
13485    RestoreExceptionOp       : printf0('RestoreException  ')
13486
13487    ELSE
13488       InternalError ('operator not expected')
13489    END
13490 END WriteOperator ;
13491
13492
13493 (*
13494    WriteOperand - displays the operands name, symbol id and mode of addressing.
13495 *)
13496
13497 PROCEDURE WriteOperand (Sym: CARDINAL) ;
13498 VAR
13499    n: Name ;
13500 BEGIN
13501    IF Sym=NulSym
13502    THEN
13503       printf0('<nulsym>')
13504    ELSE
13505       n := GetSymName(Sym) ;
13506       printf1('%a', n) ;
13507       IF IsVar(Sym) OR IsConst(Sym)
13508       THEN
13509          printf0('[') ; WriteMode(GetMode(Sym)) ; printf0(']')
13510       END ;
13511       printf1('(%d)', Sym)
13512    END
13513 END WriteOperand ;
13514
13515
13516 PROCEDURE WriteMode (Mode: ModeOfAddr) ;
13517 BEGIN
13518    CASE Mode OF
13519
13520    ImmediateValue: printf0('i') |
13521    NoValue       : printf0('n') |
13522    RightValue    : printf0('r') |
13523    LeftValue     : printf0('l')
13524
13525    ELSE
13526       InternalError ('unrecognised mode')
13527    END
13528 END WriteMode ;
13529
13530
13531 (*
13532    GetQuadOp - returns the operator for quad.
13533 *)
13534
13535 PROCEDURE GetQuadOp (quad: CARDINAL) : QuadOperator ;
13536 VAR
13537    f: QuadFrame ;
13538 BEGIN
13539    f := GetQF (quad) ;
13540    RETURN f^.Operator
13541 END GetQuadOp ;
13542
13543
13544 (*
13545    GetM2OperatorDesc - returns the Modula-2 string associated with the quad operator
13546                        (if possible).  It returns NIL if no there is not an obvious match
13547                        in Modula-2.  It is assummed that the string will be used during
13548                        construction of error messages and therefore keywords are
13549                        wrapped with a format specifier.
13550 *)
13551
13552 PROCEDURE GetM2OperatorDesc (op: QuadOperator) : String ;
13553 BEGIN
13554    CASE op OF
13555
13556    NegateOp    :  RETURN InitString ('-') |
13557    AddOp       :  RETURN InitString ('+') |
13558    SubOp       :  RETURN InitString ('-') |
13559    MultOp      :  RETURN InitString ('*') |
13560    DivM2Op,
13561    DivCeilOp,
13562    DivFloorOp,
13563    DivTruncOp  :  RETURN InitString ('{%kDIV}') |
13564    ModM2Op,
13565    ModCeilOp,
13566    ModFloorOp  :  RETURN InitString ('{%kMOD}') |
13567    ModTruncOp  :  RETURN InitString ('{%kREM}') |
13568    LogicalOrOp :  RETURN InitString ('{%kOR}') |
13569    LogicalAndOp:  RETURN InitString ('{%kAND}') |
13570    InclOp      :  RETURN InitString ('{%kINCL}') |
13571    ExclOp      :  RETURN InitString ('{%kEXCL}')
13572
13573    ELSE
13574       RETURN NIL
13575    END
13576 END GetM2OperatorDesc ;
13577
13578
13579
13580 (*
13581    PushExit - pushes the exit value onto the EXIT stack.
13582 *)
13583
13584 PROCEDURE PushExit (Exit: CARDINAL) ;
13585 BEGIN
13586    PushWord(ExitStack, Exit)
13587 END PushExit ;
13588
13589
13590 (*
13591    PopExit - pops the exit value from the EXIT stack.
13592 *)
13593
13594 PROCEDURE PopExit() : WORD ;
13595 BEGIN
13596    RETURN( PopWord(ExitStack) )
13597 END PopExit ;
13598
13599
13600 (*
13601    PushFor - pushes the exit value onto the FOR stack.
13602 *)
13603
13604 PROCEDURE PushFor (Exit: CARDINAL) ;
13605 BEGIN
13606    PushWord(ForStack, Exit)
13607 END PushFor ;
13608
13609
13610 (*
13611    PopFor - pops the exit value from the FOR stack.
13612 *)
13613
13614 PROCEDURE PopFor() : WORD ;
13615 BEGIN
13616    RETURN( PopWord(ForStack) )
13617 END PopFor ;
13618
13619
13620 (*
13621    OperandTno - returns the ident operand stored in the true position
13622                 on the boolean stack.  This is exactly the same as
13623                 OperandT but it has no IsBoolean checking.
13624 *)
13625
13626 PROCEDURE OperandTno (pos: CARDINAL) : WORD ;
13627 VAR
13628    f: BoolFrame ;
13629 BEGIN
13630    Assert(pos>0) ;
13631    f := PeepAddress(BoolStack, pos) ;
13632    RETURN( f^.TrueExit )
13633 END OperandTno ;
13634
13635
13636 (*
13637    OperandFno - returns the ident operand stored in the false position
13638                 on the boolean stack.  This is exactly the same as
13639                 OperandF but it has no IsBoolean checking.
13640 *)
13641
13642 PROCEDURE OperandFno (pos: CARDINAL) : WORD ;
13643 VAR
13644    f: BoolFrame ;
13645 BEGIN
13646    Assert(pos>0) ;
13647    f := PeepAddress (BoolStack, pos) ;
13648    RETURN f^.FalseExit
13649 END OperandFno ;
13650
13651
13652 (*
13653    OperandTtok - returns the token associated with the position, pos
13654                  on the boolean stack.
13655 *)
13656
13657 PROCEDURE OperandTtok (pos: CARDINAL) : CARDINAL ;
13658 VAR
13659    f: BoolFrame ;
13660 BEGIN
13661    Assert (pos > 0) ;
13662    f := PeepAddress (BoolStack, pos) ;
13663    RETURN f^.tokenno
13664 END OperandTtok ;
13665
13666
13667 (*
13668    PopBooltok - Pops a True and a False exit quad number from the True/False
13669                 stack.
13670 *)
13671
13672 PROCEDURE PopBooltok (VAR True, False: CARDINAL; VAR tokno: CARDINAL) ;
13673 VAR
13674    f: BoolFrame ;
13675 BEGIN
13676    f := PopAddress (BoolStack) ;
13677    WITH f^ DO
13678       True := TrueExit ;
13679       False := FalseExit ;
13680       tokno := tokenno ;
13681       Assert (BooleanOp)
13682    END ;
13683    DISPOSE (f)
13684 END PopBooltok ;
13685
13686
13687 (*
13688    PushBooltok - Push a True and a False exit quad numbers onto the
13689                  True/False stack.
13690 *)
13691
13692 PROCEDURE PushBooltok (True, False: CARDINAL; tokno: CARDINAL) ;
13693 VAR
13694    f: BoolFrame ;
13695 BEGIN
13696    Assert (True<=NextQuad) ;
13697    Assert (False<=NextQuad) ;
13698    f := newBoolFrame () ;
13699    WITH f^ DO
13700       TrueExit := True ;
13701       FalseExit := False ;
13702       BooleanOp := TRUE ;
13703       tokenno := tokno ;
13704       Annotation := NIL
13705    END ;
13706    PushAddress (BoolStack, f) ;
13707    Annotate ('<q%1d>|<q%2d>||true quad|false quad')
13708 END PushBooltok ;
13709
13710
13711 (*
13712    PopBool - Pops a True and a False exit quad number from the True/False
13713              stack.
13714 *)
13715
13716 PROCEDURE PopBool (VAR True, False: CARDINAL) ;
13717 VAR
13718    tokno: CARDINAL ;
13719 BEGIN
13720    PopBooltok (True, False, tokno)
13721 END PopBool ;
13722
13723
13724 (*
13725    PushBool - Push a True and a False exit quad numbers onto the
13726               True/False stack.
13727 *)
13728
13729 PROCEDURE PushBool (True, False: CARDINAL) ;
13730 BEGIN
13731    PushBooltok (True, False, UnknownTokenNo)
13732 END PushBool ;
13733
13734
13735 (*
13736    IsBoolean - returns true is the Stack position pos contains a Boolean
13737                Exit. False is returned if an Ident is stored.
13738 *)
13739
13740 PROCEDURE IsBoolean (pos: CARDINAL) : BOOLEAN ;
13741 VAR
13742    f: BoolFrame ;
13743 BEGIN
13744    Assert(pos>0) ;
13745    f := PeepAddress(BoolStack, pos) ;
13746    RETURN( f^.BooleanOp )
13747 END IsBoolean ;
13748
13749
13750 (*
13751    OperandD - returns possible array dimension associated with the ident
13752               operand stored on the boolean stack.
13753 *)
13754
13755 PROCEDURE OperandD (pos: CARDINAL) : WORD ;
13756 VAR
13757    f: BoolFrame ;
13758 BEGIN
13759    Assert(pos>0) ;
13760    Assert(NOT IsBoolean (pos)) ;
13761    f := PeepAddress(BoolStack, pos) ;
13762    RETURN( f^.Dimension )
13763 END OperandD ;
13764
13765
13766 (*
13767    OperandA - returns possible array symbol associated with the ident
13768               operand stored on the boolean stack.
13769 *)
13770
13771 PROCEDURE OperandA (pos: CARDINAL) : WORD ;
13772 VAR
13773    f: BoolFrame ;
13774 BEGIN
13775    Assert(pos>0) ;
13776    Assert(NOT IsBoolean (pos)) ;
13777    f := PeepAddress(BoolStack, pos) ;
13778    RETURN( f^.Unbounded )
13779 END OperandA ;
13780
13781
13782 (*
13783    OperandT - returns the ident operand stored in the true position on the boolean stack.
13784 *)
13785
13786 PROCEDURE OperandT (pos: CARDINAL) : WORD ;
13787 BEGIN
13788    Assert(NOT IsBoolean (pos)) ;
13789    RETURN( OperandTno(pos) )
13790 END OperandT ;
13791
13792
13793 (*
13794    OperandF - returns the ident operand stored in the false position on the boolean stack.
13795 *)
13796
13797 PROCEDURE OperandF (pos: CARDINAL) : WORD ;
13798 BEGIN
13799    Assert(NOT IsBoolean (pos)) ;
13800    RETURN( OperandFno(pos) )
13801 END OperandF ;
13802
13803
13804 (*
13805    OperandRW - returns the rw operand stored on the boolean stack.
13806 *)
13807
13808 PROCEDURE OperandRW (pos: CARDINAL) : WORD ;
13809 VAR
13810    f: BoolFrame ;
13811 BEGIN
13812    Assert(pos>0) ;
13813    Assert(NOT IsBoolean (pos)) ;
13814    f := PeepAddress(BoolStack, pos) ;
13815    RETURN( f^.ReadWrite )
13816 END OperandRW ;
13817
13818
13819 (*
13820    OperandMergeRW - returns the rw operand if not NulSym else it
13821                     returns True.
13822 *)
13823
13824 PROCEDURE OperandMergeRW (pos: CARDINAL) : WORD ;
13825 BEGIN
13826    IF OperandRW (pos) = NulSym
13827    THEN
13828       RETURN OperandT (pos)
13829    ELSE
13830       RETURN OperandRW (pos)
13831    END
13832 END OperandMergeRW ;
13833
13834
13835 (*
13836    OperandTok - returns the token associated with pos, on the stack.
13837 *)
13838
13839 PROCEDURE OperandTok (pos: CARDINAL) : WORD ;
13840 BEGIN
13841    Assert (NOT IsBoolean (pos)) ;
13842    RETURN OperandTtok (pos)
13843 END OperandTok ;
13844
13845
13846 (*
13847    BuildCodeOn - generates a quadruple declaring that code should be
13848                  emmitted from henceforth.
13849
13850                  The Stack is unnaffected.
13851 *)
13852
13853 PROCEDURE BuildCodeOn ;
13854 BEGIN
13855    GenQuad(CodeOnOp, NulSym, NulSym, NulSym)
13856 END BuildCodeOn ;
13857
13858
13859 (*
13860    BuildCodeOff - generates a quadruple declaring that code should not be
13861                   emmitted from henceforth.
13862
13863                   The Stack is unnaffected.
13864 *)
13865
13866 PROCEDURE BuildCodeOff ;
13867 BEGIN
13868    GenQuad(CodeOffOp, NulSym, NulSym, NulSym)
13869 END BuildCodeOff ;
13870
13871
13872 (*
13873    BuildProfileOn - generates a quadruple declaring that profile timings
13874                     should be emmitted from henceforth.
13875
13876                     The Stack is unnaffected.
13877 *)
13878
13879 PROCEDURE BuildProfileOn ;
13880 BEGIN
13881    GenQuad(ProfileOnOp, NulSym, NulSym, NulSym)
13882 END BuildProfileOn ;
13883
13884
13885 (*
13886    BuildProfileOn - generates a quadruple declaring that profile timings
13887                     should be emmitted from henceforth.
13888
13889                     The Stack is unnaffected.
13890 *)
13891
13892 PROCEDURE BuildProfileOff ;
13893 BEGIN
13894    GenQuad(ProfileOffOp, NulSym, NulSym, NulSym)
13895 END BuildProfileOff ;
13896
13897
13898 (*
13899    BuildOptimizeOn - generates a quadruple declaring that optimization
13900                      should occur from henceforth.
13901
13902                      The Stack is unnaffected.
13903 *)
13904
13905 PROCEDURE BuildOptimizeOn ;
13906 BEGIN
13907    GenQuad(OptimizeOnOp, NulSym, NulSym, NulSym)
13908 END BuildOptimizeOn ;
13909
13910
13911 (*
13912    BuildOptimizeOff - generates a quadruple declaring that optimization
13913                       should not occur from henceforth.
13914
13915                       The Stack is unnaffected.
13916 *)
13917
13918 PROCEDURE BuildOptimizeOff ;
13919 BEGIN
13920    GenQuad(OptimizeOffOp, NulSym, NulSym, NulSym)
13921 END BuildOptimizeOff ;
13922
13923
13924 (*
13925    BuildInline - builds an Inline pseudo quadruple operator.
13926                  The inline interface, Sym, is stored as the operand
13927                  to the operator InlineOp.
13928
13929                  The stack is expected to contain:
13930
13931
13932                         Entry                   Exit
13933                         =====                   ====
13934
13935                  Ptr ->
13936                         +--------------+
13937                         | Sym          |        Empty
13938                         |--------------|
13939 *)
13940
13941 PROCEDURE BuildInline ;
13942 VAR
13943    Sym: CARDINAL ;
13944 BEGIN
13945    PopT(Sym) ;
13946    GenQuad(InlineOp, NulSym, NulSym, Sym)
13947 END BuildInline ;
13948
13949
13950 (*
13951    BuildLineNo - builds a LineNumberOp pseudo quadruple operator.
13952                  This quadruple indicates which source line has been
13953                  processed, these quadruples are only generated if we
13954                  are producing runtime debugging information.
13955
13956                  The stack is not affected, read or altered in any way.
13957
13958
13959                         Entry                   Exit
13960                         =====                   ====
13961
13962                  Ptr ->                              <- Ptr
13963 *)
13964
13965 PROCEDURE BuildLineNo ;
13966 VAR
13967    filename: Name ;
13968    f       : QuadFrame ;
13969 BEGIN
13970    IF (NextQuad#Head) AND (GenerateLineDebug OR GenerateDebugging) AND FALSE
13971    THEN
13972       filename := makekey(string(GetFileName())) ;
13973       f := GetQF(NextQuad-1) ;
13974       IF NOT ((f^.Operator=LineNumberOp) AND (f^.Operand1=WORD(filename)))
13975       THEN
13976          GenQuad(LineNumberOp, WORD(filename), NulSym, WORD(GetLineNo()))
13977       END
13978    END
13979 END BuildLineNo ;
13980
13981
13982 (*
13983    UseLineNote - uses the line note and returns it to the free list.
13984 *)
13985
13986 PROCEDURE UseLineNote (l: LineNote) ;
13987 VAR
13988    f: QuadFrame ;
13989 BEGIN
13990    WITH l^ DO
13991       f := GetQF(NextQuad-1) ;
13992       IF (f^.Operator=LineNumberOp) AND (f^.Operand1=WORD(File))
13993       THEN
13994          (* do nothing *)
13995       ELSE
13996          IF FALSE
13997          THEN
13998             GenQuad(LineNumberOp, WORD(File), NulSym, WORD(Line))
13999          END
14000       END ;
14001       Next := FreeLineList
14002    END ;
14003    FreeLineList := l
14004 END UseLineNote ;
14005
14006
14007 (*
14008    PopLineNo - pops a line note from the line stack.
14009 *)
14010
14011 PROCEDURE PopLineNo () : LineNote ;
14012 VAR
14013    l: LineNote ;
14014 BEGIN
14015    l := PopAddress(LineStack) ;
14016    IF l=NIL
14017    THEN
14018       InternalError ('no line note available')
14019    END ;
14020    RETURN( l  )
14021 END PopLineNo ;
14022
14023
14024 (*
14025    InitLineNote - creates a line note and initializes it to
14026                   contain, file, line.
14027 *)
14028
14029 PROCEDURE InitLineNote (file: Name; line: CARDINAL) : LineNote ;
14030 VAR
14031    l: LineNote ;
14032 BEGIN
14033    IF FreeLineList=NIL
14034    THEN
14035       NEW(l)
14036    ELSE
14037       l := FreeLineList ;
14038       FreeLineList := FreeLineList^.Next
14039    END ;
14040    WITH l^ DO
14041       File := file ;
14042       Line := line
14043    END ;
14044    RETURN( l )
14045 END InitLineNote ;
14046
14047
14048 (*
14049    PushLineNote -
14050 *)
14051
14052 PROCEDURE PushLineNote (l: LineNote) ;
14053 BEGIN
14054    PushAddress(LineStack, l)
14055 END PushLineNote ;
14056
14057
14058 (*
14059    PushLineNo - pushes the current file and line number to the stack.
14060 *)
14061
14062 PROCEDURE PushLineNo ;
14063 BEGIN
14064    PushLineNote(InitLineNote(makekey(string(GetFileName())), GetLineNo()))
14065 END PushLineNo ;
14066
14067
14068 (*
14069    BuildStmtNote - builds a StatementNoteOp pseudo quadruple operator.
14070                    This quadruple indicates which source line has been
14071                    processed and it represents the start of a statement
14072                    sequence.
14073                    It differs from LineNumberOp in that multiple successive
14074                    LineNumberOps will be removed and the final one is attached to
14075                    the next real GCC tree.  Whereas a StatementNoteOp is always left
14076                    alone.  Depending upon the debugging level it will issue a nop
14077                    instruction to ensure that the gdb single step will step into
14078                    this line.  Practically it allows pedalogical debugging to
14079                    occur when there is syntax sugar such as:
14080
14081
14082                          END  (* step *)
14083                       END  (* step *)
14084                    END ; (* step *)
14085                    a := 1 ; (* step *)
14086
14087                    REPEAT (* step *)
14088                       i := 1  (* step *)
14089
14090                    The stack is not affected, read or altered in any way.
14091
14092
14093                         Entry                   Exit
14094                         =====                   ====
14095
14096                  Ptr ->                              <- Ptr
14097 *)
14098
14099 PROCEDURE BuildStmtNote (offset: INTEGER) ;
14100 VAR
14101    filename: Name ;
14102    f       : QuadFrame ;
14103    i       : INTEGER ;
14104 BEGIN
14105    IF NextQuad#Head
14106    THEN
14107       f := GetQF (NextQuad-1) ;
14108       i := offset ;
14109       INC (i, GetTokenNo ()) ;
14110       (* no need to have multiple notes at the same position.  *)
14111       IF (f^.Operator # StatementNoteOp) OR (f^.Operand3 # VAL (CARDINAL, i))
14112       THEN
14113          filename := makekey (string (GetFileName ())) ;
14114          GenQuad (StatementNoteOp, WORD (filename), NulSym, i)
14115       END
14116    END
14117 END BuildStmtNote ;
14118
14119
14120 (*
14121    AddRecordToList - adds the record held on the top of stack to the
14122                      list of records and varient fields.
14123 *)
14124
14125 PROCEDURE AddRecordToList ;
14126 VAR
14127    r: CARDINAL ;
14128    n: CARDINAL ;
14129 BEGIN
14130    r := OperandT(1) ;
14131    Assert(IsRecord(r) OR IsFieldVarient(r)) ;
14132    (*
14133       r might be a field varient if the declaration consists of nested
14134       varients.  However ISO TSIZE can only utilise record types, we store
14135       a varient field anyway as the next pass would not know whether to
14136       ignore a varient field.
14137    *)
14138    PutItemIntoList (VarientFields, r) ;
14139    IF DebugVarients
14140    THEN
14141       n := NoOfItemsInList(VarientFields) ;
14142       IF IsRecord(r)
14143       THEN
14144          printf2('in list: record %d is %d\n', n, r)
14145       ELSE
14146          printf2('in list: varient field %d is %d\n', n, r)
14147       END
14148    END
14149 END AddRecordToList ;
14150
14151
14152 (*
14153    AddVarientToList - adds varient held on the top of stack to the list.
14154 *)
14155
14156 PROCEDURE AddVarientToList ;
14157 VAR
14158    v, n: CARDINAL ;
14159 BEGIN
14160    v := OperandT(1) ;
14161    Assert(IsVarient(v)) ;
14162    PutItemIntoList(VarientFields, v) ;
14163    IF DebugVarients
14164    THEN
14165       n := NoOfItemsInList(VarientFields) ;
14166       printf2('in list: varient %d is %d\n', n, v)
14167    END
14168 END AddVarientToList ;
14169
14170
14171 (*
14172    AddVarientFieldToList - adds varient field, f, to the list of all varient
14173                            fields created.
14174 *)
14175
14176 PROCEDURE AddVarientFieldToList (f: CARDINAL) ;
14177 VAR
14178    n: CARDINAL ;
14179 BEGIN
14180    Assert(IsFieldVarient(f)) ;
14181    PutItemIntoList(VarientFields, f) ;
14182    IF DebugVarients
14183    THEN
14184       n := NoOfItemsInList(VarientFields) ;
14185       printf2('in list: varient field %d is %d\n', n, f)
14186    END
14187 END AddVarientFieldToList ;
14188
14189
14190 (*
14191    GetRecordOrField -
14192 *)
14193
14194 PROCEDURE GetRecordOrField () : CARDINAL ;
14195 VAR
14196    f: CARDINAL ;
14197 BEGIN
14198    INC(VarientFieldNo) ;
14199    f := GetItemFromList(VarientFields, VarientFieldNo) ;
14200    IF DebugVarients
14201    THEN
14202       IF IsRecord(f)
14203       THEN
14204          printf2('out list: record %d is %d\n', VarientFieldNo, f)
14205       ELSE
14206          printf2('out list: varient field %d is %d\n', VarientFieldNo, f)
14207       END
14208    END ;
14209    RETURN( f )
14210 END GetRecordOrField ;
14211
14212
14213 (*
14214    BeginVarient - begin a varient record.
14215 *)
14216
14217 PROCEDURE BeginVarient ;
14218 VAR
14219    r, v: CARDINAL ;
14220 BEGIN
14221    r := GetRecordOrField() ;
14222    Assert(IsRecord(r) OR IsFieldVarient(r)) ;
14223    v := GetRecordOrField() ;
14224    Assert(IsVarient(v)) ;
14225    BuildRange(InitCaseBounds(PushCase(r, v)))
14226 END BeginVarient ;
14227
14228
14229 (*
14230    EndVarient - end a varient record.
14231 *)
14232
14233 PROCEDURE EndVarient ;
14234 BEGIN
14235    PopCase
14236 END EndVarient ;
14237
14238
14239 (*
14240    ElseVarient - associate an ELSE clause with a varient record.
14241 *)
14242
14243 PROCEDURE ElseVarient ;
14244 VAR
14245    f: CARDINAL ;
14246 BEGIN
14247    f := GetRecordOrField() ;
14248    Assert(IsFieldVarient(f)) ;
14249    ElseCase(f)
14250 END ElseVarient ;
14251
14252
14253
14254 (*
14255    BeginVarientList - begin an ident list containing ranges belonging to a
14256                       varient list.
14257 *)
14258
14259 PROCEDURE BeginVarientList ;
14260 VAR
14261    f: CARDINAL ;
14262 BEGIN
14263    f := GetRecordOrField() ;
14264    Assert(IsFieldVarient(f)) ;
14265    BeginCaseList(f)
14266 END BeginVarientList ;
14267
14268
14269 (*
14270    EndVarientList - end a range list for a varient field.
14271 *)
14272
14273 PROCEDURE EndVarientList ;
14274 BEGIN
14275    EndCaseList
14276 END EndVarientList ;
14277
14278
14279 (*
14280    AddVarientRange - creates a range from the top two contant expressions
14281                      on the stack which are recorded with the current
14282                      varient field.  The stack is unaltered.
14283 *)
14284
14285 PROCEDURE AddVarientRange ;
14286 VAR
14287    r1, r2: CARDINAL ;
14288 BEGIN
14289    PopT(r2) ;
14290    PopT(r1) ;
14291    AddRange(r1, r2, GetTokenNo())
14292 END AddVarientRange ;
14293
14294
14295 (*
14296    AddVarientEquality - adds the contant expression on the top of the stack
14297                         to the current varient field being recorded.
14298                         The stack is unaltered.
14299 *)
14300
14301 PROCEDURE AddVarientEquality ;
14302 VAR
14303    r1: CARDINAL ;
14304 BEGIN
14305    PopT(r1) ;
14306    AddRange(r1, NulSym, GetTokenNo())
14307 END AddVarientEquality ;
14308
14309
14310 (*
14311    IncOperandD - increment the dimension number associated with symbol
14312                  at, pos, on the boolean stack.
14313 *)
14314
14315 (*
14316 PROCEDURE IncOperandD (pos: CARDINAL) ;
14317 VAR
14318    f: BoolFrame ;
14319 BEGIN
14320    f := PeepAddress(BoolStack, pos) ;
14321    INC(f^.Dimension)
14322 END IncOperandD ;
14323 *)
14324
14325
14326 (*
14327    PushTFA - Push True, False, Array, numbers onto the
14328              True/False stack.  True and False are assumed to
14329              contain Symbols or Ident etc.
14330 *)
14331
14332 PROCEDURE PushTFA (True, False, Array: WORD) ;
14333 VAR
14334    f: BoolFrame ;
14335 BEGIN
14336    f := newBoolFrame () ;
14337    WITH f^ DO
14338       TrueExit := True ;
14339       FalseExit := False ;
14340       Unbounded := Array
14341    END ;
14342    PushAddress(BoolStack, f)
14343 END PushTFA ;
14344
14345
14346 (*
14347    PushTFAD - Push True, False, Array, Dim, numbers onto the
14348               True/False stack.  True and False are assumed to
14349               contain Symbols or Ident etc.
14350 *)
14351
14352 PROCEDURE PushTFAD (True, False, Array, Dim: WORD) ;
14353 VAR
14354    f: BoolFrame ;
14355 BEGIN
14356    f := newBoolFrame () ;
14357    WITH f^ DO
14358       TrueExit := True ;
14359       FalseExit := False ;
14360       Unbounded := Array ;
14361       Dimension := Dim
14362    END ;
14363    PushAddress(BoolStack, f)
14364 END PushTFAD ;
14365
14366
14367 (*
14368    PushTFADtok - Push True, False, Array, Dim, numbers onto the
14369                  True/False stack.  True and False are assumed to
14370                  contain Symbols or Ident etc.
14371 *)
14372
14373 PROCEDURE PushTFADtok (True, False, Array, Dim: WORD; tokno: CARDINAL) ;
14374 VAR
14375    f: BoolFrame ;
14376 BEGIN
14377    f := newBoolFrame () ;
14378    WITH f^ DO
14379       TrueExit := True ;
14380       FalseExit := False ;
14381       Unbounded := Array ;
14382       Dimension := Dim ;
14383       tokenno := tokno
14384    END ;
14385    PushAddress (BoolStack, f)
14386 END PushTFADtok ;
14387
14388
14389 (*
14390    PushTFADrwtok - Push True, False, Array, Dim, rw, numbers onto the
14391                    True/False stack.  True and False are assumed to
14392                    contain Symbols or Ident etc.
14393 *)
14394
14395 PROCEDURE PushTFADrwtok (True, False, Array, Dim, rw: WORD; Tok: CARDINAL) ;
14396 VAR
14397    f: BoolFrame ;
14398 BEGIN
14399    f := newBoolFrame () ;
14400    WITH f^ DO
14401       TrueExit := True ;
14402       FalseExit := False ;
14403       Unbounded := Array ;
14404       Dimension := Dim ;
14405       ReadWrite := rw ;
14406       tokenno := Tok
14407    END ;
14408    PushAddress (BoolStack, f)
14409 END PushTFADrwtok ;
14410
14411
14412 (*
14413    PopTFrwtok - Pop a True and False number from the True/False stack.
14414                 True and False are assumed to contain Symbols or Ident etc.
14415 *)
14416
14417 PROCEDURE PopTFrwtok (VAR True, False, rw: WORD; VAR tokno: CARDINAL) ;
14418 VAR
14419    f: BoolFrame ;
14420 BEGIN
14421    f := PopAddress(BoolStack) ;
14422    WITH f^ DO
14423       True := TrueExit ;
14424       False := FalseExit ;
14425       Assert(NOT BooleanOp) ;
14426       rw := ReadWrite ;
14427       tokno := tokenno
14428    END ;
14429    DISPOSE(f)
14430 END PopTFrwtok ;
14431
14432
14433 (*
14434    PushTFrwtok - Push an item onto the stack in the T (true) position,
14435                  it is assummed to be a token and its token location is recorded.
14436 *)
14437
14438 PROCEDURE PushTFrwtok (True, False, rw: WORD; tokno: CARDINAL) ;
14439 VAR
14440    f: BoolFrame ;
14441 BEGIN
14442    f := newBoolFrame () ;
14443    WITH f^ DO
14444       TrueExit := True ;
14445       FalseExit := False ;
14446       ReadWrite := rw ;
14447       tokenno := tokno
14448    END ;
14449    PushAddress(BoolStack, f)
14450 END PushTFrwtok ;
14451
14452
14453 (*
14454    PushTFDtok - Push True, False, Dim, numbers onto the
14455                 True/False stack.  True and False are assumed to
14456                 contain Symbols or Ident etc.
14457 *)
14458
14459 PROCEDURE PushTFDtok (True, False, Dim: WORD; Tok: CARDINAL) ;
14460 VAR
14461    f: BoolFrame ;
14462 BEGIN
14463    f := newBoolFrame () ;
14464    WITH f^ DO
14465       TrueExit := True ;
14466       FalseExit := False ;
14467       Dimension := Dim ;
14468       tokenno := Tok
14469    END ;
14470    PushAddress (BoolStack, f)
14471 END PushTFDtok ;
14472
14473
14474 (*
14475    PopTFDtok - Pop a True, False, Dim number from the True/False stack.
14476                True and False are assumed to contain Symbols or Ident etc.
14477 *)
14478
14479 PROCEDURE PopTFDtok (VAR True, False, Dim: WORD; VAR Tok: CARDINAL) ;
14480 VAR
14481    f: BoolFrame ;
14482 BEGIN
14483    f := PopAddress(BoolStack) ;
14484    WITH f^ DO
14485       True := TrueExit ;
14486       False := FalseExit ;
14487       Dim := Dimension ;
14488       Tok := tokenno ;
14489       Assert(NOT BooleanOp)
14490    END ;
14491    DISPOSE(f)
14492 END PopTFDtok ;
14493
14494
14495 (*
14496    PushTFDrwtok - Push True, False, Dim, numbers onto the
14497                   True/False stack.  True and False are assumed to
14498                   contain Symbols or Ident etc.
14499 *)
14500
14501 PROCEDURE PushTFDrwtok (True, False, Dim, rw: WORD; Tok: CARDINAL) ;
14502 VAR
14503    f: BoolFrame ;
14504 BEGIN
14505    f := newBoolFrame () ;
14506    WITH f^ DO
14507       TrueExit := True ;
14508       FalseExit := False ;
14509       Dimension := Dim ;
14510       ReadWrite := rw ;
14511       tokenno := Tok
14512    END ;
14513    PushAddress (BoolStack, f)
14514 END PushTFDrwtok ;
14515
14516
14517 (*
14518    PushTFrw - Push a True and False numbers onto the True/False stack.
14519               True and False are assumed to contain Symbols or Ident etc.
14520               It also pushes the higher level symbol which is associated
14521               with the True symbol.  Eg record variable or array variable.
14522 *)
14523
14524 PROCEDURE PushTFrw (True, False: WORD; rw: CARDINAL) ;
14525 VAR
14526    f: BoolFrame ;
14527 BEGIN
14528    f := newBoolFrame () ;
14529    WITH f^ DO
14530       TrueExit := True ;
14531       FalseExit := False ;
14532       ReadWrite := rw
14533    END ;
14534    PushAddress(BoolStack, f)
14535 END PushTFrw ;
14536
14537
14538 (*
14539    PopTFrw - Pop a True and False number from the True/False stack.
14540              True and False are assumed to contain Symbols or Ident etc.
14541 *)
14542
14543 PROCEDURE PopTFrw (VAR True, False, rw: WORD) ;
14544 VAR
14545    f: BoolFrame ;
14546 BEGIN
14547    f := PopAddress(BoolStack) ;
14548    WITH f^ DO
14549       True := TrueExit ;
14550       False := FalseExit ;
14551       Assert(NOT BooleanOp) ;
14552       rw := ReadWrite
14553    END ;
14554    DISPOSE(f)
14555 END PopTFrw ;
14556
14557
14558 (*
14559    PushTF - Push a True and False numbers onto the True/False stack.
14560             True and False are assumed to contain Symbols or Ident etc.
14561 *)
14562
14563 PROCEDURE PushTF (True, False: WORD) ;
14564 VAR
14565    f: BoolFrame ;
14566 BEGIN
14567    f := newBoolFrame () ;
14568    WITH f^ DO
14569       TrueExit := True ;
14570       FalseExit := False
14571    END ;
14572    PushAddress(BoolStack, f)
14573 END PushTF ;
14574
14575
14576 (*
14577    PopTF - Pop a True and False number from the True/False stack.
14578            True and False are assumed to contain Symbols or Ident etc.
14579 *)
14580
14581 PROCEDURE PopTF (VAR True, False: WORD) ;
14582 VAR
14583    f: BoolFrame ;
14584 BEGIN
14585    f := PopAddress(BoolStack) ;
14586    WITH f^ DO
14587       True := TrueExit ;
14588       False := FalseExit ;
14589       Assert(NOT BooleanOp)
14590    END ;
14591    DISPOSE(f)
14592 END PopTF ;
14593
14594
14595 (*
14596    newBoolFrame - creates a new BoolFrame with all fields initialised to their defaults.
14597 *)
14598
14599 PROCEDURE newBoolFrame () : BoolFrame ;
14600 VAR
14601    f: BoolFrame ;
14602 BEGIN
14603    NEW (f) ;
14604    WITH f^ DO
14605       TrueExit   := 0 ;
14606       FalseExit  := 0 ;
14607       Unbounded  := NulSym ;
14608       BooleanOp  := FALSE ;
14609       Dimension  := 0 ;
14610       ReadWrite  := NulSym ;
14611       name       := NulSym ;
14612       Annotation := NIL ;
14613       tokenno    := UnknownTokenNo
14614    END ;
14615    RETURN f
14616 END newBoolFrame ;
14617
14618
14619 (*
14620    PushTtok - Push an item onto the stack in the T (true) position,
14621               it is assummed to be a token and its token location is recorded.
14622 *)
14623
14624 PROCEDURE PushTtok (True: WORD; tokno: CARDINAL) ;
14625 VAR
14626    f: BoolFrame ;
14627 BEGIN
14628    (* PrintTokenNo (tokno) ; *)
14629    f := newBoolFrame () ;
14630    WITH f^ DO
14631       TrueExit := True ;
14632       tokenno := tokno
14633    END ;
14634    PushAddress (BoolStack, f)
14635 END PushTtok ;
14636
14637
14638 (*
14639    PushT - Push an item onto the stack in the T (true) position.
14640 *)
14641
14642 PROCEDURE PushT (True: WORD) ;
14643 VAR
14644    f: BoolFrame ;
14645 BEGIN
14646    f := newBoolFrame () ;
14647    WITH f^ DO
14648       TrueExit := True
14649    END ;
14650    PushAddress (BoolStack, f)
14651 END PushT ;
14652
14653
14654 (*
14655    PopT - Pops the T value from the stack.
14656 *)
14657
14658 PROCEDURE PopT (VAR True: WORD) ;
14659 VAR
14660    f: BoolFrame ;
14661 BEGIN
14662    f := PopAddress (BoolStack) ;
14663    WITH f^ DO
14664       True := TrueExit ;
14665       Assert(NOT BooleanOp)
14666    END ;
14667    DISPOSE(f)
14668 END PopT ;
14669
14670
14671 (*
14672    PopTtok - Pops the T value from the stack and token position.
14673 *)
14674
14675 PROCEDURE PopTtok (VAR True: WORD; VAR tok: CARDINAL) ;
14676 VAR
14677    f: BoolFrame ;
14678 BEGIN
14679    f := PopAddress(BoolStack) ;
14680    WITH f^ DO
14681       True := TrueExit ;
14682       tok := tokenno ;
14683       Assert(NOT BooleanOp)
14684    END ;
14685    DISPOSE(f)
14686 END PopTtok ;
14687
14688
14689 (*
14690    PushTrw - Push an item onto the True/False stack. The False value will be zero.
14691 *)
14692
14693 (*
14694 PROCEDURE PushTrw (True: WORD; rw: WORD) ;
14695 VAR
14696    f: BoolFrame ;
14697 BEGIN
14698    f := newBoolFrame () ;
14699    WITH f^ DO
14700       TrueExit := True ;
14701       ReadWrite := rw
14702    END ;
14703    PushAddress(BoolStack, f)
14704 END PushTrw ;
14705 *)
14706
14707
14708 (*
14709    PushTrwtok - Push an item onto the True/False stack. The False value will be zero.
14710 *)
14711
14712 PROCEDURE PushTrwtok (True: WORD; rw: WORD; tok: CARDINAL) ;
14713 VAR
14714    f: BoolFrame ;
14715 BEGIN
14716    f := newBoolFrame () ;
14717    WITH f^ DO
14718       TrueExit := True ;
14719       ReadWrite := rw ;
14720       tokenno := tok
14721    END ;
14722    PushAddress(BoolStack, f)
14723 END PushTrwtok ;
14724
14725
14726 (*
14727    PopTrw - Pop a True field and rw symbol from the stack.
14728 *)
14729
14730 PROCEDURE PopTrw (VAR True, rw: WORD) ;
14731 VAR
14732    f: BoolFrame ;
14733 BEGIN
14734    f := PopAddress(BoolStack) ;
14735    WITH f^ DO
14736       True := TrueExit ;
14737       Assert(NOT BooleanOp) ;
14738       rw := ReadWrite
14739    END ;
14740    DISPOSE(f)
14741 END PopTrw ;
14742
14743
14744 (*
14745    PopTrwtok - Pop a True field and rw symbol from the stack.
14746 *)
14747
14748 PROCEDURE PopTrwtok (VAR True, rw: WORD; VAR tok: CARDINAL) ;
14749 VAR
14750    f: BoolFrame ;
14751 BEGIN
14752    f := PopAddress(BoolStack) ;
14753    WITH f^ DO
14754       True := TrueExit ;
14755       Assert(NOT BooleanOp) ;
14756       rw := ReadWrite ;
14757       tok := tokenno
14758    END ;
14759    DISPOSE(f)
14760 END PopTrwtok ;
14761
14762
14763 (*
14764    PushTFn - Push a True and False numbers onto the True/False stack.
14765              True and False are assumed to contain Symbols or Ident etc.
14766 *)
14767
14768 PROCEDURE PushTFn (True, False, n: WORD) ;
14769 VAR
14770    f: BoolFrame ;
14771 BEGIN
14772    f := newBoolFrame () ;
14773    WITH f^ DO
14774       TrueExit  := True ;
14775       FalseExit := False ;
14776       name      := n
14777    END ;
14778    PushAddress(BoolStack, f)
14779 END PushTFn ;
14780
14781
14782 (*
14783    PushTFntok - Push a True and False numbers onto the True/False stack.
14784                 True and False are assumed to contain Symbols or Ident etc.
14785 *)
14786
14787 PROCEDURE PushTFntok (True, False, n: WORD; tokno: CARDINAL) ;
14788 VAR
14789    f: BoolFrame ;
14790 BEGIN
14791    f := newBoolFrame () ;
14792    WITH f^ DO
14793       TrueExit  := True ;
14794       FalseExit := False ;
14795       name      := n ;
14796       tokenno   := tokno
14797    END ;
14798    PushAddress (BoolStack, f)
14799 END PushTFntok ;
14800
14801
14802 (*
14803    PopTFn - Pop a True and False number from the True/False stack.
14804             True and False are assumed to contain Symbols or Ident etc.
14805 *)
14806
14807 PROCEDURE PopTFn (VAR True, False, n: WORD) ;
14808 VAR
14809    f: BoolFrame ;
14810 BEGIN
14811    f := PopAddress(BoolStack) ;
14812    WITH f^ DO
14813       True := TrueExit ;
14814       False := FalseExit ;
14815       n := name ;
14816       Assert(NOT BooleanOp)
14817    END ;
14818    DISPOSE(f)
14819 END PopTFn ;
14820
14821
14822 (*
14823    PopNothing - pops the top element on the boolean stack.
14824 *)
14825
14826 PROCEDURE PopNothing ;
14827 VAR
14828    f: BoolFrame ;
14829 BEGIN
14830    f := PopAddress(BoolStack) ;
14831    DISPOSE(f)
14832 END PopNothing ;
14833
14834
14835 (*
14836    PopN - pops multiple elements from the BoolStack.
14837 *)
14838
14839 PROCEDURE PopN (n: CARDINAL) ;
14840 BEGIN
14841    WHILE n>0 DO
14842       PopNothing ;
14843       DEC(n)
14844    END
14845 END PopN ;
14846
14847
14848 (*
14849    PushTFtok - Push an item onto the stack in the T (true) position,
14850                it is assummed to be a token and its token location is recorded.
14851 *)
14852
14853 PROCEDURE PushTFtok (True, False: WORD; tokno: CARDINAL) ;
14854 VAR
14855    f: BoolFrame ;
14856 BEGIN
14857    f := newBoolFrame () ;
14858    WITH f^ DO
14859       TrueExit := True ;
14860       FalseExit := False ;
14861       tokenno := tokno
14862    END ;
14863    PushAddress(BoolStack, f)
14864 END PushTFtok ;
14865
14866
14867 (*
14868    PopTFtok - Pop T/F/tok from the stack.
14869 *)
14870
14871 PROCEDURE PopTFtok (VAR True, False: WORD; VAR tokno: CARDINAL) ;
14872 VAR
14873    f: BoolFrame ;
14874 BEGIN
14875    f := PopAddress(BoolStack) ;
14876    WITH f^ DO
14877       True := TrueExit ;
14878       False := FalseExit ;
14879       tokno := tokenno
14880    END
14881 END PopTFtok ;
14882
14883
14884 (*
14885    PushTFAtok - Push T/F/A/tok to the stack.
14886 *)
14887
14888 PROCEDURE PushTFAtok (True, False, Array: WORD; tokno: CARDINAL) ;
14889 VAR
14890    f: BoolFrame ;
14891 BEGIN
14892    f := newBoolFrame () ;
14893    WITH f^ DO
14894       TrueExit := True ;
14895       FalseExit := False ;
14896       Unbounded := Array ;
14897       tokenno := tokno
14898    END ;
14899    PushAddress(BoolStack, f)
14900 END PushTFAtok ;
14901
14902
14903 (*
14904    Top - returns the no of items held in the stack.
14905 *)
14906
14907 PROCEDURE Top () : CARDINAL ;
14908 BEGIN
14909    RETURN( NoOfItemsInStackAddress(BoolStack) )
14910 END Top ;
14911
14912
14913 (*
14914    PushAutoOn - push the auto flag and then set it to TRUE.
14915                 Any call to ident in the parser will result in the token being pushed.
14916 *)
14917
14918 PROCEDURE PushAutoOn ;
14919 BEGIN
14920    PushWord(AutoStack, IsAutoOn) ;
14921    IsAutoOn := TRUE
14922 END PushAutoOn ;
14923
14924
14925 (*
14926    PushAutoOff - push the auto flag and then set it to FALSE.
14927 *)
14928
14929 PROCEDURE PushAutoOff ;
14930 BEGIN
14931    PushWord(AutoStack, IsAutoOn) ;
14932    IsAutoOn := FALSE
14933 END PushAutoOff ;
14934
14935
14936 (*
14937    IsAutoPushOn - returns the value of the current Auto ident push flag.
14938 *)
14939
14940 PROCEDURE IsAutoPushOn () : BOOLEAN ;
14941 BEGIN
14942    RETURN( IsAutoOn )
14943 END IsAutoPushOn ;
14944
14945
14946 (*
14947    PopAuto - restores the previous value of the Auto flag.
14948 *)
14949
14950 PROCEDURE PopAuto ;
14951 BEGIN
14952    IsAutoOn := PopWord(AutoStack)
14953 END PopAuto ;
14954
14955
14956 (*
14957    PushInConstExpression - push the InConstExpression flag and then set it to TRUE.
14958 *)
14959
14960 PROCEDURE PushInConstExpression ;
14961 BEGIN
14962    PushWord(ConstStack, InConstExpression) ;
14963    InConstExpression := TRUE
14964 END PushInConstExpression ;
14965
14966
14967 (*
14968    PopInConstExpression - restores the previous value of the InConstExpression.
14969 *)
14970
14971 PROCEDURE PopInConstExpression ;
14972 BEGIN
14973    InConstExpression := PopWord(ConstStack)
14974 END PopInConstExpression ;
14975
14976
14977 (*
14978    IsInConstExpression - returns the value of the InConstExpression.
14979 *)
14980
14981 PROCEDURE IsInConstExpression () : BOOLEAN ;
14982 BEGIN
14983    RETURN( InConstExpression )
14984 END IsInConstExpression ;
14985
14986
14987 (*
14988    MustCheckOverflow - returns TRUE if the quadruple should test for overflow.
14989 *)
14990
14991 PROCEDURE MustCheckOverflow (q: CARDINAL) : BOOLEAN ;
14992 VAR
14993    f: QuadFrame ;
14994 BEGIN
14995    f := GetQF(q) ;
14996    RETURN( f^.CheckOverflow )
14997 END MustCheckOverflow ;
14998
14999
15000 (*
15001    StressStack -
15002 *)
15003
15004 (*
15005 PROCEDURE StressStack ;
15006 CONST
15007    Maxtries = 1000 ;
15008 VAR
15009    n, i, j: CARDINAL ;
15010 BEGIN
15011    PushT(1) ;
15012    PopT(i) ;
15013    Assert(i=1) ;
15014    FOR n := 1 TO Maxtries DO
15015       FOR i := n TO 1 BY -1 DO
15016          PushT(i)
15017       END ;
15018       FOR i := n TO 1 BY -1 DO
15019          Assert(OperandT(i)=i)
15020       END ;
15021       FOR i := 1 TO n DO
15022          Assert(OperandT(i)=i)
15023       END ;
15024       FOR i := 1 TO n BY 10 DO
15025          Assert(OperandT(i)=i)
15026       END ;
15027       IF (n>1) AND (n MOD 2 = 0)
15028       THEN
15029          FOR i := 1 TO n DIV 2 DO
15030             PopT(j) ;
15031             Assert(j=i)
15032          END ;
15033          FOR i := n DIV 2 TO 1 BY -1 DO
15034             PushT(i)
15035          END
15036       END ;
15037       FOR i := 1 TO n DO
15038          PopT(j) ;
15039          Assert(j=i)
15040       END
15041    END
15042 END StressStack ;
15043 *)
15044
15045
15046 (*
15047    Init - initialize the M2Quads module, all the stacks, all the lists
15048           and the quads list.
15049 *)
15050
15051 PROCEDURE Init ;
15052 BEGIN
15053    LogicalOrTok := MakeKey('_LOR') ;
15054    LogicalAndTok := MakeKey('_LAND') ;
15055    LogicalXorTok := MakeKey('_LXOR') ;
15056    LogicalDifferenceTok := MakeKey('_LDIFF') ;
15057    QuadArray := InitIndex (1) ;
15058    FreeList := 1 ;
15059    NewQuad(NextQuad) ;
15060    Assert(NextQuad=1) ;
15061    BoolStack := InitStackAddress() ;
15062    ExitStack := InitStackWord() ;
15063    RepeatStack := InitStackWord() ;
15064    WhileStack := InitStackWord() ;
15065    ForStack := InitStackWord() ;
15066    WithStack := InitStackAddress() ;
15067    ReturnStack := InitStackWord() ;
15068    LineStack := InitStackAddress() ;
15069    PriorityStack := InitStackWord() ;
15070    TryStack := InitStackWord() ;
15071    CatchStack := InitStackWord() ;
15072    ExceptStack := InitStackWord() ;
15073    ConstructorStack := InitStackAddress() ;
15074    ConstStack := InitStackWord() ;
15075    (* StressStack ; *)
15076    SuppressWith := FALSE ;
15077    Head := 1 ;
15078    LastQuadNo := 0 ;
15079    MustNotCheckBounds := FALSE ;
15080    InitQuad := 0 ;
15081    GrowInitialization := 0 ;
15082    ForInfo := InitIndex (1) ;
15083    QuadrupleGeneration := TRUE ;
15084    BuildingHigh := FALSE ;
15085    BuildingSize := FALSE ;
15086    AutoStack := InitStackWord() ;
15087    IsAutoOn := TRUE ;
15088    InConstExpression := FALSE ;
15089    FreeLineList := NIL ;
15090    InitList(VarientFields) ;
15091    VarientFieldNo := 0 ;
15092    NoOfQuads := 0
15093 END Init ;
15094
15095
15096 BEGIN
15097    Init
15098 END M2Quads.