gcc/m2/gm2-compiler/M2Quads.mod

   1 (* M2Quads.mod generates quadruples.
   2
   3 Copyright (C) 2001-2024 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, MetaErrorT3,
  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                         PutVarHeap,
  89                         IsVarParam, IsProcedure, IsPointer, IsParameter,
  90                         IsUnboundedParam, IsEnumeration, IsDefinitionForC,
  91                         IsVarAParam, IsVarient, IsLegal,
  92                         UsesVarArgs, UsesOptArg,
  93                         GetOptArgInit,
  94                         IsReturnOptional,
  95                         NoOfElements,
  96                         NoOfParam,
  97                         StartScope, EndScope,
  98                         IsGnuAsm, IsGnuAsmVolatile,
  99                         MakeRegInterface, PutRegInterface,
 100                         HasExceptionBlock, PutExceptionBlock,
 101                         HasExceptionFinally, PutExceptionFinally,
 102                         GetParent, GetRecord, IsRecordField, IsFieldVarient, IsRecord,
 103                         IsFieldEnumeration,
 104                         IsVar, IsProcType, IsType, IsSubrange, IsExported,
 105                         IsConst, IsConstString, IsModule, IsDefImp,
 106                         IsArray, IsUnbounded, IsProcedureNested,
 107                         IsParameterUnbounded,
 108                         IsPartialUnbounded, IsProcedureBuiltin,
 109                         IsSet, IsConstSet, IsConstructor, PutConst,
 110                         PutConstructor, PutConstructorFrom,
 111                         PutDeclared,
 112                         MakeComponentRecord, MakeComponentRef,
 113                         IsSubscript, IsComponent,
 114                         IsTemporary,
 115                         IsAModula2Type,
 116                         PutLeftValueFrontBackType,
 117                         PushSize, PushValue, PopValue,
 118                         GetVariableAtAddress, IsVariableAtAddress,
 119                         MakeError, UnknownReported,
 120                         IsProcedureBuiltinAvailable,
 121                         IsError,
 122                         IsInnerModule,
 123                         IsImportStatement, IsImport, GetImportModule, GetImportDeclared,
 124                         GetImportStatementList,
 125                         GetModuleDefImportStatementList, GetModuleModImportStatementList,
 126                         IsCtor, IsPublic, IsExtern, IsMonoName,
 127
 128                         GetUnboundedRecordType,
 129                         GetUnboundedAddressOffset,
 130                         GetUnboundedHighOffset,
 131                         PutVarArrayRef,
 132
 133                         ForeachFieldEnumerationDo, ForeachLocalSymDo,
 134                         GetExported, PutImported, GetSym, GetLibName,
 135                         IsUnused,
 136                         NulSym ;
 137
 138 FROM M2Batch IMPORT MakeDefinitionSource ;
 139 FROM M2GCCDeclare IMPORT PutToBeSolvedByQuads ;
 140
 141 FROM FifoQueue IMPORT GetConstFromFifoQueue,
 142                       PutConstructorIntoFifoQueue, GetConstructorFromFifoQueue ;
 143
 144 FROM M2Comp IMPORT CompilingImplementationModule,
 145                    CompilingProgramModule ;
 146
 147 FROM M2LexBuf IMPORT currenttoken, UnknownTokenNo, BuiltinTokenNo,
 148                      GetToken, MakeVirtualTok,
 149                      GetFileName, TokenToLineNo, GetTokenName,
 150                      GetTokenNo, GetLineNo, GetPreviousTokenLineNo, PrintTokenNo ;
 151
 152 FROM M2Error IMPORT Error,
 153                     InternalError,
 154                     WriteFormat0, WriteFormat1, WriteFormat2, WriteFormat3,
 155                     NewError, NewWarning, ErrorFormat0, ErrorFormat1,
 156                     ErrorFormat2, ErrorFormat3, FlushErrors, ChainError,
 157                     ErrorString,
 158                     ErrorStringAt, ErrorStringAt2, ErrorStringsAt2,
 159                     WarnStringAt, WarnStringAt2, WarnStringsAt2 ;
 160
 161 FROM M2Printf IMPORT printf0, printf1, printf2, printf3, printf4 ;
 162
 163 FROM M2Reserved IMPORT PlusTok, MinusTok, TimesTok, DivTok, ModTok,
 164                        DivideTok, RemTok,
 165                        OrTok, AndTok, AmbersandTok,
 166                        EqualTok, LessEqualTok, GreaterEqualTok,
 167                        LessTok, GreaterTok, HashTok, LessGreaterTok,
 168                        InTok,
 169                        UpArrowTok, RParaTok, LParaTok, CommaTok,
 170                        NulTok, ByTok,
 171                        SemiColonTok, toktype ;
 172
 173 FROM M2Base IMPORT True, False, Boolean, Cardinal, Integer, Char,
 174                    Real, LongReal, ShortReal, Nil,
 175                    ZType, RType, CType,
 176                    Re, Im, Cmplx,
 177                    NegateType, ComplexToScalar, GetCmplxReturnType,
 178                    IsAssignmentCompatible, IsExpressionCompatible,
 179                    AssignmentRequiresWarning,
 180                    CannotCheckTypeInPass3, ScalarToComplex, MixTypes,
 181                    CheckAssignmentCompatible, CheckExpressionCompatible,
 182                    High, LengthS, New, Dispose, Inc, Dec, Incl, Excl,
 183                    Cap, Abs, Odd,
 184                    IsOrd, Chr, Convert, Val, IsFloat, IsTrunc,
 185                    IsInt, Min, Max,
 186                    IsPseudoBaseProcedure, IsPseudoBaseFunction,
 187                    IsMathType, IsOrdinalType, IsRealType,
 188                    IsBaseType, GetBaseTypeMinMax, ActivationPointer ;
 189
 190 FROM M2System IMPORT IsPseudoSystemFunction, IsPseudoSystemProcedure,
 191                      IsSystemType, GetSystemTypeMinMax,
 192                      IsPseudoSystemFunctionConstExpression,
 193                      IsGenericSystemType,
 194                      Adr, TSize, TBitSize, AddAdr, SubAdr, DifAdr, Cast,
 195                      Shift, Rotate, MakeAdr, Address, Byte, Word, Loc, Throw ;
 196
 197 FROM M2Size IMPORT Size ;
 198 FROM M2Bitset IMPORT Bitset ;
 199
 200 FROM M2ALU IMPORT PushInt, Gre, Less, PushNulSet, AddBitRange, AddBit,
 201                   IsGenericNulSet, IsValueAndTreeKnown, AddField,
 202                   AddElements, ChangeToConstructor ;
 203
 204 FROM Lists IMPORT List, InitList, GetItemFromList, NoOfItemsInList, PutItemIntoList,
 205                   IsItemInList, KillList, IncludeItemIntoList ;
 206
 207 FROM M2Options IMPORT NilChecking,
 208                       WholeDivChecking, WholeValueChecking,
 209                       IndexChecking, RangeChecking,
 210                       CaseElseChecking, ReturnChecking,
 211                       UnusedVariableChecking, UnusedParameterChecking,
 212                       Iso, Pim, Pim2, Pim3, Pim4, PositiveModFloorDiv,
 213                       Pedantic, CompilerDebugging, GenerateDebugging,
 214                       GenerateLineDebug, Exceptions,
 215                       Profiling, Coding, Optimizing,
 216                       UninitVariableChecking,
 217                       ScaffoldDynamic, ScaffoldStatic, cflag,
 218                       ScaffoldMain, SharedFlag, WholeProgram,
 219                       GetRuntimeModuleOverride ;
 220
 221 FROM M2Pass IMPORT IsPassCodeGeneration, IsNoPass ;
 222
 223 FROM M2StackAddress IMPORT StackOfAddress, InitStackAddress, KillStackAddress,
 224                            PushAddress, PopAddress, PeepAddress,
 225                            IsEmptyAddress, NoOfItemsInStackAddress ;
 226
 227 FROM M2StackWord IMPORT StackOfWord, InitStackWord, KillStackWord,
 228                         PushWord, PopWord, PeepWord, RemoveTop,
 229                         IsEmptyWord, NoOfItemsInStackWord ;
 230
 231 FROM Indexing IMPORT Index, InitIndex, GetIndice, PutIndice, InBounds, HighIndice, IncludeIndiceIntoIndex ;
 232
 233 FROM M2Range IMPORT InitAssignmentRangeCheck,
 234                     InitReturnRangeCheck,
 235                     InitSubrangeRangeCheck,
 236                     InitStaticArraySubscriptRangeCheck,
 237                     InitDynamicArraySubscriptRangeCheck,
 238                     InitIncRangeCheck,
 239                     InitDecRangeCheck,
 240                     InitInclCheck,
 241                     InitExclCheck,
 242                     InitRotateCheck,
 243                     InitShiftCheck,
 244                     InitTypesAssignmentCheck,
 245                     InitTypesExpressionCheck,
 246                     InitTypesParameterCheck,
 247                     InitForLoopBeginRangeCheck,
 248                     InitForLoopToRangeCheck,
 249                     InitForLoopEndRangeCheck,
 250                     InitPointerRangeCheck,
 251                     InitNoReturnRangeCheck,
 252                     InitNoElseRangeCheck,
 253                     InitCaseBounds,
 254                     InitWholeZeroDivisionCheck,
 255                     InitWholeZeroRemainderCheck,
 256                     InitParameterRangeCheck,
 257                     WriteRangeCheck ;
 258
 259 FROM M2CaseList IMPORT PushCase, PopCase, AddRange, BeginCaseList, EndCaseList, ElseCase ;
 260 FROM PCSymBuild IMPORT SkipConst ;
 261 FROM m2builtins IMPORT GetBuiltinTypeInfoType ;
 262
 263 IMPORT M2Error ;
 264
 265
 266 CONST
 267    DebugStackOn = TRUE ;
 268    DebugVarients = FALSE ;
 269    BreakAtQuad = 53 ;
 270    DebugTokPos = FALSE ;
 271
 272 TYPE
 273    ConstructorFrame = POINTER TO RECORD
 274                                     type : CARDINAL ;
 275                                     index: CARDINAL ;
 276                                  END ;
 277
 278    BoolFrame = POINTER TO RECORD
 279                              TrueExit  : CARDINAL ;
 280                              FalseExit : CARDINAL ;
 281                              Unbounded : CARDINAL ;
 282                              BooleanOp : BOOLEAN ;
 283                              Dimension : CARDINAL ;
 284                              ReadWrite : CARDINAL ;
 285                              name      : CARDINAL ;
 286                              Annotation: String ;
 287                              tokenno   : CARDINAL ;
 288                           END ;
 289
 290    QuadFrame = POINTER TO RECORD
 291                              Operator           : QuadOperator ;
 292                              Operand1           : CARDINAL ;
 293                              Operand2           : CARDINAL ;
 294                              Operand3           : CARDINAL ;
 295                              Trash              : CARDINAL ;
 296                              Next               : CARDINAL ;     (* Next quadruple.                 *)
 297                              LineNo             : CARDINAL ;     (* Line No of source text.         *)
 298                              TokenNo            : CARDINAL ;     (* Token No of source text.        *)
 299                              NoOfTimesReferenced: CARDINAL ;     (* No of times quad is referenced. *)
 300                              CheckOverflow      : BOOLEAN ;      (* should backend check overflow   *)
 301                              op1pos,
 302                              op2pos,
 303                              op3pos             : CARDINAL ;     (* Token position of operands.     *)
 304                           END ;
 305
 306    WithFrame = POINTER TO RECORD
 307                              RecordSym   : CARDINAL ;
 308                              RecordType  : CARDINAL ;
 309                              RecordRef   : CARDINAL ;
 310                              rw          : CARDINAL ;          (* The record variable.  *)
 311                              RecordTokPos: CARDINAL ;          (* Token of the record.  *)
 312                           END ;
 313
 314    ForLoopInfo = POINTER TO RECORD
 315                                IncrementQuad,
 316                                StartOfForLoop,                 (* We keep a list of all for         *)
 317                                EndOfForLoop,                   (* loops so we can check index.      *)
 318                                ForLoopIndex,
 319                                IndexTok      : CARDINAL ;      (* Used to ensure iterators are not  *)
 320                                                                (* user modified.                    *)
 321                             END ;
 322
 323    LineNote  = POINTER TO RECORD
 324                              Line: CARDINAL ;
 325                              File: Name ;
 326                              Next: LineNote ;
 327                           END ;
 328 VAR
 329    ConstructorStack,
 330    LineStack,
 331    BoolStack,
 332    WithStack            : StackOfAddress ;
 333    TryStack,
 334    CatchStack,
 335    ExceptStack,
 336    ConstStack,
 337    AutoStack,
 338    RepeatStack,
 339    WhileStack,
 340    ForStack,
 341    ExitStack,
 342    ReturnStack          : StackOfWord ;   (* Return quadruple of the procedure.  *)
 343    PriorityStack        : StackOfWord ;   (* Temporary variable holding old      *)
 344                                           (* priority.                           *)
 345    SuppressWith         : BOOLEAN ;
 346    QuadArray            : Index ;
 347    NextQuad             : CARDINAL ;  (* Next quadruple number to be created.    *)
 348    FreeList             : CARDINAL ;  (* FreeList of quadruples.                 *)
 349    CurrentProc          : CARDINAL ;  (* Current procedure being compiled, used  *)
 350                                       (* to determine which procedure a RETURN.  *)
 351                                       (* ReturnValueOp must have as its 3rd op.  *)
 352    InitQuad             : CARDINAL ;  (* Initial Quad BackPatch that starts the  *)
 353                                       (* suit of Modules.                        *)
 354    LastQuadNo           : CARDINAL ;  (* Last Quadruple accessed by GetQuad.     *)
 355    ArithPlusTok,                      (* Internal + token for arithmetic only.   *)
 356    LogicalOrTok,                      (* Internal _LOR token.                    *)
 357    LogicalAndTok,                     (* Internal _LAND token.                   *)
 358    LogicalXorTok,                     (* Internal _LXOR token.                   *)
 359    LogicalDifferenceTok : Name ;      (* Internal _LDIFF token.                  *)
 360    InConstExpression,
 361    IsAutoOn,                          (* Should parser automatically push        *)
 362                                       (* idents?                                 *)
 363    MustNotCheckBounds   : BOOLEAN ;
 364    ForInfo              : Index ;     (* Start and end of all FOR loops.         *)
 365    GrowInitialization   : CARDINAL ;  (* Upper limit of where the initialized    *)
 366                                       (* quadruples.                             *)
 367    BuildingHigh,
 368    BuildingSize,
 369    QuadrupleGeneration  : BOOLEAN ;      (* Should we be generating quadruples?  *)
 370    FreeLineList         : LineNote ;  (* Free list of line notes.                *)
 371    VarientFields        : List ;      (* The list of all varient fields created. *)
 372    VarientFieldNo       : CARDINAL ;  (* Used to retrieve the VarientFields      *)
 373                                       (* in order.                               *)
 374    NoOfQuads            : CARDINAL ;  (* Number of used quadruples.              *)
 375    Head                 : CARDINAL ;  (* Head of the list of quadruples.         *)
 376
 377
 378 (*
 379    Rules for file and initialization quadruples:
 380
 381    StartModFileOp  - indicates that this file (module) has produced the
 382                      following code
 383    StartDefFileOp  - indicates that this definition module has produced
 384                      this code.
 385    EndFileOp       - indicates that a module has finished
 386    InitStartOp     - the start of the initialization code of a module
 387    InitEndOp       - the end of the above
 388    FinallyStartOp  - the start of the finalization code of a module
 389    FinallyEndOp    - the end of the above
 390 *)
 391
 392
 393 (*
 394 #define InitString(X) InitStringDB(X, __FILE__, __LINE__)
 395 #define InitStringCharStar(X) InitStringCharStarDB(X, __FILE__, __LINE__)
 396 #define InitStringChar(X) InitStringCharDB(X, __FILE__, __LINE__)
 397 #define Mult(X,Y) MultDB(X, Y, __FILE__, __LINE__)
 398 #define Dup(X) DupDB(X, __FILE__, __LINE__)
 399 #define Slice(X,Y,Z) SliceDB(X, Y, Z, __FILE__, __LINE__)
 400 *)
 401
 402
 403 (*
 404    doDSdbEnter -
 405 *)
 406
 407 (*
 408 PROCEDURE doDSdbEnter ;
 409 BEGIN
 410    PushAllocation
 411 END doDSdbEnter ;
 412 *)
 413
 414 (*
 415    doDSdbExit -
 416 *)
 417
 418 (*
 419 PROCEDURE doDSdbExit (s: String) ;
 420 BEGIN
 421    s := PopAllocationExemption(TRUE, s)
 422 END doDSdbExit ;
 423 *)
 424
 425 (*
 426    DSdbEnter -
 427 *)
 428
 429 PROCEDURE DSdbEnter ;
 430 BEGIN
 431 END DSdbEnter ;
 432
 433
 434 (*
 435    DSdbExit -
 436 *)
 437
 438 PROCEDURE DSdbExit ;
 439 BEGIN
 440 END DSdbExit ;
 441
 442
 443 (*
 444 #define DBsbEnter doDBsbEnter
 445 #define DBsbExit  doDBsbExit
 446 *)
 447
 448
 449 (*
 450    SetOptionProfiling - builds a profile quadruple if the profiling
 451                         option was given to the compiler.
 452 *)
 453
 454 PROCEDURE SetOptionProfiling (b: BOOLEAN) ;
 455 BEGIN
 456    IF b#Profiling
 457    THEN
 458       IF b
 459       THEN
 460          BuildProfileOn
 461       ELSE
 462          BuildProfileOff
 463       END ;
 464       Profiling := b
 465    END
 466 END SetOptionProfiling ;
 467
 468
 469 (*
 470    SetOptionCoding - builds a code quadruple if the profiling
 471                      option was given to the compiler.
 472 *)
 473
 474 PROCEDURE SetOptionCoding (b: BOOLEAN) ;
 475 BEGIN
 476    IF b#Coding
 477    THEN
 478       IF b
 479       THEN
 480          BuildCodeOn
 481       ELSE
 482          BuildCodeOff
 483       END ;
 484       Coding := b
 485    END
 486 END SetOptionCoding ;
 487
 488
 489 (*
 490    SetOptionOptimizing - builds a quadruple to say that the optimization option
 491                          has been found in a comment.
 492 *)
 493
 494 PROCEDURE SetOptionOptimizing (b: BOOLEAN) ;
 495 BEGIN
 496    IF b
 497    THEN
 498       BuildOptimizeOn
 499    ELSE
 500       BuildOptimizeOff
 501    END
 502 END SetOptionOptimizing ;
 503
 504
 505 (*
 506    GetQF - returns the QuadFrame associated with, q.
 507 *)
 508
 509 PROCEDURE GetQF (q: CARDINAL) : QuadFrame ;
 510 BEGIN
 511    RETURN QuadFrame (GetIndice (QuadArray, q))
 512 END GetQF ;
 513
 514
 515 (*
 516    Opposite - returns the opposite comparison operator.
 517 *)
 518
 519 PROCEDURE Opposite (Operator: QuadOperator) : QuadOperator ;
 520 VAR
 521    Op: QuadOperator ;
 522 BEGIN
 523    CASE Operator OF
 524
 525    IfNotEquOp : Op := IfEquOp |
 526    IfEquOp    : Op := IfNotEquOp |
 527    IfLessEquOp: Op := IfGreOp |
 528    IfGreOp    : Op := IfLessEquOp |
 529    IfGreEquOp : Op := IfLessOp |
 530    IfLessOp   : Op := IfGreEquOp |
 531    IfInOp     : Op := IfNotInOp |
 532    IfNotInOp  : Op := IfInOp
 533
 534    ELSE
 535       InternalError ('unexpected operator')
 536    END ;
 537    RETURN Op
 538 END Opposite ;
 539
 540
 541 (*
 542    IsReferenced - returns true if QuadNo is referenced by another quadruple.
 543 *)
 544
 545 PROCEDURE IsReferenced (QuadNo: CARDINAL) : BOOLEAN ;
 546 VAR
 547    f: QuadFrame ;
 548 BEGIN
 549    f := GetQF(QuadNo) ;
 550    WITH f^ DO
 551       RETURN( (Operator=ProcedureScopeOp) OR (Operator=NewLocalVarOp) OR
 552               (NoOfTimesReferenced>0) )
 553    END
 554 END IsReferenced ;
 555
 556
 557 (*
 558    IsBackReference - returns TRUE if quadruple, q, is referenced from a quad further on.
 559 *)
 560
 561 PROCEDURE IsBackReference (q: CARDINAL) : BOOLEAN ;
 562 VAR
 563    i            : CARDINAL ;
 564    op           : QuadOperator ;
 565    op1, op2, op3: CARDINAL ;
 566 BEGIN
 567    i := q ;
 568    WHILE i#0 DO
 569       GetQuad (i, op, op1, op2, op3) ;
 570       CASE op OF
 571
 572       NewLocalVarOp,
 573       KillLocalVarOp,
 574       FinallyStartOp,
 575       FinallyEndOp,
 576       InitEndOp,
 577       InitStartOp,
 578       EndFileOp,
 579       StartDefFileOp,
 580       StartModFileOp:  RETURN( FALSE ) |       (* run into end of procedure or module *)
 581
 582       GotoOp,
 583       IfEquOp,
 584       IfLessEquOp,
 585       IfGreEquOp,
 586       IfGreOp,
 587       IfLessOp,
 588       IfNotEquOp,
 589       IfInOp,
 590       IfNotInOp     :  IF op3=q
 591                        THEN
 592                           RETURN( TRUE )
 593                        END
 594
 595       ELSE
 596       END ;
 597       i := GetNextQuad (i)
 598    END ;
 599    InternalError ('fix this for the sake of efficiency..')
 600 END IsBackReference ;
 601
 602
 603 (*
 604    IsUnConditional - returns true if QuadNo is an unconditional jump.
 605 *)
 606
 607 PROCEDURE IsUnConditional (QuadNo: CARDINAL) : BOOLEAN ;
 608 VAR
 609    f: QuadFrame ;
 610 BEGIN
 611    f := GetQF(QuadNo) ;
 612    WITH f^ DO
 613       CASE Operator OF
 614
 615       ThrowOp,
 616       RetryOp,
 617       CallOp,
 618       ReturnOp,
 619       GotoOp  : RETURN( TRUE )
 620
 621       ELSE
 622          RETURN( FALSE )
 623       END
 624    END
 625 END IsUnConditional ;
 626
 627
 628 (*
 629    IsConditional - returns true if QuadNo is a conditional jump.
 630 *)
 631
 632 PROCEDURE IsConditional (QuadNo: CARDINAL) : BOOLEAN ;
 633 VAR
 634    f: QuadFrame ;
 635 BEGIN
 636    f := GetQF(QuadNo) ;
 637    WITH f^ DO
 638       CASE Operator OF
 639
 640       IfInOp,
 641       IfNotInOp,
 642       IfEquOp,
 643       IfNotEquOp,
 644       IfLessOp,
 645       IfLessEquOp,
 646       IfGreOp,
 647       IfGreEquOp : RETURN( TRUE )
 648
 649       ELSE
 650          RETURN( FALSE )
 651       END ;
 652    END
 653 END IsConditional ;
 654
 655
 656 (*
 657    IsBackReferenceConditional - returns TRUE if quadruple, q, is referenced from
 658                                 a conditional quad further on.
 659 *)
 660
 661 PROCEDURE IsBackReferenceConditional (q: CARDINAL) : BOOLEAN ;
 662 VAR
 663    i            : CARDINAL ;
 664    op           : QuadOperator ;
 665    op1, op2, op3: CARDINAL ;
 666 BEGIN
 667    i := q ;
 668    WHILE i#0 DO
 669       GetQuad (i, op, op1, op2, op3) ;
 670       CASE op OF
 671
 672       NewLocalVarOp,
 673       KillLocalVarOp,
 674       FinallyStartOp,
 675       FinallyEndOp,
 676       InitEndOp,
 677       InitStartOp,
 678       EndFileOp,
 679       StartDefFileOp,
 680       StartModFileOp:  RETURN( FALSE ) |       (* run into end of procedure or module *)
 681
 682       TryOp,
 683       RetryOp,
 684       GotoOp,
 685       IfEquOp,
 686       IfLessEquOp,
 687       IfGreEquOp,
 688       IfGreOp,
 689       IfLessOp,
 690       IfNotEquOp,
 691       IfInOp,
 692       IfNotInOp     :  IF (op3=q) AND IsConditional(q)
 693                        THEN
 694                           RETURN( TRUE )
 695                        END
 696
 697       ELSE
 698          RETURN FALSE
 699       END ;
 700       i := GetNextQuad (i)
 701    END ;
 702    InternalError ('fix this for the sake of efficiency..')
 703 END IsBackReferenceConditional ;
 704
 705
 706 (*
 707    IsQuadA - returns true if QuadNo is a op.
 708 *)
 709
 710 PROCEDURE IsQuadA (QuadNo: CARDINAL; op: QuadOperator) : BOOLEAN ;
 711 VAR
 712    f: QuadFrame ;
 713 BEGIN
 714    f := GetQF(QuadNo) ;
 715    WITH f^ DO
 716       RETURN( Operator=op )
 717    END
 718 END IsQuadA ;
 719
 720
 721 (*
 722    IsGoto - returns true if QuadNo is a goto operation.
 723 *)
 724
 725 PROCEDURE IsGoto (QuadNo: CARDINAL) : BOOLEAN ;
 726 BEGIN
 727    RETURN( IsQuadA (QuadNo, GotoOp) )
 728 END IsGoto ;
 729
 730
 731 (*
 732    IsCall - returns true if QuadNo is a call operation.
 733 *)
 734
 735 PROCEDURE IsCall (QuadNo: CARDINAL) : BOOLEAN ;
 736 BEGIN
 737    RETURN( IsQuadA(QuadNo, CallOp) )
 738 END IsCall ;
 739
 740
 741 (*
 742    IsReturn - returns true if QuadNo is a return operation.
 743 *)
 744
 745 PROCEDURE IsReturn (QuadNo: CARDINAL) : BOOLEAN ;
 746 BEGIN
 747    RETURN( IsQuadA(QuadNo, ReturnOp) )
 748 END IsReturn ;
 749
 750
 751 (*
 752    IsNewLocalVar - returns true if QuadNo is a NewLocalVar operation.
 753 *)
 754
 755 PROCEDURE IsNewLocalVar (QuadNo: CARDINAL) : BOOLEAN ;
 756 BEGIN
 757    RETURN( IsQuadA(QuadNo, NewLocalVarOp) )
 758 END IsNewLocalVar ;
 759
 760
 761 (*
 762    IsKillLocalVar - returns true if QuadNo is a KillLocalVar operation.
 763 *)
 764
 765 PROCEDURE IsKillLocalVar (QuadNo: CARDINAL) : BOOLEAN ;
 766 BEGIN
 767    RETURN( IsQuadA(QuadNo, KillLocalVarOp) )
 768 END IsKillLocalVar ;
 769
 770
 771 (*
 772    IsProcedureScope - returns true if QuadNo is a ProcedureScope operation.
 773 *)
 774
 775 PROCEDURE IsProcedureScope (QuadNo: CARDINAL) : BOOLEAN ;
 776 BEGIN
 777    RETURN( IsQuadA(QuadNo, ProcedureScopeOp) )
 778 END IsProcedureScope ;
 779
 780
 781 (*
 782    IsCatchBegin - returns true if QuadNo is a catch begin quad.
 783 *)
 784
 785 PROCEDURE IsCatchBegin (QuadNo: CARDINAL) : BOOLEAN ;
 786 BEGIN
 787    RETURN( IsQuadA(QuadNo, CatchBeginOp) )
 788 END IsCatchBegin ;
 789
 790
 791 (*
 792    IsCatchEnd - returns true if QuadNo is a catch end quad.
 793 *)
 794
 795 PROCEDURE IsCatchEnd (QuadNo: CARDINAL) : BOOLEAN ;
 796 BEGIN
 797    RETURN( IsQuadA(QuadNo, CatchEndOp) )
 798 END IsCatchEnd ;
 799
 800
 801 (*
 802    IsInitStart - returns true if QuadNo is a init start quad.
 803 *)
 804
 805 PROCEDURE IsInitStart (QuadNo: CARDINAL) : BOOLEAN ;
 806 BEGIN
 807    RETURN( IsQuadA(QuadNo, InitStartOp) )
 808 END IsInitStart ;
 809
 810
 811 (*
 812    IsInitEnd - returns true if QuadNo is a init end quad.
 813 *)
 814
 815 PROCEDURE IsInitEnd (QuadNo: CARDINAL) : BOOLEAN ;
 816 BEGIN
 817    RETURN( IsQuadA(QuadNo, InitEndOp) )
 818 END IsInitEnd ;
 819
 820
 821 (*
 822    IsFinallyStart - returns true if QuadNo is a finally start quad.
 823 *)
 824
 825 PROCEDURE IsFinallyStart (QuadNo: CARDINAL) : BOOLEAN ;
 826 BEGIN
 827    RETURN( IsQuadA(QuadNo, FinallyStartOp) )
 828 END IsFinallyStart ;
 829
 830
 831 (*
 832    IsFinallyEnd - returns true if QuadNo is a finally end quad.
 833 *)
 834
 835 PROCEDURE IsFinallyEnd (QuadNo: CARDINAL) : BOOLEAN ;
 836 BEGIN
 837    RETURN( IsQuadA(QuadNo, FinallyEndOp) )
 838 END IsFinallyEnd ;
 839
 840
 841 (*
 842    IsInitialisingConst - returns TRUE if the quadruple is setting
 843                          a const (op1) with a value.
 844 *)
 845
 846 PROCEDURE IsInitialisingConst (QuadNo: CARDINAL) : BOOLEAN ;
 847 VAR
 848    op           : QuadOperator ;
 849    op1, op2, op3: CARDINAL ;
 850 BEGIN
 851    GetQuad (QuadNo, op, op1, op2, op3) ;
 852    CASE op OF
 853
 854    InclOp,
 855    ExclOp,
 856    UnboundedOp,
 857    FunctValueOp,
 858    NegateOp,
 859    BecomesOp,
 860    HighOp,
 861    SizeOp,
 862    AddrOp,
 863    RecordFieldOp,
 864    ArrayOp,
 865    LogicalShiftOp,
 866    LogicalRotateOp,
 867    LogicalOrOp,
 868    LogicalAndOp,
 869    LogicalXorOp,
 870    CoerceOp,
 871    ConvertOp,
 872    CastOp,
 873    AddOp,
 874    SubOp,
 875    MultOp,
 876    ModFloorOp,
 877    DivCeilOp,
 878    ModCeilOp,
 879    DivFloorOp,
 880    ModTruncOp,
 881    DivTruncOp,
 882    DivM2Op,
 883    ModM2Op,
 884    XIndrOp,
 885    IndrXOp,
 886    SaveExceptionOp,
 887    RestoreExceptionOp:  RETURN( IsConst(op1) )
 888
 889    ELSE
 890       RETURN( FALSE )
 891    END
 892 END IsInitialisingConst ;
 893
 894
 895 (*
 896    IsOptimizeOn - returns true if the Optimize flag was true at QuadNo.
 897 *)
 898
 899 PROCEDURE IsOptimizeOn (QuadNo: CARDINAL) : BOOLEAN ;
 900 VAR
 901    f : QuadFrame ;
 902    n,
 903    q : CARDINAL ;
 904    On: BOOLEAN ;
 905 BEGIN
 906    On := Optimizing ;
 907    q := Head ;
 908    WHILE (q#0) AND (q#QuadNo) DO
 909       f := GetQF(q) ;
 910       WITH f^ DO
 911          IF Operator=OptimizeOnOp
 912          THEN
 913             On := TRUE
 914          ELSIF Operator=OptimizeOffOp
 915          THEN
 916             On := FALSE
 917          END ;
 918          n := Next
 919       END ;
 920       q := n
 921    END ;
 922    RETURN( On )
 923 END IsOptimizeOn ;
 924
 925
 926 (*
 927    IsProfileOn - returns true if the Profile flag was true at QuadNo.
 928 *)
 929
 930 PROCEDURE IsProfileOn (QuadNo: CARDINAL) : BOOLEAN ;
 931 VAR
 932    f : QuadFrame ;
 933    n,
 934    q : CARDINAL ;
 935    On: BOOLEAN ;
 936 BEGIN
 937    On := Profiling ;
 938    q := Head ;
 939    WHILE (q#0) AND (q#QuadNo) DO
 940       f := GetQF(q) ;
 941       WITH f^ DO
 942          IF Operator=ProfileOnOp
 943          THEN
 944             On := TRUE
 945          ELSIF Operator=ProfileOffOp
 946          THEN
 947             On := FALSE
 948          END ;
 949          n := Next
 950       END ;
 951       q := n
 952    END ;
 953    RETURN( On )
 954 END IsProfileOn ;
 955
 956
 957 (*
 958    IsCodeOn - returns true if the Code flag was true at QuadNo.
 959 *)
 960
 961 PROCEDURE IsCodeOn (QuadNo: CARDINAL) : BOOLEAN ;
 962 VAR
 963    f : QuadFrame ;
 964    n,
 965    q : CARDINAL ;
 966    On: BOOLEAN ;
 967 BEGIN
 968    On := Coding ;
 969    q := Head ;
 970    WHILE (q#0) AND (q#QuadNo) DO
 971       f := GetQF(q) ;
 972       WITH f^ DO
 973          IF Operator=CodeOnOp
 974          THEN
 975             On := TRUE
 976          ELSIF Operator=CodeOffOp
 977          THEN
 978             On := FALSE
 979          END ;
 980          n := Next
 981       END ;
 982       q := n
 983    END ;
 984    RETURN( On )
 985 END IsCodeOn ;
 986
 987
 988 (*
 989    IsDefOrModFile - returns TRUE if QuadNo is a start of Module or Def file
 990                     directive.
 991 *)
 992
 993 PROCEDURE IsDefOrModFile (QuadNo: CARDINAL) : BOOLEAN ;
 994 VAR
 995    f: QuadFrame ;
 996 BEGIN
 997    f := GetQF(QuadNo) ;
 998    WITH f^ DO
 999       RETURN( (Operator=StartDefFileOp) OR (Operator=StartModFileOp) )
1000    END
1001 END IsDefOrModFile ;
1002
1003
1004 (*
1005    IsPseudoQuad - returns true if QuadNo is a compiler directive.
1006                   ie code, profile and optimize.
1007                      StartFile, EndFile,
1008 *)
1009
1010 PROCEDURE IsPseudoQuad (QuadNo: CARDINAL) : BOOLEAN ;
1011 VAR
1012    f: QuadFrame ;
1013 BEGIN
1014    f := GetQF(QuadNo) ;
1015    WITH f^ DO
1016       RETURN( (Operator=CodeOnOp) OR (Operator=CodeOffOp) OR
1017               (Operator=ProfileOnOp) OR (Operator=ProfileOffOp) OR
1018               (Operator=OptimizeOnOp) OR (Operator=OptimizeOffOp) OR
1019               (Operator=EndFileOp) OR
1020               (Operator=StartDefFileOp) OR (Operator=StartModFileOp)
1021             )
1022    END
1023 END IsPseudoQuad ;
1024
1025
1026 (*
1027    GetLastFileQuad - returns the Quadruple number of the last StartDefFile or
1028                      StartModFile quadruple.
1029 *)
1030
1031 PROCEDURE GetLastFileQuad (QuadNo: CARDINAL) : CARDINAL ;
1032 VAR
1033    f       : QuadFrame ;
1034    q, i,
1035    FileQuad: CARDINAL ;
1036 BEGIN
1037    q := Head ;
1038    FileQuad := 0 ;
1039    REPEAT
1040       f := GetQF(q) ;
1041       WITH f^ DO
1042          IF (Operator=StartModFileOp) OR (Operator=StartDefFileOp)
1043          THEN
1044             FileQuad := q
1045          END ;
1046          i := Next
1047       END ;
1048       q := i
1049    UNTIL (i=QuadNo) OR (i=0) ;
1050    Assert(i#0) ;
1051    Assert(FileQuad#0) ;
1052    RETURN( FileQuad )
1053 END GetLastFileQuad ;
1054
1055
1056 (*
1057    GetLastQuadNo - returns the last quadruple number referenced
1058                    by a GetQuad.
1059 *)
1060
1061 PROCEDURE GetLastQuadNo () : CARDINAL ;
1062 BEGIN
1063    RETURN( LastQuadNo )
1064 END GetLastQuadNo ;
1065
1066
1067 (*
1068    QuadToLineNo - Converts a QuadNo into the approprate line number of the
1069                   source file, the line number is returned.
1070
1071                   This may be used to yield an idea where abouts in the
1072                   source file the code generetion is
1073                   processing.
1074 *)
1075
1076 PROCEDURE QuadToLineNo (QuadNo: CARDINAL) : CARDINAL ;
1077 VAR
1078    f: QuadFrame ;
1079 BEGIN
1080    IF ((LastQuadNo=0) AND (NOT IsNoPass()) AND (NOT IsPassCodeGeneration())) OR
1081       (NOT InBounds(QuadArray, QuadNo))
1082    THEN
1083       RETURN( 0 )
1084    ELSE
1085       f := GetQF(QuadNo) ;
1086       RETURN( f^.LineNo )
1087    END
1088 END QuadToLineNo ;
1089
1090
1091 (*
1092    QuadToTokenNo - Converts a QuadNo into the approprate token number of the
1093                    source file, the line number is returned.
1094
1095                    This may be used to yield an idea where abouts in the
1096                    source file the code generetion is
1097                    processing.
1098 *)
1099
1100 PROCEDURE QuadToTokenNo (QuadNo: CARDINAL) : CARDINAL ;
1101 VAR
1102    f: QuadFrame ;
1103 BEGIN
1104    IF ((LastQuadNo=0) AND (NOT IsNoPass()) AND (NOT IsPassCodeGeneration())) OR
1105       (NOT InBounds(QuadArray, QuadNo))
1106    THEN
1107       RETURN( 0 )
1108    ELSE
1109       f := GetQF(QuadNo) ;
1110       RETURN( f^.TokenNo )
1111    END
1112 END QuadToTokenNo ;
1113
1114
1115 (*
1116    GetQuad - returns the Quadruple QuadNo.
1117 *)
1118
1119 PROCEDURE GetQuad (QuadNo: CARDINAL;
1120                    VAR Op: QuadOperator;
1121                    VAR Oper1, Oper2, Oper3: 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    END
1133 END GetQuad ;
1134
1135
1136 (*
1137    GetQuadtok - returns the Quadruple QuadNo.
1138 *)
1139
1140 PROCEDURE GetQuadtok (QuadNo: CARDINAL;
1141                       VAR Op: QuadOperator;
1142                       VAR Oper1, Oper2, Oper3: CARDINAL;
1143                       VAR Op1Pos, Op2Pos, Op3Pos: CARDINAL) ;
1144 VAR
1145    f: QuadFrame ;
1146 BEGIN
1147    f := GetQF (QuadNo) ;
1148    LastQuadNo := QuadNo ;
1149    WITH f^ DO
1150       Op := Operator ;
1151       Oper1 := Operand1 ;
1152       Oper2 := Operand2 ;
1153       Oper3 := Operand3 ;
1154       Op1Pos := op1pos ;
1155       Op2Pos := op2pos ;
1156       Op3Pos := op3pos
1157    END
1158 END GetQuadtok ;
1159
1160
1161 (*
1162    GetQuadOtok - returns the Quadruple QuadNo.
1163 *)
1164
1165 PROCEDURE GetQuadOtok (QuadNo: CARDINAL;
1166                        VAR tok: CARDINAL;
1167                        VAR Op: QuadOperator;
1168                        VAR Oper1, Oper2, Oper3: CARDINAL;
1169                        VAR overflowChecking: BOOLEAN ;
1170                        VAR Op1Pos, Op2Pos, Op3Pos: CARDINAL) ;
1171 VAR
1172    f: QuadFrame ;
1173 BEGIN
1174    f := GetQF (QuadNo) ;
1175    LastQuadNo := QuadNo ;
1176    WITH f^ DO
1177       Op := Operator ;
1178       Oper1 := Operand1 ;
1179       Oper2 := Operand2 ;
1180       Oper3 := Operand3 ;
1181       Op1Pos := op1pos ;
1182       Op2Pos := op2pos ;
1183       Op3Pos := op3pos ;
1184       tok := TokenNo ;
1185       overflowChecking := CheckOverflow
1186    END
1187 END GetQuadOtok ;
1188
1189
1190 (*
1191    PutQuadOtok - alters a quadruple QuadNo with Op, Oper1, Oper2, Oper3, and
1192                  sets a boolean to determinine whether overflow should be checked.
1193 *)
1194
1195 PROCEDURE PutQuadOtok (QuadNo: CARDINAL;
1196                        tok: CARDINAL;
1197                        Op: QuadOperator;
1198                        Oper1, Oper2, Oper3: CARDINAL;
1199                        overflowChecking: BOOLEAN ;
1200                        Op1Pos, Op2Pos, Op3Pos: CARDINAL) ;
1201 VAR
1202    f: QuadFrame ;
1203 BEGIN
1204    IF QuadNo = BreakAtQuad
1205    THEN
1206       stop
1207    END ;
1208    IF QuadrupleGeneration
1209    THEN
1210       EraseQuad (QuadNo) ;
1211       AddQuadInformation (QuadNo, Op, Oper1, Oper2, Oper3) ;
1212       f := GetQF (QuadNo) ;
1213       WITH f^ DO
1214          Operator      := Op ;
1215          Operand1      := Oper1 ;
1216          Operand2      := Oper2 ;
1217          Operand3      := Oper3 ;
1218          CheckOverflow := overflowChecking ;
1219          op1pos        := Op1Pos ;
1220          op2pos        := Op2Pos ;
1221          op3pos        := Op3Pos ;
1222          TokenNo       := tok
1223       END
1224    END
1225 END PutQuadOtok ;
1226
1227
1228 (*
1229    AddQuadInformation - adds variable analysis and jump analysis to the new quadruple.
1230 *)
1231
1232 PROCEDURE AddQuadInformation (QuadNo: CARDINAL;
1233                               Op: QuadOperator;
1234                               Oper1, Oper2, Oper3: CARDINAL) ;
1235 BEGIN
1236    CASE Op OF
1237
1238    IfInOp,
1239    IfNotInOp,
1240    IfEquOp,
1241    IfNotEquOp,
1242    IfLessOp,
1243    IfLessEquOp,
1244    IfGreOp,
1245    IfGreEquOp : ManipulateReference(QuadNo, Oper3) ;
1246                 CheckAddVariableRead(Oper1, FALSE, QuadNo) ;
1247                 CheckAddVariableRead(Oper2, FALSE, QuadNo) |
1248
1249    TryOp,
1250    RetryOp,
1251    GotoOp     : ManipulateReference(QuadNo, Oper3) |
1252
1253    (* variable references *)
1254
1255    InclOp,
1256    ExclOp            : CheckConst(Oper1) ;
1257                        CheckAddVariableRead(Oper3, FALSE, QuadNo) ;
1258                        CheckAddVariableWrite(Oper1, TRUE, QuadNo) |
1259    UnboundedOp,
1260    FunctValueOp,
1261    NegateOp,
1262    BecomesOp,
1263    HighOp,
1264    SizeOp            : CheckConst(Oper1) ;
1265                        CheckAddVariableWrite(Oper1, FALSE, QuadNo) ;
1266                        CheckAddVariableRead(Oper3, FALSE, QuadNo) |
1267    AddrOp            : CheckConst(Oper1) ;
1268                        CheckAddVariableWrite(Oper1, FALSE, QuadNo) ;
1269                        (* CheckAddVariableReadLeftValue(Oper3, QuadNo) *)
1270                        (* the next line is a kludge and assumes we _will_
1271                           write to the variable as we have taken its address *)
1272                        CheckRemoveVariableWrite(Oper1, TRUE, QuadNo) |
1273    ReturnValueOp     : CheckAddVariableRead(Oper1, FALSE, QuadNo) |
1274    ReturnOp,
1275    NewLocalVarOp,
1276    KillLocalVarOp    : |
1277    CallOp            : CheckAddVariableRead(Oper3, TRUE, QuadNo) |
1278
1279    ParamOp           : CheckAddVariableRead(Oper2, FALSE, QuadNo) ;
1280                        CheckAddVariableRead(Oper3, FALSE, QuadNo) ;
1281                        IF (Oper1>0) AND (Oper1<=NoOfParam(Oper2)) AND
1282                           IsVarParam(Oper2, Oper1)
1283                        THEN
1284                           (* _may_ also write to a var parameter, although we dont know *)
1285                           CheckAddVariableWrite(Oper3, TRUE, QuadNo)
1286                        END |
1287    RecordFieldOp,
1288    ArrayOp,
1289    LogicalShiftOp,
1290    LogicalRotateOp,
1291    LogicalOrOp,
1292    LogicalAndOp,
1293    LogicalXorOp,
1294    CoerceOp,
1295    ConvertOp,
1296    CastOp,
1297    AddOp,
1298    SubOp,
1299    MultOp,
1300    DivM2Op,
1301    ModM2Op,
1302    ModFloorOp,
1303    DivCeilOp,
1304    ModCeilOp,
1305    DivFloorOp,
1306    ModTruncOp,
1307    DivTruncOp        : CheckConst(Oper1) ;
1308                        CheckAddVariableWrite(Oper1, FALSE, QuadNo) ;
1309                        CheckAddVariableRead(Oper2, FALSE, QuadNo) ;
1310                        CheckAddVariableRead(Oper3, FALSE, QuadNo) |
1311
1312    XIndrOp           : CheckConst(Oper1) ;
1313                        CheckAddVariableWrite(Oper1, TRUE, QuadNo) ;
1314                        CheckAddVariableRead(Oper3, FALSE, QuadNo) |
1315
1316    IndrXOp           : CheckConst(Oper1) ;
1317                        CheckAddVariableWrite(Oper1, FALSE, QuadNo) ;
1318                        CheckAddVariableRead(Oper3, TRUE, QuadNo) |
1319
1320 (* RangeCheckOp      : CheckRangeAddVariableRead(Oper3, QuadNo) | *)
1321    SaveExceptionOp   : CheckConst(Oper1) ;
1322                        CheckAddVariableWrite(Oper1, FALSE, QuadNo) |
1323    RestoreExceptionOp: CheckAddVariableRead(Oper1, FALSE, QuadNo)
1324
1325    ELSE
1326    END
1327 END AddQuadInformation ;
1328
1329
1330 PROCEDURE stop ; BEGIN END stop ;
1331
1332
1333 (*
1334    PutQuadO - alters a quadruple QuadNo with Op, Oper1, Oper2, Oper3, and
1335               sets a boolean to determinine whether overflow should be checked.
1336 *)
1337
1338 PROCEDURE PutQuadO (QuadNo: CARDINAL;
1339                     Op: QuadOperator;
1340                     Oper1, Oper2, Oper3: CARDINAL;
1341                     overflow: BOOLEAN) ;
1342 VAR
1343    f: QuadFrame ;
1344 BEGIN
1345    IF QuadNo = BreakAtQuad
1346    THEN
1347       stop
1348    END ;
1349    IF QuadrupleGeneration
1350    THEN
1351       EraseQuad (QuadNo) ;
1352       AddQuadInformation (QuadNo, Op, Oper1, Oper2, Oper3) ;
1353       f := GetQF (QuadNo) ;
1354       WITH f^ DO
1355          Operator      := Op ;
1356          Operand1      := Oper1 ;
1357          Operand2      := Oper2 ;
1358          Operand3      := Oper3 ;
1359          CheckOverflow := overflow
1360       END
1361    END
1362 END PutQuadO ;
1363
1364
1365 (*
1366    PutQuad - overwrites a quadruple QuadNo with Op, Oper1, Oper2, Oper3
1367 *)
1368
1369 PROCEDURE PutQuad (QuadNo: CARDINAL;
1370                    Op: QuadOperator;
1371                    Oper1, Oper2, Oper3: CARDINAL) ;
1372 BEGIN
1373    PutQuadO (QuadNo, Op, Oper1, Oper2, Oper3, TRUE)
1374 END PutQuad ;
1375
1376
1377 (*
1378    UndoReadWriteInfo -
1379 *)
1380
1381 PROCEDURE UndoReadWriteInfo (QuadNo: CARDINAL;
1382                              Op: QuadOperator;
1383                              Oper1, Oper2, Oper3: CARDINAL) ;
1384 BEGIN
1385    CASE Op OF
1386
1387    (* jumps, calls and branches *)
1388    IfInOp,
1389    IfNotInOp,
1390    IfEquOp,
1391    IfNotEquOp,
1392    IfLessOp,
1393    IfLessEquOp,
1394    IfGreOp,
1395    IfGreEquOp        : RemoveReference(QuadNo) ;
1396                        CheckRemoveVariableRead(Oper1, FALSE, QuadNo) ;
1397                        CheckRemoveVariableRead(Oper2, FALSE, QuadNo) |
1398
1399    TryOp,
1400    RetryOp,
1401    GotoOp            : RemoveReference(QuadNo) |
1402
1403    (* variable references *)
1404
1405    InclOp,
1406    ExclOp            : CheckRemoveVariableRead(Oper1, FALSE, QuadNo) ;
1407                        CheckRemoveVariableWrite(Oper1, TRUE, QuadNo) |
1408
1409    UnboundedOp,
1410    FunctValueOp,
1411    NegateOp,
1412    BecomesOp,
1413    HighOp,
1414    SizeOp            : CheckRemoveVariableWrite(Oper1, FALSE, QuadNo) ;
1415                        CheckRemoveVariableRead(Oper3, FALSE, QuadNo) |
1416    AddrOp            : CheckRemoveVariableWrite(Oper1, FALSE, QuadNo) ;
1417                        (* CheckRemoveVariableReadLeftValue(Oper3, QuadNo) ; *)
1418                        (* the next line is a kludge and assumes we _will_
1419                           write to the variable as we have taken its address *)
1420                        CheckRemoveVariableWrite(Oper1, TRUE, QuadNo) |
1421    ReturnValueOp     : CheckRemoveVariableRead(Oper1, FALSE, QuadNo) |
1422    ReturnOp,
1423    CallOp,
1424    NewLocalVarOp,
1425    KillLocalVarOp    : |
1426    ParamOp           : CheckRemoveVariableRead(Oper2, FALSE, QuadNo) ;
1427                        CheckRemoveVariableRead(Oper3, FALSE, QuadNo) ;
1428                        IF (Oper1>0) AND (Oper1<=NoOfParam(Oper2)) AND
1429                           IsVarParam(Oper2, Oper1)
1430                        THEN
1431                           (* _may_ also write to a var parameter, although we dont know *)
1432                           CheckRemoveVariableWrite(Oper3, TRUE, QuadNo)
1433                        END |
1434    RecordFieldOp,
1435    ArrayOp,
1436    LogicalShiftOp,
1437    LogicalRotateOp,
1438    LogicalOrOp,
1439    LogicalAndOp,
1440    LogicalXorOp,
1441    CoerceOp,
1442    ConvertOp,
1443    CastOp,
1444    AddOp,
1445    SubOp,
1446    MultOp,
1447    DivM2Op,
1448    ModM2Op,
1449    ModFloorOp,
1450    DivCeilOp,
1451    ModCeilOp,
1452    DivFloorOp,
1453    ModTruncOp,
1454    DivTruncOp        : CheckRemoveVariableWrite(Oper1, FALSE, QuadNo) ;
1455                        CheckRemoveVariableRead(Oper2, FALSE, QuadNo) ;
1456                        CheckRemoveVariableRead(Oper3, FALSE, QuadNo) |
1457
1458    XIndrOp           : CheckRemoveVariableWrite(Oper1, TRUE, QuadNo) ;
1459                        CheckRemoveVariableRead(Oper3, FALSE, QuadNo) |
1460
1461    IndrXOp           : CheckRemoveVariableWrite(Oper1, FALSE, QuadNo) ;
1462                        CheckRemoveVariableRead(Oper3, TRUE, QuadNo) |
1463
1464 (* RangeCheckOp      : CheckRangeRemoveVariableRead(Oper3, QuadNo) | *)
1465    SaveExceptionOp   : CheckRemoveVariableWrite(Oper1, FALSE, QuadNo) |
1466    RestoreExceptionOp: CheckRemoveVariableRead(Oper1, FALSE, QuadNo)
1467
1468    ELSE
1469    END
1470 END UndoReadWriteInfo ;
1471
1472
1473 (*
1474    EraseQuad - erases a quadruple QuadNo, the quadruple is still in the list
1475                but wiped clean.
1476 *)
1477
1478 PROCEDURE EraseQuad (QuadNo: CARDINAL) ;
1479 VAR
1480    f: QuadFrame ;
1481 BEGIN
1482    f := GetQF(QuadNo) ;
1483    WITH f^ DO
1484       UndoReadWriteInfo(QuadNo, Operator, Operand1, Operand2, Operand3) ;
1485       Operator := DummyOp ;   (* finally blank it out *)
1486       Operand1 := 0 ;
1487       Operand2 := 0 ;
1488       Operand3 := 0 ;
1489       Trash := 0 ;
1490       op1pos   := UnknownTokenNo ;
1491       op2pos   := UnknownTokenNo ;
1492       op3pos   := UnknownTokenNo
1493    END
1494 END EraseQuad ;
1495
1496
1497 (*
1498    CheckAddVariableReadLeftValue -
1499 *)
1500
1501 (*
1502 PROCEDURE CheckAddVariableReadLeftValue (sym: CARDINAL; q: CARDINAL) ;
1503 BEGIN
1504    IF IsVar(sym)
1505    THEN
1506       PutReadQuad(sym, LeftValue, q)
1507    END
1508 END CheckAddVariableReadLeftValue ;
1509 *)
1510
1511
1512 (*
1513    CheckRemoveVariableReadLeftValue -
1514 *)
1515
1516 (*
1517 PROCEDURE CheckRemoveVariableReadLeftValue (sym: CARDINAL; q: CARDINAL) ;
1518 BEGIN
1519    IF IsVar(sym)
1520    THEN
1521       RemoveReadQuad(sym, LeftValue, q)
1522    END
1523 END CheckRemoveVariableReadLeftValue ;
1524 *)
1525
1526
1527 (*
1528    CheckAddVariableRead - checks to see whether symbol, Sym, is a variable or
1529                           a parameter and if so it then adds this quadruple
1530                           to the variable list.
1531 *)
1532
1533 PROCEDURE CheckAddVariableRead (Sym: CARDINAL; canDereference: BOOLEAN; Quad: CARDINAL) ;
1534 BEGIN
1535    IF IsVar(Sym)
1536    THEN
1537       PutReadQuad(Sym, GetMode(Sym), Quad) ;
1538       IF (GetMode(Sym)=LeftValue) AND canDereference
1539       THEN
1540          PutReadQuad(Sym, RightValue, Quad)
1541       END
1542    END
1543 END CheckAddVariableRead ;
1544
1545
1546 (*
1547    CheckRemoveVariableRead - checks to see whether, Sym, is a variable or
1548                              a parameter and if so then it removes the
1549                              quadruple from the variable list.
1550 *)
1551
1552 PROCEDURE CheckRemoveVariableRead (Sym: CARDINAL; canDereference: BOOLEAN; Quad: CARDINAL) ;
1553 BEGIN
1554    IF IsVar(Sym)
1555    THEN
1556       RemoveReadQuad(Sym, GetMode(Sym), Quad) ;
1557       IF (GetMode(Sym)=LeftValue) AND canDereference
1558       THEN
1559          RemoveReadQuad(Sym, RightValue, Quad)
1560       END
1561    END
1562 END CheckRemoveVariableRead ;
1563
1564
1565 (*
1566    CheckAddVariableWrite - checks to see whether symbol, Sym, is a variable and
1567                            if so it then adds this quadruple to the variable list.
1568 *)
1569
1570 PROCEDURE CheckAddVariableWrite (Sym: CARDINAL; canDereference: BOOLEAN; Quad: CARDINAL) ;
1571 BEGIN
1572    IF IsVar(Sym)
1573    THEN
1574       IF (GetMode(Sym)=LeftValue) AND canDereference
1575       THEN
1576          PutReadQuad(Sym, LeftValue, Quad) ;
1577          PutWriteQuad(Sym, RightValue, Quad)
1578       ELSE
1579          PutWriteQuad(Sym, GetMode(Sym), Quad)
1580       END
1581    END
1582 END CheckAddVariableWrite ;
1583
1584
1585 (*
1586    CheckRemoveVariableWrite - checks to see whether, Sym, is a variable and
1587                               if so then it removes the quadruple from the
1588                               variable list.
1589 *)
1590
1591 PROCEDURE CheckRemoveVariableWrite (Sym: CARDINAL; canDereference: BOOLEAN; Quad: CARDINAL) ;
1592 BEGIN
1593    IF IsVar(Sym)
1594    THEN
1595       IF (GetMode(Sym)=LeftValue) AND canDereference
1596       THEN
1597          RemoveReadQuad(Sym, LeftValue, Quad) ;
1598          RemoveWriteQuad(Sym, RightValue, Quad)
1599       ELSE
1600          RemoveWriteQuad(Sym, GetMode(Sym), Quad)
1601       END
1602    END
1603 END CheckRemoveVariableWrite ;
1604
1605
1606 (*
1607    CheckConst -
1608 *)
1609
1610 PROCEDURE CheckConst (sym: CARDINAL) ;
1611 BEGIN
1612    IF IsConst(sym)
1613    THEN
1614       PutToBeSolvedByQuads(sym)
1615    END
1616 END CheckConst ;
1617
1618
1619 (*
1620    GetFirstQuad - returns the first quadruple.
1621 *)
1622
1623 PROCEDURE GetFirstQuad () : CARDINAL ;
1624 BEGIN
1625    RETURN( Head )
1626 END GetFirstQuad ;
1627
1628
1629 (*
1630    GetNextQuad - returns the Quadruple number following QuadNo.
1631 *)
1632
1633 PROCEDURE GetNextQuad (QuadNo: CARDINAL) : CARDINAL ;
1634 VAR
1635    f: QuadFrame ;
1636 BEGIN
1637    f := GetQF(QuadNo) ;
1638    RETURN( f^.Next )
1639 END GetNextQuad ;
1640
1641
1642 (*
1643    SubQuad - subtracts a quadruple QuadNo from a list Head.
1644 *)
1645
1646 PROCEDURE SubQuad (QuadNo: CARDINAL) ;
1647 VAR
1648    i   : CARDINAL ;
1649    f, g: QuadFrame ;
1650 BEGIN
1651    f := GetQF(QuadNo) ;
1652    WITH f^ DO
1653       AlterReference(Head, QuadNo, f^.Next) ;
1654       UndoReadWriteInfo(QuadNo, Operator, Operand1, Operand2, Operand3)
1655    END ;
1656    IF Head=QuadNo
1657    THEN
1658       Head := f^.Next
1659    ELSE
1660       i := Head ;
1661       g := GetQF(i) ;
1662       WHILE g^.Next#QuadNo DO
1663          i := g^.Next ;
1664          g := GetQF(i)
1665       END ;
1666       g^.Next := f^.Next
1667    END ;
1668    f^.Operator := DummyOp ;
1669    DEC(NoOfQuads)
1670 END SubQuad ;
1671
1672
1673 (*
1674    GetRealQuad - returns the Quadruple number of the real quadruple
1675                  at QuadNo or beyond.
1676 *)
1677
1678 PROCEDURE GetRealQuad (QuadNo: CARDINAL) : CARDINAL ;
1679 VAR
1680    f: QuadFrame ;
1681 BEGIN
1682    WHILE QuadNo#0 DO
1683       IF InBounds(QuadArray, QuadNo)
1684       THEN
1685          f := GetQF(QuadNo) ;
1686          WITH f^ DO
1687             IF (NOT IsPseudoQuad(QuadNo)) AND
1688                (Operator#DummyOp) AND (Operator#LineNumberOp) AND (Operator#StatementNoteOp)
1689             THEN
1690                RETURN( QuadNo )
1691             END
1692          END ;
1693          INC(QuadNo)
1694       ELSE
1695          RETURN( 0 )
1696       END
1697    END ;
1698    RETURN( 0 )
1699 END GetRealQuad ;
1700
1701
1702 (*
1703    AlterReference - alters all references from OldQuad, to NewQuad in a
1704                     quadruple list Head.
1705 *)
1706
1707 PROCEDURE AlterReference (Head, OldQuad, NewQuad: CARDINAL) ;
1708 VAR
1709    f, g: QuadFrame ;
1710    i   : CARDINAL ;
1711 BEGIN
1712    f := GetQF(OldQuad) ;
1713    WHILE (f^.NoOfTimesReferenced>0) AND (Head#0) DO
1714       g := GetQF(Head) ;
1715       WITH g^ DO
1716          CASE Operator OF
1717
1718          IfInOp,
1719          IfNotInOp,
1720          IfEquOp,
1721          IfNotEquOp,
1722          IfLessOp,
1723          IfLessEquOp,
1724          IfGreOp,
1725          IfGreEquOp,
1726          TryOp,
1727          RetryOp,
1728          GotoOp     : IF Operand3=OldQuad
1729                       THEN
1730                          ManipulateReference(Head, NewQuad)
1731                       END
1732
1733          ELSE
1734          END ;
1735          i := Next
1736       END ;
1737       Head := i
1738    END
1739 END AlterReference ;
1740
1741
1742 (*
1743    GrowQuads - grows the list of quadruples to the quadruple, to.
1744 *)
1745
1746 PROCEDURE GrowQuads (to: CARDINAL) ;
1747 VAR
1748    i: CARDINAL ;
1749    f: QuadFrame ;
1750 BEGIN
1751    IF (to#0) AND (to>GrowInitialization)
1752    THEN
1753       i := GrowInitialization+1 ;
1754       WHILE i<=to DO
1755          IF InBounds(QuadArray, i)
1756          THEN
1757             Assert(GetIndice(QuadArray, i)#NIL)
1758          ELSE
1759             NEW(f) ;
1760             IF f=NIL
1761             THEN
1762                InternalError ('out of memory error when trying to allocate a quadruple')
1763             END ;
1764             PutIndice(QuadArray, i, f) ;
1765             f^.NoOfTimesReferenced := 0
1766          END ;
1767          INC(i)
1768       END ;
1769       GrowInitialization := to
1770    END
1771 END GrowQuads ;
1772
1773
1774 (*
1775    ManipulateReference - manipulates the quadruple, q, so that it now points to quad, to.
1776 *)
1777
1778 PROCEDURE ManipulateReference (q: CARDINAL; to: CARDINAL) ;
1779 VAR
1780    f: QuadFrame ;
1781 BEGIN
1782    Assert((GrowInitialization>=q) OR (to=0)) ;
1783    GrowQuads(to) ;
1784    RemoveReference(q) ;
1785    f := GetQF(q) ;
1786    f^.Operand3 := to ;
1787    IF to#0
1788    THEN
1789       f := GetQF(to) ;
1790       INC(f^.NoOfTimesReferenced)
1791    END
1792 END ManipulateReference ;
1793
1794
1795 (*
1796    RemoveReference - remove the reference by quadruple, q, to wherever
1797                      it was pointing to.
1798 *)
1799
1800 PROCEDURE RemoveReference (q: CARDINAL) ;
1801 VAR
1802    f, g: QuadFrame ;
1803 BEGIN
1804    f := GetQF(q) ;
1805    IF (f^.Operand3#0) AND (f^.Operand3<NextQuad)
1806    THEN
1807       g := GetQF(f^.Operand3) ;
1808       Assert(g^.NoOfTimesReferenced#0) ;
1809       DEC(g^.NoOfTimesReferenced)
1810    END
1811 END RemoveReference ;
1812
1813
1814 (*
1815    CountQuads - returns the number of quadruples.
1816 *)
1817
1818 PROCEDURE CountQuads () : CARDINAL ;
1819 BEGIN
1820    RETURN( NoOfQuads )
1821 END CountQuads ;
1822
1823
1824 (*
1825    NewQuad - sets QuadNo to a new quadruple.
1826 *)
1827
1828 PROCEDURE NewQuad (VAR QuadNo: CARDINAL) ;
1829 VAR
1830    f: QuadFrame ;
1831 BEGIN
1832    QuadNo := FreeList ;
1833    IF InBounds (QuadArray, QuadNo) AND (GetIndice (QuadArray, QuadNo) # NIL)
1834    THEN
1835       f := GetIndice (QuadArray, QuadNo)
1836    ELSE
1837       NEW (f) ;
1838       IF f=NIL
1839       THEN
1840          InternalError ('out of memory error trying to allocate a quadruple')
1841       ELSE
1842          INC (NoOfQuads) ;
1843          PutIndice (QuadArray, QuadNo, f) ;
1844          f^.NoOfTimesReferenced := 0
1845       END
1846    END ;
1847    WITH f^ DO
1848       Operator := DummyOp ;
1849       Operand3 := 0 ;
1850       Next := 0
1851    END ;
1852    INC (FreeList) ;
1853    IF GrowInitialization < FreeList
1854    THEN
1855       GrowInitialization := FreeList
1856    END
1857 END NewQuad ;
1858
1859
1860 (*
1861    CheckVariableAt - checks to see whether, sym, was declared at a particular address.
1862 *)
1863
1864 PROCEDURE CheckVariableAt (sym: CARDINAL) ;
1865 BEGIN
1866    IF IsVar (sym) AND IsVariableAtAddress (sym)
1867    THEN
1868       IF GetMode (sym) = LeftValue
1869       THEN
1870          GenQuad (InitAddressOp, sym, NulSym, GetVariableAtAddress (sym))
1871       ELSE
1872          InternalError ('expecting lvalue for this variable which is declared at an explicit address')
1873       END
1874    END
1875 END CheckVariableAt ;
1876
1877
1878 (*
1879    CheckVariablesAt - checks to see whether we need to initialize any pointers
1880                       which point to variable declared at addresses.
1881 *)
1882
1883 PROCEDURE CheckVariablesAt (scope: CARDINAL) ;
1884 BEGIN
1885    ForeachLocalSymDo (scope, CheckVariableAt)
1886 END CheckVariablesAt ;
1887
1888
1889 (*
1890    GetTurnInterrupts - returns the TurnInterrupts procedure function.
1891 *)
1892
1893 PROCEDURE GetTurnInterrupts (tok: CARDINAL) : CARDINAL ;
1894 BEGIN
1895    IF Iso
1896    THEN
1897       RETURN GetQualidentImport (tok,
1898                                  MakeKey ('TurnInterrupts'), MakeKey ('COROUTINES'))
1899    ELSE
1900       RETURN GetQualidentImport (tok,
1901                                  MakeKey ('TurnInterrupts'), MakeKey ('SYSTEM'))
1902    END
1903 END GetTurnInterrupts ;
1904
1905
1906 (*
1907    GetProtection - returns the PROTECTION data type.
1908 *)
1909
1910 PROCEDURE GetProtection (tok: CARDINAL) : CARDINAL ;
1911 BEGIN
1912    IF Iso
1913    THEN
1914       RETURN GetQualidentImport (tok,
1915                                  MakeKey ('PROTECTION'), MakeKey ('COROUTINES'))
1916    ELSE
1917       RETURN GetQualidentImport (tok,
1918                                  MakeKey ('PROTECTION'), MakeKey ('SYSTEM'))
1919    END
1920 END GetProtection ;
1921
1922
1923 (*
1924    CheckNeedPriorityBegin - checks to see whether we need to save the old
1925                             module priority and change to another module
1926                             priority.
1927                             The current module initialization or procedure
1928                             being built is defined by, scope. The module whose
1929                             priority will be used is defined by, module.
1930 *)
1931
1932 PROCEDURE CheckNeedPriorityBegin (tok: CARDINAL; scope, module: CARDINAL) ;
1933 VAR
1934    ProcSym, old: CARDINAL ;
1935 BEGIN
1936    IF GetPriority (module) # NulSym
1937    THEN
1938       (* module has been given a priority *)
1939       ProcSym := GetTurnInterrupts (tok) ;
1940       IF ProcSym # NulSym
1941       THEN
1942          old := MakeTemporary (tok, RightValue) ;
1943          PutVar (old, GetProtection (tok)) ;
1944
1945          GenQuadO (tok, SavePriorityOp, old, scope, ProcSym, FALSE) ;
1946          PushWord (PriorityStack, old)
1947       END
1948    END
1949 END CheckNeedPriorityBegin ;
1950
1951
1952 (*
1953    CheckNeedPriorityEnd - checks to see whether we need to restore the old
1954                           module priority.
1955                           The current module initialization or procedure
1956                           being built is defined by, scope.
1957 *)
1958
1959 PROCEDURE CheckNeedPriorityEnd (tok: CARDINAL;
1960                                 scope, module: CARDINAL) ;
1961 VAR
1962    ProcSym, old: CARDINAL ;
1963 BEGIN
1964    IF GetPriority (module) # NulSym
1965    THEN
1966       (* module has been given a priority *)
1967       ProcSym := GetTurnInterrupts (tok) ;
1968       IF ProcSym # NulSym
1969       THEN
1970          old := PopWord (PriorityStack) ;
1971          GenQuad (RestorePriorityOp, old, scope, ProcSym)
1972       END
1973    END
1974 END CheckNeedPriorityEnd ;
1975
1976
1977 (*
1978    StartBuildDefFile - generates a StartFileDefOp quadruple indicating the file
1979                        that has produced the subsequent quadruples.
1980                        The code generator uses the StartDefFileOp quadruples
1981                        to relate any error to the appropriate file.
1982
1983
1984                        Entry                   Exit
1985                        =====                   ====
1986
1987
1988                 Ptr ->                                        <- Ptr
1989                        +------------+          +------------+
1990                        | ModuleName |          | ModuleName |
1991                        |------------|          |------------|
1992
1993
1994                        Quadruples Produced
1995
1996                        q     StartDefFileOp  _  _  ModuleSym
1997 *)
1998
1999 PROCEDURE StartBuildDefFile (tok: CARDINAL) ;
2000 VAR
2001    ModuleName: Name ;
2002 BEGIN
2003    PopT (ModuleName) ;
2004    PushT (ModuleName) ;
2005    GenQuadO (tok, StartDefFileOp, tok, NulSym, GetModule (ModuleName), FALSE)
2006 END StartBuildDefFile ;
2007
2008
2009 (*
2010    StartBuildModFile - generates a StartModFileOp quadruple indicating the file
2011                        that has produced the subsequent quadruples.
2012                        The code generator uses the StartModFileOp quadruples
2013                        to relate any error to the appropriate file.
2014
2015
2016                        Entry                   Exit
2017                        =====                   ====
2018
2019
2020                 Ptr ->                                        <- Ptr
2021                        +------------+          +------------+
2022                        | ModuleName |          | ModuleName |
2023                        |------------|          |------------|
2024
2025
2026                        Quadruples Produced
2027
2028                        q     StartModFileOp  lineno  filename  ModuleSym
2029 *)
2030
2031 PROCEDURE StartBuildModFile (tok: CARDINAL) ;
2032 BEGIN
2033    GenQuadO (tok, StartModFileOp, tok,
2034              WORD (makekey (string (GetFileName ()))),
2035              GetFileModule (), FALSE)
2036 END StartBuildModFile ;
2037
2038
2039 (*
2040    EndBuildFile - generates an EndFileOp quadruple indicating the file
2041                   that has produced the previous quadruples has ended.
2042
2043                   Entry                   Exit
2044                   =====                   ====
2045
2046
2047            Ptr ->                                        <- Ptr
2048                   +------------+          +------------+
2049                   | ModuleName |          | ModuleName |
2050                   |------------|          |------------|
2051
2052
2053                   Quadruples Produced
2054
2055                   q     EndFileOp  _  _  ModuleSym
2056 *)
2057
2058 PROCEDURE EndBuildFile (tok: CARDINAL) ;
2059 VAR
2060    ModuleName: Name ;
2061 BEGIN
2062    ModuleName := OperandT (1) ;
2063    GenQuadO (tok, EndFileOp, NulSym, NulSym, GetModule (ModuleName), FALSE)
2064 END EndBuildFile ;
2065
2066
2067 (*
2068    StartBuildInit - Sets the start of initialization code of the
2069                     current module to the next quadruple.
2070 *)
2071
2072 PROCEDURE StartBuildInit (tok: CARDINAL) ;
2073 VAR
2074    name     : Name ;
2075    ModuleSym: CARDINAL ;
2076 BEGIN
2077    PopT(name) ;
2078    ModuleSym := GetCurrentModule() ;
2079    Assert(IsModule(ModuleSym) OR IsDefImp(ModuleSym)) ;
2080    Assert(GetSymName(ModuleSym)=name) ;
2081    PutModuleStartQuad(ModuleSym, NextQuad) ;
2082    GenQuad(InitStartOp, tok, GetFileModule(), ModuleSym) ;
2083    PushWord(ReturnStack, 0) ;
2084    PushT(name) ;
2085    CheckVariablesAt(ModuleSym) ;
2086    CheckNeedPriorityBegin(tok, ModuleSym, ModuleSym) ;
2087    PushWord(TryStack, NextQuad) ;
2088    PushWord(CatchStack, 0) ;
2089    IF HasExceptionBlock(ModuleSym)
2090    THEN
2091       GenQuad(TryOp, NulSym, NulSym, 0)
2092    END
2093 END StartBuildInit ;
2094
2095
2096 (*
2097    EndBuildInit - Sets the end initialization code of a module.
2098 *)
2099
2100 PROCEDURE EndBuildInit (tok: CARDINAL) ;
2101 BEGIN
2102    IF HasExceptionBlock(GetCurrentModule())
2103    THEN
2104       BuildRTExceptLeave (tok, TRUE) ;
2105       GenQuadO (tok, CatchEndOp, NulSym, NulSym, NulSym, FALSE)
2106    END ;
2107    BackPatch (PopWord (ReturnStack), NextQuad) ;
2108    CheckNeedPriorityEnd (tok, GetCurrentModule(), GetCurrentModule()) ;
2109    PutModuleEndQuad (GetCurrentModule(), NextQuad) ;
2110    CheckVariablesInBlock (GetCurrentModule()) ;
2111    GenQuadO (tok, InitEndOp, tok, GetFileModule(), GetCurrentModule(), FALSE)
2112 END EndBuildInit ;
2113
2114
2115 (*
2116    StartBuildFinally - Sets the start of finalization code of the
2117                        current module to the next quadruple.
2118 *)
2119
2120 PROCEDURE StartBuildFinally (tok: CARDINAL) ;
2121 VAR
2122    name     : Name ;
2123    ModuleSym: CARDINAL ;
2124 BEGIN
2125    PopT(name) ;
2126    ModuleSym := GetCurrentModule() ;
2127    Assert(IsModule(ModuleSym) OR IsDefImp(ModuleSym)) ;
2128    Assert(GetSymName(ModuleSym)=name) ;
2129    PutModuleFinallyStartQuad(ModuleSym, NextQuad) ;
2130    GenQuadO (tok, FinallyStartOp, tok, GetFileModule(), ModuleSym, FALSE) ;
2131    PushWord (ReturnStack, 0) ;
2132    PushT (name) ;
2133    (* CheckVariablesAt(ModuleSym) ; *)
2134    CheckNeedPriorityBegin (tok, ModuleSym, ModuleSym) ;
2135    PushWord (TryStack, NextQuad) ;
2136    PushWord (CatchStack, 0) ;
2137    IF HasExceptionFinally (ModuleSym)
2138    THEN
2139       GenQuadO (tok, TryOp, NulSym, NulSym, 0, FALSE)
2140    END
2141 END StartBuildFinally ;
2142
2143
2144 (*
2145    EndBuildFinally - Sets the end finalization code of a module.
2146 *)
2147
2148 PROCEDURE EndBuildFinally (tok: CARDINAL) ;
2149 BEGIN
2150    IF HasExceptionFinally(GetCurrentModule())
2151    THEN
2152       BuildRTExceptLeave (tok, TRUE) ;
2153       GenQuadO (tok, CatchEndOp, NulSym, NulSym, NulSym, FALSE)
2154    END ;
2155    BackPatch (PopWord (ReturnStack), NextQuad) ;
2156    CheckNeedPriorityEnd (tok, GetCurrentModule (), GetCurrentModule ()) ;
2157    PutModuleFinallyEndQuad(GetCurrentModule (), NextQuad) ;
2158    CheckVariablesInBlock (GetCurrentModule ()) ;
2159    GenQuadO (tok, FinallyEndOp, tok, GetFileModule (),
2160              GetCurrentModule(), FALSE)
2161 END EndBuildFinally ;
2162
2163
2164 (*
2165    BuildRTExceptEnter - informs RTExceptions that we are about to enter the except state.
2166 *)
2167
2168 PROCEDURE BuildRTExceptEnter (tok: CARDINAL) ;
2169 VAR
2170    old,
2171    ProcSym: CARDINAL ;
2172 BEGIN
2173    IF Exceptions
2174    THEN
2175       (* now inform the Modula-2 runtime we are in the exception state *)
2176       ProcSym := GetQualidentImport (tok,
2177                                      MakeKey('SetExceptionState'), MakeKey('RTExceptions')) ;
2178       IF ProcSym=NulSym
2179       THEN
2180          MetaErrorT0 (tok,
2181                       '{%W}no procedure SetExceptionState found in RTExceptions which is needed to implement exception handling')
2182       ELSE
2183          old := MakeTemporary (tok, RightValue) ;
2184          PutVar (old, Boolean) ;
2185          GenQuadO (tok, SaveExceptionOp, old, NulSym, ProcSym, FALSE) ;
2186          PushWord (ExceptStack, old)
2187       END
2188    ELSE
2189       MetaErrorT0 (tok,
2190                    '{%E}cannot use {%kEXCEPT} blocks with the -fno-exceptions flag')
2191    END
2192 END BuildRTExceptEnter ;
2193
2194
2195 (*
2196    BuildRTExceptLeave - informs RTExceptions that we are about to leave the except state.
2197                         If, destroy, is TRUE then pop the ExceptStack.
2198 *)
2199
2200 PROCEDURE BuildRTExceptLeave (tok: CARDINAL; destroy: BOOLEAN) ;
2201 VAR
2202    old,
2203    ProcSym: CARDINAL ;
2204 BEGIN
2205    IF Exceptions
2206    THEN
2207       (* now inform the Modula-2 runtime we are in the exception state *)
2208       ProcSym := GetQualidentImport (tok,
2209                                      MakeKey('SetExceptionState'), MakeKey('RTExceptions')) ;
2210       IF ProcSym#NulSym
2211       THEN
2212          IF destroy
2213          THEN
2214             old := PopWord (ExceptStack)
2215          ELSE
2216             old := PeepWord (ExceptStack, 1)
2217          END ;
2218          GenQuadO (tok, RestoreExceptionOp, old, NulSym, ProcSym, FALSE)
2219       END
2220    ELSE
2221       (* no need for an error message here as it will be generated in the Enter procedure above *)
2222    END
2223 END BuildRTExceptLeave ;
2224
2225
2226 (*
2227    BuildExceptInitial - adds an CatchBeginOp, CatchEndOp quadruple
2228                         in the current block.
2229 *)
2230
2231 PROCEDURE BuildExceptInitial (tok: CARDINAL) ;
2232 VAR
2233    previous: CARDINAL ;
2234 BEGIN
2235    (* we have finished the 'try' block, so now goto the return
2236       section which will tidy up (any) priorities before returning.
2237    *)
2238    GenQuadO (tok, GotoOp, NulSym, NulSym, PopWord(ReturnStack), FALSE) ;
2239    PushWord (ReturnStack, NextQuad-1) ;
2240    (*
2241       this is the 'catch' block.
2242    *)
2243    BackPatch (PeepWord (TryStack, 1), NextQuad) ;
2244    GenQuadO (tok, CatchBeginOp, NulSym, NulSym, NulSym, FALSE) ;
2245    previous := PopWord (CatchStack) ;
2246    IF previous # 0
2247    THEN
2248       MetaErrorT0 (tok,
2249                    '{%E}only allowed one EXCEPT statement in a procedure or module')
2250    END ;
2251    PushWord (CatchStack, NextQuad-1) ;
2252    BuildRTExceptEnter (tok)
2253 END BuildExceptInitial ;
2254
2255
2256 (*
2257    BuildExceptFinally - adds an ExceptOp quadruple in a modules
2258                         finally block.
2259 *)
2260
2261 PROCEDURE BuildExceptFinally (tok: CARDINAL) ;
2262 BEGIN
2263    BuildExceptInitial (tok)
2264 END BuildExceptFinally ;
2265
2266
2267 (*
2268    BuildExceptProcedure - adds an ExceptOp quadruple in a procedure
2269                           block.
2270 *)
2271
2272 PROCEDURE BuildExceptProcedure (tok: CARDINAL) ;
2273 BEGIN
2274    BuildExceptInitial (tok)
2275 END BuildExceptProcedure ;
2276
2277
2278 (*
2279    BuildRetry - adds an RetryOp quadruple.
2280 *)
2281
2282 PROCEDURE BuildRetry (tok: CARDINAL);
2283 BEGIN
2284    IF PeepWord (CatchStack, 1) = 0
2285    THEN
2286       MetaErrorT0 (tok,
2287                    '{%E}the {%kRETRY} statement must occur after an {%kEXCEPT} statement in the same module or procedure block')
2288    ELSE
2289       BuildRTExceptLeave (tok, FALSE) ;
2290       GenQuadO (tok, RetryOp, NulSym, NulSym, PeepWord (TryStack, 1), FALSE)
2291    END
2292 END BuildRetry ;
2293
2294
2295 (*
2296    SafeRequestSym - only used during scaffold to get argc, argv, envp.
2297                     It attempts to get symbol name from the current scope(s) and if
2298                     it fails then it falls back onto default constants.
2299 *)
2300
2301 PROCEDURE SafeRequestSym (tok: CARDINAL; name: Name) : CARDINAL ;
2302 VAR
2303    sym: CARDINAL ;
2304 BEGIN
2305    sym := GetSym (name) ;
2306    IF sym = NulSym
2307    THEN
2308       IF name = MakeKey ('argc')
2309       THEN
2310          RETURN MakeConstLit (tok, MakeKey ('0'), ZType)
2311       ELSIF (name = MakeKey ('argv')) OR (name = MakeKey ('envp'))
2312       THEN
2313          RETURN Nil
2314       ELSE
2315          InternalError ('not expecting this parameter name') ;
2316          RETURN Nil
2317       END
2318    END ;
2319    RETURN sym
2320 END SafeRequestSym ;
2321
2322
2323 (*
2324    callRequestDependant - create a call:
2325                           RequestDependant (GetSymName (modulesym), GetLibName (modulesym),
2326                                             GetSymName (depModuleSym), GetLibName (depModuleSym));
2327 *)
2328
2329 PROCEDURE callRequestDependant (tokno: CARDINAL;
2330                                 moduleSym, depModuleSym: CARDINAL;
2331                                 requestDep: CARDINAL) ;
2332 BEGIN
2333    Assert (requestDep # NulSym) ;
2334    PushTtok (requestDep, tokno) ;
2335    PushTF (Adr, Address) ;
2336    PushTtok (MakeConstLitString (tokno, GetSymName (moduleSym)), tokno) ;
2337    PushT (1) ;
2338    BuildAdrFunction ;
2339
2340    PushTF (Adr, Address) ;
2341    PushTtok (MakeConstLitString (tokno, GetLibName (moduleSym)), tokno) ;
2342    PushT (1) ;
2343    BuildAdrFunction ;
2344
2345    IF depModuleSym = NulSym
2346    THEN
2347       PushTF (Nil, Address) ;
2348       PushTF (Nil, Address)
2349    ELSE
2350       PushTF (Adr, Address) ;
2351       PushTtok (MakeConstLitString (tokno, GetSymName (depModuleSym)), tokno) ;
2352       PushT (1) ;
2353       BuildAdrFunction ;
2354
2355       PushTF (Adr, Address) ;
2356       PushTtok (MakeConstLitString (tokno, GetLibName (depModuleSym)), tokno) ;
2357       PushT (1) ;
2358       BuildAdrFunction
2359    END ;
2360
2361    PushT (4) ;
2362    BuildProcedureCall (tokno)
2363 END callRequestDependant ;
2364
2365
2366 (*
2367    ForeachImportInDepDo -
2368 *)
2369
2370 PROCEDURE ForeachImportInDepDo (importStatements: List; moduleSym, requestDep: CARDINAL) ;
2371 VAR
2372    i, j,
2373    m, n    : CARDINAL ;
2374    imported,
2375    stmt     : CARDINAL ;
2376    l       : List ;
2377 BEGIN
2378    IF importStatements # NIL
2379    THEN
2380       i := 1 ;
2381       n := NoOfItemsInList (importStatements) ;
2382       WHILE i <= n DO
2383          stmt := GetItemFromList (importStatements, i) ;
2384          Assert (IsImportStatement (stmt)) ;
2385          l := GetImportStatementList (stmt) ;
2386          j := 1 ;
2387          m := NoOfItemsInList (l) ;
2388          WHILE j <= m DO
2389             imported := GetItemFromList (l, j) ;
2390             Assert (IsImport (imported)) ;
2391             callRequestDependant (GetImportDeclared (imported),
2392                                   moduleSym, GetImportModule (imported),
2393                                   requestDep) ;
2394             INC (j) ;
2395          END ;
2396          INC (i)
2397       END
2398    END
2399 END ForeachImportInDepDo ;
2400
2401
2402 (*
2403    ForeachImportedModuleDo -
2404 *)
2405
2406 PROCEDURE ForeachImportedModuleDo (moduleSym, requestDep: CARDINAL) ;
2407 VAR
2408    importStatements: List ;
2409 BEGIN
2410    importStatements := GetModuleModImportStatementList (moduleSym) ;
2411    ForeachImportInDepDo (importStatements, moduleSym, requestDep) ;
2412    importStatements := GetModuleDefImportStatementList (moduleSym) ;
2413    ForeachImportInDepDo (importStatements, moduleSym, requestDep)
2414 END ForeachImportedModuleDo ;
2415
2416
2417 (*
2418    BuildM2DepFunction - creates the dependency graph procedure using IR:
2419                         static void
2420                         dependencies (void)
2421                         {
2422                            M2RTS_RequestDependant (module_name, libname, "b", "b libname");
2423                            M2RTS_RequestDependant (module_name, libname, NULL, NULL);
2424                         }
2425 *)
2426
2427 PROCEDURE BuildM2DepFunction (tokno: CARDINAL; moduleSym: CARDINAL) ;
2428 VAR
2429    requestDep,
2430    ctor, init, fini, dep: CARDINAL ;
2431 BEGIN
2432    IF ScaffoldDynamic
2433    THEN
2434       (* Scaffold required and dynamic dependency graph should be produced.  *)
2435       GetModuleCtors (moduleSym, ctor, init, fini, dep) ;
2436       PushT (dep) ;
2437       BuildProcedureStart ;
2438       BuildProcedureBegin ;
2439       StartScope (dep) ;
2440       requestDep := GetQualidentImport (tokno,
2441                                         MakeKey ("RequestDependant"),
2442                                         MakeKey ("M2RTS")) ;
2443       IF requestDep # NulSym
2444       THEN
2445          ForeachImportedModuleDo (moduleSym, requestDep) ;
2446          callRequestDependant (tokno, moduleSym, NulSym, requestDep)
2447       END ;
2448       EndScope ;
2449       BuildProcedureEnd ;
2450       PopN (1)
2451    END
2452 END BuildM2DepFunction ;
2453
2454
2455 (*
2456    BuildM2LinkFunction - creates the _M2_link procedure which will
2457                          cause the linker to pull in all the module ctors.
2458 *)
2459
2460 PROCEDURE BuildM2LinkFunction (tokno: CARDINAL) ;
2461 BEGIN
2462    IF ScaffoldDynamic
2463    THEN
2464       IF linkFunction # NulSym
2465       THEN
2466          (* void
2467            _M2_link (void)
2468            {
2469               for each module in uselist do
2470                  PROC foo_%d = _M2_module_ctor
2471               done
2472            }.  *)
2473          PushT (linkFunction) ;
2474          BuildProcedureStart ;
2475          BuildProcedureBegin ;
2476          StartScope (linkFunction) ;
2477          PopulateCtorArray (tokno) ;
2478          EndScope ;
2479          BuildProcedureEnd ;
2480          PopN (1)
2481       END
2482    END
2483 END BuildM2LinkFunction ;
2484
2485
2486 (*
2487    BuildTry - build the try statement for main.
2488 *)
2489
2490 PROCEDURE BuildTry (tokno: CARDINAL) ;
2491 BEGIN
2492    IF Exceptions
2493    THEN
2494       PushWord (TryStack, NextQuad) ;
2495       PushWord (CatchStack, 0) ;
2496       GenQuadO (tokno, TryOp, NulSym, NulSym, 0, FALSE)
2497    END
2498 END BuildTry ;
2499
2500
2501 (*
2502    BuildExcept - build the except block for main.
2503 *)
2504
2505 PROCEDURE BuildExcept (tokno: CARDINAL) ;
2506 VAR
2507    catchProcedure: CARDINAL ;
2508 BEGIN
2509    IF Exceptions
2510    THEN
2511       BuildExceptInitial (tokno) ;
2512       catchProcedure := GetQualidentImport (tokno,
2513                                             MakeKey ('DefaultErrorCatch'),
2514                                             MakeKey ('RTExceptions')) ;
2515       IF catchProcedure # NulSym
2516       THEN
2517          PushTtok (catchProcedure, tokno) ;
2518          PushT (0) ;
2519          BuildProcedureCall (tokno)
2520       END ;
2521       BuildRTExceptLeave (tokno, TRUE) ;
2522       GenQuadO (tokno, CatchEndOp, NulSym, NulSym, NulSym, FALSE)
2523    END
2524 END BuildExcept ;
2525
2526
2527 (*
2528    BuildM2MainFunction - creates the main function with appropriate calls to the scaffold.
2529 *)
2530
2531 PROCEDURE BuildM2MainFunction (tokno: CARDINAL) ;
2532 BEGIN
2533    IF (ScaffoldDynamic OR ScaffoldStatic) AND (NOT SharedFlag)
2534    THEN
2535       (* Scaffold required and main should be produced.  *)
2536       (*
2537          int
2538          main (int argc, char *argv[], char *envp[])
2539          {
2540             try {
2541                _M2_init (argc, argv, envp);
2542                _M2_fini (argc, argv, envp);
2543                return 0;
2544             }
2545             catch (...) {
2546                RTExceptions_DefaultErrorCatch ();
2547                return 0;
2548             }
2549          }
2550       *)
2551       PushT (mainFunction) ;
2552       BuildProcedureStart ;
2553       BuildProcedureBegin ;
2554       StartScope (mainFunction) ;
2555       BuildTry (tokno) ;
2556       (* _M2_init (argc, argv, envp);  *)
2557       PushTtok (initFunction, tokno) ;
2558       PushTtok (RequestSym (tokno, MakeKey ("argc")), tokno) ;
2559       PushTtok (RequestSym (tokno, MakeKey ("argv")), tokno) ;
2560       PushTtok (RequestSym (tokno, MakeKey ("envp")), tokno) ;
2561       PushT (3) ;
2562       BuildProcedureCall (tokno) ;
2563
2564       (* _M2_fini (argc, argv, envp);  *)
2565       PushTtok (finiFunction, tokno) ;
2566       PushTtok (RequestSym (tokno, MakeKey ("argc")), tokno) ;
2567       PushTtok (RequestSym (tokno, MakeKey ("argv")), tokno) ;
2568       PushTtok (RequestSym (tokno, MakeKey ("envp")), tokno) ;
2569       PushT (3) ;
2570       BuildProcedureCall (tokno) ;
2571       PushZero (tokno, Integer) ;
2572       BuildReturn (tokno) ;
2573       BuildExcept (tokno) ;
2574       PushZero (tokno, Integer) ;
2575       BuildReturn (tokno) ;
2576       EndScope ;
2577       BuildProcedureEnd ;
2578       PopN (1)
2579    END
2580 END BuildM2MainFunction ;
2581
2582
2583 (*
2584    BuildStringAdrParam - push the address of a nul terminated string onto the quad stack.
2585 *)
2586
2587 PROCEDURE BuildStringAdrParam (tok: CARDINAL; name: Name);
2588 VAR
2589    str, m2strnul: CARDINAL ;
2590 BEGIN
2591    PushTF (Adr, Address) ;
2592    str := MakeConstLitString (tok, name) ;
2593    m2strnul := MakeConstStringM2nul (tok, str) ;
2594    PushTtok (m2strnul, tok) ;
2595    PushT (1) ;
2596    BuildAdrFunction
2597 END BuildStringAdrParam ;
2598
2599
2600 (*
2601    BuildM2InitFunction -
2602 *)
2603
2604 PROCEDURE BuildM2InitFunction (tok: CARDINAL; moduleSym: CARDINAL) ;
2605 VAR
2606    constructModules: CARDINAL ;
2607 BEGIN
2608    IF ScaffoldDynamic OR ScaffoldStatic
2609    THEN
2610       (* Scaffold required and main should be produced.  *)
2611       (* int
2612          _M2_init (int argc, char *argv[], char *envp[])
2613          {
2614             M2RTS_ConstructModules (module_name, libname,
2615                                     overrideliborder, argc, argv, envp);
2616          }  *)
2617       PushT (initFunction) ;
2618       BuildProcedureStart ;
2619       BuildProcedureBegin ;
2620       StartScope (initFunction) ;
2621       IF ScaffoldDynamic
2622       THEN
2623          IF linkFunction # NulSym
2624          THEN
2625             (* _M2_link ();  *)
2626             PushTtok (linkFunction, tok) ;
2627             PushT (0) ;
2628             BuildProcedureCall (tok)
2629          END ;
2630
2631          (* Lookup ConstructModules and call it.  *)
2632          constructModules := GetQualidentImport (tok,
2633                                                  MakeKey ("ConstructModules"),
2634                                                  MakeKey ("M2RTS")) ;
2635          IF constructModules # NulSym
2636          THEN
2637             (* ConstructModules (module_name, argc, argv, envp);  *)
2638             PushTtok (constructModules, tok) ;
2639
2640             BuildStringAdrParam (tok, GetSymName (moduleSym)) ;
2641             BuildStringAdrParam (tok, GetLibName (moduleSym)) ;
2642             BuildStringAdrParam (tok, makekey (GetRuntimeModuleOverride ())) ;
2643
2644             PushTtok (SafeRequestSym (tok, MakeKey ("argc")), tok) ;
2645             PushTtok (SafeRequestSym (tok, MakeKey ("argv")), tok) ;
2646             PushTtok (SafeRequestSym (tok, MakeKey ("envp")), tok) ;
2647             PushT (6) ;
2648             BuildProcedureCall (tok) ;
2649          END
2650       ELSIF ScaffoldStatic
2651       THEN
2652          ForeachModuleCallInit (tok,
2653                                 SafeRequestSym (tok, MakeKey ("argc")),
2654                                 SafeRequestSym (tok, MakeKey ("argv")),
2655                                 SafeRequestSym (tok, MakeKey ("envp")))
2656       END ;
2657       EndScope ;
2658       BuildProcedureEnd ;
2659       PopN (1)
2660    END
2661 END BuildM2InitFunction ;
2662
2663
2664 (*
2665    BuildM2FiniFunction -
2666 *)
2667
2668 PROCEDURE BuildM2FiniFunction (tok: CARDINAL; moduleSym: CARDINAL) ;
2669 VAR
2670    deconstructModules: CARDINAL ;
2671 BEGIN
2672    IF ScaffoldDynamic OR ScaffoldStatic
2673    THEN
2674       (* Scaffold required and main should be produced.  *)
2675       PushT (finiFunction) ;
2676       BuildProcedureStart ;
2677       BuildProcedureBegin ;
2678       StartScope (finiFunction) ;
2679       IF ScaffoldDynamic
2680       THEN
2681          (* static void
2682             _M2_finish (int argc, char *argv[], char *envp[])
2683             {
2684               M2RTS_DeconstructModules (module_name, argc, argv, envp);
2685             }  *)
2686          deconstructModules := GetQualidentImport (tok,
2687                                                    MakeKey ("DeconstructModules"),
2688                                                    MakeKey ("M2RTS")) ;
2689          IF deconstructModules # NulSym
2690          THEN
2691             (* DeconstructModules (module_name, argc, argv, envp);  *)
2692             PushTtok (deconstructModules, tok) ;
2693
2694             PushTF(Adr, Address) ;
2695             PushTtok (MakeConstLitString (tok, GetSymName (moduleSym)), tok) ;
2696             PushT(1) ;
2697             BuildAdrFunction ;
2698
2699             PushTF(Adr, Address) ;
2700             PushTtok (MakeConstLitString (tok, GetLibName (moduleSym)), tok) ;
2701             PushT(1) ;
2702             BuildAdrFunction ;
2703
2704             PushTtok (SafeRequestSym (tok, MakeKey ("argc")), tok) ;
2705             PushTtok (SafeRequestSym (tok, MakeKey ("argv")), tok) ;
2706             PushTtok (SafeRequestSym (tok, MakeKey ("envp")), tok) ;
2707             PushT (5) ;
2708             BuildProcedureCall (tok)
2709          END
2710       ELSIF ScaffoldStatic
2711       THEN
2712          ForeachModuleCallFinish (tok,
2713                                   SafeRequestSym (tok, MakeKey ("argc")),
2714                                   SafeRequestSym (tok, MakeKey ("argv")),
2715                                   SafeRequestSym (tok, MakeKey ("envp")))
2716       END ;
2717       EndScope ;
2718       BuildProcedureEnd ;
2719       PopN (1)
2720    END
2721 END BuildM2FiniFunction ;
2722
2723
2724 (*
2725    BuildM2CtorFunction - create a constructor function associated with moduleSym.
2726
2727                          void
2728                          ctorFunction ()
2729                          {
2730                            M2RTS_RegisterModule (GetSymName (moduleSym), GetLibName (moduleSym),
2731                                                  init, fini, dependencies);
2732                          }
2733 *)
2734
2735 PROCEDURE BuildM2CtorFunction (tok: CARDINAL; moduleSym: CARDINAL) ;
2736 VAR
2737    RegisterModule       : CARDINAL ;
2738    ctor, init, fini, dep: CARDINAL ;
2739 BEGIN
2740    IF ScaffoldDynamic
2741    THEN
2742       GetModuleCtors (moduleSym, ctor, init, fini, dep) ;
2743       IF ctor # NulSym
2744       THEN
2745          Assert (IsProcedure (ctor)) ;
2746          PushT (ctor) ;
2747          BuildProcedureStart ;
2748          BuildProcedureBegin ;
2749          StartScope (ctor) ;
2750          RegisterModule := GetQualidentImport (tok,
2751                                                MakeKey ("RegisterModule"),
2752                                                MakeKey ("M2RTS")) ;
2753          IF RegisterModule # NulSym
2754          THEN
2755             (* RegisterModule (module_name, init, fini, dependencies);  *)
2756             PushTtok (RegisterModule, tok) ;
2757
2758             PushTF (Adr, Address) ;
2759             PushTtok (MakeConstLitString (tok, GetSymName (moduleSym)), tok) ;
2760             PushT (1) ;
2761             BuildAdrFunction ;
2762
2763             PushTF (Adr, Address) ;
2764             PushTtok (MakeConstLitString (tok, GetLibName (moduleSym)), tok) ;
2765             PushT (1) ;
2766             BuildAdrFunction ;
2767
2768             PushTtok (init, tok) ;
2769             PushTtok (fini, tok) ;
2770             PushTtok (dep, tok) ;
2771             PushT (5) ;
2772             BuildProcedureCall (tok)
2773          END ;
2774          EndScope ;
2775          BuildProcedureEnd ;
2776          PopN (1)
2777       END
2778    END
2779 END BuildM2CtorFunction ;
2780
2781
2782 (*
2783    BuildScaffold - generate the main, init, finish functions if
2784                    no -c and this is the application module.
2785 *)
2786
2787 PROCEDURE BuildScaffold (tok: CARDINAL; moduleSym: CARDINAL) ;
2788 BEGIN
2789    IF GetMainModule () = moduleSym
2790    THEN
2791       DeclareScaffold (tok) ;
2792       IF (ScaffoldMain OR (NOT cflag))
2793       THEN
2794          (* There are module init/fini functions and
2795             application init/fini functions.
2796             Here we create the application pair.  *)
2797          BuildM2LinkFunction (tok) ;
2798          BuildM2MainFunction (tok) ;
2799          BuildM2InitFunction (tok, moduleSym) ;  (* Application init.  *)
2800          BuildM2FiniFunction (tok, moduleSym) ;  (* Application fini.  *)
2801       END ;
2802       BuildM2DepFunction (tok, moduleSym) ;  (* Per module dependency.  *)
2803       (* Each module needs a ctor to register the module
2804          init/finish/dep with M2RTS.  *)
2805       BuildM2CtorFunction (tok, moduleSym)
2806    ELSIF WholeProgram
2807    THEN
2808       DeclareScaffold (tok) ;
2809       BuildM2DepFunction (tok, moduleSym) ;  (* Per module dependency.  *)
2810       (* Each module needs a ctor to register the module
2811          init/finish/dep with M2RTS.  *)
2812       BuildM2CtorFunction (tok, moduleSym)
2813    END
2814 END BuildScaffold ;
2815
2816
2817 (*
2818    BuildModuleStart - starts current module scope.
2819 *)
2820
2821 PROCEDURE BuildModuleStart (tok: CARDINAL) ;
2822 BEGIN
2823    GenQuadO (tok,
2824              ModuleScopeOp, tok,
2825              WORD (makekey (string (GetFileName ()))), GetCurrentModule (), FALSE)
2826 END BuildModuleStart ;
2827
2828
2829 (*
2830    StartBuildInnerInit - Sets the start of initialization code of the
2831                          inner module to the next quadruple.
2832 *)
2833
2834 PROCEDURE StartBuildInnerInit (tok: CARDINAL) ;
2835 BEGIN
2836    PutModuleStartQuad (GetCurrentModule(), NextQuad) ;
2837    GenQuadO (tok, InitStartOp, tok, NulSym, GetCurrentModule(), FALSE) ;
2838    PushWord (ReturnStack, 0) ;
2839    CheckNeedPriorityBegin (tok, GetCurrentModule(), GetCurrentModule()) ;
2840    PushWord (TryStack, NextQuad) ;
2841    PushWord (CatchStack, 0) ;
2842    IF HasExceptionFinally (GetCurrentModule())
2843    THEN
2844       GenQuadO (tok, TryOp, NulSym, NulSym, 0, FALSE)
2845    END
2846 END StartBuildInnerInit ;
2847
2848
2849 (*
2850    EndBuildInnerInit - Sets the end initialization code of a module.
2851 *)
2852
2853 PROCEDURE EndBuildInnerInit (tok: CARDINAL) ;
2854 BEGIN
2855    IF HasExceptionBlock (GetCurrentModule())
2856    THEN
2857       BuildRTExceptLeave (tok, TRUE) ;
2858       GenQuadO (tok, CatchEndOp, NulSym, NulSym, NulSym, FALSE)
2859    END ;
2860    PutModuleEndQuad (GetCurrentModule(), NextQuad) ;
2861    CheckVariablesInBlock (GetCurrentModule ()) ;
2862    BackPatch (PopWord (ReturnStack), NextQuad) ;
2863    CheckNeedPriorityEnd (tok, GetCurrentModule (), GetCurrentModule ()) ;
2864    GenQuadO (tok, InitEndOp, tok, NulSym, GetCurrentModule (), FALSE)
2865 END EndBuildInnerInit ;
2866
2867
2868 (*
2869    BuildModulePriority - assigns the current module with a priority
2870                          from the top of stack.
2871
2872                          Entry                   Exit
2873                          =====                   ====
2874
2875
2876                   Ptr ->                         Empty
2877                          +------------+
2878                          | Priority   |
2879                          |------------|
2880 *)
2881
2882 PROCEDURE BuildModulePriority ;
2883 VAR
2884    Priority: CARDINAL ;
2885 BEGIN
2886    PopT (Priority) ;
2887    PutPriority (GetCurrentModule (), Priority)
2888 END BuildModulePriority ;
2889
2890
2891 (*
2892    ForLoopAnalysis - checks all the FOR loops for index variable manipulation
2893                      and dangerous usage outside the loop.
2894 *)
2895
2896 PROCEDURE ForLoopAnalysis ;
2897 VAR
2898    i, n   : CARDINAL ;
2899    forDesc: ForLoopInfo ;
2900 BEGIN
2901    IF Pedantic
2902    THEN
2903       n := HighIndice (ForInfo) ;
2904       i := 1 ;
2905       WHILE i <= n DO
2906          forDesc := GetIndice (ForInfo, i) ;
2907          CheckForIndex (forDesc) ;
2908          INC (i)
2909       END
2910    END
2911 END ForLoopAnalysis ;
2912
2913
2914 (*
2915    AddForInfo - adds the description of the FOR loop into the record list.
2916                 This is used if -pedantic is turned on to check index variable
2917                 usage.
2918 *)
2919
2920 PROCEDURE AddForInfo (Start, End, IncQuad: CARDINAL; Sym: CARDINAL; idtok: CARDINAL) ;
2921 VAR
2922    forDesc: ForLoopInfo ;
2923 BEGIN
2924    IF Pedantic
2925    THEN
2926       NEW (forDesc) ;
2927       WITH forDesc^ DO
2928          IncrementQuad := IncQuad ;
2929          StartOfForLoop := Start ;
2930          EndOfForLoop := End ;
2931          ForLoopIndex := Sym ;
2932          IndexTok := idtok
2933       END ;
2934       IncludeIndiceIntoIndex (ForInfo, forDesc)
2935    END
2936 END AddForInfo ;
2937
2938
2939 (*
2940    CheckForIndex - checks the quadruples: Start..End to see whether a
2941                    for loop index is manipulated by the programmer.
2942                    It generates a warning if this is the case.
2943                    It also checks to see whether the IndexSym is read
2944                    immediately outside the loop in which case a warning
2945                    is issued.
2946 *)
2947
2948 PROCEDURE CheckForIndex (forDesc: ForLoopInfo) ;
2949 VAR
2950    ReadStart, ReadEnd,
2951    WriteStart, WriteEnd: CARDINAL ;
2952 BEGIN
2953    GetWriteLimitQuads (forDesc^.ForLoopIndex, RightValue, forDesc^.StartOfForLoop, forDesc^.EndOfForLoop, WriteStart, WriteEnd) ;
2954    IF (WriteStart < forDesc^.IncrementQuad) AND (WriteStart > forDesc^.StartOfForLoop)
2955    THEN
2956       MetaErrorT1 (forDesc^.IndexTok,
2957                    '{%kFOR} loop index variable {%1Wad} is being manipulated inside the loop',
2958                    forDesc^.ForLoopIndex) ;
2959       MetaErrorT1 (QuadToTokenNo (WriteStart),
2960                    '{%kFOR} loop index variable {%1Wad} is being manipulated, this is considered bad practice and may cause unknown program behaviour',
2961                    forDesc^.ForLoopIndex)
2962    END ;
2963    GetWriteLimitQuads (forDesc^.ForLoopIndex, RightValue, forDesc^.EndOfForLoop, 0, WriteStart, WriteEnd) ;
2964    GetReadLimitQuads (forDesc^.ForLoopIndex, RightValue, forDesc^.EndOfForLoop, 0, ReadStart, ReadEnd) ;
2965    IF (ReadStart#0) AND ((ReadStart < WriteStart) OR (WriteStart = 0))
2966    THEN
2967       MetaErrorT1 (forDesc^.IndexTok,
2968                    '{%kFOR} loop index variable {%1Wad} is being read outside the FOR loop (without being reset)',
2969                    forDesc^.ForLoopIndex) ;
2970       MetaErrorT1 (QuadToTokenNo (ReadStart),
2971                    '{%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',
2972                    forDesc^.ForLoopIndex)
2973    END
2974 END CheckForIndex ;
2975
2976
2977 (*
2978    GetCurrentFunctionName - returns the name for the current __FUNCTION__
2979 *)
2980
2981 (*
2982 PROCEDURE GetCurrentFunctionName () : Name ;
2983 VAR
2984    s: String ;
2985    n: Name ;
2986 BEGIN
2987    IF CurrentProc=NulSym
2988    THEN
2989       s := InitStringCharStar(KeyToCharStar(GetSymName(GetCurrentModule()))) ;
2990       s := Sprintf1(Mark(InitString('module %s initialization')), s) ;
2991       n := makekey(string(s)) ;
2992       s := KillString(s) ;
2993       RETURN( n )
2994    ELSE
2995       RETURN( GetSymName(CurrentProc) )
2996    END
2997 END GetCurrentFunctionName ;
2998 *)
2999
3000
3001 (*
3002    BuildRange - generates a RangeCheckOp quad with, r, as its operand.
3003 *)
3004
3005 PROCEDURE BuildRange (r: CARDINAL) ;
3006 BEGIN
3007    GenQuad (RangeCheckOp, WORD (GetLineNo ()), NulSym, r)
3008 END BuildRange ;
3009
3010
3011 (*
3012    BuildError - generates a ErrorOp quad, indicating that if this
3013                 quadruple is reachable, then a runtime error would
3014                 occur.
3015 *)
3016
3017 PROCEDURE BuildError (r: CARDINAL) ;
3018 BEGIN
3019    GenQuad (ErrorOp, WORD (GetLineNo ()), NulSym, r)
3020 END BuildError ;
3021
3022
3023 (*
3024    CheckPointerThroughNil - builds a range quadruple, providing, sym, is
3025                             a candidate for checking against NIL.
3026                             This range quadruple is only expanded into
3027                             code during the code generation phase
3028                             thus allowing limited compile time checking.
3029 *)
3030
3031 PROCEDURE CheckPointerThroughNil (tokpos: CARDINAL; sym: CARDINAL) ;
3032 BEGIN
3033    IF IsVar (sym) AND GetVarPointerCheck (sym)
3034    THEN
3035       (* PutVarPointerCheck(sym, FALSE) ;  (* so we do not detect this again *) *)
3036       BuildRange (InitPointerRangeCheck (tokpos, sym, GetMode (sym) = LeftValue))
3037    END
3038 END CheckPointerThroughNil ;
3039
3040
3041 (*
3042    CollectLow - returns the low of the subrange value.
3043 *)
3044
3045 PROCEDURE CollectLow (sym: CARDINAL) : CARDINAL ;
3046 VAR
3047    low, high: CARDINAL ;
3048 BEGIN
3049    IF IsSubrange (sym)
3050    THEN
3051       GetSubrange (sym, high, low) ;
3052       RETURN low
3053    ELSE
3054       InternalError  ('expecting Subrange symbol')
3055    END
3056 END CollectLow ;
3057
3058
3059 (*
3060    CollectHigh - returns the high of the subrange value, sym.
3061 *)
3062
3063 PROCEDURE CollectHigh (sym: CARDINAL) : CARDINAL ;
3064 VAR
3065    low, high: CARDINAL ;
3066 BEGIN
3067    IF IsSubrange (sym)
3068    THEN
3069       GetSubrange (sym, high, low) ;
3070       RETURN high
3071    ELSE
3072       InternalError  ('expecting Subrange symbol')
3073    END
3074 END CollectHigh ;
3075
3076
3077 (*
3078    BackPatchSubrangesAndOptParam - runs through all the quadruples and finds SubrangeLow or SubrangeHigh
3079                                    quadruples and replaces it by an assignment to the Low or High component
3080                                    of the subrange type.
3081
3082                                    Input:
3083                                    SubrangeLow    op1     op3         (* op3 is a subrange *)
3084
3085                                    Output:
3086                                    Becomes        op1     low
3087
3088                                    Input:
3089                                    SubrangeHigh   op1     op3         (* op3 is a subrange *)
3090
3091                                    Output:
3092                                    Becomes        op1     high
3093
3094                                    Input:
3095                                    OptParam       op1     op2    op3
3096
3097                                    Output:
3098                                    Param          op1     op2    GetOptArgInit(op3)
3099 *)
3100
3101 PROCEDURE BackPatchSubrangesAndOptParam ;
3102 VAR
3103    f: QuadFrame ;
3104    q: CARDINAL ;
3105 BEGIN
3106    q := GetFirstQuad () ;
3107    IF q # 0
3108    THEN
3109       REPEAT
3110          f := GetQF (q) ;
3111          WITH f^ DO
3112             CASE Operator OF
3113
3114             SubrangeLowOp :  Operand3 := CollectLow (Operand3) ;
3115                              Operator := BecomesOp |
3116             SubrangeHighOp:  Operand3 := CollectHigh (Operand3) ;
3117                              Operator := BecomesOp |
3118             OptParamOp    :  Operand3 := GetOptArgInit (Operand3) ;
3119                              Operator := ParamOp
3120
3121             ELSE
3122             END ;
3123             q := Next
3124          END
3125       UNTIL q = 0
3126    END
3127 END BackPatchSubrangesAndOptParam ;
3128
3129
3130 (*
3131    CheckCompatibleWithBecomes - checks to see that symbol, sym, is
3132                                 compatible with the := operator.
3133 *)
3134
3135 PROCEDURE CheckCompatibleWithBecomes (des, expr,
3136                                       destok, exprtok: CARDINAL) ;
3137 BEGIN
3138    IF IsType (des)
3139    THEN
3140       MetaErrorT1 (destok,
3141                    'an assignment cannot assign a value to a type {%1a}', des)
3142    ELSIF IsProcedure (des)
3143    THEN
3144       MetaErrorT1 (destok,
3145                    'an assignment cannot assign a value to a procedure {%1a}', des)
3146    ELSIF IsFieldEnumeration (des)
3147    THEN
3148       MetaErrorT1 (destok,
3149                    'an assignment cannot assign a value to an enumeration field {%1a}', des)
3150    END ;
3151    IF IsPseudoBaseProcedure (expr) OR IsPseudoBaseFunction (expr)
3152    THEN
3153       MetaErrorT1 (exprtok,
3154                   'an assignment cannot assign a {%1d} {%1a}', expr)
3155    END
3156 END CheckCompatibleWithBecomes ;
3157
3158
3159 (*
3160    BuildAssignmentWithoutBounds - calls BuildAssignment but makes sure we do not
3161                                   check bounds.
3162 *)
3163
3164 PROCEDURE BuildAssignmentWithoutBounds (tok: CARDINAL; checkTypes, checkOverflow: BOOLEAN) ;
3165 VAR
3166    old: BOOLEAN ;
3167 BEGIN
3168    old := MustNotCheckBounds ;
3169    MustNotCheckBounds := TRUE ;
3170    doBuildAssignment (tok, checkTypes, checkOverflow) ;
3171    MustNotCheckBounds := old
3172 END BuildAssignmentWithoutBounds ;
3173
3174
3175 (*
3176    MarkArrayWritten - marks, Array, as being written.
3177 *)
3178
3179 PROCEDURE MarkArrayWritten (Array: CARDINAL) ;
3180 BEGIN
3181    IF (Array#NulSym) AND IsVarAParam(Array)
3182    THEN
3183       PutVarWritten (Array, TRUE)
3184    END
3185 END MarkArrayWritten ;
3186
3187
3188 (*
3189    MarkAsReadWrite - marks the variable or parameter as being
3190                      read/write.
3191 *)
3192
3193 PROCEDURE MarkAsReadWrite (sym: CARDINAL) ;
3194 BEGIN
3195    IF (sym#NulSym) AND IsVar(sym)
3196    THEN
3197       PutReadQuad (sym, RightValue, NextQuad) ;
3198       PutWriteQuad (sym, RightValue, NextQuad)
3199    END
3200 END MarkAsReadWrite ;
3201
3202
3203 (*
3204    MarkAsRead - marks the variable or parameter as being read.
3205 *)
3206
3207 PROCEDURE MarkAsRead (sym: CARDINAL) ;
3208 BEGIN
3209    IF (sym#NulSym) AND IsVar(sym)
3210    THEN
3211       PutReadQuad (sym, RightValue, NextQuad)
3212    END
3213 END MarkAsRead ;
3214
3215
3216 (*
3217    MarkAsWrite - marks the variable or parameter as being written.
3218 *)
3219
3220 PROCEDURE MarkAsWrite (sym: CARDINAL) ;
3221 BEGIN
3222    IF (sym # NulSym) AND IsVar (sym)
3223    THEN
3224       PutWriteQuad (sym, RightValue, NextQuad)
3225    END
3226 END MarkAsWrite ;
3227
3228
3229 (*
3230    doVal - return an expression which is VAL(type, expr).  If
3231            expr is a constant then return expr.
3232 *)
3233
3234 PROCEDURE doVal (type, expr: CARDINAL) : CARDINAL ;
3235 BEGIN
3236    IF (NOT IsConst (expr)) AND (SkipType (type) # GetDType (expr))
3237    THEN
3238       PushTF (Convert, NulSym) ;
3239       PushT (SkipType(type)) ;
3240       PushT (expr) ;
3241       PushT (2) ;          (* Two parameters *)
3242       BuildConvertFunction ;
3243       PopT (expr)
3244    END ;
3245    RETURN( expr )
3246 END doVal ;
3247
3248
3249 (*
3250    MoveWithMode -
3251 *)
3252
3253 PROCEDURE MoveWithMode (tokno: CARDINAL;
3254                         Des, Exp, Array: CARDINAL;
3255                         destok, exptok: CARDINAL;
3256                         checkOverflow: BOOLEAN) ;
3257 VAR
3258    t: CARDINAL ;
3259 BEGIN
3260    IF IsConstString(Exp) AND IsConst(Des)
3261    THEN
3262       GenQuadOtok (tokno, BecomesOp, Des, NulSym, Exp, TRUE,
3263                    destok, UnknownTokenNo, exptok) ;
3264       PutConstString (tokno, Des, GetString (Exp))
3265    ELSE
3266       IF GetMode(Des)=RightValue
3267       THEN
3268          IF GetMode(Exp)=LeftValue
3269          THEN
3270             CheckPointerThroughNil (tokno, Exp) ;  (*    Des = *Exp    *)
3271             doIndrX (tokno, Des, Exp)
3272          ELSE
3273             GenQuadOtok (tokno, BecomesOp, Des, NulSym, Exp, TRUE,
3274                          destok, UnknownTokenNo, exptok)
3275          END
3276       ELSIF GetMode(Des)=LeftValue
3277       THEN
3278          MarkArrayWritten (Array) ;
3279          IF GetMode(Exp) = LeftValue
3280          THEN
3281             t := MakeTemporary (tokno, RightValue) ;
3282             PutVar(t, GetSType(Exp)) ;
3283             CheckPointerThroughNil (tokno, Exp) ;
3284             doIndrX (tokno, t, Exp) ;
3285             CheckPointerThroughNil (tokno, Des) ;  (*    *Des = Exp    *)
3286             GenQuadO (tokno, XIndrOp, Des, GetSType (Des), doVal (GetSType (Des), t),
3287                       checkOverflow)
3288          ELSE
3289             CheckPointerThroughNil (tokno, Des) ;  (*    *Des = Exp    *)
3290             GenQuadO (tokno, XIndrOp, Des, GetSType (Des), doVal (GetSType (Des), Exp),
3291                       checkOverflow)
3292          END
3293       ELSE
3294          GenQuadOtok (tokno, BecomesOp, Des, NulSym, Exp, TRUE,
3295                       destok, UnknownTokenNo, exptok)
3296       END
3297    END
3298 END MoveWithMode ;
3299
3300
3301 (*
3302    BuildBuiltinConst - makes reference to a builtin constant within gm2.
3303
3304                               Entry                 Exit
3305
3306                        Ptr ->
3307                               +------------+        +------------+
3308                               | Ident      |        | Sym        |
3309                               |------------|        |------------|
3310
3311                        Quadruple produced:
3312
3313                        q    Sym  BuiltinConstOp  Ident
3314 *)
3315
3316 PROCEDURE BuildBuiltinConst ;
3317 VAR
3318    idtok: CARDINAL ;
3319    Id   : CARDINAL ;
3320    Sym  : CARDINAL ;
3321 BEGIN
3322    PopTtok (Id, idtok) ;
3323    Sym := MakeTemporary (idtok, ImmediateValue) ;
3324    PutVar (Sym, Integer) ;
3325 (*
3326    CASE GetBuiltinConstType(KeyToCharStar(Name(Id))) OF
3327
3328    0:  ErrorFormat1(NewError(GetTokenNo()),
3329                     '%a unrecognised builtin constant', Id) |
3330    1:  PutVar(Sym, Integer) |
3331    2:  PutVar(Sym, Real)
3332
3333    ELSE
3334       InternalError ('unrecognised value')
3335    END ;
3336 *)
3337    GenQuadO (idtok, BuiltinConstOp, Sym, NulSym, Id, FALSE) ;
3338    PushTtok (Sym, idtok)
3339 END BuildBuiltinConst ;
3340
3341
3342 (*
3343    BuildBuiltinTypeInfo - make reference to a builtin typeinfo function
3344                           within gm2.
3345
3346                                  Entry                 Exit
3347
3348                           Ptr ->
3349                                  +-------------+
3350                                  | Type        |
3351                                  |-------------|       +------------+
3352                                  | Ident       |       | Sym        |
3353                                  |-------------|       |------------|
3354
3355                           Quadruple produced:
3356
3357                           q    Sym  BuiltinTypeInfoOp  Type Ident
3358 *)
3359
3360 PROCEDURE BuildBuiltinTypeInfo ;
3361 VAR
3362    idtok: CARDINAL ;
3363    Ident,
3364    Type,
3365    Sym  : CARDINAL ;
3366 BEGIN
3367    PopTtok (Ident, idtok) ;
3368    PopT (Type) ;
3369    Sym := MakeTemporary (BuiltinTokenNo, ImmediateValue) ;
3370    CASE GetBuiltinTypeInfoType (KeyToCharStar (Name (Ident))) OF
3371
3372    0:  ErrorFormat1 (NewError(idtok),
3373                      '%a unrecognised builtin constant', Ident) |
3374    1:  PutVar (Sym, Boolean) |
3375    2:  PutVar (Sym, ZType) |
3376    3:  PutVar (Sym, RType)
3377
3378    ELSE
3379       InternalError ('unrecognised value')
3380    END ;
3381    GenQuadO (idtok, BuiltinTypeInfoOp, Sym, Type, Ident, FALSE) ;
3382    PushTtok (Sym, idtok)
3383 END BuildBuiltinTypeInfo ;
3384
3385
3386 (*
3387    CheckBecomesMeta - checks to make sure that we are not
3388                       assigning a variable to a constant.
3389                       Also check we are not assigning to an
3390                       unbounded array.
3391 *)
3392
3393 PROCEDURE CheckBecomesMeta (Des, Exp: CARDINAL; combinedtok, destok, exprtok: CARDINAL) ;
3394 BEGIN
3395    IF IsConst (Des) AND IsVar (Exp)
3396    THEN
3397       MetaErrorsT2 (combinedtok,
3398                     'in assignment, cannot assign a variable {%2a} to a constant {%1a}',
3399                     'designator {%1Da} is declared as a {%kCONST}', Des, Exp)
3400    END ;
3401    IF (GetDType(Des) # NulSym) AND IsVar (Des) AND IsUnbounded (GetDType (Des))
3402    THEN
3403       MetaErrorT1 (destok,
3404                    'in assignment, cannot assign to an unbounded array {%1ad}', Des)
3405    END ;
3406    IF (GetDType(Exp) # NulSym) AND IsVar (Exp) AND IsUnbounded (GetDType (Exp))
3407    THEN
3408       MetaErrorT1 (exprtok,
3409                   'in assignment, cannot assign from an unbounded array {%1ad}', Exp)
3410    END
3411 END CheckBecomesMeta ;
3412
3413
3414 (*
3415    BuildAssignment - Builds an assignment from the values given on the
3416                      quad stack. Either an assignment to an
3417                      arithmetic expression or an assignment to a
3418                      boolean expression.  This procedure should not
3419                      be called in CONST declarations.
3420                      The Stack is expected to contain:
3421
3422
3423        Either
3424
3425                      Entry                   Exit
3426                      =====                   ====
3427
3428               Ptr ->
3429                      +------------+
3430                      | Expression |
3431                      |------------|
3432                      | Designator |
3433                      |------------|          +------------+
3434                      |            |          |            |  <- Ptr
3435                      |------------|          |------------|
3436
3437
3438                      Quadruples Produced
3439
3440                      q     BecomesOp  Designator  _  Expression
3441
3442        OR
3443
3444                      Entry                   Exit
3445                      =====                   ====
3446
3447               Ptr ->
3448                      +------------+
3449                      | True |False|
3450                      |------------|
3451                      | Designator |
3452                      |------------|          +------------+
3453                      |            |          |            |  <- Ptr
3454                      |------------|          |------------|
3455
3456
3457                      Quadruples Produced
3458
3459                      q     BecomesOp  Designator  _  TRUE
3460                      q+1   GotoOp                    q+3
3461                      q+2   BecomesOp  Designator  _  FALSE
3462
3463 *)
3464
3465 PROCEDURE BuildAssignment (becomesTokNo: CARDINAL) ;
3466 VAR
3467    des, exp   : CARDINAL ;
3468    destok,
3469    exptok,
3470    combinedtok: CARDINAL ;
3471 BEGIN
3472    des := OperandT (2) ;
3473    IF IsReadOnly (des)
3474    THEN
3475       destok := OperandTok (2) ;
3476       exptok := OperandTok (1) ;
3477       exp := OperandT (1) ;
3478       IF DebugTokPos
3479       THEN
3480          MetaErrorT1 (destok, 'destok {%1Ead}', des) ;
3481          MetaErrorT1 (exptok, 'exptok {%1Ead}', exp)
3482       END ;
3483       combinedtok := MakeVirtualTok (becomesTokNo, destok, exptok) ;
3484       IF DebugTokPos
3485       THEN
3486          MetaErrorT1 (combinedtok, 'combined {%1Ead}', des)
3487       END ;
3488       IF IsBoolean (1)
3489       THEN
3490          MetaErrorT1 (combinedtok,
3491                       'cannot assign expression to a constant designator {%1Ead}', des)
3492       ELSE
3493          exp := OperandT (1) ;
3494          MetaErrorT2 (combinedtok,
3495                       'cannot assign a constant designator {%1Ead} with an expression {%2Ead}',
3496                       des, exp)
3497       END ;
3498       PopN (2)  (* Remove both parameters.  *)
3499    ELSIF IsError (des)
3500    THEN
3501       PopN (2)  (* Remove both parameters.  *)
3502    ELSE
3503       doBuildAssignment (becomesTokNo, TRUE, TRUE)
3504    END
3505 END BuildAssignment ;
3506
3507
3508 (*
3509    BuildAssignConstant - used to create constant in the CONST declaration.
3510                          The stack is expected to contain:
3511
3512        Either
3513
3514                      Entry                   Exit
3515                      =====                   ====
3516
3517               Ptr ->
3518                      +------------+
3519                      | Expression |
3520                      |------------|
3521                      | Designator |
3522                      |------------|          +------------+
3523                      |            |          |            |  <- Ptr
3524                      |------------|          |------------|
3525
3526
3527                      Quadruples Produced
3528
3529                      q     BecomesOp  Designator  _  Expression
3530
3531        OR
3532
3533                      Entry                   Exit
3534                      =====                   ====
3535
3536               Ptr ->
3537                      +------------+
3538                      | True |False|
3539                      |------------|
3540                      | Designator |
3541                      |------------|          +------------+
3542                      |            |          |            |  <- Ptr
3543                      |------------|          |------------|
3544
3545
3546                      Quadruples Produced
3547
3548                      q     BecomesOp  Designator  _  TRUE
3549                      q+1   GotoOp                    q+3
3550                      q+2   BecomesOp  Designator  _  FALSE
3551 *)
3552
3553 PROCEDURE BuildAssignConstant (equalsTokNo: CARDINAL) ;
3554 BEGIN
3555    doBuildAssignment (equalsTokNo, TRUE, TRUE)
3556 END BuildAssignConstant ;
3557
3558
3559 (*
3560    doBuildAssignment - subsiduary procedure of BuildAssignment.
3561                        It builds the assignment and optionally
3562                        checks the types are compatible.
3563 *)
3564
3565 PROCEDURE doBuildAssignment (becomesTokNo: CARDINAL; checkTypes, checkOverflow: BOOLEAN) ;
3566 VAR
3567    r, w,
3568    t, f,
3569    Array,
3570    Des, Exp      : CARDINAL ;
3571    combinedtok,
3572    destok, exptok: CARDINAL ;
3573 BEGIN
3574    DisplayStack ;
3575    IF IsBoolean (1)
3576    THEN
3577       PopBool (t, f) ;
3578       PopTtok (Des, destok) ;
3579       (* Conditional Boolean Assignment.  *)
3580       BackPatch (t, NextQuad) ;
3581       IF GetMode (Des) = RightValue
3582       THEN
3583          GenQuadO (becomesTokNo, BecomesOp, Des, NulSym, True, checkOverflow)
3584       ELSE
3585          CheckPointerThroughNil (destok, Des) ;
3586          GenQuadO (destok, XIndrOp, Des, Boolean, True, checkOverflow)
3587       END ;
3588       GenQuadO (destok, GotoOp, NulSym, NulSym, NextQuad+2, checkOverflow) ;
3589       BackPatch (f, NextQuad) ;
3590       IF GetMode (Des) = RightValue
3591       THEN
3592          GenQuadO (becomesTokNo, BecomesOp, Des, NulSym, False, checkOverflow)
3593       ELSE
3594          CheckPointerThroughNil (destok, Des) ;
3595          GenQuadO (destok, XIndrOp, Des, Boolean, False, checkOverflow)
3596       END
3597    ELSE
3598       PopTrwtok (Exp, r, exptok) ;
3599       MarkAsRead (r) ;
3600       IF Exp = NulSym
3601       THEN
3602          MetaError0 ('{%E}unknown expression found during assignment') ;
3603          FlushErrors
3604       END ;
3605       Array := OperandA (1) ;
3606       PopTrwtok (Des, w, destok) ;
3607       MarkAsWrite (w) ;
3608       CheckCompatibleWithBecomes (Des, Exp, destok, exptok) ;
3609       combinedtok := MakeVirtualTok (becomesTokNo, destok, exptok) ;
3610       IF DebugTokPos
3611       THEN
3612          MetaErrorT1 (becomesTokNo, 'becomestok {%1Oad}', Des) ;
3613          MetaErrorT1 (destok, 'destok {%1Oad}', Des) ;
3614          MetaErrorT1 (exptok, 'exptok {%1Oad}', Exp)
3615       END ;
3616       combinedtok := MakeVirtualTok (becomesTokNo, destok, exptok) ;
3617       IF DebugTokPos
3618       THEN
3619          MetaErrorT1 (combinedtok, 'combined {%1Oad}', Des)
3620       END ;
3621       IF (GetSType (Des) # NulSym) AND (NOT IsSet (GetDType (Des)))
3622       THEN
3623          (* Tell code generator to test runtime values of assignment so ensure we
3624             catch overflow and underflow.  *)
3625          BuildRange (InitAssignmentRangeCheck (combinedtok, Des, Exp))
3626       END ;
3627       IF checkTypes
3628       THEN
3629          CheckBecomesMeta (Des, Exp, combinedtok, destok, exptok)
3630       END ;
3631       (* Simple assignment.  *)
3632       MoveWithMode (becomesTokNo, Des, Exp, Array, destok, exptok, checkOverflow) ;
3633       IF checkTypes
3634       THEN
3635          (*
3636          IF (CannotCheckTypeInPass3 (Des) OR CannotCheckTypeInPass3 (Exp))
3637          THEN
3638             (* We must do this after the assignment to allow the Designator to be
3639                resolved (if it is a constant) before the type checking is done.  *)
3640             (* Prompt post pass 3 to check the assignment once all types are resolved.  *)
3641             BuildRange (InitTypesAssignmentCheck (combinedtok, Des, Exp))
3642          END ;
3643          *)
3644          (* BuildRange (InitTypesAssignmentCheck (combinedtok, Des, Exp)) ; *)
3645          CheckAssignCompatible (Des, Exp, combinedtok, destok, exptok)
3646       END
3647    END ;
3648    DisplayStack
3649 END doBuildAssignment ;
3650
3651
3652 (*
3653    CheckAssignCompatible - checks to see that an assignment is compatible.
3654                            It performs limited checking - thorough checking
3655                            is done in pass 3.  But we do what we can here
3656                            given knowledge so far.
3657 *)
3658
3659 PROCEDURE CheckAssignCompatible (Des, Exp: CARDINAL; combinedtok, destok, exprtok: CARDINAL) ;
3660 VAR
3661    DesT, ExpT, DesL: CARDINAL ;
3662 BEGIN
3663    DesT := GetSType(Des) ;
3664    ExpT := GetSType(Exp) ;
3665    DesL := GetLType(Des) ;
3666    IF IsProcedure(Exp) AND
3667       ((DesT#NulSym) AND (NOT IsProcType(DesT))) AND
3668       ((DesL#NulSym) AND (NOT IsProcType(DesL)))
3669    THEN
3670       MetaErrorT1 (destok,
3671                   'incorrectly assigning a procedure to a designator {%1Ead} (designator is not a procedure type, {%1ast})', Des)
3672    ELSIF IsProcedure (Exp) AND IsProcedureNested (Exp)
3673    THEN
3674       MetaErrorT1 (exprtok,
3675                    'cannot call nested procedure {%1Ead} indirectly as the outer scope will not be known', Exp)
3676    ELSIF IsConstString(Exp)
3677    THEN
3678    ELSIF (DesT#NulSym) AND (IsUnbounded(DesT))
3679    THEN
3680    ELSIF (ExpT#NulSym) AND (IsUnbounded(ExpT))
3681    THEN
3682    ELSIF (DesL#NulSym) AND IsArray(DesL)
3683    THEN
3684    ELSIF IsConstructor(Exp)
3685    THEN
3686       IF ExpT=NulSym
3687       THEN
3688          (* ignore type checking *)
3689       ELSIF (DesT=NulSym) AND IsConst(Des) AND (IsConstructor(Des) OR IsConstSet(Des))
3690       THEN
3691          PutConst(Des, ExpT)
3692       ELSIF NOT IsAssignmentCompatible(DesT, ExpT)
3693       THEN
3694          MetaErrorT1 (combinedtok,
3695                       'constructor expression is not compatible during assignment to {%1Ead}', Des)
3696       END
3697    ELSIF (DesT#NulSym) AND IsSet(DesT) AND IsConst(Exp)
3698    THEN
3699       (* We ignore checking of these types in pass 3 - but we do check them thoroughly post pass 3 *)
3700    ELSIF IsConst(Exp) AND (ExpT#Address) AND (NOT IsConst(Des)) AND
3701          (DesL#NulSym) AND ((DesL=Cardinal) OR (NOT IsSubrange(DesL))) AND
3702          (NOT IsEnumeration(DesL))
3703    THEN
3704       IF (IsBaseType(DesL) OR IsSystemType(DesL))
3705       THEN
3706          CheckAssignmentCompatible (combinedtok, ExpT, DesT)
3707       ELSE
3708          MetaErrorT2 (combinedtok,
3709                       '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)
3710       END
3711    ELSE
3712       IF (DesT#NulSym) AND IsProcType(DesT) AND IsProcedure(Exp)
3713       THEN
3714          DesT := GetSType(DesT) ; (* we can at least check RETURN values of procedure variables *)
3715          (* remember that thorough assignment checking is done post pass 3 *)
3716          CheckAssignmentCompatible (combinedtok, ExpT, DesT)
3717       END
3718    END
3719 END CheckAssignCompatible ;
3720
3721
3722 (*
3723    CheckBooleanId - Checks to see if the top operand is a boolean.
3724                     If the operand is not a boolean then it is tested
3725                     with true and a boolean is generated.
3726                     The Stack:
3727
3728
3729                     Entry                     Exit
3730              Ptr ->                                          <- Ptr
3731                     +------------+            +------------+
3732                     | Sym        |            | t   | f    |
3733                     |------------|            |------------|
3734
3735                      Quadruples
3736
3737                      q   If=      Sym   True   _
3738                      q+1 GotoOp   _     _      _
3739 *)
3740
3741 PROCEDURE CheckBooleanId ;
3742 VAR
3743    tok: CARDINAL ;
3744 BEGIN
3745    IF NOT IsBoolean (1)
3746    THEN
3747       tok := OperandTok (1) ;
3748       IF IsVar (OperandT (1))
3749       THEN
3750          IF GetSType (OperandT (1)) # Boolean
3751          THEN
3752             MetaError1 ('{%1Ua:is not a boolean expression}' +
3753                         '{!%1Ua:boolean expression expected}', OperandT (1))
3754          END
3755       END ;
3756       PushT (EqualTok) ;
3757       PushT (True) ;
3758       BuildRelOp (tok)
3759    END
3760 END CheckBooleanId ;
3761
3762
3763 (*
3764    BuildAlignment - builds an assignment to an alignment constant.
3765
3766                     The Stack is expected to contain:
3767
3768
3769                             Entry                   Exit
3770                             =====                   ====
3771
3772                     Ptr ->
3773                             +---------------+
3774                             | Expression    |
3775                             |---------------|
3776                             | bytealignment |
3777                             |---------------|       empty
3778 *)
3779
3780 PROCEDURE BuildAlignment (tokno: CARDINAL) ;
3781 VAR
3782    name : Name ;
3783    expr,
3784    align: CARDINAL ;
3785 BEGIN
3786    PopT (expr) ;
3787    PopT (name) ;
3788    IF name # MakeKey ('bytealignment')
3789    THEN
3790       MetaError1 ('expecting bytealignment identifier, rather than {%1Ea}',
3791                   MakeError (tokno, name))
3792    END ;
3793    GetConstFromFifoQueue (align) ;
3794    PushT (align) ;
3795    PushT (expr) ;
3796    BuildAssignConstant (tokno)
3797 END BuildAlignment ;
3798
3799
3800 (*
3801    BuildBitLength - builds an assignment to a bit length constant.
3802
3803                     The Stack is expected to contain:
3804
3805
3806                            Entry                   Exit
3807                            =====                   ====
3808
3809                     Ptr ->
3810                            +------------+
3811                            | Expression |
3812                            |------------|          empty
3813 *)
3814
3815 PROCEDURE BuildBitLength (tokno: CARDINAL) ;
3816 VAR
3817    expr,
3818    length: CARDINAL ;
3819 BEGIN
3820    PopT (expr) ;
3821    GetConstFromFifoQueue (length) ;
3822    PushT (length) ;
3823    PushT (expr) ;
3824    BuildAssignConstant (tokno)
3825 END BuildBitLength ;
3826
3827
3828 (*
3829    BuildDefaultFieldAlignment - builds an assignment to an alignment constant.
3830
3831                                 The Stack is expected to contain:
3832
3833
3834                                        Entry                   Exit
3835                                        =====                   ====
3836
3837                                 Ptr ->
3838                                        +------------+
3839                                        | Expression |
3840                                        |------------|          empty
3841 *)
3842
3843 PROCEDURE BuildDefaultFieldAlignment ;
3844 VAR
3845    expr,
3846    align: CARDINAL ;
3847    name : Name ;
3848 BEGIN
3849    PopT (expr) ;
3850    PopT (name) ;
3851    IF name # MakeKey ('bytealignment')
3852    THEN
3853       MetaError0 ('{%E}only allowed to use the attribute {%kbytealignment} in the default record field alignment pragma')
3854    END ;
3855    GetConstFromFifoQueue (align) ;
3856    PushT (align) ;
3857    PushT (expr) ;
3858    BuildAssignConstant (GetTokenNo ())
3859 END BuildDefaultFieldAlignment ;
3860
3861
3862 (*
3863    BuildPragmaField - builds an assignment to an alignment constant.
3864
3865                       The Stack is expected to contain:
3866
3867
3868                       Entry                   Exit
3869                       =====                   ====
3870
3871                Ptr ->
3872                       +------------+
3873                       | Expression |
3874                       |------------|          empty
3875 *)
3876
3877 PROCEDURE BuildPragmaField ;
3878 VAR
3879    expr,
3880    const: CARDINAL ;
3881    name : Name ;
3882 BEGIN
3883    PopT (expr) ;
3884    PopT (name) ;
3885    IF (name # MakeKey ('unused')) AND (name # MakeKey ('bytealignment'))
3886    THEN
3887       MetaError0 ('only allowed to use the attribute {%Ekbytealignment} in the default record field alignment pragma')
3888    END ;
3889    IF expr # NulSym
3890    THEN
3891       GetConstFromFifoQueue (const) ;
3892       PushT (const) ;
3893       PushT (expr) ;
3894       BuildAssignConstant (GetTokenNo ())
3895    END
3896 END BuildPragmaField ;
3897
3898
3899 (*
3900    BuildRepeat - Builds the repeat statement from the quad stack.
3901                  The Stack is expected to contain:
3902
3903
3904                  Entry                   Exit
3905                  =====                   ====
3906
3907
3908                  Empty
3909                                                         <- Ptr
3910                                          +------------+
3911                                          | RepeatQuad |
3912                                          |------------|
3913
3914 *)
3915
3916 PROCEDURE BuildRepeat ;
3917 BEGIN
3918    PushT(NextQuad)
3919 END BuildRepeat ;
3920
3921
3922 (*
3923    BuildUntil - Builds the until part of the repeat statement
3924                 from the quad stack.
3925                 The Stack is expected to contain:
3926
3927
3928                 Entry                   Exit
3929                 =====                   ====
3930
3931         Ptr ->
3932                 +------------+
3933                 | t   | f    |
3934                 |------------|
3935                 | RepeatQuad |          Empty
3936                 |------------|
3937 *)
3938
3939 PROCEDURE BuildUntil ;
3940 VAR
3941    t, f,
3942    Repeat: CARDINAL ;
3943 BEGIN
3944    CheckBooleanId ;
3945    PopBool(t, f) ;
3946    PopT(Repeat) ;
3947    BackPatch(f, Repeat) ;          (* If False then keep on repeating *)
3948    BackPatch(t, NextQuad) ;        (* If True then exit repeat        *)
3949 END BuildUntil ;
3950
3951
3952 (*
3953    BuildWhile - Builds the While part of the While statement
3954                 from the quad stack.
3955                 The Stack is expected to contain:
3956
3957
3958                 Entry                   Exit
3959                 =====                   ====
3960
3961                                                        <- Ptr
3962                                         |------------|
3963                 Empty                   | WhileQuad  |
3964                                         |------------|
3965 *)
3966
3967 PROCEDURE BuildWhile ;
3968 BEGIN
3969    PushT(NextQuad)
3970 END BuildWhile ;
3971
3972
3973 (*
3974    BuildDoWhile - Builds the Do part of the while statement
3975                   from the quad stack.
3976                   The Stack is expected to contain:
3977
3978
3979                   Entry                   Exit
3980                   =====                   ====
3981
3982           Ptr ->
3983                   +------------+          +------------+
3984                   | t   | f    |          | 0    | f   |
3985                   |------------|          |------------|
3986                   | WhileQuad  |          | WhileQuad  |
3987                   |------------|          |------------|
3988
3989                   Quadruples
3990
3991                   BackPatch t exit to the NextQuad
3992 *)
3993
3994 PROCEDURE BuildDoWhile ;
3995 VAR
3996    t, f: CARDINAL ;
3997 BEGIN
3998    CheckBooleanId ;
3999    PopBool(t, f) ;
4000    BackPatch(t, NextQuad) ;
4001    PushBool(0, f)
4002 END BuildDoWhile ;
4003
4004
4005 (*
4006    BuildEndWhile - Builds the end part of the while statement
4007                    from the quad stack.
4008                    The Stack is expected to contain:
4009
4010
4011                    Entry                   Exit
4012                    =====                   ====
4013
4014            Ptr ->
4015                    +------------+
4016                    | t   | f    |
4017                    |------------|
4018                    | WhileQuad  |          Empty
4019                    |------------|
4020
4021                    Quadruples
4022
4023                    q    GotoOp  WhileQuad
4024                    False exit is backpatched with q+1
4025 *)
4026
4027 PROCEDURE BuildEndWhile ;
4028 VAR
4029    While,
4030    t, f : CARDINAL ;
4031 BEGIN
4032    PopBool(t, f) ;
4033    Assert(t=0) ;
4034    PopT(While) ;
4035    GenQuad(GotoOp, NulSym, NulSym, While) ;
4036    BackPatch(f, NextQuad)
4037 END BuildEndWhile ;
4038
4039
4040 (*
4041    BuildLoop - Builds the Loop part of the Loop statement
4042                from the quad stack.
4043                The Stack is expected to contain:
4044
4045
4046                Entry                   Exit
4047                =====                   ====
4048
4049                                                       <- Ptr
4050                Empty                   +------------+
4051                                        | LoopQuad   |
4052                                        |------------|
4053 *)
4054
4055 PROCEDURE BuildLoop ;
4056 BEGIN
4057    PushT(NextQuad) ;
4058    PushExit(0)       (* Seperate Exit Stack for loop end *)
4059 END BuildLoop ;
4060
4061
4062 (*
4063    BuildExit - Builds the Exit part of the Loop statement.
4064 *)
4065
4066 PROCEDURE BuildExit ;
4067 BEGIN
4068    IF IsEmptyWord(ExitStack)
4069    THEN
4070       MetaError0 ('{%EkEXIT} is only allowed in a {%kLOOP} statement')
4071    ELSE
4072       GenQuad(GotoOp, NulSym, NulSym, 0) ;
4073       PushExit(Merge(PopExit(), NextQuad-1))
4074    END
4075 END BuildExit ;
4076
4077
4078 (*
4079    BuildEndLoop - Builds the End part of the Loop statement
4080                   from the quad stack.
4081                   The Stack is expected to contain:
4082
4083
4084                   Entry                   Exit
4085                   =====                   ====
4086
4087           Ptr ->
4088                   +------------+
4089                   | LoopQuad   |          Empty
4090                   |------------|
4091
4092                   Quadruples
4093
4094                   Goto  _  _  LoopQuad
4095 *)
4096
4097 PROCEDURE BuildEndLoop ;
4098 VAR
4099    Loop: CARDINAL ;
4100 BEGIN
4101    PopT(Loop) ;
4102    GenQuad(GotoOp, NulSym, NulSym, Loop) ;
4103    BackPatch(PopExit(), NextQuad)
4104 END BuildEndLoop ;
4105
4106
4107 (*
4108    BuildThenIf - Builds the Then part of the If statement
4109                  from the quad stack.
4110                  The Stack is expected to contain:
4111
4112
4113                  Entry                   Exit
4114                  =====                   ====
4115
4116          Ptr ->                                          <- Ptr
4117                  +------------+          +------------+
4118                  | t   | f    |          | 0    | f   |
4119                  |------------|          |------------|
4120
4121                  Quadruples
4122
4123                  The true exit is BackPatched to point to
4124                  the NextQuad.
4125 *)
4126
4127 PROCEDURE BuildThenIf ;
4128 VAR
4129    t, f: CARDINAL ;
4130 BEGIN
4131    CheckBooleanId ;
4132    PopBool(t, f) ;
4133    BackPatch(t, NextQuad) ;
4134    PushBool(0, f)
4135 END BuildThenIf ;
4136
4137
4138 (*
4139    BuildElse - Builds the Else part of the If statement
4140                from the quad stack.
4141                The Stack is expected to contain:
4142
4143
4144                Entry                   Exit
4145                =====                   ====
4146
4147        Ptr ->
4148                +------------+          +------------+
4149                | t   | f    |          | t+q  | 0   |
4150                |------------|          |------------|
4151
4152                Quadruples
4153
4154                q    GotoOp  _  _  0
4155                q+1  <- BackPatched from f
4156 *)
4157
4158 PROCEDURE BuildElse ;
4159 VAR
4160    t, f: CARDINAL ;
4161 BEGIN
4162    GenQuad(GotoOp, NulSym, NulSym, 0) ;
4163    PopBool(t, f) ;
4164    BackPatch(f, NextQuad) ;
4165    PushBool(Merge(t, NextQuad-1), 0)   (* NextQuad-1 = Goto Quad *)
4166 END BuildElse ;
4167
4168
4169 (*
4170    BuildEndIf - Builds the End part of the If statement
4171                 from the quad stack.
4172                 The Stack is expected to contain:
4173
4174
4175                 Entry                   Exit
4176                 =====                   ====
4177
4178         Ptr ->
4179                 +------------+
4180                 | t   | f    |          Empty
4181                 |------------|
4182
4183                 Quadruples
4184
4185                 Both t and f are backpatched to point to the NextQuad
4186 *)
4187
4188 PROCEDURE BuildEndIf ;
4189 VAR
4190    t, f: CARDINAL ;
4191 BEGIN
4192    PopBool(t, f) ;
4193    BackPatch(t, NextQuad) ;
4194    BackPatch(f, NextQuad)
4195 END BuildEndIf ;
4196
4197
4198 (*
4199    BuildElsif1 - Builds the Elsif part of the If statement
4200                  from the quad stack.
4201                  The Stack is expected to contain:
4202
4203
4204                  Entry                   Exit
4205                  =====                   ====
4206
4207          Ptr ->
4208                  +------------+          +------------+
4209                  | t   | f    |          | t+q  | 0   |
4210                  |------------|          |------------|
4211
4212                  Quadruples
4213
4214                  q    GotoOp  _  _  0
4215                  q+1  <- BackPatched from f
4216 *)
4217
4218 PROCEDURE BuildElsif1 ;
4219 VAR
4220    t, f: CARDINAL ;
4221 BEGIN
4222    GenQuad(GotoOp, NulSym, NulSym, 0) ;
4223    PopBool(t, f) ;
4224    BackPatch(f, NextQuad) ;
4225    PushBool(Merge(t, NextQuad-1), 0)   (* NextQuad-1 = Goto Quad *)
4226 END BuildElsif1 ;
4227
4228
4229 (*
4230    BuildElsif2 - Builds the Elsif until part of the If statement
4231                  from the quad stack.
4232                  The Stack is expected to contain:
4233
4234
4235                  Entry                   Exit
4236                  =====                   ====
4237
4238           Ptr ->
4239                  +--------------+
4240                  | 0    | f1    |                            <- Ptr
4241                  |--------------|          +---------------+
4242                  | t2   | f2    |          | t2    | f1+f2 |
4243                  |--------------|          |---------------|
4244 *)
4245
4246 PROCEDURE BuildElsif2 ;
4247 VAR
4248    t1, f1,
4249    t2, f2: CARDINAL ;
4250 BEGIN
4251    PopBool(t1, f1) ;
4252    Assert(t1=0) ;
4253    PopBool(t2, f2) ;
4254    PushBool(t2, Merge(f1, f2))
4255 END BuildElsif2 ;
4256
4257
4258 (*
4259    PushOne - pushes the value one to the stack.
4260              The Stack is changed:
4261
4262
4263                     Entry                   Exit
4264                     =====                   ====
4265
4266                                                             <- Ptr
4267                                             +------------+
4268              Ptr ->                         | 1 | type   |
4269                                             |------------|
4270 *)
4271
4272 PROCEDURE PushOne (tok: CARDINAL; type: CARDINAL; message: ARRAY OF CHAR) ;
4273 BEGIN
4274    IF type = NulSym
4275    THEN
4276       PushTF (MakeConstLit (tok, MakeKey('1'), NulSym), NulSym)
4277    ELSIF IsEnumeration (type)
4278    THEN
4279       IF NoOfElements (type) = 0
4280       THEN
4281          MetaErrorString1 (ConCat (InitString ('enumeration type only has one element {%1Dad} and therefore '),
4282                                    Mark (InitString (message))),
4283                            type) ;
4284          PushZero (tok, type)
4285       ELSE
4286          PushTF (Convert, NulSym) ;
4287          PushT (type) ;
4288          PushT (MakeConstLit (tok, MakeKey ('1'), ZType)) ;
4289          PushT (2) ;          (* Two parameters *)
4290          BuildConvertFunction
4291       END
4292    ELSE
4293       PushTF (MakeConstLit (tok, MakeKey ('1'), type), type)
4294    END
4295 END PushOne ;
4296
4297
4298 (*
4299    PushZero - pushes the value zero to the stack.
4300               The Stack is changed:
4301
4302
4303                     Entry                   Exit
4304                     =====                   ====
4305
4306                                                             <- Ptr
4307                                             +------------+
4308              Ptr ->                         | 0 | type   |
4309                                             |------------|
4310 *)
4311
4312 PROCEDURE PushZero (tok: CARDINAL; type: CARDINAL) ;
4313 BEGIN
4314    IF type = NulSym
4315    THEN
4316       PushTFtok (MakeConstLit (tok, MakeKey ('0'), NulSym), NulSym, tok)
4317    ELSIF IsEnumeration (type)
4318    THEN
4319       PushTFtok (Convert, NulSym, tok) ;
4320       PushTtok (type, tok) ;
4321       PushTtok (MakeConstLit (tok, MakeKey ('0'), ZType), tok) ;
4322       PushT (2) ;          (* Two parameters *)
4323       BuildConvertFunction
4324    ELSE
4325       PushTFtok (MakeConstLit (tok, MakeKey ('0'), type), type, tok)
4326    END
4327 END PushZero ;
4328
4329
4330 (*
4331    BuildPseudoBy - Builds the Non existant part of the By
4332                    clause of the For statement
4333                    from the quad stack.
4334                    The Stack is expected to contain:
4335
4336
4337                    Entry                   Exit
4338                    =====                   ====
4339
4340                                                            <- Ptr
4341                                            +------------+
4342             Ptr ->                         | BySym | t  |
4343                    +------------+          |------------|
4344                    | e    | t   |          | e     | t  |
4345                    |------------|          |------------|
4346 *)
4347
4348 PROCEDURE BuildPseudoBy ;
4349 VAR
4350    e, t, dotok: CARDINAL ;
4351 BEGIN
4352    PopTFtok (e, t, dotok) ;  (* as there is no BY token this position is the DO at the end of the last expression.  *)
4353    PushTFtok (e, t, dotok) ;
4354    IF t=NulSym
4355    THEN
4356       t := GetSType (e)
4357    END ;
4358    PushOne (dotok, t, 'the implied FOR loop increment will cause an overflow {%1ad}')
4359 END BuildPseudoBy ;
4360
4361
4362 (*
4363    BuildForLoopToRangeCheck - builds the range check to ensure that the id
4364                               does not exceed the limits of its type.
4365 *)
4366
4367 PROCEDURE BuildForLoopToRangeCheck ;
4368 VAR
4369    d, dt,
4370    e, et: CARDINAL ;
4371 BEGIN
4372    PopTF (e, et) ;
4373    PopTF (d, dt) ;
4374    BuildRange (InitForLoopToRangeCheck (d, e)) ;
4375    PushTF (d, dt) ;
4376    PushTF (e, et)
4377 END BuildForLoopToRangeCheck ;
4378
4379
4380 (*
4381    BuildForToByDo - Builds the For To By Do part of the For statement
4382                     from the quad stack.
4383                     The Stack is expected to contain:
4384
4385
4386                     Entry                   Exit
4387                     =====                   ====
4388
4389
4390              Ptr ->                                           <- Ptr
4391                     +----------------+      |----------------|
4392                     | BySym | ByType |      | ForQuad        |
4393                     |----------------|      |----------------|
4394                     | e2             |      | LastValue      |
4395                     |----------------|      |----------------|
4396                     | e1             |      | BySym | ByType |
4397                     |----------------|      |----------------|
4398                     | Ident          |      | IdentSym       |
4399                     |----------------|      |----------------|
4400
4401
4402                     x := e1 ;
4403                     LASTVALUE := ((e2-e1) DIV BySym) * BySym + e1
4404                     IF BySym<0
4405                     THEN
4406                        IF e1<e2
4407                        THEN
4408                           goto exit
4409                        END
4410                     ELSE
4411                        IF e1>e2
4412                        THEN
4413                           goto exit
4414                        END
4415                     END ;
4416                     LOOP
4417                        body
4418                        IF x=LASTVALUE
4419                        THEN
4420                           goto exit
4421                        END ;
4422                        INC(x, BySym)
4423                     END
4424
4425                     Quadruples:
4426
4427                     q     BecomesOp  IdentSym  _  e1
4428                     q+    LastValue  := ((e1-e2) DIV by) * by + e1
4429                     q+1   if >=      by        0  q+..2
4430                     q+2   GotoOp                  q+3
4431                     q+3   If >=      e1  e2       q+5
4432                     q+4   GotoOp                  exit
4433                     q+5   ..
4434                     q+..1 Goto                    q+..5
4435                     q+..2 If >=      e2  e1       q+..4
4436                     q+..3 GotoOp                  exit
4437                     q+..4 ..
4438
4439                     The For Loop is regarded:
4440
4441                     For ident := e1 To e2 By by Do
4442
4443                     End
4444 *)
4445
4446 PROCEDURE BuildForToByDo ;
4447 VAR
4448    l1, l2    : LineNote ;
4449    e1, e2,
4450    Id        : Name ;
4451    e1tok,
4452    e2tok,
4453    idtok,
4454    bytok     : CARDINAL ;
4455    FinalValue,
4456    exit1,
4457    IdSym,
4458    BySym,
4459    ByType,
4460    ForLoop,
4461    t, f      : CARDINAL ;
4462    etype,
4463    t1        : CARDINAL ;
4464 BEGIN
4465    l2 := PopLineNo() ;
4466    l1 := PopLineNo() ;
4467    UseLineNote(l1) ;
4468    PushFor (0) ;
4469    PopTFtok (BySym, ByType, bytok) ;
4470    PopTtok (e2, e2tok) ;
4471    PopTtok (e1, e1tok) ;
4472    PopTtok (Id, idtok) ;
4473    IdSym := RequestSym (idtok, Id) ;
4474    IF NOT IsExpressionCompatible (GetSType (e1), GetSType (e2))
4475    THEN
4476       MetaError2 ('incompatible types found in {%EkFOR} loop header, initial expression {%1tsad} and final expression {%2tsad}',
4477                  e1, e2) ;
4478       CheckExpressionCompatible (idtok, GetSType (e1), GetSType (e2))
4479    END ;
4480    IF NOT IsExpressionCompatible( GetSType (e1), ByType)
4481    THEN
4482       MetaError2 ('incompatible types found in {%EkFOR} loop header, initial expression {%1tsad} and {%kBY} {%2tsad}',
4483                   e2, BySym) ;
4484       CheckExpressionCompatible (e1tok, GetSType (e1), ByType)
4485    ELSIF NOT IsExpressionCompatible (GetSType (e2), ByType)
4486    THEN
4487       MetaError2 ('incompatible types found in {%EkFOR} loop header, final expression {%1tsad} and {%kBY} {%2tsad}',
4488                   e2, BySym) ;
4489       CheckExpressionCompatible (e1tok, GetSType (e2), ByType)
4490    END ;
4491    BuildRange (InitForLoopBeginRangeCheck (IdSym, e1)) ;
4492    PushTtok (IdSym, idtok) ;
4493    PushTtok (e1, e1tok) ;
4494    BuildAssignmentWithoutBounds (idtok, TRUE, TRUE) ;
4495
4496    UseLineNote (l2) ;
4497    FinalValue := MakeTemporary (e2tok,
4498                                 AreConstant (IsConst (e1) AND IsConst (e2) AND
4499                                             IsConst (BySym))) ;
4500    PutVar (FinalValue, GetSType (IdSym)) ;
4501    etype := MixTypes (GetSType (e1), GetSType (e2), e2tok) ;
4502    e1 := doConvert (etype, e1) ;
4503    e2 := doConvert (etype, e2) ;
4504
4505    PushTF (FinalValue, GetSType(FinalValue)) ;
4506    PushTFtok (e2, GetSType(e2), e2tok) ;  (* FinalValue := ((e1-e2) DIV By) * By + e1 *)
4507    PushT (MinusTok) ;
4508    PushTFtok (e1, GetSType(e1), e1tok) ;
4509    doBuildBinaryOp (TRUE, FALSE) ;
4510    PushT (DivideTok) ;
4511    PushTFtok (BySym, ByType, bytok) ;
4512    doBuildBinaryOp (FALSE, FALSE) ;
4513    PushT (TimesTok) ;
4514    PushTFtok (BySym, ByType, bytok) ;
4515    doBuildBinaryOp (FALSE, FALSE) ;
4516    PushT (ArithPlusTok) ;
4517    PushTFtok (e1, GetSType (e1), e1tok) ;
4518    doBuildBinaryOp (FALSE, FALSE) ;
4519    BuildForLoopToRangeCheck ;
4520    BuildAssignmentWithoutBounds (e1tok, FALSE, FALSE) ;
4521
4522    (* q+1 if >=      by        0  q+..2 *)
4523    (* q+2 GotoOp                  q+3   *)
4524    PushTFtok (BySym, ByType, bytok) ;  (* BuildRelOp  1st parameter *)
4525    PushT (GreaterEqualTok) ;           (*             2nd parameter *)
4526                                        (* 3rd parameter *)
4527    PushZero (bytok, ByType) ;
4528
4529    BuildRelOp (e2tok) ;       (* choose final expression position.  *)
4530    PopBool(t, f) ;
4531    BackPatch(f, NextQuad) ;
4532    (* q+3 If >=       e1  e2      q+5  *)
4533    (* q+4 GotoOp                  Exit *)
4534    PushTFtok (e1, GetSType (e1), e1tok) ;  (* BuildRelOp  1st parameter *)
4535    PushT (GreaterEqualTok) ;               (*             2nd parameter *)
4536    PushTFtok (e2, GetSType (e2), e2tok) ;  (*             3rd parameter *)
4537    BuildRelOp (e2tok) ;           (* choose final expression position.  *)
4538    PopBool (t1, exit1) ;
4539    BackPatch (t1, NextQuad) ;
4540    PushFor (Merge (PopFor(), exit1)) ;    (* merge exit1 *)
4541
4542    GenQuad (GotoOp, NulSym, NulSym, 0) ;
4543    ForLoop := NextQuad-1 ;
4544
4545    (* ELSE *)
4546
4547    BackPatch (t, NextQuad) ;
4548    PushTFtok (e2, GetSType(e2), e2tok) ; (* BuildRelOp  1st parameter *)
4549    PushT (GreaterEqualTok) ;             (*             2nd parameter *)
4550    PushTFtok (e1, GetSType(e1), e1tok) ; (*             3rd parameter *)
4551    BuildRelOp (e2tok) ;
4552    PopBool (t1, exit1) ;
4553    BackPatch (t1, NextQuad) ;
4554    PushFor (Merge (PopFor (), exit1)) ;       (* merge exit1 *)
4555
4556    BackPatch(ForLoop, NextQuad) ; (* fixes the start of the for loop *)
4557    ForLoop := NextQuad ;
4558
4559    (* and set up the stack *)
4560
4561    PushTFtok (IdSym, GetSym (IdSym), idtok) ;
4562    PushTFtok (BySym, ByType, bytok) ;
4563    PushTFtok (FinalValue, GetSType (FinalValue), e2tok) ;
4564    PushT (ForLoop)
4565 END BuildForToByDo ;
4566
4567
4568 (*
4569    BuildEndFor - Builds the End part of the For statement
4570                  from the quad stack.
4571                  The Stack is expected to contain:
4572
4573
4574                  Entry                   Exit
4575                  =====                   ====
4576
4577          Ptr ->
4578                  +----------------+
4579                  | ForQuad        |
4580                  |----------------|
4581                  | LastValue      |
4582                  |----------------|
4583                  | BySym | ByType |
4584                  |----------------|
4585                  | IdSym          |      Empty
4586                  |----------------|
4587 *)
4588
4589 PROCEDURE BuildEndFor (endpostok: CARDINAL) ;
4590 VAR
4591    t, f,
4592    tsym,
4593    IncQuad,
4594    ForQuad: CARDINAL ;
4595    LastSym,
4596    ByType,
4597    BySym,
4598    bytok,
4599    IdSym,
4600    idtok  : CARDINAL ;
4601 BEGIN
4602    PopT (ForQuad) ;
4603    PopT (LastSym) ;
4604    PopTFtok (BySym, ByType, bytok) ;
4605    PopTtok (IdSym, idtok) ;
4606
4607    (* IF IdSym=LastSym THEN exit END *)
4608    PushTF(IdSym, GetSType (IdSym)) ;
4609    PushT (EqualTok) ;
4610    PushTF (LastSym, GetSType (LastSym)) ;
4611    BuildRelOp (endpostok) ;
4612    PopBool (t, f) ;
4613
4614    BackPatch (t, NextQuad) ;
4615    GenQuad (GotoOp, NulSym, NulSym, 0) ;
4616    PushFor (Merge (PopFor (), NextQuad-1)) ;
4617    BackPatch (f, NextQuad) ;
4618    IF GetMode (IdSym) = LeftValue
4619    THEN
4620       (* index variable is a LeftValue, therefore we must dereference it *)
4621       tsym := MakeTemporary (idtok, RightValue) ;
4622       PutVar (tsym, GetSType (IdSym)) ;
4623       CheckPointerThroughNil (idtok, IdSym) ;
4624       doIndrX (endpostok, tsym, IdSym) ;
4625       BuildRange (InitForLoopEndRangeCheck (tsym, BySym)) ;  (* --fixme-- pass endpostok.  *)
4626       IncQuad := NextQuad ;
4627       (* we have explicitly checked using the above and also
4628          this addition can legitimately overflow if a cardinal type
4629          is counting down.  The above test will generate a more
4630          precise error message, so we suppress overflow detection
4631          here.  *)
4632       GenQuadO (bytok, AddOp, tsym, tsym, BySym, FALSE) ;
4633       CheckPointerThroughNil (idtok, IdSym) ;
4634       GenQuadO (idtok, XIndrOp, IdSym, GetSType (IdSym), tsym, FALSE)
4635    ELSE
4636       BuildRange (InitForLoopEndRangeCheck (IdSym, BySym)) ;
4637       IncQuad := NextQuad ;
4638       (* we have explicitly checked using the above and also
4639          this addition can legitimately overflow if a cardinal type
4640          is counting down.  The above test will generate a more
4641          precise error message, so we suppress overflow detection
4642          here.  *)
4643       GenQuadO (idtok, AddOp, IdSym, IdSym, BySym, FALSE)
4644    END ;
4645    GenQuadO (endpostok, GotoOp, NulSym, NulSym, ForQuad, FALSE) ;
4646    BackPatch (PopFor (), NextQuad) ;
4647    AddForInfo (ForQuad, NextQuad-1, IncQuad, IdSym, idtok)
4648 END BuildEndFor ;
4649
4650
4651 (*
4652    BuildCaseStart - starts the case statement.
4653                     It initializes a backpatch list on the compile
4654                     time stack, the list is used to contain all
4655                     case break points. The list is later backpatched
4656                     and contains all positions of the case statement
4657                     which jump to the end of the case statement.
4658                     The stack also contains room for a boolean
4659                     expression, this is needed to allow , operator
4660                     in the CaseField alternatives.
4661
4662                     The Stack is expected to contain:
4663
4664
4665                     Entry                   Exit
4666                     =====                   ====
4667
4668                                                            <- Ptr
4669                                             +------------+
4670                                             | 0    | 0   |
4671                                             |------------|
4672                                             | 0    | 0   |
4673                     +-------------+         |------------|
4674                     | Expr |      |         | Expr |     |
4675                     |-------------|         |------------|
4676 *)
4677
4678 PROCEDURE BuildCaseStart ;
4679 BEGIN
4680    BuildRange (InitCaseBounds (PushCase (NulSym, NulSym, OperandT (1)))) ;
4681    PushBool (0, 0) ;  (* BackPatch list initialized *)
4682    PushBool (0, 0)    (* Room for a boolean expression *)
4683 END BuildCaseStart ;
4684
4685
4686 (*
4687    BuildCaseStartStatementSequence - starts the statement sequence
4688                                      inside a case clause.
4689                                      BackPatches the true exit to the
4690                                      NextQuad.
4691                                      The Stack:
4692
4693                                      Entry             Exit
4694
4695                               Ptr ->                                  <- Ptr
4696                                      +-----------+     +------------+
4697                                      | t   | f   |     | 0   | f    |
4698                                      |-----------|     |------------|
4699 *)
4700
4701 PROCEDURE BuildCaseStartStatementSequence ;
4702 VAR
4703    t, f: CARDINAL ;
4704 BEGIN
4705    PopBool (t, f) ;
4706    BackPatch (t, NextQuad) ;
4707    PushBool (0, f)
4708 END BuildCaseStartStatementSequence ;
4709
4710
4711 (*
4712    BuildCaseEndStatementSequence - ends the statement sequence
4713                                    inside a case clause.
4714                                    BackPatches the false exit f1 to the
4715                                    NextQuad.
4716                                    Asserts that t1 and f2 is 0
4717                                    Pushes t2+q and 0
4718
4719                                    Quadruples:
4720
4721                                    q  GotoOp  _  _  0
4722
4723                                    The Stack:
4724
4725                                    Entry             Exit
4726
4727                             Ptr ->                                  <- Ptr
4728                                    +-----------+     +------------+
4729                                    | t1  | f1  |     | 0    | 0   |
4730                                    |-----------|     |------------|
4731                                    | t2  | f2  |     | t2+q | 0   |
4732                                    |-----------|     |------------|
4733 *)
4734
4735 PROCEDURE BuildCaseEndStatementSequence ;
4736 VAR
4737    t1, f1,
4738    t2, f2: CARDINAL ;
4739 BEGIN
4740    GenQuad (GotoOp, NulSym, NulSym, 0) ;
4741    PopBool (t1, f1) ;
4742    PopBool (t2, f2) ;          (* t2 contains the break list for the case *)
4743    BackPatch (f1, NextQuad) ;  (* f1 no longer needed *)
4744    Assert (t1=0) ;
4745    Assert (f2=0) ;
4746    PushBool (Merge (t2, NextQuad-1), 0) ;  (* NextQuad-1 = Goto Quad *)
4747    PushBool (0, 0)             (* Room for boolean expression *)
4748 END BuildCaseEndStatementSequence ;
4749
4750
4751 (*
4752    BuildCaseRange - builds the range testing quaruples for
4753                     a case clause.
4754
4755                     IF (e1>=ce1) AND (e1<=ce2)
4756                     THEN
4757
4758                     ELS..
4759
4760                     The Stack:
4761
4762                     Entry             Exit
4763
4764              Ptr ->
4765                     +-----------+
4766                     | ce2       |                   <- Ptr
4767                     |-----------|     +-----------+
4768                     | ce1       |     | t   | f   |
4769                     |-----------|     |-----------|
4770                     | t1  | f1  |     | t1  | f1  |
4771                     |-----------|     |-----------|
4772                     | t2  | f2  |     | t2  | f2  |
4773                     |-----------|     |-----------|
4774                     | e1        |     | e1        |
4775                     |-----------|     |-----------|
4776 *)
4777
4778 PROCEDURE BuildCaseRange ;
4779 VAR
4780    ce1, ce2,
4781    combinedtok,
4782    ce1tok,
4783    ce2tok,
4784    e1tok,
4785    e1,
4786    t2, f2,
4787    t1, f1  : CARDINAL ;
4788 BEGIN
4789    PopTtok (ce2, ce2tok) ;
4790    PopTtok (ce1, ce1tok) ;
4791    combinedtok := MakeVirtualTok (ce2tok, ce2tok, ce1tok) ;
4792    AddRange (ce1, ce2, combinedtok) ;
4793    PopBool (t1, f1) ;
4794    PopBool (t2, f2) ;
4795    PopTtok (e1, e1tok) ;
4796    PushTtok (e1, e1tok) ;  (* leave e1 on bottom of stack when exit procedure *)
4797    PushBool (t2, f2) ;
4798    PushBool (t1, f1) ;  (* also leave t1 and f1 on the bottom of the stack *)
4799    PushTtok (e1, e1tok) ;
4800    PushT (GreaterEqualTok) ;
4801    PushTtok (ce1, ce1tok) ;
4802    BuildRelOp (combinedtok) ;
4803    PushT (AndTok) ;
4804    RecordOp ;
4805    PushTtok (e1, e1tok) ;
4806    PushT (LessEqualTok) ;
4807    PushTtok (ce2, ce2tok) ;
4808    BuildRelOp (combinedtok) ;
4809    BuildBinaryOp
4810 END BuildCaseRange ;
4811
4812
4813 (*
4814    BuildCaseEquality - builds the range testing quadruples for
4815                        a case clause.
4816
4817                        IF e1=ce1
4818                        THEN
4819
4820                        ELS..
4821
4822                        The Stack:
4823
4824                        Entry             Exit
4825
4826                 Ptr ->
4827                        +-----------+     +-----------+
4828                        | ce1       |     | t   | f   |
4829                        |-----------|     |-----------|
4830                        | t1  | f1  |     | t1  | f1  |
4831                        |-----------|     |-----------|
4832                        | t2  | f2  |     | t2  | f2  |
4833                        |-----------|     |-----------|
4834                        | e1        |     | e1        |
4835                        |-----------|     |-----------|
4836 *)
4837
4838 PROCEDURE BuildCaseEquality ;
4839 VAR
4840    ce1tok,
4841    e1tok,
4842    ce1, e1,
4843    t2, f2,
4844    t1, f1 : CARDINAL ;
4845 BEGIN
4846    PopTtok (ce1, ce1tok) ;
4847    AddRange (ce1, NulSym, ce1tok) ;
4848    PopBool (t1, f1) ;
4849    PopBool (t2, f2) ;
4850    PopTtok (e1, e1tok) ;
4851    PushTtok (e1, e1tok) ;   (* leave e1 on bottom of stack when exit procedure *)
4852    PushBool (t2, f2) ;      (* also leave t2 and f2 on the bottom of the stack *)
4853    PushBool (t1, f1) ;
4854    PushTtok (e1, e1tok) ;
4855    PushT (EqualTok) ;
4856    PushTtok (ce1, ce1tok) ;
4857    BuildRelOp (ce1tok)
4858 END BuildCaseEquality ;
4859
4860
4861 (*
4862    BuildCaseList - merges two case tests into one
4863
4864                    The Stack:
4865
4866                    Entry             Exit
4867
4868             Ptr ->
4869                    +-----------+
4870                    | t2  | f2  |
4871                    |-----------|     +-------------+
4872                    | t1  | f1  |     | t1+t2| f1+f2|
4873                    |-----------|     |-------------|
4874 *)
4875
4876 PROCEDURE BuildCaseList ;
4877 VAR
4878    t2, f2,
4879    t1, f1: CARDINAL ;
4880 BEGIN
4881    PopBool (t2, f2) ;
4882    PopBool (t1, f1) ;
4883    PushBool (Merge (t1, t2), Merge (f1, f2))
4884 END BuildCaseList ;
4885
4886
4887 (*
4888    BuildCaseOr - builds the , in the case clause.
4889
4890                  The Stack:
4891
4892                  Entry             Exit
4893
4894           Ptr ->                                  <- Ptr
4895                  +-----------+     +------------+
4896                  | t   | f   |     | t    | 0   |
4897                  |-----------|     |------------|
4898 *)
4899
4900 PROCEDURE BuildCaseOr ;
4901 VAR
4902    t, f: CARDINAL ;
4903 BEGIN
4904    PopBool (t, f) ;
4905    BackPatch (f, NextQuad) ;
4906    PushBool (t, 0)
4907 END BuildCaseOr ;
4908
4909
4910 (*
4911    BuildCaseElse - builds the else of case clause.
4912
4913                   The Stack:
4914
4915                   Entry             Exit
4916
4917            Ptr ->                                  <- Ptr
4918                   +-----------+     +------------+
4919                   | t   | f   |     | t    | 0   |
4920                   |-----------|     |------------|
4921 *)
4922
4923 PROCEDURE BuildCaseElse ;
4924 VAR
4925    t, f: CARDINAL ;
4926 BEGIN
4927    PopBool (t, f) ;
4928    BackPatch (f, NextQuad) ;
4929    PushBool (t, 0)
4930 END BuildCaseElse ;
4931
4932
4933 (*
4934    BuildCaseEnd - builds the end of case clause.
4935
4936                   The Stack:
4937
4938                   Entry             Exit
4939
4940            Ptr ->
4941                   +-----------+
4942                   | t1  | f1  |
4943                   |-----------|
4944                   | t2  | f2  |
4945                   |-----------|
4946                   | e1        |
4947                   |-----------|     Empty
4948 *)
4949
4950 PROCEDURE BuildCaseEnd ;
4951 VAR
4952    e1,
4953    t, f: CARDINAL ;
4954 BEGIN
4955    PopBool (t, f) ;
4956    BackPatch (f, NextQuad) ;
4957    BackPatch (t, NextQuad) ;
4958    PopBool (t, f) ;
4959    BackPatch (f, NextQuad) ;
4960    BackPatch (t, NextQuad) ;
4961    PopT (e1) ;
4962    PopCase
4963 END BuildCaseEnd ;
4964
4965
4966 (*
4967    BuildCaseCheck - builds the case checking code to ensure that
4968                     the program does not need an else clause at runtime.
4969                     The stack is unaltered.
4970 *)
4971
4972 PROCEDURE BuildCaseCheck ;
4973 BEGIN
4974    BuildError (InitNoElseRangeCheck ())
4975 END BuildCaseCheck ;
4976
4977
4978 (*
4979    BuildNulParam - Builds a nul parameter on the stack.
4980                    The Stack:
4981
4982                    Entry             Exit
4983
4984                                                     <- Ptr
4985                    Empty             +------------+
4986                                      | 0          |
4987                                      |------------|
4988 *)
4989
4990 PROCEDURE BuildNulParam ;
4991 BEGIN
4992    PushT (0)
4993 END BuildNulParam ;
4994
4995
4996 (*
4997    BuildSizeCheckStart - switches off all quadruple generation if the function SIZE or HIGH
4998                          is being "called".  This should be done as SIZE only requires the
4999                          actual type of the expression, not its value.  Consider the problem of
5000                          SIZE(UninitializedPointer^) which is quite legal and it must
5001                          also be safe!
5002                          ISO Modula-2 also allows HIGH(a[0]) for a two dimensional array
5003                          and there is no need to compute a[0], we just need to follow the
5004                          type and count dimensions.  However if SIZE(a) or HIGH(a) occurs
5005                          and, a, is an unbounded array then we turn on quadruple generation.
5006
5007                          The Stack is expected to contain:
5008
5009
5010                          Entry                       Exit
5011                          =====                       ====
5012
5013                  Ptr ->                                                       <- Ptr
5014                         +----------------------+     +----------------------+
5015                         | ProcSym | Type | tok |     | ProcSym | Type | tok |
5016                         |----------------------|     |----------------------|
5017 *)
5018
5019 PROCEDURE BuildSizeCheckStart ;
5020 VAR
5021    ProcSym, Type, tok: CARDINAL ;
5022 BEGIN
5023    PopTFtok (ProcSym, Type, tok) ;
5024    IF (ProcSym=Size) OR (ProcSym=TSize) OR (ProcSym=TBitSize)
5025    THEN
5026       QuadrupleGeneration := FALSE ;
5027       BuildingSize := TRUE
5028    ELSIF ProcSym=High
5029    THEN
5030       QuadrupleGeneration := FALSE ;
5031       BuildingHigh := TRUE
5032    END ;
5033    PushTFtok (ProcSym, Type, tok)
5034 END BuildSizeCheckStart ;
5035
5036
5037 (*
5038    BuildSizeCheckEnd - checks to see whether the function "called" was in fact SIZE.
5039                        If so then we restore quadruple generation.
5040 *)
5041
5042 PROCEDURE BuildSizeCheckEnd (ProcSym: CARDINAL) ;
5043 BEGIN
5044    IF (ProcSym=Size) OR (ProcSym=TSize) OR (ProcSym=TBitSize)
5045    THEN
5046       QuadrupleGeneration := TRUE ;
5047       BuildingSize := FALSE
5048    ELSIF ProcSym=High
5049    THEN
5050       QuadrupleGeneration := TRUE ;
5051       BuildingHigh := FALSE
5052    END ;
5053 END BuildSizeCheckEnd ;
5054
5055
5056 (*
5057    BuildProcedureCall - builds a procedure call.
5058                         Although this procedure does not directly
5059                         destroy the procedure parameters, it calls
5060                         routine which will manipulate the stack and
5061                         so the entry and exit states of the stack are shown.
5062
5063                         The Stack:
5064
5065
5066                         Entry                      Exit
5067
5068                  Ptr ->
5069                         +----------------+
5070                         | NoOfParam      |
5071                         |----------------|
5072                         | Param 1        |
5073                         |----------------|
5074                         | Param 2        |
5075                         |----------------|
5076                         .                .
5077                         .                .
5078                         .                .
5079                         |----------------|
5080                         | Param #        |
5081                         |----------------|
5082                         | ProcSym | Type |         Empty
5083                         |----------------|
5084 *)
5085
5086 PROCEDURE BuildProcedureCall (tokno: CARDINAL) ;
5087 VAR
5088    NoOfParam,
5089    ProcSym  : CARDINAL ;
5090 BEGIN
5091    PopT(NoOfParam) ;
5092    ProcSym := OperandT (NoOfParam+1) ;
5093    PushT (NoOfParam) ;  (* Compile time stack restored to entry state *)
5094    IF IsPseudoBaseProcedure (ProcSym) OR IsPseudoSystemProcedure (ProcSym)
5095    THEN
5096       DisplayStack ;
5097       ManipulatePseudoCallParameters ;
5098       DisplayStack ;
5099       BuildPseudoProcedureCall (tokno) ;
5100       DisplayStack
5101    ELSIF IsUnknown (ProcSym)
5102    THEN
5103       MetaError1 ('{%1Ua} is not recognised as a procedure, check declaration or import', ProcSym) ;
5104       PopN (NoOfParam + 2)
5105    ELSE
5106       DisplayStack ;
5107       BuildRealProcedureCall (tokno) ;
5108       DisplayStack ;
5109    END
5110 END BuildProcedureCall ;
5111
5112
5113 (*
5114    BuildRealProcedureCall - builds a real procedure call.
5115                             The Stack:
5116
5117
5118                             Entry                      Exit
5119
5120                      Ptr ->
5121                             +----------------+
5122                             | NoOfParam      |
5123                             |----------------|
5124                             | Param 1        |
5125                             |----------------|
5126                             | Param 2        |
5127                             |----------------|
5128                             .                .
5129                             .                .
5130                             .                .
5131                             |----------------|
5132                             | Param #        |
5133                             |----------------|
5134                             | ProcSym | Type |         Empty
5135                             |----------------|
5136 *)
5137
5138 PROCEDURE BuildRealProcedureCall (tokno: CARDINAL) ;
5139 VAR
5140    NoOfParam: CARDINAL ;
5141    ProcSym  : CARDINAL ;
5142 BEGIN
5143    PopT (NoOfParam) ;
5144    PushT (NoOfParam) ;
5145    ProcSym := OperandT (NoOfParam+2) ;
5146    ProcSym := SkipConst (ProcSym) ;
5147    (* tokno := OperandTtok (NoOfParam+2) ; *)   (* --checkme-- *)
5148    IF IsVar (ProcSym)
5149    THEN
5150       (* Procedure Variable ? *)
5151       ProcSym := SkipType (OperandF (NoOfParam+2))
5152    END ;
5153    IF IsDefImp (GetScope (ProcSym)) AND IsDefinitionForC (GetScope (ProcSym))
5154    THEN
5155       BuildRealFuncProcCall (tokno, FALSE, TRUE, FALSE)
5156    ELSE
5157       BuildRealFuncProcCall (tokno, FALSE, FALSE, FALSE)
5158    END
5159 END BuildRealProcedureCall ;
5160
5161
5162 (*
5163    BuildRealFuncProcCall - builds a real procedure or function call.
5164                            The Stack:
5165
5166
5167                             Entry                      Exit
5168
5169                      Ptr ->
5170                             +----------------+
5171                             | NoOfParam      |
5172                             |----------------|
5173                             | Param 1        |
5174                             |----------------|
5175                             | Param 2        |
5176                             |----------------|
5177                             .                .
5178                             .                .
5179                             .                .
5180                             |----------------|
5181                             | Param #        |
5182                             |----------------|
5183                             | ProcSym | Type |         Empty
5184                             |----------------|
5185 *)
5186
5187 PROCEDURE BuildRealFuncProcCall (tokno: CARDINAL; IsFunc, IsForC, ConstExpr: BOOLEAN) ;
5188 VAR
5189    AllocateProc,
5190    DeallocateProc,
5191    ForcedFunc,
5192    ParamConstant : BOOLEAN ;
5193    trash,
5194    resulttok,
5195    paramtok,
5196    proctok,
5197    NoOfParameters,
5198    i, pi,
5199    ParamType,
5200    Param1,     (* Used to remember first param for allocate/deallocate.  *)
5201    ReturnVar,
5202    ProcSym,
5203    Proc          : CARDINAL ;
5204 BEGIN
5205    Param1 := NulSym ;
5206    ParamType := NulSym ;
5207    CheckProcedureParameters (IsForC) ;
5208    PopT (NoOfParameters) ;
5209    PushT (NoOfParameters) ;  (* Restore stack to original state.  *)
5210    ProcSym := OperandT (NoOfParameters+2) ;
5211    proctok := tokno ;  (* OperandTtok (NoOfParameters+2) ;  *)
5212    IF proctok = UnknownTokenNo
5213    THEN
5214       proctok := GetTokenNo ()
5215    END ;
5216    paramtok := proctok ;
5217    ProcSym := SkipConst (ProcSym) ;
5218    ForcedFunc := FALSE ;
5219    AllocateProc := FALSE ;
5220    DeallocateProc := FALSE ;
5221    IF IsVar (ProcSym)
5222    THEN
5223       (* Procedure Variable ? *)
5224       Proc := SkipType (OperandF (NoOfParameters+2)) ;
5225       ParamConstant := FALSE
5226    ELSE
5227       Proc := ProcSym ;
5228       ParamConstant := TRUE ;
5229       AllocateProc := GetSymName (Proc) = MakeKey('ALLOCATE') ;
5230       DeallocateProc := GetSymName (Proc) = MakeKey('DEALLOCATE')
5231    END ;
5232    IF IsFunc
5233    THEN
5234       IF GetSType (Proc) = NulSym
5235       THEN
5236          MetaErrors1 ('procedure {%1a} cannot be used as a function',
5237                       'procedure {%1Da} does not have a return type',
5238                       Proc)
5239       END
5240    ELSE
5241       (* is being called as a procedure *)
5242       IF GetSType (Proc) # NulSym
5243       THEN
5244          (* however it was declared as a procedure function *)
5245          IF NOT IsReturnOptional (Proc)
5246          THEN
5247             MetaErrors1 ('function {%1a} is being called but its return value is ignored',
5248                          'function {%1Da} return a type {%1ta:of {%1ta}}',
5249                          Proc)
5250          END ;
5251          IsFunc := TRUE ;
5252          ForcedFunc := TRUE
5253       END
5254    END ;
5255    IF AllocateProc OR DeallocateProc
5256    THEN
5257       Param1 := OperandT (NoOfParameters+1)   (* Remember this before manipulating.  *)
5258    END ;
5259    ManipulateParameters (IsForC) ;
5260    CheckParameterOrdinals ;
5261    PopT(NoOfParameters) ;
5262    IF IsFunc
5263    THEN
5264       GenQuad (ParamOp, 0, Proc, ProcSym)  (* Space for return value *)
5265    END ;
5266    IF (NoOfParameters+1=NoOfParam(Proc)) AND UsesOptArg(Proc)
5267    THEN
5268       GenQuad (OptParamOp, NoOfParam(Proc), Proc, Proc)
5269    END ;
5270    i := NoOfParameters ;
5271    pi := 1 ;     (* stack index referencing stacked parameter, i *)
5272    WHILE i>0 DO
5273       paramtok := OperandTtok (pi) ;
5274       IF (AllocateProc OR DeallocateProc) AND (i = 1) AND (Param1 # NulSym)
5275       THEN
5276          ParamType := GetItemPointedTo (Param1) ;
5277          IF ParamType = NulSym
5278          THEN
5279             GenQuadO (paramtok, ParamOp, i, Proc, OperandT (pi), TRUE)
5280          ELSE
5281             IF AllocateProc
5282             THEN
5283                trash := MakeTemporary (paramtok, RightValue) ;
5284                PutVar (trash, ParamType) ;
5285                PutVarHeap (trash, TRUE)
5286             ELSE
5287                Assert (DeallocateProc) ;
5288                trash := Nil
5289             END ;
5290             GenQuadOTrash (paramtok, ParamOp, i, Proc, OperandT (pi), TRUE, trash)
5291          END
5292       ELSE
5293          GenQuadO (paramtok, ParamOp, i, Proc, OperandT (pi), TRUE)
5294       END ;
5295       IF NOT IsConst (OperandT (pi))
5296       THEN
5297          ParamConstant := FALSE
5298       END ;
5299       DEC (i) ;
5300       INC (pi)
5301    END ;
5302    GenQuadO (proctok, CallOp, NulSym, NulSym, ProcSym, TRUE) ;
5303    PopN (NoOfParameters+1) ;  (* Destroy arguments and procedure call *)
5304    IF IsFunc
5305    THEN
5306       (* ReturnVar has the type of the procedure.  *)
5307       resulttok := MakeVirtualTok (proctok, proctok, paramtok) ;
5308       IF ConstExpr AND (NOT IsProcedureBuiltinAvailable (Proc))
5309       THEN
5310          MetaError1('{%1d} {%1ad} cannot be used in a constant expression', Proc) ;
5311          ParamConstant := FALSE
5312       END ;
5313       ReturnVar := MakeTemporary (resulttok, AreConstant (ParamConstant AND ConstExpr)) ;
5314       PutVar (ReturnVar, GetSType (Proc)) ;
5315       GenQuadO (resulttok, FunctValueOp, ReturnVar, NulSym, Proc, TRUE) ;
5316       IF NOT ForcedFunc
5317       THEN
5318          PushTFtok (ReturnVar, GetSType (Proc), resulttok)
5319       END
5320    END
5321 END BuildRealFuncProcCall ;
5322
5323
5324 (*
5325    CheckProcedureParameters - Checks the parameters which are being passed to
5326                               procedure ProcSym.
5327
5328                               The Stack:
5329
5330
5331                               Entry                      Exit
5332
5333                        Ptr ->                                               <- Ptr
5334                               +----------------+         +----------------+
5335                               | NoOfParam      |         | NoOfParam      |
5336                               |----------------|         |----------------|
5337                               | Param 1        |         | Param 1        |
5338                               |----------------|         |----------------|
5339                               | Param 2        |         | Param 2        |
5340                               |----------------|         |----------------|
5341                               .                .         .                .
5342                               .                .         .                .
5343                               .                .         .                .
5344                               |----------------|         |----------------|
5345                               | Param #        |         | Param #        |
5346                               |----------------|         |----------------|
5347                               | ProcSym | Type |         | ProcSym | Type |
5348                               |----------------|         |----------------|
5349
5350 *)
5351
5352 PROCEDURE CheckProcedureParameters (IsForC: BOOLEAN) ;
5353 VAR
5354    proctok,
5355    paramtok    : CARDINAL ;
5356    n1, n2      : Name ;
5357    Dim,
5358    Actual,
5359    FormalI,
5360    ParamTotal,
5361    pi,
5362    Proc,
5363    ProcSym,
5364    i           : CARDINAL ;
5365    s           : String ;
5366 BEGIN
5367    PopT(ParamTotal) ;
5368    PushT(ParamTotal) ;  (* Restore stack to origional state *)
5369    ProcSym := OperandT(ParamTotal+1+1) ;
5370    proctok := OperandTtok(ParamTotal+1+1) ;
5371    IF IsVar(ProcSym) AND IsProcType(GetDType(ProcSym))
5372    THEN
5373       (* Procedure Variable ? *)
5374       Proc := SkipType(OperandF(ParamTotal+1+1))
5375    ELSE
5376       Proc := SkipConst(ProcSym)
5377    END ;
5378    IF NOT (IsProcedure(Proc) OR IsProcType(Proc))
5379    THEN
5380       IF IsUnknown(Proc)
5381       THEN
5382          MetaError1('{%1Ua} is not recognised as a procedure, check declaration or import', Proc)
5383       ELSE
5384          MetaErrors1('{%1a} is not recognised as a procedure, check declaration or import',
5385                      '{%1Ua} is not recognised as a procedure, check declaration or import',
5386                      Proc)
5387       END
5388    END ;
5389    IF CompilerDebugging
5390    THEN
5391       n1 := GetSymName(Proc) ;
5392       printf1('  %a ( ', n1)
5393    END ;
5394    IF DebugTokPos
5395    THEN
5396       s := InitString ('procedure') ;
5397       WarnStringAt (s, proctok)
5398    END ;
5399
5400    i := 1 ;
5401    pi := ParamTotal+1 ;   (* stack index referencing stacked parameter, i *)
5402    WHILE i<=ParamTotal DO
5403       IF i<=NoOfParam(Proc)
5404       THEN
5405          FormalI := GetParam(Proc, i) ;
5406          IF CompilerDebugging
5407          THEN
5408             n1 := GetSymName(FormalI) ;
5409             n2 := GetSymName(GetSType(FormalI)) ;
5410             printf2('%a: %a', n1, n2)
5411          END ;
5412          Actual := OperandT(pi) ;
5413          Dim := OperandD(pi) ;
5414          paramtok := OperandTtok(pi) ;
5415          IF DebugTokPos
5416          THEN
5417             s := InitString ('actual') ;
5418             WarnStringAt (s, paramtok)
5419          END ;
5420
5421          BuildRange (InitTypesParameterCheck (paramtok, Proc, i, FormalI, Actual)) ;
5422          IF IsConst(Actual)
5423          THEN
5424             IF IsVarParam(Proc, i)
5425             THEN
5426                FailParameter (paramtok,
5427                               'trying to pass a constant to a VAR parameter',
5428                               Actual, FormalI, Proc, i)
5429             ELSIF IsConstString (Actual)
5430             THEN
5431                IF (GetStringLength (Actual) = 0)   (* if = 0 then it maybe unknown at this time *)
5432                THEN
5433                   (* dont check this yet *)
5434                ELSIF IsArray(GetDType(FormalI)) AND (GetSType(GetDType(FormalI))=Char)
5435                THEN
5436                   (* allow string literals to be passed to ARRAY [0..n] OF CHAR *)
5437                ELSIF (GetStringLength(Actual) = 1)   (* if = 1 then it maybe treated as a char *)
5438                THEN
5439                   CheckParameter (paramtok, Actual, Dim, FormalI, Proc, i, NIL)
5440                ELSIF NOT IsUnboundedParam(Proc, i)
5441                THEN
5442                   IF IsForC AND (GetSType(FormalI)=Address)
5443                   THEN
5444                      FailParameter (paramtok,
5445                                     'a string constant can either be passed to an ADDRESS parameter or an ARRAY OF CHAR',
5446                                     Actual, FormalI, Proc, i)
5447                   ELSE
5448                      FailParameter (paramtok,
5449                                     'cannot pass a string constant to a non unbounded array parameter',
5450                                     Actual, FormalI, Proc, i)
5451                   END
5452                END
5453             END
5454          ELSE
5455             CheckParameter (paramtok, Actual, Dim, FormalI, Proc, i, NIL)
5456          END
5457       ELSE
5458          IF IsForC AND UsesVarArgs(Proc)
5459          THEN
5460             (* these are varargs, therefore we don't check them *)
5461             i := ParamTotal
5462          ELSE
5463             MetaErrorT2 (proctok, 'too many parameters, {%2n} passed to {%1a} ', Proc, i)
5464          END
5465       END ;
5466       INC(i) ;
5467       DEC(pi) ;
5468       IF CompilerDebugging
5469       THEN
5470          IF i<=ParamTotal
5471          THEN
5472             printf0('; ')
5473          ELSE
5474             printf0(' ) ; \n')
5475          END
5476       END
5477    END
5478 END CheckProcedureParameters ;
5479
5480
5481 (*
5482    CheckProcTypeAndProcedure - checks the ProcType with the call.
5483 *)
5484
5485 PROCEDURE CheckProcTypeAndProcedure (tokno: CARDINAL; ProcType: CARDINAL; call: CARDINAL) ;
5486 VAR
5487    n1, n2          : Name ;
5488    i, n, t         : CARDINAL ;
5489    CheckedProcedure: CARDINAL ;
5490    e               : Error ;
5491 BEGIN
5492    n := NoOfParam(ProcType) ;
5493    IF IsVar(call) OR IsTemporary(call) OR IsParameter(call)
5494    THEN
5495       CheckedProcedure := GetDType(call)
5496    ELSE
5497       CheckedProcedure := call
5498    END ;
5499    IF n#NoOfParam(CheckedProcedure)
5500    THEN
5501       e := NewError(GetDeclaredMod(ProcType)) ;
5502       n1 := GetSymName(call) ;
5503       n2 := GetSymName(ProcType) ;
5504       ErrorFormat2(e, 'procedure (%a) is a parameter being passed as variable (%a) but they are declared with different number of parameters',
5505                    n1, n2) ;
5506       e := ChainError(GetDeclaredMod(call), e) ;
5507       t := NoOfParam(CheckedProcedure) ;
5508       IF n<2
5509       THEN
5510          ErrorFormat3(e, 'procedure (%a) is being called incorrectly with (%d) parameter, declared with (%d)',
5511                       n1, n, t)
5512       ELSE
5513          ErrorFormat3(e, 'procedure (%a) is being called incorrectly with (%d) parameters, declared with (%d)',
5514                       n1, n, t)
5515       END
5516    ELSE
5517       i := 1 ;
5518       WHILE i<=n DO
5519          IF IsVarParam (ProcType, i) # IsVarParam (CheckedProcedure, i)
5520          THEN
5521             MetaError3 ('parameter {%3n} in {%1dD} causes a mismatch it was declared as a {%2d}', ProcType, GetNth (ProcType, i), i) ;
5522             MetaError3 ('parameter {%3n} in {%1dD} causes a mismatch it was declared as a {%2d}', call, GetNth (call, i), i)
5523          END ;
5524          BuildRange (InitTypesParameterCheck (tokno, CheckedProcedure, i,
5525                                               GetParam (CheckedProcedure, i),
5526                                               GetParam (ProcType, i))) ;
5527          (* CheckParameter(tokpos, GetParam(CheckedProcedure, i), 0, GetParam(ProcType, i), call, i, TypeList) ; *)
5528          INC(i)
5529       END
5530    END
5531 END CheckProcTypeAndProcedure ;
5532
5533
5534 (*
5535    IsReallyPointer - returns TRUE is sym is a pointer, address or a type declared
5536                      as a pointer or address.
5537 *)
5538
5539 PROCEDURE IsReallyPointer (Sym: CARDINAL) : BOOLEAN ;
5540 BEGIN
5541    IF IsVar(Sym)
5542    THEN
5543       Sym := GetSType(Sym)
5544    END ;
5545    Sym := SkipType(Sym) ;
5546    RETURN( IsPointer(Sym) OR (Sym=Address) )
5547 END IsReallyPointer ;
5548
5549
5550 (*
5551    LegalUnboundedParam - returns TRUE if the parameter, Actual, can legitimately be
5552                          passed to ProcSym, i, the, Formal, parameter.
5553 *)
5554
5555 PROCEDURE LegalUnboundedParam (tokpos: CARDINAL; ProcSym, i, ActualType, Actual, Dimension, Formal: CARDINAL) : BOOLEAN ;
5556 VAR
5557    FormalType: CARDINAL ;
5558    n, m      : CARDINAL ;
5559 BEGIN
5560    ActualType := SkipType(ActualType) ;
5561    FormalType := GetDType(Formal) ;
5562    FormalType := GetSType(FormalType) ;   (* type of the unbounded ARRAY *)
5563    IF IsArray(ActualType)
5564    THEN
5565       m := GetDimension(Formal) ;
5566       n := 0 ;
5567       WHILE IsArray(ActualType) DO
5568          INC(n) ;
5569          ActualType := GetDType(ActualType) ;
5570          IF (m=n) AND (ActualType=FormalType)
5571          THEN
5572             RETURN( TRUE )
5573          END
5574       END ;
5575       IF n=m
5576       THEN
5577          (* now we fall though and test ActualType against FormalType *)
5578       ELSE
5579          IF IsGenericSystemType(FormalType)
5580          THEN
5581             RETURN( TRUE )
5582          ELSE
5583             FailParameter(tokpos,
5584                           'attempting to pass an array with the incorrect number dimenisons to an unbounded formal parameter of different dimensions',
5585                           Actual, Formal, ProcSym, i) ;
5586             RETURN( FALSE )
5587          END
5588       END
5589    ELSIF IsUnbounded(ActualType)
5590    THEN
5591       IF (Dimension=0) AND (GetDimension(Formal)=GetDimension(Actual))
5592       THEN
5593          (* now we fall though and test ActualType against FormalType *)
5594          ActualType := GetSType(ActualType)
5595       ELSE
5596          IF IsGenericSystemType(FormalType)
5597          THEN
5598             RETURN( TRUE )
5599          ELSE
5600             IF GetDimension(Actual)-Dimension = GetDimension(Formal)
5601             THEN
5602                ActualType := GetSType(ActualType)
5603             ELSE
5604                FailParameter(tokpos,
5605                              'attempting to pass an unbounded array with the incorrect number dimenisons to an unbounded formal parameter of different dimensions',
5606                              Actual, Formal, ProcSym, i) ;
5607                RETURN( FALSE )
5608             END
5609          END
5610       END
5611    END ;
5612    IF IsGenericSystemType (FormalType) OR
5613       IsGenericSystemType (ActualType) OR
5614       IsAssignmentCompatible (FormalType, ActualType)
5615    THEN
5616       (* we think it is legal, but we ask post pass 3 to check as
5617          not all types are known at this point *)
5618       RETURN( TRUE )
5619    ELSE
5620       FailParameter(tokpos,
5621                     'identifier with an incompatible type is being passed to this procedure',
5622                     Actual, Formal, ProcSym, i) ;
5623       RETURN( FALSE )
5624    END
5625 END LegalUnboundedParam ;
5626
5627
5628 (*
5629    CheckParameter - checks that types ActualType and FormalType are compatible for parameter
5630                     passing. ProcSym is the procedure and i is the parameter number.
5631
5632                     We obey the following rules:
5633
5634                     (1)  we allow WORD, BYTE, LOC to be compitable with any like sized
5635                          type.
5636                     (2)  we allow ADDRESS to be compatible with any pointer type.
5637                     (3)  we relax INTEGER and CARDINAL checking for Temporary variables.
5638
5639                     Note that type sizes are checked during the code generation pass.
5640 *)
5641
5642 PROCEDURE CheckParameter (tokpos: CARDINAL;
5643                           Actual, Dimension, Formal, ProcSym: CARDINAL;
5644                           i: CARDINAL; TypeList: List) ;
5645 VAR
5646    NewList            : BOOLEAN ;
5647    ActualType, FormalType: CARDINAL ;
5648 BEGIN
5649    FormalType := GetDType(Formal) ;
5650    IF IsConstString(Actual) AND (GetStringLength(Actual) = 1)   (* if = 1 then it maybe treated as a char *)
5651    THEN
5652       ActualType := Char
5653    ELSIF Actual=Boolean
5654    THEN
5655       ActualType := Actual
5656    ELSE
5657       ActualType := GetDType(Actual)
5658    END ;
5659    IF TypeList=NIL
5660    THEN
5661       NewList := TRUE ;
5662       InitList(TypeList)
5663    ELSE
5664       NewList := FALSE
5665    END ;
5666    IF IsItemInList(TypeList, ActualType)
5667    THEN
5668       (* no need to check *)
5669       RETURN
5670    END ;
5671    IncludeItemIntoList(TypeList, ActualType) ;
5672    IF IsProcType(FormalType)
5673    THEN
5674       IF (NOT IsProcedure(Actual)) AND ((ActualType=NulSym) OR (NOT IsProcType(SkipType(ActualType))))
5675       THEN
5676          FailParameter(tokpos,
5677                        'expecting a procedure or procedure variable as a parameter',
5678                        Actual, Formal, ProcSym, i) ;
5679          RETURN
5680       END ;
5681       IF IsProcedure(Actual) AND IsProcedureNested(Actual)
5682       THEN
5683          MetaError2 ('cannot pass a nested procedure {%1Ea} seen in the {%2N} parameter as the outer scope will be unknown at runtime', Actual, i)
5684       END ;
5685       (* we can check the return type of both proc types *)
5686       IF (ActualType#NulSym) AND IsProcType(ActualType)
5687       THEN
5688          IF ((GetSType(ActualType)#NulSym) AND (GetSType(FormalType)=NulSym))
5689          THEN
5690             FailParameter(tokpos,
5691                           'the item being passed is a function whereas the formal procedure parameter is a procedure',
5692                           Actual, Formal, ProcSym, i) ;
5693             RETURN
5694          ELSIF ((GetSType(ActualType)=NulSym) AND (GetSType(FormalType)#NulSym))
5695          THEN
5696             FailParameter(tokpos,
5697                           'the item being passed is a procedure whereas the formal procedure parameter is a function',
5698                           Actual, Formal, ProcSym, i) ;
5699             RETURN
5700          ELSIF AssignmentRequiresWarning(GetSType(ActualType), GetSType(FormalType))
5701          THEN
5702             WarnParameter(tokpos,
5703                           'the return result of the procedure variable parameter may not be compatible on other targets with the return result of the item being passed',
5704                           Actual, Formal, ProcSym, i) ;
5705             RETURN
5706          ELSIF IsGenericSystemType (GetSType(FormalType)) OR
5707                IsGenericSystemType (GetSType(ActualType)) OR
5708                IsAssignmentCompatible(GetSType(ActualType), GetSType(FormalType))
5709          THEN
5710             (* pass *)
5711          ELSE
5712             FailParameter(tokpos,
5713                           'the return result of the procedure variable parameter is not compatible with the return result of the item being passed',
5714                           Actual, Formal, ProcSym, i) ;
5715             RETURN
5716          END
5717       END ;
5718       (* now to check each parameter of the proc type *)
5719       CheckProcTypeAndProcedure (tokpos, FormalType, Actual)
5720    ELSIF (ActualType#FormalType) AND (ActualType#NulSym)
5721    THEN
5722       IF IsUnknown(FormalType)
5723       THEN
5724          FailParameter(tokpos,
5725                        'procedure parameter type is undeclared',
5726                        Actual, Formal, ProcSym, i) ;
5727          RETURN
5728       END ;
5729       IF IsUnbounded(ActualType) AND (NOT IsUnboundedParam(ProcSym, i))
5730       THEN
5731          FailParameter(tokpos,
5732                        'attempting to pass an unbounded array to a NON unbounded parameter',
5733                        Actual, Formal, ProcSym, i) ;
5734          RETURN
5735       ELSIF IsUnboundedParam(ProcSym, i)
5736       THEN
5737          IF NOT LegalUnboundedParam(tokpos, ProcSym, i, ActualType, Actual, Dimension, Formal)
5738          THEN
5739             RETURN
5740          END
5741       ELSIF ActualType#FormalType
5742       THEN
5743          IF AssignmentRequiresWarning(FormalType, ActualType)
5744          THEN
5745             WarnParameter (tokpos,
5746                            'identifier being passed to this procedure may contain a possibly incompatible type when compiling for a different target',
5747                            Actual, Formal, ProcSym, i)
5748          ELSIF IsGenericSystemType (FormalType) OR
5749                IsGenericSystemType (ActualType) OR
5750                IsAssignmentCompatible (ActualType, FormalType)
5751          THEN
5752             (* so far we know it is legal, but not all types have been resolved
5753                and so this is checked later on in another pass.  *)
5754          ELSE
5755             FailParameter (tokpos,
5756                            'identifier with an incompatible type is being passed to this procedure',
5757                            Actual, Formal, ProcSym, i)
5758          END
5759       END
5760    END ;
5761    IF NewList
5762    THEN
5763       KillList(TypeList)
5764    END
5765 END CheckParameter ;
5766
5767
5768 (*
5769    DescribeType - returns a String describing a symbol, Sym, name and its type.
5770 *)
5771
5772 PROCEDURE DescribeType (Sym: CARDINAL) : String ;
5773 VAR
5774    s, s1, s2: String ;
5775    Low, High,
5776    Subrange,
5777    Subscript,
5778    Type     : CARDINAL ;
5779 BEGIN
5780    s := NIL ;
5781    IF IsConstString(Sym)
5782    THEN
5783       IF (GetStringLength(Sym) = 1)   (* if = 1 then it maybe treated as a char *)
5784       THEN
5785          s := InitString('(constant string) or {%kCHAR}')
5786       ELSE
5787          s := InitString('(constant string)')
5788       END
5789    ELSIF IsConst(Sym)
5790    THEN
5791       s := InitString('(constant)')
5792    ELSIF IsUnknown(Sym)
5793    THEN
5794       s := InitString('(unknown)')
5795    ELSE
5796       Type := GetSType(Sym) ;
5797       IF Type=NulSym
5798       THEN
5799          s := InitString('(unknown)')
5800       ELSIF IsUnbounded(Type)
5801       THEN
5802          s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(GetSType(Type))))) ;
5803          s := Sprintf1(Mark(InitString('{%%kARRAY} {%%kOF} %s')), s1)
5804       ELSIF IsArray(Type)
5805       THEN
5806          s := InitString('{%kARRAY} [') ;
5807          Subscript := GetArraySubscript(Type) ;
5808          IF Subscript#NulSym
5809          THEN
5810             Assert(IsSubscript(Subscript)) ;
5811             Subrange := GetSType(Subscript) ;
5812             IF NOT IsSubrange(Subrange)
5813             THEN
5814                MetaError3 ('error in definition of array {%1Ead} in the {%2N} subscript which has no subrange, instead type given is {%3a}',
5815                             Sym, Subscript, Subrange)
5816             END ;
5817             Assert(IsSubrange(Subrange)) ;
5818             GetSubrange(Subrange, High, Low) ;
5819             s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Low)))) ;
5820             s2 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(High)))) ;
5821             s := ConCat(s, Mark(Sprintf2(Mark(InitString('%s..%s')),
5822                                          s1, s2)))
5823          END ;
5824          s1 := Mark(DescribeType(Type)) ;
5825          s := ConCat(ConCat(s, Mark(InitString('] OF '))), s1)
5826       ELSE
5827          IF IsUnknown(Type)
5828          THEN
5829             s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Type)))) ;
5830             s := Sprintf1(Mark(InitString('%s (currently unknown, check declaration or import)')),
5831                           s1)
5832          ELSE
5833             s := InitStringCharStar(KeyToCharStar(GetSymName(Type)))
5834          END
5835       END
5836    END ;
5837    RETURN( s )
5838 END DescribeType ;
5839
5840
5841 (*
5842    FailParameter - generates an error message indicating that a parameter
5843                    declaration has failed.
5844
5845                    The parameters are:
5846
5847                    CurrentState  - string describing the current failing state.
5848                    Given         - the token that the source code provided.
5849                    Expecting     - token or identifier that was expected.
5850                    ParameterNo   - parameter number that has failed.
5851                    ProcedureSym  - procedure symbol where parameter has failed.
5852
5853                    If any parameter is Nul then it is ignored.
5854 *)
5855
5856 PROCEDURE FailParameter (tokpos       : CARDINAL;
5857                          CurrentState : ARRAY OF CHAR;
5858                          Given        : CARDINAL;
5859                          Expecting    : CARDINAL;
5860                          ProcedureSym : CARDINAL;
5861                          ParameterNo  : CARDINAL) ;
5862 VAR
5863    First,
5864    ExpectType: CARDINAL ;
5865    s, s1, s2 : String ;
5866 BEGIN
5867    MetaError2 ('parameter mismatch between the {%2N} parameter of procedure {%1Ead}',
5868                ProcedureSym, ParameterNo) ;
5869    s := InitString ('{%kPROCEDURE} {%1Eau} (') ;
5870    IF NoOfParam(ProcedureSym)>=ParameterNo
5871    THEN
5872       IF ParameterNo>1
5873       THEN
5874          s := ConCat(s, Mark(InitString('.., ')))
5875       END ;
5876       IF IsVarParam(ProcedureSym, ParameterNo)
5877       THEN
5878          s := ConCat(s, Mark(InitString('{%kVAR} ')))
5879       END ;
5880
5881       First := GetDeclaredMod(GetNthParam(ProcedureSym, ParameterNo)) ;
5882       ExpectType := GetSType(Expecting) ;
5883       IF IsUnboundedParam(ProcedureSym, ParameterNo)
5884       THEN
5885          s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Expecting)))) ;
5886          s2 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(GetSType(ExpectType))))) ;
5887          s := ConCat(s, Mark(Sprintf2(Mark(InitString('%s: {%%kARRAY} {%%kOF} %s')),
5888                                       s1, s2)))
5889       ELSE
5890          s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Expecting)))) ;
5891          s2 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(ExpectType)))) ;
5892          s := ConCat(s, Mark(Sprintf2(Mark(InitString('%s: %s')), s1, s2)))
5893       END ;
5894       IF ParameterNo<NoOfParam(ProcedureSym)
5895       THEN
5896          s := ConCat(s, Mark(InitString('; ... ')))
5897       END
5898    ELSE
5899       First := GetDeclaredMod(ProcedureSym) ;
5900       IF NoOfParam(ProcedureSym)>0
5901       THEN
5902          s := ConCat(s, Mark(InitString('..')))
5903       END
5904    END ;
5905    s := ConCat (s, Mark (InitString ('){%1Tau:% : {%1Tau}} ;'))) ;
5906    MetaErrorStringT1 (First, Dup (s), ProcedureSym) ;
5907    MetaErrorStringT1 (tokpos, s, ProcedureSym) ;
5908    MetaError1 ('item being passed is {%1EDda} {%1Dad} of type {%1Dtsd}', Given)
5909 END FailParameter ;
5910
5911
5912 (*
5913    WarnParameter - generates a warning message indicating that a parameter
5914                    use might cause problems on another target.
5915
5916                    The parameters are:
5917
5918                    CurrentState  - string describing the current failing state.
5919                    Given         - the token that the source code provided.
5920                    Expecting     - token or identifier that was expected.
5921                    ParameterNo   - parameter number that has failed.
5922                    ProcedureSym  - procedure symbol where parameter has failed.
5923
5924                    If any parameter is Nul then it is ignored.
5925 *)
5926
5927 PROCEDURE WarnParameter (tokpos       : CARDINAL;
5928                          CurrentState : ARRAY OF CHAR;
5929                          Given        : CARDINAL;
5930                          Expecting    : CARDINAL;
5931                          ProcedureSym : CARDINAL;
5932                          ParameterNo  : CARDINAL) ;
5933 VAR
5934    First,
5935    ExpectType,
5936    ReturnType: CARDINAL ;
5937    s, s1, s2 : String ;
5938 BEGIN
5939    s := InitString('{%W}') ;
5940    IF CompilingImplementationModule()
5941    THEN
5942       s := ConCat(s, Sprintf0(Mark(InitString('warning issued while compiling the implementation module\n'))))
5943    ELSIF CompilingProgramModule()
5944    THEN
5945       s := ConCat(s, Sprintf0(Mark(InitString('warning issued while compiling the program module\n'))))
5946    END ;
5947    s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(ProcedureSym)))) ;
5948    s := ConCat(s, Mark(Sprintf2(Mark(InitString('problem in parameter %d, PROCEDURE %s (')),
5949                                 ParameterNo,
5950                                 s1))) ;
5951    IF NoOfParam(ProcedureSym)>=ParameterNo
5952    THEN
5953       IF ParameterNo>1
5954       THEN
5955          s := ConCat(s, Mark(InitString('.., ')))
5956       END ;
5957       IF IsVarParam(ProcedureSym, ParameterNo)
5958       THEN
5959          s := ConCat(s, Mark(InitString('{%kVAR} ')))
5960       END ;
5961
5962       First := GetDeclaredMod(GetNthParam(ProcedureSym, ParameterNo)) ;
5963       ExpectType := GetSType(Expecting) ;
5964       IF IsUnboundedParam(ProcedureSym, ParameterNo)
5965       THEN
5966          s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Expecting)))) ;
5967          s2 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(GetSType(ExpectType))))) ;
5968          s := ConCat(s, Mark(Sprintf2(Mark(InitString('%s: {%%kARRAY} {%%kOF} %s')),
5969                                       s1, s2)))
5970       ELSE
5971          s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Expecting)))) ;
5972          s2 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(ExpectType)))) ;
5973          s := ConCat(s, Mark(Sprintf2(Mark(InitString('%s: %s')), s1, s2)))
5974       END ;
5975       IF ParameterNo<NoOfParam(ProcedureSym)
5976       THEN
5977          s := ConCat(s, Mark(InitString('; ... ')))
5978       END
5979    ELSE
5980       First := GetDeclaredMod(ProcedureSym) ;
5981       IF NoOfParam(ProcedureSym)>0
5982       THEN
5983          s := ConCat(s, Mark(InitString('..')))
5984       END
5985    END ;
5986    ReturnType := GetSType(ProcedureSym) ;
5987    IF ReturnType=NulSym
5988    THEN
5989       s := ConCat(s, Sprintf0(Mark(InitString(') ;\n'))))
5990    ELSE
5991       s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(ReturnType)))) ;
5992       s := ConCat(s, Mark(Sprintf1(Mark(InitString(') : %s ;\n')), s1)))
5993    END ;
5994    IF IsConstString(Given)
5995    THEN
5996       s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Given)))) ;
5997       s := ConCat(s, Mark(Sprintf1(Mark(InitString("item being passed is '%s'")),
5998                                    s1)))
5999    ELSIF IsTemporary(Given)
6000    THEN
6001       s := ConCat(s, Mark(InitString("item being passed has type")))
6002    ELSE
6003       s1 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Given)))) ;
6004       s := ConCat(s, Mark(Sprintf1(Mark(InitString("item being passed is '%s'")),
6005                                    s1)))
6006    END ;
6007    s1 := DescribeType(Given) ;
6008    s2 := Mark(InitString(CurrentState)) ;
6009    s := ConCat(s, Mark(Sprintf2(Mark(InitString(': %s\nparameter mismatch: %s')),
6010                                 s1, s2))) ;
6011    MetaErrorStringT0 (tokpos, Dup (s)) ;
6012    MetaErrorStringT0 (First, Dup (s))
6013 END WarnParameter ;
6014
6015
6016 (*
6017    ExpectVariable - checks to see whether, sym, is declared as a variable.
6018                     If not then it generates an error message.
6019 *)
6020
6021 (*
6022 PROCEDURE ExpectVariable (a: ARRAY OF CHAR; sym: CARDINAL) ;
6023 VAR
6024    e         : Error ;
6025    s1, s2, s3: String ;
6026 BEGIN
6027    IF NOT IsVar(sym)
6028    THEN
6029       e := NewError(GetTokenNo()) ;
6030       IF IsUnknown(sym)
6031       THEN
6032          s1 := ConCat (InitString (a),
6033                        Mark (InitString ('but was given an undeclared symbol {%E1a}'))) ;
6034
6035          ErrorString(e, Sprintf2(Mark(InitString('%s but was given an undeclared symbol %s')), s1, s2))
6036       ELSE
6037          s1 := Mark(InitString(a)) ;
6038          s2 := Mark(InitStringCharStar(KeyToCharStar(GetSymName(sym)))) ;
6039          s3 := Mark(DescribeType(sym)) ;
6040          ErrorString(e, Sprintf3(Mark(InitString('%s but was given %s: %s')),
6041                                  s1, s2, s3))
6042       END
6043    END
6044 END ExpectVariable ;
6045 *)
6046
6047
6048 (*
6049    doIndrX - perform des = *exp with a conversion if necessary.
6050 *)
6051
6052 PROCEDURE doIndrX (tok: CARDINAL;
6053                    des, exp: CARDINAL) ;
6054 VAR
6055    t: CARDINAL ;
6056 BEGIN
6057    IF GetDType(des)=GetDType(exp)
6058    THEN
6059       GenQuadOtok (tok, IndrXOp, des, GetSType (des), exp, TRUE,
6060                    tok, tok, tok)
6061    ELSE
6062       t := MakeTemporary (tok, RightValue) ;
6063       PutVar (t, GetSType (exp)) ;
6064       GenQuadOtok (tok, IndrXOp, t, GetSType (exp), exp, TRUE,
6065                    tok, tok, tok) ;
6066       GenQuadOtok (tok, BecomesOp, des, NulSym, doVal (GetSType(des), t), TRUE,
6067                    tok, UnknownTokenNo, tok)
6068    END
6069 END doIndrX ;
6070
6071
6072 (*
6073    MakeRightValue - returns a temporary which will have the RightValue of symbol, Sym.
6074                     If Sym is a right value and has type, type, then no quadruples are
6075                     generated and Sym is returned. Otherwise a new temporary is created
6076                     and an IndrX quadruple is generated.
6077 *)
6078
6079 PROCEDURE MakeRightValue (tok: CARDINAL;
6080                           Sym: CARDINAL; type: CARDINAL) : CARDINAL ;
6081 VAR
6082    t: CARDINAL ;
6083 BEGIN
6084    IF GetMode (Sym) = RightValue
6085    THEN
6086       IF GetSType(Sym) = type
6087       THEN
6088          RETURN Sym    (* already a RightValue with desired type *)
6089       ELSE
6090          (*
6091             type change or mode change, type changes are a pain, but I've
6092             left them here as it is perhaps easier to remove them later.
6093          *)
6094          t := MakeTemporary (tok, RightValue) ;
6095          PutVar (t, type) ;
6096          GenQuadOtok (tok, BecomesOp, t, NulSym, doVal (type, Sym), TRUE,
6097                       tok, tok, tok) ;
6098          RETURN t
6099       END
6100    ELSE
6101       t := MakeTemporary (tok, RightValue) ;
6102       PutVar (t, type) ;
6103       CheckPointerThroughNil (tok, Sym) ;
6104       doIndrX (tok, t, Sym) ;
6105       RETURN t
6106    END
6107 END MakeRightValue ;
6108
6109
6110 (*
6111    MakeLeftValue - returns a temporary coresponding to the LeftValue of
6112                    symbol, Sym. No quadruple is generated if Sym is already
6113                    a LeftValue and has the same type.
6114 *)
6115
6116 PROCEDURE MakeLeftValue (tok: CARDINAL;
6117                          Sym: CARDINAL; with: ModeOfAddr; type: CARDINAL) : CARDINAL ;
6118 VAR
6119    t: CARDINAL ;
6120 BEGIN
6121    IF GetMode (Sym) = LeftValue
6122    THEN
6123       IF GetSType (Sym) = type
6124       THEN
6125          RETURN Sym
6126       ELSE
6127          (*
6128             type change or mode change, type changes are a pain, but I've
6129             left them here as it is perhaps easier to remove them later
6130          *)
6131          t := MakeTemporary (tok, with) ;
6132          PutVar (t, type) ;
6133          GenQuadOtok (tok, BecomesOp, t, NulSym, Sym, TRUE,
6134                       tok, UnknownTokenNo, tok) ;
6135          RETURN t
6136       END
6137    ELSE
6138       t := MakeTemporary (tok, with) ;
6139       PutVar (t, type) ;
6140       GenQuadOtok (tok, AddrOp, t, NulSym, Sym, TRUE,
6141                    tok, UnknownTokenNo, tok) ;
6142       RETURN t
6143    END
6144 END MakeLeftValue ;
6145
6146
6147 (*
6148    ManipulatePseudoCallParameters - manipulates the parameters to a pseudo function or
6149                                     procedure. It dereferences all LeftValue parameters
6150                                     and Boolean parameters.
6151                                     The Stack:
6152
6153
6154                                     Entry                      Exit
6155
6156                              Ptr ->                            exactly the same
6157                                     +----------------+
6158                                     | NoOfParameters |
6159                                     |----------------|
6160                                     | Param 1        |
6161                                     |----------------|
6162                                     | Param 2        |
6163                                     |----------------|
6164                                     .                .
6165                                     .                .
6166                                     .                .
6167                                     |----------------|
6168                                     | Param #        |
6169                                     |----------------|
6170                                     | ProcSym | Type |
6171                                     |----------------|
6172
6173 *)
6174
6175 PROCEDURE ManipulatePseudoCallParameters ;
6176 VAR
6177    NoOfParameters,
6178    ProcSym, Proc,
6179    i, pi         : CARDINAL ;
6180    f             : BoolFrame ;
6181 BEGIN
6182    PopT(NoOfParameters) ;
6183    PushT(NoOfParameters) ;    (* restored to original state *)
6184    (* Ptr points to the ProcSym *)
6185    ProcSym := OperandT(NoOfParameters+1+1) ;
6186    IF IsVar(ProcSym)
6187    THEN
6188       InternalError ('expecting a pseudo procedure or a type')
6189    ELSE
6190       Proc := ProcSym
6191    END ;
6192    i := 1 ;
6193    pi := NoOfParameters+1 ;
6194    WHILE i<=NoOfParameters DO
6195       IF (GetMode(OperandT(pi))=LeftValue) AND
6196          (Proc#Adr) AND (Proc#Size) AND (Proc#TSize) AND (Proc#High) AND
6197          (* procedures which have first parameter as a VAR param *)
6198          (((Proc#Inc) AND (Proc#Incl) AND (Proc#Dec) AND (Proc#Excl) AND (Proc#New) AND (Proc#Dispose)) OR (i>1))
6199       THEN
6200          (* must dereference LeftValue *)
6201          f := PeepAddress(BoolStack, pi) ;
6202          f^.TrueExit := MakeRightValue (GetTokenNo(), OperandT(pi), GetSType(OperandT(pi)))
6203       END ;
6204       INC(i) ;
6205       DEC(pi)
6206    END
6207 END ManipulatePseudoCallParameters ;
6208
6209
6210 (*
6211    ManipulateParameters - manipulates the procedure parameters in
6212                           preparation for a procedure call.
6213                           Prepares Boolean, Unbounded and VAR parameters.
6214                           The Stack:
6215
6216
6217                           Entry                      Exit
6218
6219                    Ptr ->                            exactly the same
6220                           +----------------+
6221                           | NoOfParameters |
6222                           |----------------|
6223                           | Param 1        |
6224                           |----------------|
6225                           | Param 2        |
6226                           |----------------|
6227                           .                .
6228                           .                .
6229                           .                .
6230                           |----------------|
6231                           | Param #        |
6232                           |----------------|
6233                           | ProcSym | Type |
6234                           |----------------|
6235 *)
6236
6237 PROCEDURE ManipulateParameters (IsForC: BOOLEAN) ;
6238 VAR
6239    tokpos,
6240    np           : CARDINAL ;
6241    s            : String ;
6242    ArraySym,
6243    UnboundedType,
6244    ParamType,
6245    NoOfParameters,
6246    i, pi,
6247    ProcSym, rw,
6248    Proc,
6249    t            : CARDINAL ;
6250    f            : BoolFrame ;
6251 BEGIN
6252    PopT(NoOfParameters) ;
6253    ProcSym := OperandT(NoOfParameters+1) ;
6254    tokpos := OperandTtok(NoOfParameters+1) ;
6255    IF IsVar(ProcSym)
6256    THEN
6257       (* Procedure Variable ? *)
6258       Proc := SkipType(OperandF(NoOfParameters+1))
6259    ELSE
6260       Proc := SkipConst(ProcSym)
6261    END ;
6262
6263    IF IsForC AND UsesVarArgs(Proc)
6264    THEN
6265       IF NoOfParameters<NoOfParam(Proc)
6266       THEN
6267          s := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Proc)))) ;
6268          np := NoOfParam(Proc) ;
6269          ErrorStringAt2(Sprintf3(Mark(InitString('attempting to pass (%d) parameters to procedure (%s) which was declared with varargs but contains at least (%d) parameters')),
6270                                  NoOfParameters, s, np),
6271                         tokpos, GetDeclaredMod(ProcSym))
6272       END
6273    ELSIF UsesOptArg(Proc)
6274    THEN
6275       IF NOT ((NoOfParameters=NoOfParam(Proc)) OR (NoOfParameters+1=NoOfParam(Proc)))
6276       THEN
6277          s := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Proc)))) ;
6278          np := NoOfParam(Proc) ;
6279          ErrorStringAt2(Sprintf3(Mark(InitString('attempting to pass (%d) parameters to procedure (%s) which was declared with an optarg with a maximum of (%d) parameters')),
6280                                  NoOfParameters, s, np),
6281                         tokpos, GetDeclaredMod(ProcSym))
6282       END
6283    ELSIF NoOfParameters#NoOfParam(Proc)
6284    THEN
6285       s := Mark(InitStringCharStar(KeyToCharStar(GetSymName(Proc)))) ;
6286       np := NoOfParam(Proc) ;
6287       ErrorStringAt2(Sprintf3(Mark(InitString('attempting to pass (%d) parameters to procedure (%s) which was declared with (%d) parameters')),
6288                               NoOfParameters, s, np),
6289                      tokpos, GetDeclaredMod(ProcSym))
6290    END ;
6291    i := 1 ;
6292    pi := NoOfParameters ;
6293    WHILE i<=NoOfParameters DO
6294       f := PeepAddress(BoolStack, pi) ;
6295       rw := OperandMergeRW(pi) ;
6296       Assert(IsLegal(rw)) ;
6297       IF i>NoOfParam(Proc)
6298       THEN
6299          IF IsForC AND UsesVarArgs(Proc)
6300          THEN
6301             IF (GetSType(OperandT(pi))#NulSym) AND IsArray(GetDType(OperandT(pi)))
6302             THEN
6303                f^.TrueExit := MakeLeftValue(OperandTok(pi), OperandT(pi), RightValue, Address) ;
6304                MarkAsReadWrite(rw)
6305             ELSIF IsConstString (OperandT (pi))
6306             THEN
6307                f^.TrueExit := MakeLeftValue (OperandTok (pi),
6308                                              MakeConstStringCnul (OperandTok (pi), OperandT (pi)), RightValue, Address) ;
6309                MarkAsReadWrite(rw)
6310             ELSIF (GetSType(OperandT(pi))#NulSym) AND IsUnbounded(GetSType(OperandT(pi)))
6311             THEN
6312                MarkAsReadWrite(rw) ;
6313                (* pass the address field of an unbounded variable *)
6314                PushTF(Adr, Address) ;
6315                PushTFAD (f^.TrueExit, f^.FalseExit, f^.Unbounded, f^.Dimension) ;
6316                PushT(1) ;
6317                BuildAdrFunction ;
6318                PopT(f^.TrueExit)
6319             ELSIF GetMode(OperandT(pi))=LeftValue
6320             THEN
6321                MarkAsReadWrite(rw) ;
6322                (* must dereference LeftValue (even if we are passing variable as a vararg) *)
6323                t := MakeTemporary (OperandTok (pi), RightValue) ;
6324                PutVar(t, GetSType (OperandT (pi))) ;
6325                CheckPointerThroughNil (tokpos, OperandT (pi)) ;
6326                doIndrX (OperandTok(pi), t, OperandT (pi)) ;
6327                f^.TrueExit := t
6328             END
6329          ELSE
6330             MetaErrorT2 (tokpos,
6331                          'attempting to pass too many parameters to procedure {%1a}, the {%2N} parameter does not exist',
6332                          Proc, i)
6333          END
6334       ELSIF IsForC AND IsUnboundedParam(Proc, i) AND
6335             (GetSType(OperandT(pi))#NulSym) AND IsArray(GetDType(OperandT(pi)))
6336       THEN
6337          f^.TrueExit := MakeLeftValue(OperandTok(pi), OperandT(pi), RightValue, Address) ;
6338          MarkAsReadWrite(rw)
6339       ELSIF IsForC AND IsUnboundedParam(Proc, i) AND
6340             (GetSType(OperandT(pi))#NulSym) AND IsUnbounded(GetDType(OperandT(pi)))
6341       THEN
6342          MarkAsReadWrite(rw) ;
6343          (* pass the address field of an unbounded variable *)
6344          PushTF(Adr, Address) ;
6345          PushTFAD (f^.TrueExit, f^.FalseExit, f^.Unbounded, f^.Dimension) ;
6346          PushT(1) ;
6347          BuildAdrFunction ;
6348          PopT(f^.TrueExit)
6349       ELSIF IsForC AND IsConstString(OperandT(pi)) AND
6350                         (IsUnboundedParam(Proc, i) OR (GetDType(GetParam(Proc, i))=Address))
6351       THEN
6352          f^.TrueExit := MakeLeftValue (OperandTok (pi),
6353                                        MakeConstStringCnul (OperandTok (pi), OperandT (pi)),
6354                                        RightValue, Address) ;
6355          MarkAsReadWrite (rw)
6356       ELSIF IsUnboundedParam(Proc, i)
6357       THEN
6358          (* always pass constant strings with a nul terminator, but leave the HIGH as before.  *)
6359          IF IsConstString (OperandT(pi))
6360          THEN
6361             (* this is a Modula-2 string which must be nul terminated.  *)
6362             f^.TrueExit := MakeConstStringM2nul (OperandTok (pi), OperandT (pi))
6363          END ;
6364          t := MakeTemporary (OperandTok (pi), RightValue) ;
6365          UnboundedType := GetSType(GetParam(Proc, i)) ;
6366          PutVar(t, UnboundedType) ;
6367          ParamType := GetSType(UnboundedType) ;
6368          IF OperandD(pi)=0
6369          THEN
6370             ArraySym := OperandT(pi)
6371          ELSE
6372             ArraySym := OperandA(pi)
6373          END ;
6374          IF IsVarParam(Proc, i)
6375          THEN
6376             MarkArrayWritten (OperandT (pi)) ;
6377             MarkArrayWritten (OperandA (pi)) ;
6378             MarkAsReadWrite(rw) ;
6379             AssignUnboundedVar (OperandTtok (pi), OperandT (pi), ArraySym, t, ParamType, OperandD (pi))
6380          ELSE
6381             MarkAsRead(rw) ;
6382             AssignUnboundedNonVar (OperandTtok (pi), OperandT (pi), ArraySym, t, ParamType, OperandD (pi))
6383          END ;
6384          f^.TrueExit := t
6385       ELSIF IsVarParam(Proc, i)
6386       THEN
6387          (* must reference by address, but we contain the type of the referenced entity *)
6388          MarkArrayWritten(OperandT(pi)) ;
6389          MarkArrayWritten(OperandA(pi)) ;
6390          MarkAsReadWrite(rw) ;
6391          f^.TrueExit := MakeLeftValue(OperandTok(pi), OperandT(pi), LeftValue, GetSType(GetParam(Proc, i)))
6392       ELSIF (NOT IsVarParam(Proc, i)) AND (GetMode(OperandT(pi))=LeftValue)
6393       THEN
6394          (* must dereference LeftValue *)
6395          t := MakeTemporary (OperandTok (pi), RightValue) ;
6396          PutVar(t, GetSType(OperandT(pi))) ;
6397          CheckPointerThroughNil (tokpos, OperandT (pi)) ;
6398          doIndrX (OperandTok(pi), t, OperandT(pi)) ;
6399          f^.TrueExit := t ;
6400          MarkAsRead(rw)
6401       ELSE
6402          MarkAsRead(rw)
6403       END ;
6404       INC(i) ;
6405       DEC(pi)
6406    END ;
6407    PushT(NoOfParameters)
6408 END ManipulateParameters ;
6409
6410
6411 (*
6412    CheckParameterOrdinals - check that ordinal values are within type range.
6413 *)
6414
6415 PROCEDURE CheckParameterOrdinals ;
6416 VAR
6417    tokno     : CARDINAL ;
6418    Proc,
6419    ProcSym   : CARDINAL ;
6420    Actual,
6421    FormalI   : CARDINAL ;
6422    ParamTotal,
6423    pi, i     : CARDINAL ;
6424 BEGIN
6425    PopT (ParamTotal) ;
6426    PushT (ParamTotal) ;  (* Restore stack to origional state *)
6427    ProcSym := OperandT (ParamTotal+1+1) ;
6428    IF IsVar(ProcSym) AND IsProcType(GetDType(ProcSym))
6429    THEN
6430       (* Indirect procedure call.  *)
6431       Proc := SkipType(OperandF(ParamTotal+1+1))
6432    ELSE
6433       Proc := SkipConst(ProcSym)
6434    END ;
6435    i := 1 ;
6436    pi := ParamTotal+1 ;   (* stack index referencing stacked parameter, i *)
6437    WHILE i<=ParamTotal DO
6438       IF i<=NoOfParam(Proc)
6439       THEN
6440          FormalI := GetParam (Proc, i) ;
6441          Actual := OperandT (pi) ;
6442          tokno := OperandTok (pi) ;
6443          IF IsOrdinalType (GetLType (FormalI))
6444          THEN
6445             IF NOT IsSet (GetDType (FormalI))
6446             THEN
6447                (* tell code generator to test runtime values of assignment so ensure we
6448                   catch overflow and underflow *)
6449                BuildRange (InitParameterRangeCheck (tokno, Proc, i, FormalI, Actual))
6450             END
6451          END
6452       END ;
6453       INC (i) ;
6454       DEC (pi)
6455    END
6456 END CheckParameterOrdinals ;
6457
6458
6459 (*
6460    IsSameUnbounded - returns TRUE if unbounded types, t1, and, t2,
6461                      are compatible.
6462 *)
6463
6464 PROCEDURE IsSameUnbounded (t1, t2: CARDINAL) : BOOLEAN ;
6465 BEGIN
6466    Assert(IsUnbounded(t1)) ;
6467    Assert(IsUnbounded(t2)) ;
6468    RETURN( GetDType(t1)=GetDType(t2) )
6469 END IsSameUnbounded ;
6470
6471
6472 (*
6473    AssignUnboundedVar - assigns an Unbounded symbol fields,
6474                         ArrayAddress and ArrayHigh, from an array symbol.
6475                         UnboundedSym is not a VAR parameter and therefore
6476                         this procedure can complete both of the fields.
6477                         Sym can be a Variable with type Unbounded.
6478                         Sym can be a Variable with type Array.
6479                         Sym can be a String Constant.
6480
6481                         ParamType is the TYPE of the parameter
6482 *)
6483
6484 PROCEDURE AssignUnboundedVar (tok: CARDINAL;
6485                               Sym, ArraySym, UnboundedSym, ParamType: CARDINAL; dim: CARDINAL) ;
6486 VAR
6487    Type: CARDINAL ;
6488 BEGIN
6489    IF IsConst(Sym)
6490    THEN
6491       MetaErrorT1 (tok, '{%1ad} cannot be passed to a VAR formal parameter', Sym)
6492    ELSIF IsVar(Sym)
6493    THEN
6494       Type := GetDType(Sym) ;
6495       IF Type = NulSym
6496       THEN
6497          MetaErrorT1 (tok, '{%1ad} has no type and cannot be passed to a VAR formal parameter', Sym)
6498       ELSIF IsUnbounded(Type)
6499       THEN
6500          IF Type = GetSType (UnboundedSym)
6501          THEN
6502             (* Copy Unbounded Symbol ie. UnboundedSym := Sym *)
6503             PushT (UnboundedSym) ;
6504             PushT (Sym) ;
6505             BuildAssignmentWithoutBounds (tok, FALSE, TRUE)
6506          ELSIF IsSameUnbounded (Type, GetSType (UnboundedSym)) OR
6507                IsGenericSystemType (ParamType)
6508          THEN
6509             UnboundedVarLinkToArray (tok, Sym, ArraySym, UnboundedSym, ParamType, dim)
6510          ELSE
6511             MetaErrorT1 (tok, '{%1ad} cannot be passed to a VAR formal parameter', Sym)
6512          END
6513       ELSIF IsArray (Type) OR IsGenericSystemType (ParamType)
6514       THEN
6515          UnboundedVarLinkToArray (tok, Sym, ArraySym, UnboundedSym, ParamType, dim)
6516       ELSE
6517          MetaErrorT1 (tok, '{%1ad} cannot be passed to a VAR formal parameter', Sym)
6518       END
6519    ELSE
6520       MetaErrorT1 (tok, '{%1ad} cannot be passed to a VAR formal parameter', Sym)
6521    END
6522 END AssignUnboundedVar ;
6523
6524
6525 (*
6526    AssignUnboundedNonVar - assigns an Unbounded symbol fields,
6527                            The difference between this procedure and
6528                            AssignUnboundedVar is that this procedure cannot
6529                            set the Unbounded.Address since the data from
6530                            Sym will be copied because parameter is NOT a VAR
6531                            parameter.
6532                            UnboundedSym is not a VAR parameter and therefore
6533                            this procedure can only complete the HIGH field
6534                            and not the ADDRESS field.
6535                            Sym can be a Variable with type Unbounded.
6536                            Sym can be a Variable with type Array.
6537                            Sym can be a String Constant.
6538
6539                            ParamType is the TYPE of the paramater
6540 *)
6541
6542 PROCEDURE AssignUnboundedNonVar (tok: CARDINAL;
6543                                  Sym, ArraySym, UnboundedSym, ParamType: CARDINAL; dim: CARDINAL) ;
6544 VAR
6545    Type: CARDINAL ;
6546 BEGIN
6547    IF IsConst (Sym)  (* was IsConstString(Sym) *)
6548    THEN
6549       UnboundedNonVarLinkToArray (tok, Sym, ArraySym, UnboundedSym, ParamType, dim)
6550    ELSIF IsVar (Sym)
6551    THEN
6552       Type := GetDType (Sym) ;
6553       IF Type = NulSym
6554       THEN
6555          MetaErrorT1 (tok, '{%1ad} has no type and cannot be passed to a non VAR formal parameter', Sym)
6556       ELSIF IsUnbounded (Type)
6557       THEN
6558          UnboundedNonVarLinkToArray (tok, Sym, ArraySym, UnboundedSym, ParamType, dim)
6559       ELSIF IsArray (Type) OR IsGenericSystemType (ParamType)
6560       THEN
6561          UnboundedNonVarLinkToArray (tok, Sym, ArraySym, UnboundedSym, ParamType, dim)
6562       ELSE
6563          MetaErrorT1 (tok, 'illegal type parameter {%1Ead} expecting array or dynamic array', Sym)
6564       END
6565    ELSE
6566       MetaErrorT1 (tok, 'illegal parameter {%1Ead} which cannot be passed as {%kVAR} {%kARRAY} {%kOF} {%1tsad}', Sym)
6567    END
6568 END AssignUnboundedNonVar ;
6569
6570
6571 (*
6572    GenHigh - generates a HighOp but it checks if op3 is a
6573              L value and if so it dereferences it.  This
6574              is inefficient, however it is clean and we let the gcc
6575              backend detect these as common subexpressions.
6576              It will also detect that a R value -> L value -> R value
6577              via indirection and eleminate these.
6578 *)
6579
6580 PROCEDURE GenHigh (tok: CARDINAL;
6581                    op1, op2, op3: CARDINAL) ;
6582 VAR
6583    sym: CARDINAL ;
6584 BEGIN
6585    IF (GetMode(op3)=LeftValue) AND IsUnbounded(GetSType(op3))
6586    THEN
6587       sym := MakeTemporary (tok, RightValue) ;
6588       PutVar (sym, GetSType (op3)) ;
6589       doIndrX (tok, sym, op3) ;
6590       GenQuadO (tok, HighOp, op1, op2, sym, TRUE)
6591    ELSE
6592       GenQuadO (tok, HighOp, op1, op2, op3, TRUE)
6593    END
6594 END GenHigh ;
6595
6596
6597 (*
6598    AssignHighField -
6599 *)
6600
6601 PROCEDURE AssignHighField (tok: CARDINAL;
6602                            Sym, ArraySym, UnboundedSym, ParamType: CARDINAL;
6603                            actuali, formali: CARDINAL) ;
6604 VAR
6605    ReturnVar,
6606    ArrayType,
6607    Field    : CARDINAL ;
6608 BEGIN
6609    (* Unbounded.ArrayHigh := HIGH(ArraySym) *)
6610    PushTFtok (UnboundedSym, GetSType (UnboundedSym), tok) ;
6611    Field := GetUnboundedHighOffset (GetSType (UnboundedSym), formali) ;
6612    PushTFtok (Field, GetSType (Field), tok) ;
6613    PushT (1) ;
6614    BuildDesignatorRecord (tok) ;
6615    IF IsGenericSystemType (ParamType)
6616    THEN
6617       IF IsConstString (Sym)
6618       THEN
6619          PushTtok (MakeLengthConst (tok, Sym), tok)
6620       ELSE
6621          ArrayType := GetSType (Sym) ;
6622          IF IsUnbounded (ArrayType)
6623          THEN
6624             (*
6625              *  SIZE(parameter) DIV TSIZE(ParamType)
6626              *  however in this case parameter
6627              *  is an unbounded symbol and therefore we must use
6628              *  (HIGH(parameter)+1)*SIZE(unbounded type) DIV TSIZE(ParamType)
6629              *
6630              *  we call upon the function SIZE(ArraySym)
6631              *  remember SIZE doubles as
6632              *  (HIGH(a)+1) * SIZE(ArrayType) for unbounded symbols
6633              *)
6634             PushTFtok (calculateMultipicand (tok, ArraySym, ArrayType, actuali-1), Cardinal, tok) ;
6635             PushT (DivideTok) ;        (* Divide by                    *)
6636             PushTFtok (TSize, Cardinal, tok) ; (* TSIZE(ParamType)     *)
6637             PushTtok (ParamType, tok) ;
6638             PushT (1) ;                (* 1 parameter for TSIZE()      *)
6639             BuildFunctionCall (FALSE) ;
6640             BuildBinaryOp
6641          ELSE
6642             (* SIZE(parameter) DIV TSIZE(ParamType)                    *)
6643             PushTFtok (TSize, Cardinal, tok) ;  (* TSIZE(ArrayType)    *)
6644             PushTtok (ArrayType, tok) ;
6645             PushT (1) ;                (* 1 parameter for TSIZE()      *)
6646             BuildFunctionCall (TRUE) ;
6647             PushT (DivideTok) ;        (* Divide by                    *)
6648             PushTFtok (TSize, Cardinal, tok) ; (* TSIZE(ParamType)     *)
6649             PushTtok (ParamType, tok) ;
6650             PushT (1) ;                (* 1 parameter for TSIZE()      *)
6651             BuildFunctionCall (TRUE) ;
6652             BuildBinaryOp
6653          END ;
6654          (* now convert from no of elements into HIGH by subtracting 1 *)
6655          PushT (MinusTok) ;           (* -1                            *)
6656          PushTtok (MakeConstLit (tok, MakeKey('1'), Cardinal), tok) ;
6657          BuildBinaryOp
6658       END
6659    ELSE
6660       ReturnVar := MakeTemporary (tok, RightValue) ;
6661       PutVar (ReturnVar, Cardinal) ;
6662       IF (actuali # formali) AND (ArraySym # NulSym) AND IsUnbounded (GetSType (ArraySym))
6663       THEN
6664          GenHigh (tok, ReturnVar, actuali, ArraySym)
6665       ELSE
6666          GenHigh (tok, ReturnVar, formali, Sym)
6667       END ;
6668       PushTFtok (ReturnVar, GetSType(ReturnVar), tok)
6669    END ;
6670    BuildAssignmentWithoutBounds (tok, FALSE, TRUE)
6671 END AssignHighField ;
6672
6673
6674 (*
6675    AssignHighFields -
6676 *)
6677
6678 PROCEDURE AssignHighFields (tok: CARDINAL;
6679                             Sym, ArraySym, UnboundedSym, ParamType: CARDINAL; dim: CARDINAL) ;
6680 VAR
6681    type            : CARDINAL ;
6682    actuali, formali,
6683    actualn, formaln: CARDINAL ;
6684 BEGIN
6685    type := GetDType (Sym) ;
6686    actualn := 1 ;
6687    IF (type # NulSym) AND (IsUnbounded (type) OR IsArray (type))
6688    THEN
6689       actualn := GetDimension (type)
6690    END ;
6691    actuali := dim + 1 ;
6692    formali := 1 ;
6693    formaln := GetDimension (GetDType (UnboundedSym)) ;
6694    WHILE (actuali < actualn) AND (formali < formaln) DO
6695       AssignHighField (tok, Sym, ArraySym, UnboundedSym, NulSym, actuali, formali) ;
6696       INC (actuali) ;
6697       INC (formali)
6698    END ;
6699    AssignHighField (tok, Sym, ArraySym, UnboundedSym, ParamType, actuali, formali)
6700 END AssignHighFields ;
6701
6702
6703 (*
6704    UnboundedNonVarLinkToArray - links an array, ArraySym, to an unbounded
6705                                 array, UnboundedSym. The parameter is a
6706                                 NON VAR variety.
6707 *)
6708
6709 PROCEDURE UnboundedNonVarLinkToArray (tok: CARDINAL;
6710                                       Sym, ArraySym, UnboundedSym, ParamType: CARDINAL; dim: CARDINAL) ;
6711 VAR
6712    Field,
6713    AddressField: CARDINAL ;
6714 BEGIN
6715    (* Unbounded.ArrayAddress := to be assigned at runtime.  *)
6716    PushTFtok (UnboundedSym, GetSType (UnboundedSym), tok) ;
6717
6718    Field := GetUnboundedAddressOffset(GetSType(UnboundedSym)) ;
6719    PushTFtok (Field, GetSType(Field), tok) ;
6720    PushT (1) ;
6721    BuildDesignatorRecord (tok) ;
6722    PopT (AddressField) ;
6723
6724    (* caller saves non var unbounded array contents.  *)
6725    GenQuadO (tok, UnboundedOp, AddressField, NulSym, Sym, FALSE) ;
6726
6727    AssignHighFields (tok, Sym, ArraySym, UnboundedSym, ParamType, dim)
6728 END UnboundedNonVarLinkToArray ;
6729
6730
6731 (*
6732    UnboundedVarLinkToArray - links an array, ArraySym, to an unbounded array,
6733                              UnboundedSym. The parameter is a VAR variety.
6734 *)
6735
6736 PROCEDURE UnboundedVarLinkToArray (tok: CARDINAL;
6737                                    Sym, ArraySym, UnboundedSym, ParamType: CARDINAL; dim: CARDINAL) ;
6738 VAR
6739    SymType,
6740    Field  : CARDINAL ;
6741 BEGIN
6742    SymType := GetSType (Sym) ;
6743    (* Unbounded.ArrayAddress := ADR(Sym) *)
6744    PushTFtok (UnboundedSym, GetSType (UnboundedSym), tok) ;
6745    Field := GetUnboundedAddressOffset (GetSType (UnboundedSym)) ;
6746    PushTFtok (Field, GetSType (Field), tok) ;
6747    PushT (1) ;
6748    BuildDesignatorRecord (tok) ;
6749    PushTFtok (Adr, Address, tok) ;   (* ADR (Sym).  *)
6750    IF IsUnbounded (SymType) AND (dim = 0)
6751    THEN
6752       PushTFADtok (Sym, SymType, UnboundedSym, dim, tok)
6753    ELSE
6754       PushTFADtok (Sym, SymType, ArraySym, dim, tok)
6755    END ;
6756    PushT (1) ;               (* 1 parameter for ADR().  *)
6757    BuildFunctionCall (FALSE) ;
6758    BuildAssignmentWithoutBounds (tok, FALSE, TRUE) ;
6759
6760    AssignHighFields (tok, Sym, ArraySym, UnboundedSym, ParamType, dim)
6761 END UnboundedVarLinkToArray ;
6762
6763
6764 (*
6765    BuildPseudoProcedureCall - builds a pseudo procedure call.
6766                               This procedure does not directly alter the
6767                               stack, but by calling routines the stack
6768                               will change in the following way when this
6769                               procedure returns.
6770
6771                               The Stack:
6772
6773
6774                               Entry                      Exit
6775
6776                        Ptr ->
6777                               +----------------+
6778                               | NoOfParam      |
6779                               |----------------|
6780                               | Param 1        |
6781                               |----------------|
6782                               | Param 2        |
6783                               |----------------|
6784                               .                .
6785                               .                .
6786                               .                .
6787                               |----------------|
6788                               | Param #        |
6789                               |----------------|
6790                               | ProcSym | Type |         Empty
6791                               |----------------|
6792 *)
6793
6794 PROCEDURE BuildPseudoProcedureCall (tokno: CARDINAL) ;
6795 VAR
6796    NoOfParam,
6797    ProcSym  : CARDINAL ;
6798 BEGIN
6799    PopT (NoOfParam) ;
6800    ProcSym := OperandT (NoOfParam + 1) ;
6801    PushT (NoOfParam) ;
6802    (* Compile time stack restored to entry state *)
6803    IF ProcSym = New
6804    THEN
6805       BuildNewProcedure (tokno)
6806    ELSIF ProcSym = Dispose
6807    THEN
6808       BuildDisposeProcedure (tokno)
6809    ELSIF ProcSym = Inc
6810    THEN
6811       BuildIncProcedure
6812    ELSIF ProcSym = Dec
6813    THEN
6814       BuildDecProcedure
6815    ELSIF ProcSym = Incl
6816    THEN
6817       BuildInclProcedure
6818    ELSIF ProcSym = Excl
6819    THEN
6820       BuildExclProcedure
6821    ELSIF ProcSym = Throw
6822    THEN
6823       BuildThrowProcedure
6824    ELSE
6825       InternalError  ('pseudo procedure not implemented yet')
6826    END
6827 END BuildPseudoProcedureCall ;
6828
6829
6830 (*
6831    GetItemPointedTo - returns the symbol type that is being pointed to
6832                       by Sym.
6833 *)
6834
6835 PROCEDURE GetItemPointedTo (Sym: CARDINAL) : CARDINAL ;
6836 BEGIN
6837    IF IsPointer (Sym)
6838    THEN
6839       RETURN GetSType (Sym)
6840    ELSIF IsVar (Sym) OR IsType (Sym)
6841    THEN
6842       RETURN GetItemPointedTo (GetSType (Sym))
6843    ELSE
6844       RETURN NulSym
6845    END
6846 END GetItemPointedTo ;
6847
6848
6849 (*
6850    BuildThrowProcedure - builds the pseudo procedure call M2RTS.Throw.
6851                          The Stack:
6852
6853
6854                          Entry                      Exit
6855
6856                 Ptr ->
6857                          +----------------+
6858                          | NoOfParam      |
6859                          |----------------|
6860                          | Param 1        |
6861                          |----------------|
6862                          | Param 2        |
6863                          |----------------|
6864                          .                .
6865                          .                .
6866                          .                .
6867                          |----------------|
6868                          | Param #        |
6869                          |----------------|
6870                          | ProcSym | Type |         Empty
6871                          |----------------|
6872 *)
6873
6874 PROCEDURE BuildThrowProcedure ;
6875 VAR
6876    functok  : CARDINAL ;
6877    op       : CARDINAL ;
6878    NoOfParam: CARDINAL ;
6879 BEGIN
6880    PopT (NoOfParam) ;
6881    functok  := OperandTtok (NoOfParam + 1) ;
6882    IF NoOfParam = 1
6883    THEN
6884       op := OperandT (NoOfParam) ;
6885       GenQuadO (functok, ThrowOp, NulSym, NulSym, op, FALSE)
6886    ELSE
6887       MetaErrorT1 (functok, 'the pseudo procedure %{1Ea} takes one INTEGER parameter', Throw)
6888    END ;
6889    PopN (NoOfParam+1)
6890 END BuildThrowProcedure ;
6891
6892
6893 (*
6894    BuildReThrow - creates a ThrowOp _ _ NulSym, indicating that
6895                   the exception needs to be rethrown.  The stack
6896                   is unaltered.
6897 *)
6898
6899 PROCEDURE BuildReThrow (tokenno: CARDINAL) ;
6900 BEGIN
6901    GenQuadO (tokenno, ThrowOp, NulSym, NulSym, NulSym, FALSE)
6902 END BuildReThrow ;
6903
6904
6905 (*
6906    BuildNewProcedure - builds the pseudo procedure call NEW.
6907                        This procedure is traditionally a "macro" for
6908                        NEW(x, ...) --> ALLOCATE(x, TSIZE(x^, ...))
6909                        One method of implementation is to emulate a "macro"
6910                        processor by pushing the relevant input tokens
6911                        back onto the input stack.
6912                        However this causes two problems:
6913
6914                        (i)  Unnecessary code is produced for x^
6915                        (ii) SIZE must be imported from SYSTEM
6916                        Therefore we chose an alternative method of
6917                        implementation;
6918                        generate quadruples for ALLOCATE(x, TSIZE(x^, ...))
6919                        this, although slightly more efficient,
6920                        is more complex and circumvents problems (i) and (ii).
6921
6922                        The Stack:
6923
6924
6925                        Entry                      Exit
6926
6927                 Ptr ->
6928                        +----------------+
6929                        | NoOfParam      |
6930                        |----------------|
6931                        | Param 1        |
6932                        |----------------|
6933                        | Param 2        |
6934                        |----------------|
6935                        .                .
6936                        .                .
6937                        .                .
6938                        |----------------|
6939                        | Param #        |
6940                        |----------------|
6941                        | ProcSym | Type |         Empty
6942                        |----------------|
6943 *)
6944
6945 PROCEDURE BuildNewProcedure (functok: CARDINAL) ;
6946 VAR
6947    NoOfParam,
6948    SizeSym,
6949    PtrSym,
6950    ProcSym    : CARDINAL ;
6951    paramtok,
6952    combinedtok: CARDINAL ;
6953 BEGIN
6954    PopT(NoOfParam) ;
6955    IF NoOfParam>=1
6956    THEN
6957       ProcSym := RequestSym (functok, MakeKey('ALLOCATE')) ;
6958       IF (ProcSym#NulSym) AND IsProcedure(ProcSym)
6959       THEN
6960          PtrSym := OperandT (NoOfParam) ;
6961          paramtok := OperandTtok (1) ;
6962          IF IsReallyPointer(PtrSym)
6963          THEN
6964             combinedtok := MakeVirtualTok (functok, functok, paramtok) ;
6965             (*
6966                Build macro: ALLOCATE( PtrSym, SIZE(PtrSym^) )
6967             *)
6968             PushTFtok (TSize, Cardinal, paramtok) ;(* Procedure      *)
6969                                       (* x^             *)
6970             PushTtok (GetItemPointedTo (PtrSym), paramtok) ;
6971             PushT (1) ;               (* One parameter  *)
6972             BuildFunctionCall (FALSE) ;
6973             PopT (SizeSym) ;
6974
6975             PushTtok (ProcSym, combinedtok) ;  (* ALLOCATE       *)
6976             PushTtok (PtrSym, paramtok) ;      (* x              *)
6977             PushTtok (SizeSym, paramtok) ;     (* TSIZE(x^)      *)
6978             PushT (2) ;                        (* Two parameters *)
6979             BuildProcedureCall (combinedtok)
6980          ELSE
6981             MetaErrorT0 (paramtok, 'parameter to {%EkNEW} must be a pointer')
6982          END
6983       ELSE
6984          MetaErrorT0 (functok, '{%E}ALLOCATE procedure not found for NEW substitution')
6985       END
6986    ELSE
6987       MetaErrorT0 (functok, 'the pseudo procedure {%EkNEW} has one or more parameters')
6988    END ;
6989    PopN (NoOfParam+1)
6990 END BuildNewProcedure ;
6991
6992
6993 (*
6994    BuildDisposeProcedure - builds the pseudo procedure call DISPOSE.
6995                            This procedure is traditionally a "macro" for
6996                            DISPOSE(x) --> DEALLOCATE(x, TSIZE(x^))
6997                            One method of implementation is to emulate a "macro"
6998                            processor by pushing the relevant input tokens
6999                            back onto the input stack.
7000                            However this causes two problems:
7001
7002                            (i)  Unnecessary code is produced for x^
7003                            (ii) TSIZE must be imported from SYSTEM
7004                            Therefore we chose an alternative method of
7005                            implementation;
7006                            generate quadruples for DEALLOCATE(x, TSIZE(x^))
7007                            this, although slightly more efficient,
7008                            is more complex and circumvents problems (i)
7009                            and (ii).
7010
7011                            The Stack:
7012
7013
7014                            Entry                      Exit
7015
7016                     Ptr ->
7017                            +----------------+
7018                            | NoOfParam      |
7019                            |----------------|
7020                            | Param 1        |
7021                            |----------------|
7022                            | Param 2        |
7023                            |----------------|
7024                            .                .
7025                            .                .
7026                            .                .
7027                            |----------------|
7028                            | Param #        |
7029                            |----------------|
7030                            | ProcSym | Type |         Empty
7031                            |----------------|
7032 *)
7033
7034 PROCEDURE BuildDisposeProcedure (functok: CARDINAL) ;
7035 VAR
7036    NoOfParam,
7037    SizeSym,
7038    PtrSym,
7039    ProcSym    : CARDINAL ;
7040    combinedtok,
7041    paramtok   : CARDINAL ;
7042 BEGIN
7043    PopT (NoOfParam) ;
7044    IF NoOfParam>=1
7045    THEN
7046       ProcSym := RequestSym (functok, MakeKey ('DEALLOCATE')) ;
7047       IF (ProcSym # NulSym) AND IsProcedure (ProcSym)
7048       THEN
7049          PtrSym := OperandT (NoOfParam) ;
7050          paramtok := OperandTtok (1) ;
7051          IF IsReallyPointer (PtrSym)
7052          THEN
7053             combinedtok := MakeVirtualTok (functok, functok, paramtok) ;
7054             (*
7055                Build macro: DEALLOCATE( PtrSym, TSIZE(PtrSym^) )
7056             *)
7057             PushTFtok (TSize, Cardinal, paramtok) ;(* Procedure      *)
7058                                       (* x^             *)
7059             PushTtok (GetItemPointedTo(PtrSym), paramtok) ;
7060             PushT (1) ;               (* One parameter  *)
7061             BuildFunctionCall (FALSE) ;
7062             PopT (SizeSym) ;
7063
7064             PushTtok (ProcSym, combinedtok) ;         (* DEALLOCATE     *)
7065             PushTtok (PtrSym, paramtok) ;             (* x              *)
7066             PushTtok (SizeSym, paramtok) ;            (* TSIZE(x^)      *)
7067             PushT (2) ;                               (* Two parameters *)
7068             BuildProcedureCall (combinedtok)
7069          ELSE
7070             MetaErrorT0 (paramtok, 'argument to {%EkDISPOSE} must be a pointer')
7071          END
7072       ELSE
7073          MetaErrorT0 (functok, '{%E}DEALLOCATE procedure not found for DISPOSE substitution')
7074       END
7075    ELSE
7076       MetaErrorT0 (functok, 'the pseudo procedure {%EkDISPOSE} has one or more parameters')
7077    END ;
7078    PopN (NoOfParam+1)
7079 END BuildDisposeProcedure ;
7080
7081
7082 (*
7083    CheckRangeIncDec - performs des := des <tok> expr
7084                       with range checking (if enabled).
7085
7086                                Stack
7087                       Entry              Exit
7088
7089                                      +------------+
7090                       empty          | des + expr |
7091                                      |------------|
7092 *)
7093
7094 PROCEDURE CheckRangeIncDec (tokenpos: CARDINAL; des, expr: CARDINAL; tok: Name) ;
7095 VAR
7096    dtype, etype: CARDINAL ;
7097 BEGIN
7098    dtype := GetDType(des) ;
7099    etype := GetDType(expr) ;
7100    IF WholeValueChecking AND (NOT MustNotCheckBounds)
7101    THEN
7102       IF tok=PlusTok
7103       THEN
7104          BuildRange (InitIncRangeCheck (des, expr))
7105       ELSE
7106          BuildRange (InitDecRangeCheck (des, expr))
7107       END
7108    END ;
7109
7110    IF IsExpressionCompatible (dtype, etype)
7111    THEN
7112       (* the easy case simulate a straightforward macro *)
7113       PushTF (des, dtype) ;
7114       PushT (tok) ;
7115       PushTF (expr, etype) ;
7116       doBuildBinaryOp (FALSE, TRUE)
7117    ELSE
7118       IF (IsOrdinalType (dtype) OR (dtype = Address) OR IsPointer (dtype)) AND
7119          (IsOrdinalType (etype) OR (etype = Address) OR IsPointer (etype))
7120       THEN
7121          PushTF (des, dtype) ;
7122          PushT (tok) ;
7123          PushTF (Convert, NulSym) ;
7124          PushT (dtype) ;
7125          PushT (expr) ;
7126          PushT (2) ;          (* Two parameters *)
7127          BuildConvertFunction ;
7128          doBuildBinaryOp (FALSE, TRUE)
7129       ELSE
7130          IF tok=PlusTok
7131          THEN
7132             MetaError0 ('cannot perform {%EkINC} using non ordinal types')
7133          ELSE
7134             MetaError0 ('cannot perform {%EkDEC} using non ordinal types')
7135          END ;
7136          PushTFtok (MakeConstLit (tokenpos, MakeKey ('0'), NulSym), NulSym, tokenpos)
7137       END
7138    END
7139 END CheckRangeIncDec ;
7140
7141
7142 (*
7143    BuildIncProcedure - builds the pseudo procedure call INC.
7144                        INC is a procedure which increments a variable.
7145                        It takes one or two parameters:
7146                        INC(a, b)  or  INC(a)
7147                        a := a+b   or  a := a+1
7148
7149                        The Stack:
7150
7151
7152                        Entry                      Exit
7153
7154                 Ptr ->
7155                        +----------------+
7156                        | NoOfParam      |
7157                        |----------------|
7158                        | Param 1        |
7159                        |----------------|
7160                        | Param 2        |
7161                        |----------------|
7162                        .                .
7163                        .                .
7164                        .                .
7165                        |----------------|
7166                        | Param #        |
7167                        |----------------|
7168                        | ProcSym | Type |         Empty
7169                        |----------------|
7170 *)
7171
7172 PROCEDURE BuildIncProcedure ;
7173 VAR
7174    proctok   : CARDINAL ;
7175    NoOfParam,
7176    dtype,
7177    OperandSym,
7178    VarSym,
7179    TempSym   : CARDINAL ;
7180 BEGIN
7181    PopT (NoOfParam) ;
7182    proctok := OperandTtok (NoOfParam + 1) ;
7183    IF (NoOfParam = 1) OR (NoOfParam = 2)
7184    THEN
7185       VarSym := OperandT (NoOfParam) ;  (* bottom/first parameter *)
7186       IF IsVar (VarSym)
7187       THEN
7188          dtype := GetDType (VarSym) ;
7189          IF NoOfParam = 2
7190          THEN
7191             OperandSym := DereferenceLValue (OperandTok (1), OperandT (1))
7192          ELSE
7193             PushOne (proctok, dtype, 'the {%EkINC} will cause an overflow {%1ad}') ;
7194             PopT (OperandSym)
7195          END ;
7196
7197          PushT (VarSym) ;
7198          TempSym := DereferenceLValue (OperandTok (NoOfParam), VarSym) ;
7199          CheckRangeIncDec (proctok, TempSym, OperandSym, PlusTok) ;  (* TempSym + OperandSym *)
7200          BuildAssignmentWithoutBounds (proctok, FALSE, TRUE)   (* VarSym := TempSym + OperandSym *)
7201       ELSE
7202          MetaErrorT1 (proctok,
7203                       'base procedure {%EkINC} expects a variable as a parameter but was given {%1Ed}',
7204                       VarSym)
7205       END
7206    ELSE
7207       MetaErrorT0 (proctok,
7208                    'the base procedure {%EkINC} expects 1 or 2 parameters')
7209    END ;
7210    PopN (NoOfParam + 1)
7211 END BuildIncProcedure ;
7212
7213
7214 (*
7215    BuildDecProcedure - builds the pseudo procedure call DEC.
7216                        DEC is a procedure which decrements a variable.
7217                        It takes one or two parameters:
7218                        DEC(a, b)  or  DEC(a)
7219                        a := a-b   or  a := a-1
7220
7221                        The Stack:
7222
7223
7224                        Entry                      Exit
7225
7226                 Ptr ->
7227                        +----------------+
7228                        | NoOfParam      |
7229                        |----------------|
7230                        | Param 1        |
7231                        |----------------|
7232                        | Param 2        |
7233                        |----------------|
7234                        .                .
7235                        .                .
7236                        .                .
7237                        |----------------|
7238                        | Param #        |
7239                        |----------------|
7240                        | ProcSym | Type |         Empty
7241                        |----------------|
7242 *)
7243
7244 PROCEDURE BuildDecProcedure ;
7245 VAR
7246    proctok,
7247    NoOfParam,
7248    dtype,
7249    OperandSym,
7250    VarSym,
7251    TempSym   : CARDINAL ;
7252 BEGIN
7253    PopT (NoOfParam) ;
7254    proctok := OperandTtok (NoOfParam + 1) ;
7255    IF (NoOfParam = 1) OR (NoOfParam = 2)
7256    THEN
7257       VarSym := OperandT (NoOfParam) ;  (* bottom/first parameter *)
7258       IF IsVar (VarSym)
7259       THEN
7260          dtype := GetDType (VarSym) ;
7261          IF NoOfParam = 2
7262          THEN
7263             OperandSym := DereferenceLValue (OperandTok (1), OperandT (1))
7264          ELSE
7265             PushOne (proctok, dtype, 'the {%EkDEC} will cause an overflow {%1ad}') ;
7266             PopT (OperandSym)
7267          END ;
7268
7269          PushT (VarSym) ;
7270          TempSym := DereferenceLValue (OperandTok (NoOfParam), VarSym) ;
7271          CheckRangeIncDec (proctok, TempSym, OperandSym, MinusTok) ;  (* TempSym - OperandSym *)
7272          BuildAssignmentWithoutBounds (proctok, FALSE, TRUE)   (* VarSym := TempSym - OperandSym *)
7273       ELSE
7274          MetaErrorT1 (proctok,
7275                       'base procedure {%EkDEC} expects a variable as a parameter but was given {%1Ed}',
7276                       VarSym)
7277       END
7278    ELSE
7279       MetaErrorT0 (proctok,
7280                    'the base procedure {%EkDEC} expects 1 or 2 parameters')
7281    END ;
7282    PopN (NoOfParam + 1)
7283 END BuildDecProcedure ;
7284
7285
7286 (*
7287    DereferenceLValue - checks to see whether, operand, is declare as an LValue
7288                        and if so it dereferences it.
7289 *)
7290
7291 PROCEDURE DereferenceLValue (tok: CARDINAL; operand: CARDINAL) : CARDINAL ;
7292 VAR
7293    sym: CARDINAL ;
7294 BEGIN
7295    IF GetMode (operand) = LeftValue
7296    THEN
7297       (* dereference the pointer *)
7298       sym := MakeTemporary (tok, AreConstant(IsConst(operand))) ;
7299       PutVar(sym, GetSType (operand)) ;
7300
7301       PushTtok (sym, tok) ;
7302       PushTtok (operand, tok) ;
7303       BuildAssignmentWithoutBounds (tok, FALSE, TRUE) ;
7304       RETURN sym
7305    ELSE
7306       RETURN operand
7307    END
7308 END DereferenceLValue ;
7309
7310
7311 (*
7312    BuildInclProcedure - builds the pseudo procedure call INCL.
7313                         INCL is a procedure which adds bit b into a BITSET a.
7314                         It takes two parameters:
7315                         INCL(a, b)
7316
7317                         a := a + {b}
7318
7319                         The Stack:
7320
7321
7322                         Entry                      Exit
7323
7324                  Ptr ->
7325                         +----------------+
7326                         | NoOfParam      |
7327                         |----------------|
7328                         | Param 1        |
7329                         |----------------|
7330                         | Param 2        |
7331                         |----------------|
7332                         | ProcSym | Type |         Empty
7333                         |----------------|
7334 *)
7335
7336 PROCEDURE BuildInclProcedure ;
7337 VAR
7338    proctok,
7339    optok     : CARDINAL ;
7340    NoOfParam,
7341    DerefSym,
7342    OperandSym,
7343    VarSym    : CARDINAL ;
7344 BEGIN
7345    PopT (NoOfParam) ;
7346    proctok := OperandTtok (NoOfParam + 1) ;
7347    IF NoOfParam = 2
7348    THEN
7349       VarSym := OperandT (2) ;
7350       MarkArrayWritten (OperandA (2)) ;
7351       OperandSym := OperandT (1) ;
7352       optok := OperandTok (1) ;
7353       IF IsVar (VarSym)
7354       THEN
7355          IF IsSet (GetDType (VarSym))
7356          THEN
7357             DerefSym := DereferenceLValue (optok, OperandSym) ;
7358             BuildRange (InitInclCheck (VarSym, DerefSym)) ;
7359             GenQuadO (proctok, InclOp, VarSym, NulSym, DerefSym, FALSE)
7360          ELSE
7361             MetaErrorT1 (proctok,
7362                          'the first parameter to {%EkINCL} must be a set variable but is {%1Ed}',
7363                          VarSym)
7364          END
7365       ELSE
7366          MetaErrorT1 (proctok,
7367                       'base procedure {%EkINCL} expects a variable as a parameter but is {%1Ed}',
7368                       VarSym)
7369       END
7370    ELSE
7371       MetaErrorT0 (proctok, 'the base procedure {%EkINCL} expects 1 or 2 parameters')
7372    END ;
7373    PopN (NoOfParam + 1)
7374 END BuildInclProcedure ;
7375
7376
7377 (*
7378    BuildExclProcedure - builds the pseudo procedure call EXCL.
7379                         INCL is a procedure which removes bit b from SET a.
7380                         It takes two parameters:
7381                         EXCL(a, b)
7382
7383                         a := a - {b}
7384
7385                         The Stack:
7386
7387
7388                         Entry                      Exit
7389
7390                  Ptr ->
7391                         +----------------+
7392                         | NoOfParam      |
7393                         |----------------|
7394                         | Param 1        |
7395                         |----------------|
7396                         | Param 2        |
7397                         |----------------|
7398                         | ProcSym | Type |         Empty
7399                         |----------------|
7400 *)
7401
7402 PROCEDURE BuildExclProcedure ;
7403 VAR
7404    proctok,
7405    optok     : CARDINAL ;
7406    NoOfParam,
7407    DerefSym,
7408    OperandSym,
7409    VarSym    : CARDINAL ;
7410 BEGIN
7411    PopT (NoOfParam) ;
7412    proctok := OperandTtok (NoOfParam + 1) ;
7413    IF NoOfParam=2
7414    THEN
7415       VarSym := OperandT (2) ;
7416       MarkArrayWritten (OperandA(2)) ;
7417       OperandSym := OperandT (1) ;
7418       optok := OperandTok (1) ;
7419       IF IsVar (VarSym)
7420       THEN
7421          IF IsSet (GetDType (VarSym))
7422          THEN
7423             DerefSym := DereferenceLValue (optok, OperandSym) ;
7424             BuildRange (InitExclCheck (VarSym, DerefSym)) ;
7425             GenQuadO (proctok, ExclOp, VarSym, NulSym, DerefSym, FALSE)
7426          ELSE
7427             MetaErrorT1 (proctok,
7428                          'the first parameter to {%EkEXCL} must be a set variable but is {%1Ed}',
7429                          VarSym)
7430          END
7431       ELSE
7432          MetaErrorT1 (proctok,
7433                       'base procedure {%EkEXCL} expects a variable as a parameter but is {%1Ed}',
7434                       VarSym)
7435       END
7436    ELSE
7437       MetaErrorT0 (proctok,
7438                    'the base procedure {%EkEXCL} expects 1 or 2 parameters')
7439    END ;
7440    PopN (NoOfParam + 1)
7441 END BuildExclProcedure ;
7442
7443
7444 (*
7445    CheckBuildFunction - checks to see whether ProcSym is a function
7446                         and if so it adds a TempSym value which will
7447                         hold the return value once the function finishes.
7448                         This procedure also generates an error message
7449                         if the user is calling a function and ignoring
7450                         the return result.  The additional TempSym
7451                         is not created if ProcSym is a procedure
7452                         and the stack is unaltered.
7453
7454                         The Stack:
7455
7456
7457                        Entry                      Exit
7458
7459                 Ptr ->
7460
7461                                                   +----------------+
7462                                                   | ProcSym | Type |
7463                        +----------------+         |----------------|
7464                        | ProcSym | Type |         | TempSym | Type |
7465                        |----------------|         |----------------|
7466 *)
7467
7468 PROCEDURE CheckBuildFunction () : BOOLEAN ;
7469 VAR
7470    n            : Name ;
7471    tokpos,
7472    TempSym,
7473    ProcSym, Type: CARDINAL ;
7474 BEGIN
7475    PopTFtok(ProcSym, Type, tokpos) ;
7476    IF IsVar(ProcSym) AND IsProcType(Type)
7477    THEN
7478       IF GetSType(Type)#NulSym
7479       THEN
7480          TempSym := MakeTemporary (tokpos, RightValue) ;
7481          PutVar(TempSym, GetSType(Type)) ;
7482          PushTFtok(TempSym, GetSType(Type), tokpos) ;
7483          PushTFtok(ProcSym, Type, tokpos) ;
7484          IF NOT IsReturnOptional(Type)
7485          THEN
7486             IF IsTemporary(ProcSym)
7487             THEN
7488                ErrorFormat0 (NewError (tokpos),
7489                              'function is being called but its return value is ignored')
7490             ELSE
7491                n := GetSymName (ProcSym) ;
7492                ErrorFormat1 (NewError (tokpos),
7493                             'function (%a) is being called but its return value is ignored', n)
7494             END
7495          END ;
7496          RETURN TRUE
7497       END
7498    ELSIF IsProcedure(ProcSym) AND (Type#NulSym)
7499    THEN
7500       TempSym := MakeTemporary (tokpos, RightValue) ;
7501       PutVar(TempSym, Type) ;
7502       PushTFtok(TempSym, Type, tokpos) ;
7503       PushTFtok(ProcSym, Type, tokpos) ;
7504       IF NOT IsReturnOptional(ProcSym)
7505       THEN
7506          n := GetSymName(ProcSym) ;
7507          ErrorFormat1(NewError(tokpos),
7508                       'function (%a) is being called but its return value is ignored', n)
7509       END ;
7510       RETURN TRUE
7511    END ;
7512    PushTFtok (ProcSym, Type, tokpos) ;
7513    RETURN FALSE
7514 END CheckBuildFunction ;
7515
7516
7517 (*
7518    BuildFunctionCall - builds a function call.
7519                        The Stack:
7520
7521
7522                        Entry                      Exit
7523
7524                 Ptr ->
7525                        +----------------+
7526                        | NoOfParam      |
7527                        |----------------|
7528                        | Param 1        |
7529                        |----------------|
7530                        | Param 2        |
7531                        |----------------|
7532                        .                .
7533                        .                .
7534                        .                .
7535                        |----------------|
7536                        | Param #        |                        <- Ptr
7537                        |----------------|         +------------+
7538                        | ProcSym | Type |         | ReturnVar  |
7539                        |----------------|         |------------|
7540 *)
7541
7542 PROCEDURE BuildFunctionCall (ConstExpr: BOOLEAN) ;
7543 VAR
7544    paramtok,
7545    combinedtok,
7546    functok,
7547    NoOfParam,
7548    ProcSym    : CARDINAL ;
7549 BEGIN
7550    PopT (NoOfParam) ;
7551    functok  := OperandTtok (NoOfParam + 1) ;
7552    ProcSym := OperandT (NoOfParam + 1) ;
7553    ProcSym := SkipConst (ProcSym) ;
7554    PushT (NoOfParam) ;
7555    (* Compile time stack restored to entry state.  *)
7556    IF IsUnknown (ProcSym)
7557    THEN
7558       paramtok := OperandTtok (1) ;
7559       combinedtok := MakeVirtualTok (functok, functok, paramtok) ;
7560       MetaErrorT1 (functok, 'procedure function {%1Ea} is undefined', ProcSym) ;
7561       PopN (NoOfParam + 2) ;
7562       (* Fake return value to continue compiling.  *)
7563       PushT (MakeConstLit (combinedtok, MakeKey ('0'), NulSym))
7564    ELSIF IsAModula2Type (ProcSym)
7565    THEN
7566       ManipulatePseudoCallParameters ;
7567       BuildTypeCoercion
7568    ELSIF IsPseudoSystemFunction (ProcSym) OR
7569          IsPseudoBaseFunction (ProcSym)
7570    THEN
7571       ManipulatePseudoCallParameters ;
7572       BuildPseudoFunctionCall
7573    ELSE
7574       BuildRealFunctionCall (functok, ConstExpr)
7575    END
7576 END BuildFunctionCall ;
7577
7578
7579 (*
7580    BuildConstFunctionCall - builds a function call and checks that this function can be
7581                             called inside a ConstExpression.
7582
7583                             The Stack:
7584
7585
7586                             Entry                      Exit
7587
7588                      Ptr ->
7589                             +----------------+
7590                             | NoOfParam      |
7591                             |----------------|
7592                             | Param 1        |
7593                             |----------------|
7594                             | Param 2        |
7595                             |----------------|
7596                             .                .
7597                             .                .
7598                             .                .
7599                             |----------------|
7600                             | Param #        |                        <- Ptr
7601                             |----------------|         +------------+
7602                             | ProcSym | Type |         | ReturnVar  |
7603                             |----------------|         |------------|
7604
7605 *)
7606
7607 PROCEDURE BuildConstFunctionCall ;
7608 VAR
7609    functok,
7610    combinedtok,
7611    paramtok,
7612    ConstExpression,
7613    NoOfParam,
7614    ProcSym        : CARDINAL ;
7615 BEGIN
7616    DisplayStack ;
7617    PopT(NoOfParam) ;
7618    ProcSym := OperandT (NoOfParam + 1) ;
7619    functok := OperandTtok (NoOfParam + 1) ;
7620    IF CompilerDebugging
7621    THEN
7622       printf2 ('procsym = %d  token = %d\n', ProcSym, functok) ;
7623       (* ErrorStringAt (InitString ('constant function'), functok).  *)
7624    END ;
7625    PushT (NoOfParam) ;
7626    IF (ProcSym # Convert) AND
7627       (IsPseudoBaseFunction (ProcSym) OR
7628        IsPseudoSystemFunctionConstExpression (ProcSym) OR
7629        (IsProcedure (ProcSym) AND IsProcedureBuiltin (ProcSym)))
7630    THEN
7631       BuildFunctionCall (TRUE)
7632    ELSE
7633       IF IsAModula2Type (ProcSym)
7634       THEN
7635          (* Type conversion.  *)
7636          IF NoOfParam = 1
7637          THEN
7638             ConstExpression := OperandT (NoOfParam + 1) ;
7639             paramtok := OperandTtok (NoOfParam + 1) ;
7640             PopN (NoOfParam + 2) ;
7641             (* Build macro: CONVERT( ProcSym, ConstExpression ).  *)
7642             PushTFtok (Convert, NulSym, functok) ;
7643             PushTtok (ProcSym, functok) ;
7644             PushTtok (ConstExpression, paramtok) ;
7645             PushT (2) ;  (* Two parameters.  *)
7646             BuildConvertFunction
7647          ELSE
7648             MetaErrorT0 (functok, '{%E}a constant type conversion can only have one argument')
7649          END
7650       ELSE
7651          (* Error issue message and fake return stack.  *)
7652          IF Iso
7653          THEN
7654             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')
7655          ELSE
7656             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')
7657          END ;
7658          IF NoOfParam > 0
7659          THEN
7660             paramtok := OperandTtok (NoOfParam + 1) ;
7661             combinedtok := MakeVirtualTok (functok, functok, paramtok)
7662          ELSE
7663             combinedtok := functok
7664          END ;
7665          PopN (NoOfParam+2) ;
7666          PushT (MakeConstLit (combinedtok, MakeKey('0'), NulSym))   (* Fake return value to continue compiling.  *)
7667       END
7668    END
7669 END BuildConstFunctionCall ;
7670
7671
7672 (*
7673    BuildTypeCoercion - builds the type coersion.
7674                        MODULA-2 allows types to be coersed with no runtime
7675                        penility.
7676                        It insists that the TSIZE(t1)=TSIZE(t2) where
7677                        t2 variable := t2(variable of type t1).
7678                        The ReturnVar on the stack is of type t2.
7679
7680                        The Stack:
7681
7682
7683                        Entry                      Exit
7684
7685                 Ptr ->
7686                        +----------------+
7687                        | NoOfParam      |
7688                        |----------------|
7689                        | Param 1        |
7690                        |----------------|
7691                        | Param 2        |
7692                        |----------------|
7693                        .                .
7694                        .                .
7695                        .                .
7696                        |----------------|
7697                        | Param #        |                        <- Ptr
7698                        |----------------|         +------------+
7699                        | ProcSym | Type |         | ReturnVar  |
7700                        |----------------|         |------------|
7701
7702                        Quadruples:
7703
7704                        CoerceOp  ReturnVar  Type  Param1
7705
7706                        A type coercion will only be legal if the different
7707                        types have exactly the same size.
7708                        Since we can only decide this after M2Eval has processed
7709                        the symbol table then we create a quadruple explaining
7710                        the coercion taking place, the code generator can test
7711                        this assertion and report an error if the type sizes
7712                        differ.
7713 *)
7714
7715 PROCEDURE BuildTypeCoercion ;
7716 VAR
7717    resulttok,
7718    proctok,
7719    exptok   : CARDINAL ;
7720    r,
7721    exp,
7722    NoOfParam,
7723    ReturnVar,
7724    ProcSym  : CARDINAL ;
7725 BEGIN
7726    PopT(NoOfParam) ;
7727    ProcSym := OperandT (NoOfParam+1) ;
7728    proctok := OperandTok (NoOfParam+1) ;
7729    IF NOT IsAModula2Type (ProcSym)
7730    THEN
7731       MetaError1 ('coersion expecting a type, seen {%1Ea} which is {%1Ed}', ProcSym)
7732    END ;
7733    IF NoOfParam = 1
7734    THEN
7735       PopTrwtok (exp, r, exptok) ;
7736       MarkAsRead (r) ;
7737       resulttok := MakeVirtualTok (proctok, proctok, exptok) ;
7738       ReturnVar := MakeTemporary (resulttok, RightValue) ;
7739       PutVar (ReturnVar, ProcSym) ;  (* Set ReturnVar's TYPE.  *)
7740       PopN (1) ;   (* Pop procedure.  *)
7741       IF IsConst (exp) OR IsVar (exp)
7742       THEN
7743          GenQuad (CoerceOp, ReturnVar, ProcSym, exp)
7744       ELSE
7745          MetaError2 ('trying to coerse {%1EMRad} which is not a variable or constant into {%2ad}',
7746                      exp, ProcSym) ;
7747          MetaError2 ('trying to coerse {%1ECad} which is not a variable or constant into {%2ad}',
7748                      exp, ProcSym)
7749       END ;
7750       PushTFtok (ReturnVar, ProcSym, resulttok)
7751    ELSE
7752       MetaError0 ('{%E}only one parameter expected in a TYPE coersion')
7753    END
7754 END BuildTypeCoercion ;
7755
7756
7757 (*
7758    BuildRealFunctionCall - builds a function call.
7759                            The Stack:
7760
7761
7762                            Entry                      Exit
7763
7764                     Ptr ->
7765                            +----------------+
7766                            | NoOfParam      |
7767                            |----------------|
7768                            | Param 1        |
7769                            |----------------|
7770                            | Param 2        |
7771                            |----------------|
7772                            .                .
7773                            .                .
7774                            .                .
7775                            |----------------|
7776                            | Param #        |                        <- Ptr
7777                            |----------------|         +------------+
7778                            | ProcSym | Type |         | ReturnVar  |
7779                            |----------------|         |------------|
7780 *)
7781
7782 PROCEDURE BuildRealFunctionCall (tokno: CARDINAL; ConstExpr: BOOLEAN) ;
7783 VAR
7784    NoOfParam,
7785    ProcSym  : CARDINAL ;
7786 BEGIN
7787    PopT(NoOfParam) ;
7788    PushT(NoOfParam) ;
7789    ProcSym := OperandT (NoOfParam+2) ;
7790    ProcSym := SkipConst (ProcSym) ;
7791    IF IsVar(ProcSym)
7792    THEN
7793       (* Procedure Variable therefore get its type to see if it is a FOR "C" call.  *)
7794       ProcSym := SkipType (OperandF (NoOfParam+2))
7795    END ;
7796    IF IsDefImp (GetScope (ProcSym)) AND IsDefinitionForC (GetScope (ProcSym))
7797    THEN
7798       BuildRealFuncProcCall (tokno, TRUE, TRUE, ConstExpr)
7799    ELSE
7800       BuildRealFuncProcCall (tokno, TRUE, FALSE, ConstExpr)
7801    END
7802 END BuildRealFunctionCall ;
7803
7804
7805 (*
7806    BuildPseudoFunctionCall - builds the pseudo function
7807                              The Stack:
7808
7809
7810                              Entry                      Exit
7811
7812                       Ptr ->
7813                              +----------------+
7814                              | NoOfParam      |
7815                              |----------------|
7816                              | Param 1        |
7817                              |----------------|
7818                              | Param 2        |
7819                              |----------------|
7820                              .                .
7821                              .                .
7822                              .                .
7823                              |----------------|
7824                              | Param #        |                        <- Ptr
7825                              |----------------|         +------------+
7826                              | ProcSym | Type |         | ReturnVar  |
7827                              |----------------|         |------------|
7828
7829 *)
7830
7831 PROCEDURE BuildPseudoFunctionCall ;
7832 VAR
7833    NoOfParam,
7834    ProcSym  : CARDINAL ;
7835 BEGIN
7836    PopT (NoOfParam) ;
7837    ProcSym := OperandT (NoOfParam+1) ;
7838    ProcSym := SkipConst (ProcSym) ;
7839    PushT (NoOfParam) ;
7840    (* Compile time stack restored to entry state *)
7841    IF ProcSym = High
7842    THEN
7843       BuildHighFunction
7844    ELSIF ProcSym = LengthS
7845    THEN
7846       BuildLengthFunction
7847    ELSIF ProcSym = Adr
7848    THEN
7849       BuildAdrFunction
7850    ELSIF ProcSym = Size
7851    THEN
7852       BuildSizeFunction
7853    ELSIF ProcSym = TSize
7854    THEN
7855       BuildTSizeFunction
7856    ELSIF ProcSym = TBitSize
7857    THEN
7858       BuildTBitSizeFunction
7859    ELSIF ProcSym = Convert
7860    THEN
7861       BuildConvertFunction
7862    ELSIF ProcSym = Odd
7863    THEN
7864       BuildOddFunction
7865    ELSIF ProcSym = Abs
7866    THEN
7867       BuildAbsFunction
7868    ELSIF ProcSym = Cap
7869    THEN
7870       BuildCapFunction
7871    ELSIF ProcSym = Val
7872    THEN
7873       BuildValFunction
7874    ELSIF ProcSym = Chr
7875    THEN
7876       BuildChrFunction
7877    ELSIF IsOrd (ProcSym)
7878    THEN
7879       BuildOrdFunction (ProcSym)
7880    ELSIF IsInt (ProcSym)
7881    THEN
7882       BuildIntFunction (ProcSym)
7883    ELSIF IsTrunc (ProcSym)
7884    THEN
7885       BuildTruncFunction (ProcSym)
7886    ELSIF IsFloat (ProcSym)
7887    THEN
7888       BuildFloatFunction (ProcSym)
7889    ELSIF ProcSym = Min
7890    THEN
7891       BuildMinFunction
7892    ELSIF ProcSym = Max
7893    THEN
7894       BuildMaxFunction
7895    ELSIF ProcSym = AddAdr
7896    THEN
7897       BuildAddAdrFunction
7898    ELSIF ProcSym = SubAdr
7899    THEN
7900       BuildSubAdrFunction
7901    ELSIF ProcSym = DifAdr
7902    THEN
7903       BuildDifAdrFunction
7904    ELSIF ProcSym = Cast
7905    THEN
7906       BuildCastFunction
7907    ELSIF ProcSym = Shift
7908    THEN
7909       BuildShiftFunction
7910    ELSIF ProcSym = Rotate
7911    THEN
7912       BuildRotateFunction
7913    ELSIF ProcSym = MakeAdr
7914    THEN
7915       BuildMakeAdrFunction
7916    ELSIF ProcSym = Re
7917    THEN
7918       BuildReFunction
7919    ELSIF ProcSym = Im
7920    THEN
7921       BuildImFunction
7922    ELSIF ProcSym = Cmplx
7923    THEN
7924       BuildCmplxFunction
7925    ELSE
7926       InternalError  ('pseudo function not implemented yet')
7927    END
7928 END BuildPseudoFunctionCall ;
7929
7930
7931 (*
7932    BuildAddAdrFunction - builds the pseudo procedure call ADDADR.
7933
7934                          PROCEDURE ADDADR (addr: ADDRESS; offset: CARDINAL): ADDRESS ;
7935
7936                          Which returns address given by (addr + offset),
7937                          [ the standard says that it _may_
7938                            "raise an exception if this address is not valid."
7939                            currently we do not generate any exception code ]
7940
7941                          The Stack:
7942
7943                          Entry                      Exit
7944
7945                   Ptr ->
7946                          +----------------+
7947                          | NoOfParam      |
7948                          |----------------|
7949                          | Param 1        |
7950                          |----------------|
7951                          | Param 2        |                        <- Ptr
7952                          |----------------|         +------------+
7953                          | ProcSym | Type |         | ReturnVar  |
7954                          |----------------|         |------------|
7955 *)
7956
7957 PROCEDURE BuildAddAdrFunction ;
7958 VAR
7959    combinedtok,
7960    functok,
7961    optok      : CARDINAL ;
7962    ReturnVar,
7963    NoOfParam,
7964    OperandSym,
7965    VarSym     : CARDINAL ;
7966 BEGIN
7967    PopT (NoOfParam) ;
7968    functok := OperandTtok (NoOfParam + 1) ;
7969    IF NoOfParam=2
7970    THEN
7971       VarSym := OperandT (2) ;
7972       OperandSym := OperandT (1) ;
7973       optok := OperandTok (1) ;
7974       combinedtok := MakeVirtualTok (functok, functok, optok) ;
7975       PopN (NoOfParam + 1) ;
7976       IF IsVar (VarSym)
7977       THEN
7978          IF IsReallyPointer (VarSym) OR (GetSType (VarSym) = Address)
7979          THEN
7980             ReturnVar := MakeTemporary (combinedtok, RightValue) ;
7981             PutVar (ReturnVar, Address) ;
7982             GenQuad (AddOp, ReturnVar, VarSym, DereferenceLValue (optok, OperandSym)) ;
7983             PushTFtok (ReturnVar, Address, combinedtok)
7984          ELSE
7985             MetaErrorT1 (functok,
7986                          'the first parameter to ADDADR {%1Ea} must be a variable of type ADDRESS or a {%EkPOINTER}, rather than a {%1Etsd}',
7987                          VarSym) ;
7988             PushTFtok (MakeConstLit (combinedtok, MakeKey('0'), Address), Address, combinedtok)
7989          END
7990       ELSE
7991          MetaErrorT0 (functok, '{%E}SYSTEM procedure ADDADR expects a variable of type ADDRESS or POINTER as its first parameter') ;
7992          PushTFtok (MakeConstLit (combinedtok, MakeKey('0'), Address), Address, combinedtok)
7993       END
7994    ELSE
7995       MetaErrorT0 (functok, '{%E}SYSTEM procedure ADDADR expects 2 parameters') ;
7996       PopN (NoOfParam + 1) ;
7997       PushTFtok (MakeConstLit (functok, MakeKey ('0'), Address), Address, functok)
7998    END
7999 END BuildAddAdrFunction ;
8000
8001
8002 (*
8003    BuildSubAdrFunction - builds the pseudo procedure call ADDADR.
8004
8005                          PROCEDURE SUBADR (addr: ADDRESS; offset: CARDINAL): ADDRESS ;
8006
8007                          Which returns address given by (addr - offset),
8008                          [ the standard says that it _may_
8009                            "raise an exception if this address is not valid."
8010                            currently we do not generate any exception code ]
8011
8012                          The Stack:
8013
8014                          Entry                      Exit
8015
8016                   Ptr ->
8017                          +----------------+
8018                          | NoOfParam      |
8019                          |----------------|
8020                          | Param 1        |
8021                          |----------------|
8022                          | Param 2        |                        <- Ptr
8023                          |----------------|         +------------+
8024                          | ProcSym | Type |         | ReturnVar  |
8025                          |----------------|         |------------|
8026 *)
8027
8028 PROCEDURE BuildSubAdrFunction ;
8029 VAR
8030    functok,
8031    combinedtok,
8032    optok,
8033    vartok     : CARDINAL ;
8034    ReturnVar,
8035    NoOfParam,
8036    OperandSym,
8037    VarSym     : CARDINAL ;
8038 BEGIN
8039    PopT (NoOfParam) ;
8040    functok := OperandTtok (NoOfParam + 1) ;
8041    OperandSym := OperandT (1) ;
8042    optok := OperandTok (1) ;
8043    IF NoOfParam = 2
8044    THEN
8045       VarSym := OperandT (2) ;
8046       vartok := OperandTok (2) ;
8047       combinedtok := MakeVirtualTok (functok, functok, optok) ;
8048       PopN (NoOfParam + 1) ;
8049       IF IsVar (VarSym)
8050       THEN
8051          IF IsReallyPointer (VarSym) OR (GetSType (VarSym) = Address)
8052          THEN
8053             ReturnVar := MakeTemporary (combinedtok, RightValue) ;
8054             PutVar (ReturnVar, Address) ;
8055             GenQuad (SubOp, ReturnVar, VarSym, DereferenceLValue (optok, OperandSym)) ;
8056             PushTFtok (ReturnVar, Address, combinedtok)
8057          ELSE
8058             MetaErrorT1 (functok,
8059                          'the first parameter to {%EkSUBADR} {%1Ea} must be a variable of type ADDRESS or a {%EkPOINTER}, rather than a {%1Etsd}',
8060                          VarSym) ;
8061             PushTFtok (MakeConstLit (vartok, MakeKey('0'), Address), Address, vartok)
8062          END
8063       ELSE
8064          combinedtok := MakeVirtualTok (functok, functok, optok) ;
8065          MetaErrorT0 (combinedtok,
8066                       '{%E}SYSTEM procedure {%EkSUBADR} expects a variable of type ADDRESS or POINTER as its first parameter') ;
8067          PushTFtok (MakeConstLit (combinedtok, MakeKey ('0'), Address), Address, combinedtok)
8068       END
8069    ELSE
8070       combinedtok := MakeVirtualTok (functok, functok, optok) ;
8071       MetaErrorT0 (functok,
8072                    '{%E}SYSTEM procedure {%EkSUBADR} expects 2 parameters') ;
8073       PopN (NoOfParam+1) ;
8074       PushTFtok (MakeConstLit (combinedtok, MakeKey('0'), Address), Address, combinedtok)
8075    END
8076 END BuildSubAdrFunction ;
8077
8078
8079 (*
8080    BuildDifAdrFunction - builds the pseudo procedure call DIFADR.
8081
8082                          PROCEDURE DIFADR (addr1, addr2: ADDRESS): INTEGER ;
8083
8084                          Which returns address given by (addr1 - addr2),
8085                          [ the standard says that it _may_
8086                            "raise an exception if this address is invalid or
8087                             address space is non-contiguous."
8088                            currently we do not generate any exception code ]
8089
8090                          The Stack:
8091
8092                          Entry                      Exit
8093
8094                   Ptr ->
8095                          +----------------+
8096                          | NoOfParam      |
8097                          |----------------|
8098                          | Param 1        |
8099                          |----------------|
8100                          | Param 2        |                        <- Ptr
8101                          |----------------|         +------------+
8102                          | ProcSym | Type |         | ReturnVar  |
8103                          |----------------|         |------------|
8104 *)
8105
8106 PROCEDURE BuildDifAdrFunction ;
8107 VAR
8108    functok,
8109    optok,
8110    vartok,
8111    combinedtok: CARDINAL ;
8112    TempVar,
8113    NoOfParam,
8114    OperandSym,
8115    VarSym     : CARDINAL ;
8116 BEGIN
8117    PopT (NoOfParam) ;
8118    functok := OperandTtok (NoOfParam + 1) ;
8119    OperandSym := OperandT (1) ;
8120    optok := OperandTok (1) ;
8121    IF NoOfParam = 2
8122    THEN
8123       VarSym := OperandT (2) ;
8124       vartok := OperandTok (2) ;
8125       combinedtok := MakeVirtualTok (functok, functok, optok) ;
8126       PopN (NoOfParam + 1) ;
8127       IF IsVar (VarSym)
8128       THEN
8129          IF IsReallyPointer (VarSym) OR (GetSType (VarSym) = Address)
8130          THEN
8131             IF IsReallyPointer (OperandSym) OR (GetSType (OperandSym) = Address)
8132             THEN
8133                TempVar := MakeTemporary (vartok, RightValue) ;
8134                PutVar (TempVar, Address) ;
8135                GenQuad (SubOp, TempVar, VarSym, DereferenceLValue (optok, OperandSym)) ;
8136                (*
8137                   Build macro: CONVERT( INTEGER, TempVar )
8138                *)
8139                PushTFtok (Convert, NulSym, functok) ;
8140                PushTtok (Integer, functok) ;
8141                PushTtok (TempVar, vartok) ;
8142                PushT (2) ;          (* Two parameters *)
8143                BuildConvertFunction
8144             ELSE
8145                MetaError1 ('the second parameter to {%EkDIFADR} {%1Ea} must be a variable of type ADDRESS or a {%EkPOINTER}, rather than a {%1Etsd}',
8146                            OperandSym) ;
8147                PushTFtok (MakeConstLit (combinedtok, MakeKey ('0'), Integer), Integer, combinedtok)
8148             END
8149          ELSE
8150             MetaErrorT1 (vartok,
8151                          'the first parameter to {%EkDIFADR} {%1Ea} must be a variable of type ADDRESS or a {%EkPOINTER}, rather than a {%1Etsd}',
8152                          VarSym) ;
8153             PushTFtok (MakeConstLit (combinedtok, MakeKey ('0'), Integer), Integer, combinedtok)
8154          END
8155       ELSE
8156          MetaError0 ('{%E}SYSTEM procedure {%EkDIFADR} expects a variable of type ADDRESS or POINTER as its first parameter') ;
8157          PushTFtok (MakeConstLit (combinedtok, MakeKey('0'), Integer), Integer, combinedtok)
8158       END
8159    ELSE
8160       combinedtok := MakeVirtualTok (functok, functok, optok) ;
8161       MetaErrorT0 (functok, '{%E}SYSTEM procedure {%EkDIFADR} expects 2 parameters') ;
8162       PopN (NoOfParam+1) ;
8163       PushTFtok (MakeConstLit (combinedtok, MakeKey('0'), Integer), Integer, combinedtok)
8164    END
8165 END BuildDifAdrFunction ;
8166
8167
8168 (*
8169    BuildHighFunction - checks the stack in preparation for generating
8170                        quadruples which perform HIGH.
8171                        This procedure does not alter the stack but
8172                        determines whether, a, in HIGH(a) is an ArraySym
8173                        or UnboundedSym.
8174                        Both cases are different and appropriate quadruple
8175                        generating routines are called.
8176
8177                        The Stack:
8178
8179
8180                        Entry                      Exit
8181
8182                 Ptr ->
8183                        +----------------+
8184                        | NoOfParam      |
8185                        |----------------|
8186                        | Param 1        |
8187                        |----------------|
8188                        | Param 2        |
8189                        |----------------|
8190                        .                .
8191                        .                .
8192                        .                .
8193                        |----------------|
8194                        | Param #        |                        <- Ptr
8195                        |----------------|         +------------+
8196                        | ProcSym | Type |         | ReturnVar  |
8197                        |----------------|         |------------|
8198
8199 *)
8200
8201 PROCEDURE BuildHighFunction ;
8202 VAR
8203    functok,
8204    combinedtok,
8205    paramtok   : CARDINAL ;
8206    ProcSym,
8207    Type,
8208    NoOfParam,
8209    Param      : CARDINAL ;
8210 BEGIN
8211    PopT (NoOfParam) ;
8212    ProcSym := OperandT (NoOfParam+1) ;
8213    functok := OperandTok (NoOfParam + 1) ;
8214    BuildSizeCheckEnd (ProcSym) ;   (* quadruple generation now on *)
8215    IF NoOfParam = 1
8216    THEN
8217       Param := OperandT (1) ;
8218       paramtok := OperandTok (1) ;
8219       combinedtok := MakeVirtualTok (paramtok, functok, paramtok) ;
8220       Type := GetDType (Param) ;
8221       (* Restore stack to original form *)
8222       PushT (NoOfParam) ;
8223       IF (NOT IsVar(Param)) AND (NOT IsConstString(Param)) AND (NOT IsConst(Param))
8224       THEN
8225          (* we cannot test for IsConst(Param) AND (GetSType(Param)=Char)  as the type might not be assigned yet *)
8226          MetaError1 ('base procedure {%EkHIGH} expects a variable or string constant as its parameter {%1d:rather than {%1d}} {%1asa}', Param)
8227       ELSIF IsUnbounded(Type)
8228       THEN
8229          BuildHighFromUnbounded (combinedtok)
8230       ELSE
8231          BuildConstHighFromSym (combinedtok)
8232       END
8233    ELSE
8234       MetaError0 ('base procedure {%EkHIGH} requires one parameter') ;
8235       PopN (2) ;
8236       PushTFtok (MakeConstLit (functok, MakeKey ('0'), Cardinal), Cardinal, functok)
8237    END
8238 END BuildHighFunction ;
8239
8240
8241 (*
8242    BuildConstHighFromSym - builds the pseudo function HIGH from an Sym.
8243                            Sym is a constant or an array which has constant bounds
8244                            and therefore it can be calculated at compile time.
8245
8246                            The Stack:
8247
8248
8249                            Entry                      Exit
8250
8251                    Ptr ->
8252                            +----------------+
8253                            | NoOfParam      |
8254                            |----------------|
8255                            | Param 1        |
8256                            |----------------|
8257                            | Param 2        |
8258                            |----------------|
8259                            .                .
8260                            .                .
8261                            .                .
8262                            |----------------|
8263                            | Param #        |                        <- Ptr
8264                            |----------------|         +------------+
8265                            | ProcSym | Type |         | ReturnVar  |
8266                            |----------------|         |------------|
8267 *)
8268
8269 PROCEDURE BuildConstHighFromSym (tok: CARDINAL) ;
8270 VAR
8271    NoOfParam,
8272    ReturnVar: CARDINAL ;
8273 BEGIN
8274    PopT (NoOfParam) ;
8275    ReturnVar := MakeTemporary (tok, ImmediateValue) ;
8276    GenHigh (tok, ReturnVar, 1, OperandT (1)) ;
8277    PopN (NoOfParam+1) ;
8278    PushTtok (ReturnVar, tok)
8279 END BuildConstHighFromSym ;
8280
8281
8282 (*
8283    BuildHighFromUnbounded - builds the pseudo function HIGH from an
8284                             UnboundedSym.
8285
8286                             The Stack:
8287
8288
8289                             Entry                      Exit
8290
8291                      Ptr ->
8292                             +----------------+
8293                             | NoOfParam      |
8294                             |----------------|
8295                             | Param #        |                        <- Ptr
8296                             |----------------|         +------------+
8297                             | ProcSym | Type |         | ReturnVar  |
8298                             |----------------|         |------------|
8299
8300 *)
8301
8302 PROCEDURE BuildHighFromUnbounded (tok: CARDINAL) ;
8303 VAR
8304    Dim,
8305    NoOfParam,
8306    ReturnVar: CARDINAL ;
8307 BEGIN
8308    PopT (NoOfParam) ;
8309    Assert (NoOfParam=1) ;
8310    ReturnVar := MakeTemporary (tok, RightValue) ;
8311    PutVar (ReturnVar, Cardinal) ;
8312    Dim := OperandD (1) ;
8313    INC (Dim) ;
8314    IF Dim > 1
8315    THEN
8316       GenHigh (tok, ReturnVar, Dim, OperandA(1))
8317    ELSE
8318       GenHigh (tok, ReturnVar, Dim, OperandT(1))
8319    END ;
8320    PopN (2) ;
8321    PushTFtok (ReturnVar, GetSType(ReturnVar), tok)
8322 END BuildHighFromUnbounded ;
8323
8324
8325 (*
8326    GetQualidentImport - returns the symbol as if it were qualified from, module.n.
8327                         This is used to reference runtime support procedures and an
8328                         error is generated if the symbol cannot be obtained.
8329 *)
8330
8331 PROCEDURE GetQualidentImport (tokno: CARDINAL;
8332                               n: Name; module: Name) : CARDINAL ;
8333 VAR
8334    ModSym: CARDINAL ;
8335 BEGIN
8336    ModSym := MakeDefinitionSource (tokno, module) ;
8337    IF ModSym=NulSym
8338    THEN
8339       MetaErrorNT2 (tokno,
8340                     'module %a cannot be found and is needed to import %a', module, n) ;
8341       FlushErrors ;
8342       RETURN NulSym
8343    END ;
8344    Assert(IsDefImp(ModSym)) ;
8345    IF (GetExported (tokno, ModSym, n)=NulSym) OR IsUnknown (GetExported (tokno, ModSym, n))
8346    THEN
8347       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',
8348                    module, n) ;
8349       FlushErrors ;
8350       RETURN NulSym
8351    END ;
8352    RETURN GetExported (tokno, MakeDefinitionSource (tokno, module), n)
8353 END GetQualidentImport ;
8354
8355
8356 (*
8357    MakeLengthConst - creates a constant which contains the length of string, sym.
8358 *)
8359
8360 PROCEDURE MakeLengthConst (tok: CARDINAL; sym: CARDINAL) : CARDINAL ;
8361 BEGIN
8362    RETURN MakeConstant (tok, GetStringLength (sym))
8363 END MakeLengthConst ;
8364
8365
8366 (*
8367    BuildLengthFunction - builds the inline standard function LENGTH.
8368
8369                          The Stack:
8370
8371
8372                          Entry                      Exit
8373
8374                   Ptr ->
8375                          +----------------+
8376                          | NoOfParam      |
8377                          |----------------|
8378                          | Param 1        |                        <- Ptr
8379                          |----------------|         +------------+
8380                          | ProcSym | Type |         | ReturnVar  |
8381                          |----------------|         |------------|
8382
8383 *)
8384
8385 PROCEDURE BuildLengthFunction ;
8386 VAR
8387    combinedtok,
8388    paramtok,
8389    functok    : CARDINAL ;
8390    ProcSym,
8391    Type,
8392    NoOfParam,
8393    Param,
8394    ReturnVar  : CARDINAL ;
8395 BEGIN
8396    PopT (NoOfParam) ;
8397    Param := OperandT (1) ;
8398    paramtok := OperandTok (1) ;
8399    functok := OperandTok (NoOfParam + 1) ;
8400    (* Restore stack to origional form *)
8401    PushT (NoOfParam) ;
8402    Type := GetSType (Param) ;  (* get the type from the symbol, not the stack *)
8403    IF NoOfParam # 1
8404    THEN
8405       MetaErrorT1 (functok, 'base procedure {%1EkLENGTH} expects 1 parameter, seen {%1n} parameters', NoOfParam)
8406    END ;
8407    IF NoOfParam >= 1
8408    THEN
8409       combinedtok := MakeVirtualTok (paramtok, functok, paramtok) ;
8410       IF IsConst (Param) AND (GetSType (Param) = Char)
8411       THEN
8412          PopT (NoOfParam) ;
8413          PopN (NoOfParam + 1) ;
8414          ReturnVar := MakeConstLit (combinedtok, MakeKey ('1'), Cardinal) ;
8415          PushTtok (ReturnVar, combinedtok)
8416       ELSIF IsConstString (Param)
8417       THEN
8418          PopT (NoOfParam) ;
8419          ReturnVar := MakeLengthConst (combinedtok, OperandT (1)) ;
8420          PopN (NoOfParam + 1) ;
8421          PushTtok (ReturnVar, combinedtok)
8422       ELSE
8423          ProcSym := GetQualidentImport (functok, MakeKey ('Length'), MakeKey ('M2RTS')) ;
8424          IF (ProcSym # NulSym) AND IsProcedure (ProcSym)
8425          THEN
8426             PopT (NoOfParam) ;
8427             IF IsConst (OperandT (1))
8428             THEN
8429                (* we can fold this in M2GenGCC.  *)
8430                ReturnVar := MakeTemporary (combinedtok, ImmediateValue) ;
8431                PutVar (ReturnVar, Cardinal) ;
8432                GenQuad (StandardFunctionOp, ReturnVar, ProcSym, OperandT (1)) ;
8433                PopN (NoOfParam + 1) ;
8434                PushTtok (ReturnVar, combinedtok)
8435             ELSE
8436                (* no we must resolve this at runtime or in the GCC optimizer.  *)
8437                PopTF (Param, Type);
8438                PopN (NoOfParam) ;
8439                PushTtok (ProcSym, functok) ;
8440                PushTFtok (Param, Type, paramtok) ;
8441                PushT (NoOfParam) ;
8442                BuildRealFunctionCall (functok, FALSE)
8443             END
8444          ELSE
8445             PopT (NoOfParam) ;
8446             PopN (NoOfParam + 1) ;
8447             PushTtok (MakeConstLit (combinedtok, MakeKey ('0'), Cardinal), combinedtok) ;
8448             MetaErrorT0 (functok, 'no procedure Length found for substitution to the standard function {%1EkLENGTH} which is required to calculate non constant string lengths')
8449          END
8450       END
8451    ELSE
8452       (* NoOfParam is _very_ wrong, we flush all outstanding errors *)
8453       FlushErrors
8454    END
8455 END BuildLengthFunction ;
8456
8457
8458 (*
8459    BuildOddFunction - builds the pseudo procedure call ODD.
8460                       This procedure is actually a "macro" for
8461                       ORD(x) --> VAL(BOOLEAN, x MOD 2)
8462                       However we cannot push tokens back onto the input stack
8463                       because the compiler is currently building a function
8464                       call and expecting a ReturnVar on the stack.
8465                       Hence we manipulate the stack and call
8466                       BuildConvertFunction.
8467
8468                       The Stack:
8469
8470
8471                       Entry                      Exit
8472
8473                Ptr ->
8474                       +----------------+
8475                       | NoOfParam      |
8476                       |----------------|
8477                       | Param 1        |
8478                       |----------------|
8479                       | Param 2        |
8480                       |----------------|
8481                       .                .
8482                       .                .
8483                       .                .
8484                       |----------------|
8485                       | Param #        |
8486                       |----------------|
8487                       | ProcSym | Type |         Empty
8488                       |----------------|
8489 *)
8490
8491 PROCEDURE BuildOddFunction ;
8492 VAR
8493    combinedtok,
8494    optok,
8495    functok    : CARDINAL ;
8496    NoOfParam,
8497    Res, Var   : CARDINAL ;
8498 BEGIN
8499    PopT (NoOfParam) ;
8500    functok := OperandTok (NoOfParam + 1) ;
8501    IF NoOfParam=1
8502    THEN
8503       Var := OperandT (1) ;
8504       optok := OperandTok (1) ;
8505       combinedtok := MakeVirtualTok (functok, functok, optok) ;
8506       IF IsVar(Var) OR IsConst(Var)
8507       THEN
8508          PopN (NoOfParam + 1) ;
8509          (*
8510             Build macro: VAL(BOOLEAN, (x MOD 2))
8511          *)
8512
8513          (* compute (x MOD 2) *)
8514          PushTFtok (Var, GetSType (Var), optok) ;
8515          PushT (ModTok) ;
8516          PushTFtok (MakeConstLit (optok, MakeKey ('2'), ZType), ZType, optok) ;
8517          BuildBinaryOp ;
8518          PopT (Res) ;
8519
8520          (* compute IF ...=0 *)
8521          PushTtok (Res, optok) ;
8522          PushT (EqualTok) ;
8523          PushTFtok (MakeConstLit (optok, MakeKey ('0'), ZType), ZType, optok) ;
8524          BuildRelOp (combinedtok) ;
8525          BuildThenIf ;
8526
8527          Res := MakeTemporary (combinedtok, RightValue) ;
8528          PutVar (Res, Boolean) ;
8529
8530          PushTtok (Res, combinedtok) ;
8531          PushTtok (False, combinedtok) ;
8532          BuildAssignment (combinedtok) ;
8533          BuildElse ;
8534          PushTtok (Res, combinedtok) ;
8535          PushTtok (True, combinedtok) ;
8536          BuildAssignment (combinedtok) ;
8537          BuildEndIf ;
8538
8539          PushTtok (Res, combinedtok)
8540       ELSE
8541          MetaErrorT1 (optok,
8542                       'the parameter to {%1EkODD} must be a variable or constant, seen {%1ad}',
8543                       Var) ;
8544          PushTtok (False, combinedtok)
8545       END
8546    ELSE
8547       MetaErrorT1 (functok,
8548                    'the pseudo procedure {%E1kODD} only has one parameter, seen {%1n} parameters',
8549                    NoOfParam) ;
8550       PushTtok (False, functok)
8551    END
8552 END BuildOddFunction ;
8553
8554
8555 (*
8556    BuildAbsFunction - builds a call to the standard function ABS.
8557
8558                       We cannot implement it as a macro or inline an
8559                       IF THEN statement as the IF THEN ELSE requires
8560                       we write the value to the same variable (or constant)
8561                       twice. The macro implementation will fail as
8562                       the compiler maybe building a function
8563                       call and expecting a ReturnVar on the stack.
8564                       The only method to implement this is to pass it to the
8565                       gcc backend.
8566
8567                       The Stack:
8568
8569
8570                       Entry                      Exit
8571
8572                Ptr ->
8573                       +----------------+
8574                       | NoOfParam      |
8575                       |----------------|
8576                       | Param 1        |
8577                       |----------------|
8578                       | Param 2        |
8579                       |----------------|
8580                       .                .
8581                       .                .
8582                       .                .
8583                       |----------------|
8584                       | Param #        |
8585                       |----------------|
8586                       | ProcSym | Type |         Empty
8587                       |----------------|
8588 *)
8589
8590 PROCEDURE BuildAbsFunction ;
8591 VAR
8592    vartok,
8593    functok,
8594    combinedtok: CARDINAL ;
8595    NoOfParam,
8596    ProcSym,
8597    Res, Var : CARDINAL ;
8598 BEGIN
8599    PopT (NoOfParam) ;
8600    functok := OperandTok (NoOfParam + 1) ;
8601    IF NoOfParam = 1
8602    THEN
8603       Var := OperandT (1) ;
8604       vartok := OperandTok (1) ;
8605       combinedtok := MakeVirtualTok (functok, functok, vartok) ;
8606       IF IsVar(Var) OR IsConst(Var)
8607       THEN
8608          ProcSym := OperandT (NoOfParam + 1) ;
8609          PopN (NoOfParam + 1) ;
8610
8611          Res := MakeTemporary (combinedtok, AreConstant (IsConst (Var))) ;
8612          PutVar (Res, GetSType (Var)) ;
8613
8614          GenQuadO (combinedtok, StandardFunctionOp, Res, ProcSym, Var, FALSE) ;
8615          PushTFtok (Res, GetSType (Var), combinedtok)
8616       ELSE
8617          MetaErrorT1 (vartok,
8618                       'the parameter to {%AkABS} must be a variable or constant, seen {%1ad}',
8619                       Var)
8620       END
8621    ELSE
8622       MetaErrorT1 (functok,
8623                    'the pseudo procedure {%AkABS} only has one parameter, seen {%1n} parameters',
8624                    NoOfParam)
8625    END
8626 END BuildAbsFunction ;
8627
8628
8629 (*
8630    BuildCapFunction - builds the pseudo procedure call CAP.
8631                       We generate a the following quad:
8632
8633
8634                       StandardFunctionOp  ReturnVal  Cap  Param1
8635
8636                       The Stack:
8637
8638
8639                       Entry                      Exit
8640
8641                Ptr ->
8642                       +----------------+
8643                       | NoOfParam = 1  |
8644                       |----------------|
8645                       | Param 1        |
8646                       |----------------|         +-------------+
8647                       | ProcSym | Type |         | ReturnVal   |
8648                       |----------------|         |-------------|
8649 *)
8650
8651 PROCEDURE BuildCapFunction ;
8652 VAR
8653    optok,
8654    functok,
8655    combinedtok: CARDINAL ;
8656    NoOfParam,
8657    ProcSym,
8658    Res, Var : CARDINAL ;
8659 BEGIN
8660    PopT (NoOfParam) ;
8661    functok := OperandTok (NoOfParam + 1) ;
8662    IF NoOfParam = 1
8663    THEN
8664       Var := OperandT (1) ;
8665       optok := OperandTok (1) ;
8666       IF IsVar (Var) OR IsConst (Var)
8667       THEN
8668          ProcSym := OperandT (NoOfParam + 1) ;
8669          PopN (NoOfParam + 1) ;
8670
8671          combinedtok := MakeVirtualTok (functok, functok, optok) ;
8672          Res := MakeTemporary (combinedtok, AreConstant (IsConst (Var))) ;
8673          PutVar (Res, Char) ;
8674          GenQuadO (combinedtok, StandardFunctionOp, Res, ProcSym, Var, FALSE) ;
8675          PushTFtok (Res, Char, combinedtok)
8676       ELSE
8677          MetaErrorT1 (optok,
8678                       'the parameter to {%AkCAP} must be a variable or constant, seen {%1ad}',
8679                       Var)
8680       END
8681    ELSE
8682       MetaErrorT1 (functok,
8683                    'the pseudo procedure {%AkCAP} only has one parameter, seen {%1n} parameters',
8684                    NoOfParam)
8685    END
8686 END BuildCapFunction ;
8687
8688
8689 (*
8690    BuildChrFunction - builds the pseudo procedure call CHR.
8691                       This procedure is actually a "macro" for
8692                       CHR(x) --> CONVERT(CHAR, x)
8693                       However we cannot push tokens back onto the input stack
8694                       because the compiler is currently building a function
8695                       call and expecting a ReturnVar on the stack.
8696                       Hence we manipulate the stack and call
8697                       BuildConvertFunction.
8698
8699                       The Stack:
8700
8701
8702                       Entry                      Exit
8703
8704                Ptr ->
8705                       +----------------+
8706                       | NoOfParam      |
8707                       |----------------|
8708                       | Param 1        |
8709                       |----------------|
8710                       | Param 2        |
8711                       |----------------|
8712                       .                .
8713                       .                .
8714                       .                .
8715                       |----------------|
8716                       | Param #        |
8717                       |----------------|
8718                       | ProcSym | Type |         Empty
8719                       |----------------|
8720 *)
8721
8722 PROCEDURE BuildChrFunction ;
8723 VAR
8724    functok,
8725    optok      : CARDINAL ;
8726    NoOfParam,
8727    Var        : CARDINAL ;
8728 BEGIN
8729    PopT (NoOfParam) ;
8730    functok := OperandTok (NoOfParam + 1) ;
8731    IF NoOfParam = 1
8732    THEN
8733       Var := OperandT (1) ;
8734       optok := OperandTok (1) ;
8735       IF IsVar (Var) OR IsConst (Var)
8736       THEN
8737          PopN (NoOfParam + 1) ;
8738          (*
8739             Build macro: CONVERT( CHAR, Var )
8740          *)
8741          PushTFtok (Convert, NulSym, functok) ;
8742          PushTtok (Char, functok) ;
8743          PushTtok (Var, optok) ;
8744          PushT (2) ;          (* Two parameters *)
8745          BuildConvertFunction
8746       ELSE
8747          MetaErrorT1 (optok,
8748                       'the parameter to {%AkCHR} must be a variable or constant, seen {%1ad}',
8749                       Var)
8750       END
8751    ELSE
8752       MetaErrorT1 (functok,
8753                    'the pseudo procedure {%AkCHR} only has one parameter, seen {%1n} parameters',
8754                    NoOfParam)
8755    END
8756 END BuildChrFunction ;
8757
8758
8759 (*
8760    BuildOrdFunction - builds the pseudo procedure call ORD.
8761                       This procedure is actually a "macro" for
8762                       ORD(x) --> CONVERT(GetSType(sym), x)
8763                       However we cannot push tokens back onto the input stack
8764                       because the compiler is currently building a function
8765                       call and expecting a ReturnVar on the stack.
8766                       Hence we manipulate the stack and call
8767                       BuildConvertFunction.
8768
8769                       The Stack:
8770
8771
8772                       Entry                      Exit
8773
8774                Ptr ->
8775                       +----------------+
8776                       | NoOfParam      |
8777                       |----------------|
8778                       | Param 1        |
8779                       |----------------|
8780                       | Param 2        |
8781                       |----------------|
8782                       .                .
8783                       .                .
8784                       .                .
8785                       |----------------|
8786                       | Param #        |
8787                       |----------------|
8788                       | ProcSym | Type |         Empty
8789                       |----------------|
8790 *)
8791
8792 PROCEDURE BuildOrdFunction (Sym: CARDINAL) ;
8793 VAR
8794    functok,
8795    optok    : CARDINAL ;
8796    NoOfParam,
8797    Type, Var: CARDINAL ;
8798 BEGIN
8799    PopT (NoOfParam) ;
8800    functok := OperandTok (NoOfParam + 1) ;
8801    IF NoOfParam = 1
8802    THEN
8803       Var := OperandT (1) ;
8804       optok := OperandTok (1) ;
8805       IF IsVar (Var) OR IsConst (Var)
8806       THEN
8807          Type := GetSType (Sym) ;
8808          PopN (NoOfParam + 1) ;
8809          (*
8810             Build macro: CONVERT( CARDINAL, Var )
8811          *)
8812          PushTFtok (Convert, NulSym, functok) ;
8813          PushTtok (Type, optok) ;
8814          PushTtok (Var, optok) ;
8815          PushT (2) ;          (* Two parameters *)
8816          BuildConvertFunction
8817       ELSE
8818          MetaErrorT2 (optok,
8819                       'the parameter to {%1Aa} must be a variable or constant, seen {%2ad}',
8820                       Sym, Var)
8821       END
8822    ELSE
8823       MetaErrorT2 (functok,
8824                    'the pseudo procedure {%1Aa} only has one parameter, seen {%2n} parameters',
8825                    Sym, NoOfParam)
8826    END
8827 END BuildOrdFunction ;
8828
8829
8830 (*
8831    BuildIntFunction - builds the pseudo procedure call INT.
8832                       This procedure is actually a "macro" for
8833                       INT(x) --> CONVERT(INTEGER, x)
8834                       However we cannot push tokens back onto the input stack
8835                       because the compiler is currently building a function
8836                       call and expecting a ReturnVar on the stack.
8837                       Hence we manipulate the stack and call
8838                       BuildConvertFunction.
8839
8840                       The Stack:
8841
8842
8843                       Entry                      Exit
8844
8845                Ptr ->
8846                       +----------------+
8847                       | NoOfParam      |
8848                       |----------------|
8849                       | Param 1        |
8850                       |----------------|
8851                       | Param 2        |
8852                       |----------------|
8853                       .                .
8854                       .                .
8855                       .                .
8856                       |----------------|
8857                       | Param #        |
8858                       |----------------|
8859                       | ProcSym | Type |         Empty
8860                       |----------------|
8861 *)
8862
8863 PROCEDURE BuildIntFunction (Sym: CARDINAL) ;
8864 VAR
8865    combinedtok,
8866    functok,
8867    optok      : CARDINAL ;
8868    NoOfParam,
8869    Type, Var  : CARDINAL ;
8870 BEGIN
8871    PopT (NoOfParam) ;
8872    functok := OperandTok (NoOfParam + 1) ;
8873    IF NoOfParam = 1
8874    THEN
8875       Var := OperandT (1) ;
8876       optok := OperandTok (1) ;
8877       IF IsVar (Var) OR IsConst (Var)
8878       THEN
8879          Type := GetSType (Sym) ;  (* return type of function *)
8880          PopN (NoOfParam + 1) ;
8881          (* Build macro: CONVERT( CARDINAL, Var ).  *)
8882          PushTFtok (Convert, NulSym, functok) ;
8883          PushTtok (Type, functok) ;
8884          PushTtok (Var, optok) ;
8885          PushT (2) ;          (* Two parameters *)
8886          BuildConvertFunction
8887       ELSE
8888          combinedtok := MakeVirtualTok (functok, optok, optok) ;
8889          MetaErrorT2 (optok,
8890                       'the parameter to {%1Ea} must be a variable or constant, seen {%2ad}',
8891                       Sym, Var) ;
8892          PushTtok (combinedtok, MakeConstLit (combinedtok, MakeKey ('0'), ZType))
8893       END
8894    ELSE
8895       MetaErrorT2 (functok,
8896                    'the pseudo procedure {%1Ea} only has one parameter, seen {%2n} parameters',
8897                    Sym, NoOfParam) ;
8898       PushTtok (functok, MakeConstLit (functok, MakeKey ('0'), ZType))
8899    END
8900 END BuildIntFunction ;
8901
8902
8903 (*
8904    BuildMakeAdrFunction - builds the pseudo procedure call MAKEADR.
8905
8906                           The Stack:
8907
8908
8909                           Entry                      Exit
8910
8911                    Ptr ->
8912                           +----------------+
8913                           | NoOfParam      |
8914                           |----------------|
8915                           | Param 1        |
8916                           |----------------|
8917                           | Param 2        |
8918                           |----------------|
8919                           .                .
8920                           .                .
8921                           .                .
8922                           |----------------|
8923                           | Param #        |
8924                           |----------------|
8925                           | ProcSym | Type |         Empty
8926                           |----------------|
8927 *)
8928
8929 PROCEDURE BuildMakeAdrFunction ;
8930 VAR
8931    functok,
8932    starttok,
8933    endtok,
8934    resulttok     : CARDINAL ;
8935    AreConst      : BOOLEAN ;
8936    i, pi,
8937    NoOfParameters: CARDINAL ;
8938    ReturnVar     : CARDINAL ;
8939 BEGIN
8940    PopT (NoOfParameters) ;
8941    functok := OperandTok (NoOfParameters + 1) ;
8942    IF NoOfParameters>0
8943    THEN
8944       starttok := OperandTok (NoOfParameters + 1) ;  (* ADR token.  *)
8945       endtok := OperandTok (1) ;  (* last parameter.  *)
8946       GenQuad (ParamOp, 0, MakeAdr, MakeAdr) ;
8947       i := NoOfParameters ;
8948       (* stack index referencing stacked parameter, i *)
8949       pi := 1 ;
8950       WHILE i > 0 DO
8951          GenQuadO (OperandTok (pi), ParamOp, i, MakeAdr, OperandT (pi), TRUE) ;
8952          DEC (i) ;
8953          INC (pi)
8954       END ;
8955       AreConst := TRUE ;
8956       i := 1 ;
8957       WHILE i <= NoOfParameters DO
8958          IF IsVar (OperandT (i))
8959          THEN
8960             AreConst := FALSE ;
8961          ELSIF NOT IsConst (OperandT (i))
8962          THEN
8963             MetaError1 ('problem in the {%1EN} argument for {%kMAKEADR}, all arguments to {%kMAKEADR} must be either variables or constants', i)
8964          END ;
8965          INC (i)
8966       END ;
8967       (* ReturnVar - will have the type of the procedure *)
8968       resulttok := MakeVirtualTok (starttok, starttok, endtok) ;
8969       ReturnVar := MakeTemporary (resulttok, AreConstant(AreConst)) ;
8970       PutVar (ReturnVar, GetSType(MakeAdr)) ;
8971       GenQuadO (resulttok, FunctValueOp, ReturnVar, NulSym, MakeAdr, TRUE) ;
8972       PopN (NoOfParameters+1) ;
8973       PushTFtok (ReturnVar, GetSType (MakeAdr), resulttok)
8974    ELSE
8975       MetaError1 ('the pseudo procedure {%EkMAKEADR} requires at least one parameter, seen {%1n}', NoOfParameters) ;
8976       PopN (1) ;
8977       PushTFtok (Nil, GetSType (MakeAdr), functok)
8978    END
8979 END BuildMakeAdrFunction ;
8980
8981
8982 (*
8983    BuildShiftFunction - builds the pseudo procedure call SHIFT.
8984
8985                         PROCEDURE SHIFT (val: <any type>;
8986                                          num: INTEGER): <any type> ;
8987
8988                        "Returns a bit sequence obtained from val by
8989                         shifting up or down (left or right) by the
8990                         absolute value of num, introducing
8991                         zeros as necessary.  The direction is down if
8992                         the sign of num is negative, otherwise the
8993                         direction is up."
8994
8995                         The Stack:
8996
8997                         Entry                      Exit
8998
8999                  Ptr ->
9000                         +----------------+
9001                         | NoOfParam      |
9002                         |----------------|
9003                         | Param 1        |
9004                         |----------------|
9005                         | Param 2        |                        <- Ptr
9006                         |----------------|         +------------+
9007                         | ProcSym | Type |         | ReturnVar  |
9008                         |----------------|         |------------|
9009 *)
9010
9011 PROCEDURE BuildShiftFunction ;
9012 VAR
9013    combinedtok,
9014    paramtok,
9015    functok,
9016    vartok,
9017    exptok     : CARDINAL ;
9018    r,
9019    procSym,
9020    returnVar,
9021    NoOfParam,
9022    derefExp,
9023    Exp,
9024    varSet     : CARDINAL ;
9025 BEGIN
9026    PopT (NoOfParam) ;
9027    paramtok := OperandTok (1) ;
9028    functok := OperandTok (NoOfParam + 1) ;
9029    IF NoOfParam=2
9030    THEN
9031       PopTrwtok (Exp, r, exptok) ;
9032       MarkAsRead (r) ;
9033       PopTtok (varSet, vartok) ;
9034       PopT (procSym) ;
9035       combinedtok := MakeVirtualTok (functok, exptok, vartok) ;
9036       IF (GetSType (varSet) # NulSym) AND IsSet (GetDType (varSet))
9037       THEN
9038          derefExp := DereferenceLValue (exptok, Exp) ;
9039          BuildRange (InitShiftCheck (varSet, derefExp)) ;
9040          returnVar := MakeTemporary (combinedtok, RightValue) ;
9041          PutVar (returnVar, GetSType (varSet)) ;
9042          GenQuad (LogicalShiftOp, returnVar, varSet, derefExp) ;
9043          PushTFtok (returnVar, GetSType (varSet), combinedtok)
9044       ELSE
9045          MetaErrorT1 (vartok,
9046                       'SYSTEM procedure {%1EkSHIFT} expects a constant or variable which has a type of SET as its first parameter, seen {%1ad}',
9047                       varSet) ;
9048          PushTFtok (MakeConstLit (combinedtok, MakeKey ('0'), Cardinal), Cardinal, combinedtok)
9049       END
9050    ELSE
9051       combinedtok := MakeVirtualTok (functok, functok, paramtok) ;
9052       MetaErrorT1 (functok,
9053                    'the pseudo procedure {%kSHIFT} requires at least two parameters, seen {%1En}',
9054                    NoOfParam) ;
9055       PopN (NoOfParam + 1) ;
9056       PushTFtok (MakeConstLit (combinedtok, MakeKey ('0'), Cardinal), Cardinal, combinedtok)
9057    END
9058 END BuildShiftFunction ;
9059
9060
9061 (*
9062    BuildRotateFunction - builds the pseudo procedure call ROTATE.
9063
9064                          PROCEDURE ROTATE (val: <any type>;
9065                                            num: INTEGER): <any type> ;
9066
9067                         "Returns a bit sequence obtained from val
9068                          by rotating up or down (left or right) by
9069                          the absolute value of num.  The direction is
9070                          down if the sign of num is negative, otherwise
9071                          the direction is up."
9072
9073                          The Stack:
9074
9075                          Entry                      Exit
9076
9077                   Ptr ->
9078                          +----------------+
9079                          | NoOfParam      |
9080                          |----------------|
9081                          | Param 1        |
9082                          |----------------|
9083                          | Param 2        |                        <- Ptr
9084                          |----------------|         +------------+
9085                          | ProcSym | Type |         | ReturnVar  |
9086                          |----------------|         |------------|
9087 *)
9088
9089 PROCEDURE BuildRotateFunction ;
9090 VAR
9091    combinedtok,
9092    functok,
9093    vartok,
9094    exptok     : CARDINAL ;
9095    r,
9096    procSym,
9097    returnVar,
9098    NoOfParam,
9099    derefExp,
9100    Exp,
9101    varSet     : CARDINAL ;
9102 BEGIN
9103    PopT (NoOfParam) ;
9104    functok := OperandTok (NoOfParam + 1) ;
9105    IF NoOfParam = 2
9106    THEN
9107       PopTrwtok (Exp, r, exptok) ;
9108       MarkAsRead (r) ;
9109       PopTtok (varSet, vartok) ;
9110       PopT (procSym) ;
9111       IF (GetSType (varSet) # NulSym) AND IsSet (GetDType (varSet))
9112       THEN
9113          combinedtok := MakeVirtualTok (functok, functok, exptok) ;
9114          derefExp := DereferenceLValue (exptok, Exp) ;
9115          BuildRange (InitRotateCheck (varSet, derefExp)) ;
9116          returnVar := MakeTemporary (combinedtok, RightValue) ;
9117          PutVar (returnVar, GetSType (varSet)) ;
9118          GenQuadO (combinedtok, LogicalRotateOp, returnVar, varSet, derefExp, TRUE) ;
9119          PushTFtok (returnVar, GetSType (varSet), combinedtok)
9120       ELSE
9121          MetaErrorT1 (vartok,
9122                       'SYSTEM procedure {%EkROTATE} expects a constant or variable which has a type of SET as its first parameter, seen {%1ad}',
9123                       varSet) ;
9124          PushTFtok (MakeConstLit (functok, MakeKey('0'), Cardinal), Cardinal, functok)
9125       END
9126    ELSE
9127       MetaErrorT1 (functok,
9128                    'SYSTEM procedure {%EkROTATE} expects 2 parameters and was given {%1n} parameters',
9129                    NoOfParam) ;
9130       PopN (NoOfParam + 1) ;
9131       PushTFtok (MakeConstLit (functok, MakeKey ('0'), Cardinal), Cardinal, functok)
9132    END
9133 END BuildRotateFunction ;
9134
9135
9136 (*
9137    BuildValFunction - builds the pseudo procedure call VAL.
9138                       This procedure is actually a "macro" for
9139                       VAL(Type, x) --> CONVERT(Type, x)
9140                       However we cannot push tokens back onto the input stack
9141                       because the compiler is currently building a function
9142                       call and expecting a ReturnVar on the stack.
9143                       Hence we manipulate the stack and call
9144                       BuildConvertFunction.
9145
9146                       The Stack:
9147
9148
9149                       Entry                      Exit
9150
9151                Ptr ->
9152                       +----------------+
9153                       | NoOfParam      |
9154                       |----------------|
9155                       | Param 1        |
9156                       |----------------|
9157                       | Param 2        |
9158                       |----------------|
9159                       .                .
9160                       .                .
9161                       .                .
9162                       |----------------|
9163                       | Param #        |
9164                       |----------------|
9165                       | ProcSym | Type |         Empty
9166                       |----------------|
9167 *)
9168
9169 PROCEDURE BuildValFunction ;
9170 VAR
9171    functok  : CARDINAL ;
9172    NoOfParam,
9173    ProcSym,
9174    Exp, Type: CARDINAL ;
9175    tok, r,
9176    typetok,
9177    exptok   : CARDINAL ;
9178 BEGIN
9179    PopT (NoOfParam) ;
9180    functok := OperandTok (NoOfParam + 1) ;
9181    IF NoOfParam = 2
9182    THEN
9183       PopTrwtok (Exp, r, exptok) ;
9184       MarkAsRead (r) ;
9185       PopTtok (Type, typetok) ;
9186       PopTtok (ProcSym, tok) ;
9187       IF IsUnknown (Type)
9188       THEN
9189          (* not sensible to try and recover when we dont know the return type.  *)
9190          MetaErrorT1 (typetok,
9191                       'undeclared type found in builtin procedure function {%AkVAL} {%1ad}',
9192                       Type)
9193          (* non recoverable error.  *)
9194       ELSIF (IsSet (Type) OR IsEnumeration (Type) OR IsSubrange (Type) OR
9195              IsType (Type) OR IsPointer (Type) OR IsProcType (Type)) AND
9196              (IsVar (Exp) OR IsConst (Exp) OR IsProcedure (Exp))
9197       THEN
9198          (*
9199             Build macro: CONVERT( Type, Var )
9200          *)
9201          PushTFtok (Convert, NulSym, tok) ;
9202          PushTtok (Type, typetok) ;
9203          PushTtok (Exp, exptok) ;
9204          PushT (2) ;          (* Two parameters *)
9205          BuildConvertFunction
9206       ELSE
9207          (* not sensible to try and recover when we dont know the return type.  *)
9208          MetaErrorT0 (functok,
9209                       'the builtin procedure {%AkVAL} has the following formal parameter declaration {%kVAL} (type, expression)')
9210          (* non recoverable error.  *)
9211       END
9212    ELSE
9213       (* not sensible to try and recover when we dont know the return type.  *)
9214       MetaErrorT1 (functok,
9215                    'the builtin procedure {%AkVAL} expects 2 parameters, a type and an expression, but was given {%1n} parameters', NoOfParam)
9216       (* non recoverable error.  *)
9217    END
9218 END BuildValFunction ;
9219
9220
9221 (*
9222    BuildCastFunction - builds the pseudo procedure call CAST.
9223                        This procedure is actually a "macro" for
9224                        CAST(Type, x) --> Type(x)
9225                        However we cannot push tokens back onto the input stack
9226                        because the compiler is currently building a function
9227                        call and expecting a ReturnVar on the stack.
9228                        Hence we manipulate the stack and call
9229                        BuildConvertFunction.
9230
9231                        The Stack:
9232
9233
9234                        Entry                      Exit
9235
9236                 Ptr ->
9237                        +----------------+
9238                        | NoOfParam      |
9239                        |----------------|
9240                        | Param 1        |
9241                        |----------------|
9242                        | Param 2        |
9243                        |----------------|
9244                        .                .
9245                        .                .
9246                        .                .
9247                        |----------------|
9248                        | Param #        |
9249                        |----------------|
9250                        | ProcSym | Type |         Empty
9251                        |----------------|
9252 *)
9253
9254 PROCEDURE BuildCastFunction ;
9255 VAR
9256    combinedtok,
9257    typetok,
9258    functok,
9259    vartok     : CARDINAL ;
9260    n          : Name ;
9261    ReturnVar,
9262    NoOfParam,
9263    Var, Type  : CARDINAL ;
9264 BEGIN
9265    PopT (NoOfParam) ;
9266    functok := OperandTok (NoOfParam + 1) ;
9267    IF NoOfParam = 2
9268    THEN
9269       Type := OperandT (2) ;
9270       typetok := OperandTok (2) ;
9271       Var := OperandT (1) ;
9272       vartok := OperandTok (1) ;
9273       IF IsUnknown (Type)
9274       THEN
9275          n := GetSymName (Type) ;
9276          WriteFormat1 ('undeclared type found in CAST (%a)', n)
9277       ELSIF IsSet (Type) OR IsEnumeration (Type) OR IsSubrange (Type) OR IsType (Type) OR
9278             IsPointer (Type) OR IsArray (Type) OR IsProcType (Type)
9279       THEN
9280          IF IsConst (Var)
9281          THEN
9282             PopN (NoOfParam+1) ;
9283             (*
9284                Build macro: Type( Var )
9285             *)
9286             PushTFtok (Type, NulSym, typetok) ;
9287             PushTtok (Var, vartok) ;
9288             PushT (1) ;          (* one parameter *)
9289             BuildTypeCoercion
9290          ELSIF IsVar (Var) OR IsProcedure (Var)
9291          THEN
9292             PopN (NoOfParam + 1) ;
9293             combinedtok := MakeVirtualTok (functok, functok, vartok) ;
9294             ReturnVar := MakeTemporary (combinedtok, RightValue) ;
9295             PutVar (ReturnVar, Type) ;
9296             GenQuadO (combinedtok, CastOp, ReturnVar, Type, Var, FALSE) ;
9297             PushTFtok (ReturnVar, Type, combinedtok)
9298          ELSE
9299             (* not sensible to try and recover when we dont know the return type.  *)
9300             MetaErrorT0 (functok,
9301                          'the second parameter to the builtin procedure {%AkCAST} must either be a variable, constant or a procedure.  The formal parameters to cast are {%kCAST} (type, variable or constant or procedure)')
9302             (* non recoverable error.  *)
9303          END
9304       ELSE
9305          (* not sensible to try and recover when we dont know the return type.  *)
9306          MetaErrorT0 (functok,
9307                       'the builtin procedure {%AkCAST} has the following formal parameter declaration {%kCAST} (type, expression)')
9308          (* non recoverable error.  *)
9309       END
9310    ELSE
9311       (* not sensible to try and recover when we dont know the return type.  *)
9312       MetaErrorT1 (functok,
9313                    'the builtin procedure {%AkCAST} `expects 2 parameters, a type and an expression, but was given {%1n} parameters', NoOfParam)
9314       (* non recoverable error.  *)
9315    END
9316 END BuildCastFunction ;
9317
9318
9319 (*
9320    BuildConvertFunction - builds the pseudo function CONVERT.
9321                           CONVERT( Type, Variable ) ;
9322
9323                           The Stack:
9324
9325
9326                           Entry                      Exit
9327
9328                    Ptr ->
9329                           +----------------+
9330                           | NoOfParam      |
9331                           |----------------|
9332                           | Param 1        |
9333                           |----------------|
9334                           | Param 2        |
9335                           |----------------|
9336                           .                .
9337                           .                .
9338                           .                .
9339                           |----------------|
9340                           | Param #        |                                 <- Ptr
9341                           |----------------|         +---------------------+
9342                           | ProcSym | Type |         | ReturnVar | Param1  |
9343                           |----------------|         |---------------------|
9344
9345                           Quadruples:
9346
9347                           ConvertOp  ReturnVar  Param1  Param2
9348
9349                           Converts variable Param2 into a variable Param1
9350                           with a type Param1.
9351 *)
9352
9353 PROCEDURE BuildConvertFunction ;
9354 VAR
9355    combinedtok,
9356    functok,
9357    typetok,
9358    exptok     : CARDINAL ;
9359    t, r,
9360    Exp, Type,
9361    ProcSym,
9362    NoOfParam,
9363    ReturnVar  : CARDINAL ;
9364 BEGIN
9365    PopT (NoOfParam) ;
9366    functok := OperandTok (NoOfParam + 1) ;
9367    IF NoOfParam = 2
9368    THEN
9369       PopTrwtok (Exp, r, exptok) ;
9370       MarkAsRead (r) ;
9371       PopTtok (Type, typetok) ;
9372       PopT (ProcSym) ;
9373       IF IsUnknown (Type)
9374       THEN
9375          (* we cannot recover if we dont have a type.  *)
9376          MetaErrorT1 (typetok, 'undeclared type {%1Aad} found in {%kCONVERT}', Type)
9377          (* non recoverable error.  *)
9378       ELSIF IsUnknown (Exp)
9379       THEN
9380          (* we cannot recover if we dont have a type.  *)
9381          MetaErrorT1 (typetok, 'unknown {%1Ad} {%1ad} found in {%kCONVERT}', Exp)
9382          (* non recoverable error.  *)
9383       ELSIF (IsSet (Type) OR IsEnumeration (Type) OR IsSubrange (Type) OR
9384              IsType (Type) OR IsPointer (Type) OR IsProcType (Type) OR IsRecord (Type)) AND
9385             (IsVar (Exp) OR IsConst (Exp) OR IsProcedure (Exp))
9386       THEN
9387          (* firstly dereference Var *)
9388          IF GetMode (Exp) = LeftValue
9389          THEN
9390             t := MakeTemporary (exptok, RightValue) ;
9391             PutVar (t, GetSType (Exp)) ;
9392             CheckPointerThroughNil (exptok, Exp) ;
9393             doIndrX (exptok, t, Exp) ;
9394             Exp := t
9395          END ;
9396
9397          combinedtok := MakeVirtualTok (functok, functok, exptok) ;
9398          ReturnVar := MakeTemporary (combinedtok, AreConstant (IsConst (Exp))) ;
9399          PutVar (ReturnVar, Type) ;
9400          GenQuadO (combinedtok, ConvertOp, ReturnVar, Type, Exp, TRUE) ;
9401          PushTFtok (ReturnVar, Type, combinedtok)
9402       ELSE
9403          (* not sensible to try and recover when we dont know the return type.  *)
9404          MetaErrorT0 (functok,
9405                       'the builtin procedure {%AkCONVERT} has the following formal parameter declaration {%kCONVERT} (type, expression)')
9406          (* non recoverable error.  *)
9407       END
9408    ELSE
9409       (* not sensible to try and recover when we dont know the return type.  *)
9410       MetaErrorT1 (functok,
9411                    'the builtin procedure {%AkCONVERT} expects 2 parameters, a type and an expression, but was given {%1n} parameters', NoOfParam)
9412       (* non recoverable error.  *)
9413    END
9414 END BuildConvertFunction ;
9415
9416
9417 (*
9418    CheckBaseTypeValue - checks to see whether the value, min, really exists.
9419 *)
9420
9421 PROCEDURE CheckBaseTypeValue (tok: CARDINAL;
9422                               type: CARDINAL;
9423                               min: CARDINAL;
9424                               func: CARDINAL) : CARDINAL ;
9425 BEGIN
9426    IF (type = Real) OR (type = LongReal) OR (type = ShortReal)
9427    THEN
9428       PushValue (min) ;
9429       IF NOT IsValueAndTreeKnown ()
9430       THEN
9431          MetaErrorT2 (tok,
9432                       '{%1Ead} ({%2ad}) cannot be calculated at compile time for the target architecture', func, type) ;
9433          RETURN MakeConstLit (tok, MakeKey ('1.0'), RType)
9434       END
9435    END ;
9436    RETURN min
9437 END CheckBaseTypeValue ;
9438
9439
9440 (*
9441    GetTypeMin - returns the minimium value of type.
9442 *)
9443
9444 PROCEDURE GetTypeMin (tok: CARDINAL; func, type: CARDINAL) : CARDINAL ;
9445 VAR
9446    min, max: CARDINAL ;
9447 BEGIN
9448    IF IsSubrange (type)
9449    THEN
9450       min := MakeTemporary (tok, ImmediateValue) ;
9451       PutVar (min, type) ;
9452       GenQuad (SubrangeLowOp, min, NulSym, type) ;
9453       RETURN min
9454    ELSIF IsSet (SkipType (type))
9455    THEN
9456       RETURN GetTypeMin (tok, func, GetSType (SkipType (type)))
9457    ELSIF IsBaseType (type) OR IsEnumeration (type)
9458    THEN
9459       GetBaseTypeMinMax (type, min, max) ;
9460       min := CheckBaseTypeValue (tok, type, min, func) ;
9461       RETURN min
9462    ELSIF IsSystemType (type)
9463    THEN
9464       GetSystemTypeMinMax (type, min, max) ;
9465       RETURN min
9466    ELSIF GetSType (type) = NulSym
9467    THEN
9468       MetaErrorT1 (tok,
9469                    'unable to obtain the {%AkMIN} value for type {%1ad}', type) ;
9470       (* non recoverable error.  *)
9471       InternalError ('MetaErrorT1 {%AkMIN} should call abort')
9472    ELSE
9473       RETURN GetTypeMin (tok, func, GetSType (type))
9474    END
9475 END GetTypeMin ;
9476
9477
9478 (*
9479    GetTypeMax - returns the maximum value of type.
9480 *)
9481
9482 PROCEDURE GetTypeMax (tok: CARDINAL; func, type: CARDINAL) : CARDINAL ;
9483 VAR
9484    min, max: CARDINAL ;
9485 BEGIN
9486    IF IsSubrange (type)
9487    THEN
9488       max := MakeTemporary (tok, ImmediateValue) ;
9489       PutVar (max, type) ;
9490       GenQuad (SubrangeHighOp, max, NulSym, type) ;
9491       RETURN max
9492    ELSIF IsSet (SkipType (type))
9493    THEN
9494       RETURN GetTypeMax (tok, func, GetSType (SkipType (type)))
9495    ELSIF IsBaseType (type) OR IsEnumeration (type)
9496    THEN
9497       GetBaseTypeMinMax (type, min, max) ;
9498       min := CheckBaseTypeValue (tok, type, min, func) ;
9499       RETURN max
9500    ELSIF IsSystemType (type)
9501    THEN
9502       GetSystemTypeMinMax (type, min, max) ;
9503       RETURN max
9504    ELSIF GetSType (type) = NulSym
9505    THEN
9506       MetaErrorT1 (tok,
9507                    'unable to obtain the {%AkMAX} value for type {%1ad}', type) ;
9508       (* non recoverable error.  *)
9509       InternalError ('MetaErrorT1 {%AkMAX} should call abort')
9510    ELSE
9511       RETURN GetTypeMax (tok, func, GetSType (type))
9512    END
9513 END GetTypeMax ;
9514
9515
9516 (*
9517    BuildMinFunction - builds the pseudo function call Min.
9518
9519                       The Stack:
9520
9521                       Entry                      Exit
9522
9523                Ptr ->
9524                       +----------------+
9525                       | NoOfParam=1    |
9526                       |----------------|
9527                       | Param 1        |
9528                       |----------------|
9529                       | ProcSym | Type |         Empty
9530                       |----------------|
9531 *)
9532
9533 PROCEDURE BuildMinFunction ;
9534 VAR
9535    combinedtok,
9536    functok,
9537    vartok     : CARDINAL ;
9538    func,
9539    min,
9540    NoOfParam,
9541    Var        : CARDINAL ;
9542 BEGIN
9543    PopT (NoOfParam) ;
9544    func := OperandT (NoOfParam + 1) ;
9545    functok := OperandTtok (NoOfParam + 1) ;
9546    IF NoOfParam = 1
9547    THEN
9548       Var := OperandT (1) ;
9549       vartok := OperandTok (1) ;
9550       PopN (NoOfParam+1) ;    (* destroy arguments to this function *)
9551       combinedtok := MakeVirtualTok (functok, functok, vartok) ;
9552       IF IsAModula2Type (Var)
9553       THEN
9554          min := GetTypeMin (vartok, func, Var) ;
9555          PushTFtok (min, GetSType (min), combinedtok)
9556       ELSIF IsVar (Var)
9557       THEN
9558          min := GetTypeMin (vartok, func, GetSType (Var)) ;
9559          PushTFtok (min, GetSType (Var), combinedtok)
9560       ELSE
9561          (* we dont know the type therefore cannot fake a return.  *)
9562          MetaErrorT1 (vartok,
9563                       'parameter to {%AkMIN} must be a type or a variable, seen {%1ad}',
9564                       Var)
9565          (* non recoverable error.  *)
9566       END
9567    ELSE
9568       (* we dont know the type therefore cannot fake a return.  *)
9569       MetaErrorT1 (functok,
9570                    'the pseudo builtin procedure function {%AkMIN} only has one parameter, seen  {%1n}',
9571                    NoOfParam)
9572       (* non recoverable error.  *)
9573    END
9574 END BuildMinFunction ;
9575
9576
9577 (*
9578    BuildMaxFunction - builds the pseudo function call Max.
9579
9580                       The Stack:
9581
9582                       Entry                      Exit
9583
9584                Ptr ->
9585                       +----------------+
9586                       | NoOfParam=1    |
9587                       |----------------|
9588                       | Param 1        |
9589                       |----------------|
9590                       | ProcSym | Type |         Empty
9591                       |----------------|
9592 *)
9593
9594 PROCEDURE BuildMaxFunction ;
9595 VAR
9596    combinedtok,
9597    functok,
9598    vartok     : CARDINAL ;
9599    func,
9600    max,
9601    NoOfParam,
9602    Var        : CARDINAL ;
9603 BEGIN
9604    PopT (NoOfParam) ;
9605    func := OperandT (NoOfParam + 1) ;
9606    functok := OperandTtok (NoOfParam + 1) ;
9607    IF NoOfParam = 1
9608    THEN
9609       Var := OperandT (1) ;
9610       vartok := OperandTok (1) ;
9611       PopN (NoOfParam + 1) ;    (* destroy arguments to this function *)
9612       combinedtok := MakeVirtualTok (functok, functok, vartok) ;
9613       IF IsAModula2Type (Var)
9614       THEN
9615          max := GetTypeMax (vartok, func, Var) ;
9616          PushTFtok (max, GetSType (max), combinedtok)
9617       ELSIF IsVar(Var)
9618       THEN
9619          max := GetTypeMax (vartok, func, GetSType (Var)) ;
9620          PushTFtok (max, GetSType (Var), combinedtok)
9621       ELSE
9622          (* we dont know the type therefore cannot fake a return.  *)
9623          MetaErrorT1 (vartok,
9624                       'parameter to {%AkMAX} must be a type or a variable, seen {%1ad}',
9625                       Var)
9626          (* non recoverable error.  *) ;
9627       END
9628    ELSE
9629       (* we dont know the type therefore cannot fake a return.  *)
9630       MetaErrorT1 (functok,
9631                    'the pseudo builtin procedure function {%AkMAX} only has one parameter, seen {%1n}',
9632                    NoOfParam)
9633       (* non recoverable error.  *)
9634    END
9635 END BuildMaxFunction ;
9636
9637
9638 (*
9639    BuildTruncFunction - builds the pseudo procedure call TRUNC.
9640                         This procedure is actually a "macro" for
9641                         TRUNC(x) --> CONVERT(INTEGER, x)
9642                         However we cannot push tokens back onto the input stack
9643                         because the compiler is currently building a function
9644                         call and expecting a ReturnVar on the stack.
9645                         Hence we manipulate the stack and call
9646                         BuildConvertFunction.
9647
9648                         The Stack:
9649
9650
9651                         Entry                      Exit
9652
9653                  Ptr ->
9654                         +----------------+
9655                         | NoOfParam      |
9656                         |----------------|
9657                         | Param 1        |
9658                         |----------------|
9659                         | Param 2        |
9660                         |----------------|
9661                         .                .
9662                         .                .
9663                         .                .
9664                         |----------------|
9665                         | Param #        |
9666                         |----------------|
9667                         | ProcSym | Type |         Empty
9668                         |----------------|
9669 *)
9670
9671 PROCEDURE BuildTruncFunction (Sym: CARDINAL) ;
9672 VAR
9673    vartok,
9674    functok  : CARDINAL ;
9675    NoOfParam: CARDINAL ;
9676    ProcSym,
9677    Type,
9678    Var      : CARDINAL ;
9679 BEGIN
9680    PopT (NoOfParam) ;
9681    Assert (IsTrunc (OperandT (NoOfParam+1))) ;
9682    functok := OperandTtok (NoOfParam + 1) ;
9683    IF NoOfParam = 1
9684    THEN
9685       ProcSym := RequestSym (functok, MakeKey ('CONVERT')) ;
9686       IF (ProcSym # NulSym) AND IsProcedure (ProcSym)
9687       THEN
9688          Var := OperandT (1) ;
9689          vartok := OperandTtok (1) ;
9690          Type := GetSType (Sym) ;
9691          PopN (NoOfParam + 1) ;    (* destroy arguments to this function *)
9692          IF IsVar (Var) OR IsConst (Var)
9693          THEN
9694             IF IsRealType (GetSType (Var))
9695             THEN
9696                (* build macro: CONVERT( INTEGER, Var ).  *)
9697                PushTFtok (ProcSym, NulSym, functok) ;
9698                PushTtok (Type, functok) ;
9699                PushTtok (Var, vartok) ;
9700                PushT (2) ;          (* two parameters *)
9701                BuildConvertFunction
9702             ELSE
9703                MetaErrorT1 (functok,
9704                             'argument to {%1E%ad} must be a float point type', Sym) ;
9705                PushTFtok (MakeConstLit (functok, MakeKey('0'), Type), Type, functok)
9706             END
9707          ELSE
9708             MetaErrorT2 (vartok,
9709                          'argument to {%1E%ad} must be a variable or constant, seen {%2ad}',
9710                          Sym, Var) ;
9711             PushTFtok (MakeConstLit (functok, MakeKey('0'), Type), Type, functok)
9712          END
9713       ELSE
9714          InternalError  ('CONVERT procedure not found for TRUNC substitution')
9715       END
9716    ELSE
9717       (* we dont know the type therefore cannot fake a return.  *)
9718       MetaErrorT1 (functok,
9719                    'the pseudo builtin procedure function {%AkTRUNC} only has one parameter, seen  {%1n}', NoOfParam)
9720       (* non recoverable error.  *)
9721    END
9722 END BuildTruncFunction ;
9723
9724
9725 (*
9726    BuildFloatFunction - builds the pseudo procedure call FLOAT.
9727                         This procedure is actually a "macro" for
9728                         FLOAT(x) --> CONVERT(REAL, x)
9729                         However we cannot push tokens back onto the input stack
9730                         because the compiler is currently building a function
9731                         call and expecting a ReturnVar on the stack.
9732                         Hence we manipulate the stack and call
9733                         BuildConvertFunction.
9734
9735                         The Stack:
9736
9737
9738                         Entry                      Exit
9739
9740                  Ptr ->
9741                         +----------------+
9742                         | NoOfParam      |
9743                         |----------------|
9744                         | Param 1        |
9745                         |----------------|
9746                         | Param 2        |
9747                         |----------------|
9748                         .                .
9749                         .                .
9750                         .                .
9751                         |----------------|
9752                         | Param #        |
9753                         |----------------|
9754                         | ProcSym | Type |         Empty
9755                         |----------------|
9756 *)
9757
9758 PROCEDURE BuildFloatFunction (Sym: CARDINAL) ;
9759 VAR
9760    vartok,
9761    functok  : CARDINAL ;
9762    NoOfParam: CARDINAL ;
9763    Type,
9764    Var,
9765    ProcSym  : CARDINAL ;
9766 BEGIN
9767    PopT (NoOfParam) ;
9768    functok := OperandTtok (NoOfParam + 1) ;
9769    Type := GetSType (Sym) ;
9770    IF NoOfParam = 1
9771    THEN
9772       ProcSym := RequestSym (functok, MakeKey ('CONVERT')) ;
9773       IF (ProcSym # NulSym) AND IsProcedure (ProcSym)
9774       THEN
9775          Var := OperandT (1) ;
9776          vartok := OperandTtok (1) ;
9777          IF IsVar (Var) OR IsConst (Var)
9778          THEN
9779             PopN (NoOfParam + 1) ;    (* destroy arguments to this function.  *)
9780             (* build macro: CONVERT (REAL, Var).  *)
9781             PushTFtok (ProcSym, NulSym, functok) ;
9782             PushTtok (Type, functok) ;
9783             PushTtok (Var, vartok) ;
9784             PushT(2) ;          (* two parameters.  *)
9785             BuildConvertFunction
9786          ELSE
9787             MetaErrorT1 (vartok,
9788                          'argument to {%1E%ad} must be a variable or constant', ProcSym) ;
9789             PushTFtok (MakeConstLit (functok, MakeKey('0.0'), Type), Type, functok)
9790          END
9791       ELSE
9792          InternalError  ('CONVERT procedure not found for FLOAT substitution')
9793       END
9794    ELSE
9795       MetaErrorT1 (functok,
9796                    'the builtin procedure function {%1Ead} only has one parameter',
9797                    Sym) ;
9798       PushTFtok (MakeConstLit (functok, MakeKey('0.0'), Type), Type, functok)
9799    END
9800 END BuildFloatFunction ;
9801
9802
9803 (*
9804    BuildReFunction - builds the pseudo procedure call RE.
9805
9806                      The Stack:
9807
9808
9809                          Entry                      Exit
9810
9811                  Ptr ->
9812                         +----------------+
9813                         | NoOfParam      |
9814                         |----------------|
9815                         | Param 1        |
9816                         |----------------|
9817                         | Param 2        |
9818                         |----------------|
9819                         .                .
9820                         .                .
9821                         .                .
9822                         |----------------|
9823                         | Param #        |
9824                         |----------------|
9825                         | ProcSym | Type |         Empty
9826                         |----------------|
9827 *)
9828
9829 PROCEDURE BuildReFunction ;
9830 VAR
9831    func,
9832    combinedtok,
9833    vartok,
9834    functok    : CARDINAL ;
9835    NoOfParam  : CARDINAL ;
9836    ReturnVar,
9837    Var        : CARDINAL ;
9838 BEGIN
9839    PopT (NoOfParam) ;
9840    functok := OperandTtok (NoOfParam + 1) ;
9841    func := OperandT (NoOfParam + 1) ;
9842    IF NoOfParam=1
9843    THEN
9844       Var := OperandT (1) ;
9845       vartok := OperandTok (1) ;
9846       combinedtok := MakeVirtualTok (functok, functok, vartok) ;
9847       IF IsVar(Var) OR IsConst(Var)
9848       THEN
9849          ReturnVar := MakeTemporary (combinedtok, AreConstant (IsConst (Var))) ;
9850          PutVar (ReturnVar, ComplexToScalar (GetDType (Var))) ;
9851          GenQuadO (combinedtok, StandardFunctionOp, ReturnVar, Re, Var, FALSE) ;
9852          PopN (NoOfParam+1) ;  (* destroy arguments to this function *)
9853          PushTFtok (ReturnVar, GetSType (ReturnVar), combinedtok)
9854       ELSE
9855          PopN (NoOfParam+1) ;  (* destroy arguments to this function *)
9856          PushTFtok (MakeConstLit (combinedtok, MakeKey ('1.0'), RType), RType, combinedtok) ;
9857          MetaErrorT2 (vartok,
9858                       'the parameter to the builtin procedure function {%1Ead} must be a constant or a variable, seen {%2ad}',
9859                       func, Var)
9860       END
9861    ELSE
9862       PopN (NoOfParam+1) ;  (* destroy arguments to this function *)
9863       PushTFtok (MakeConstLit (functok, MakeKey ('1.0'), RType), RType, functok) ;
9864       MetaErrorT2 (functok,
9865                    'the builtin procedure function {%1Ead} only has one parameter, seen {%2n}',
9866                    func, NoOfParam)
9867    END
9868 END BuildReFunction ;
9869
9870
9871 (*
9872    BuildImFunction - builds the pseudo procedure call IM.
9873
9874                      The Stack:
9875
9876
9877                          Entry                      Exit
9878
9879                  Ptr ->
9880                         +----------------+
9881                         | NoOfParam      |
9882                         |----------------|
9883                         | Param 1        |
9884                         |----------------|
9885                         | Param 2        |
9886                         |----------------|
9887                         .                .
9888                         .                .
9889                         .                .
9890                         |----------------|
9891                         | Param #        |
9892                         |----------------|
9893                         | ProcSym | Type |         Empty
9894                         |----------------|
9895 *)
9896
9897 PROCEDURE BuildImFunction ;
9898 VAR
9899    func,
9900    combinedtok,
9901    vartok,
9902    functok    : CARDINAL ;
9903    NoOfParam  : CARDINAL ;
9904    ReturnVar,
9905    Var        : CARDINAL ;
9906 BEGIN
9907    PopT (NoOfParam) ;
9908    functok := OperandTtok (NoOfParam + 1) ;
9909    func := OperandT (NoOfParam + 1) ;
9910    IF NoOfParam=1
9911    THEN
9912       Var := OperandT (1) ;
9913       vartok := OperandTok (1) ;
9914       combinedtok := MakeVirtualTok (functok, functok, vartok) ;
9915       IF IsVar(Var) OR IsConst(Var)
9916       THEN
9917          ReturnVar := MakeTemporary (combinedtok, AreConstant (IsConst (Var))) ;
9918          PutVar (ReturnVar, ComplexToScalar (GetDType (Var))) ;
9919          GenQuadO (combinedtok, StandardFunctionOp, ReturnVar, Im, Var, FALSE) ;
9920          PopN (NoOfParam+1) ;  (* destroy arguments to this function *)
9921          PushTFtok (ReturnVar, GetSType (ReturnVar), combinedtok)
9922       ELSE
9923          PopN (NoOfParam+1) ;  (* destroy arguments to this function *)
9924          PushTFtok (MakeConstLit (combinedtok, MakeKey ('1.0'), RType), RType, combinedtok) ;
9925          MetaErrorT2 (vartok,
9926                       'the parameter to the builtin procedure function {%1Ead} must be a constant or a variable, seen {%2ad}',
9927                       func, Var)
9928       END
9929    ELSE
9930       PopN (NoOfParam+1) ;  (* destroy arguments to this function *)
9931       PushTFtok (MakeConstLit (functok, MakeKey ('1.0'), RType), RType, functok) ;
9932       MetaErrorT2 (functok,
9933                    'the builtin procedure function {%1Ead} only has one parameter, seen {%2n}',
9934                    func, NoOfParam)
9935    END
9936 END BuildImFunction ;
9937
9938
9939 (*
9940    BuildCmplxFunction - builds the pseudo procedure call CMPLX.
9941
9942                         The Stack:
9943
9944
9945                         Entry                      Exit
9946
9947                  Ptr ->
9948                         +----------------+
9949                         | NoOfParam      |
9950                         |----------------|
9951                         | Param 1        |
9952                         |----------------|
9953                         | Param 2        |
9954                         |----------------|
9955                         .                .
9956                         .                .
9957                         .                .
9958                         |----------------|
9959                         | Param #        |
9960                         |----------------|
9961                         | ProcSym | Type |         Empty
9962                         |----------------|
9963 *)
9964
9965 PROCEDURE BuildCmplxFunction ;
9966 VAR
9967    functok,
9968    endtok,
9969    combinedtok: CARDINAL ;
9970    NoOfParam  : CARDINAL ;
9971    func,
9972    ReturnVar,
9973    l, r       : CARDINAL ;
9974 BEGIN
9975    PopT (NoOfParam) ;
9976    functok := OperandTtok (NoOfParam + 1) ;
9977    func := OperandT (NoOfParam + 1) ;
9978    IF NoOfParam = 2
9979    THEN
9980       l := OperandT (2) ;
9981       r := OperandT (1) ;
9982       endtok := OperandTok (1) ;
9983       combinedtok := MakeVirtualTok (functok, functok, endtok) ;
9984       IF (IsVar(l) OR IsConst(l)) AND
9985          (IsVar(r) OR IsConst(r))
9986       THEN
9987          CheckExpressionCompatible (combinedtok, GetSType(l), GetSType(r)) ;
9988          ReturnVar := MakeTemporary (combinedtok, AreConstant (IsConst (l) AND IsConst (r))) ;
9989          PutVar (ReturnVar, GetCmplxReturnType (GetDType (l), GetDType (r))) ;
9990          GenQuadO (combinedtok, StandardFunctionOp, ReturnVar, Cmplx, Make2Tuple (l, r), TRUE) ;
9991          PopN (NoOfParam+1) ;   (* destroy arguments to this function *)
9992          PushTFtok (ReturnVar, GetSType (ReturnVar), combinedtok)
9993       ELSE
9994          IF IsVar (l) OR IsConst (l)
9995          THEN
9996             MetaErrorT2 (functok,
9997                       'the builtin procedure {%1Ead} requires two parameters, both must be variables or constants but the second parameter is {%2d}',
9998                       func, r)
9999          ELSE
10000             MetaErrorT2 (functok,
10001                          'the builtin procedure {%1Ead} requires two parameters, both must be variables or constants but the first parameter is {%2d}',
10002                       func, l)
10003          END ;
10004          PopN (NoOfParam+1) ;  (* destroy arguments to this function *)
10005          PushTFtok (MakeConstLit (combinedtok, MakeKey ('1.0'), CType), CType, combinedtok)
10006       END
10007    ELSE
10008       MetaErrorT2 (functok,
10009                    'the builtin procedure {%1Ead} requires two parameters, seen {%2n}',
10010                    func, NoOfParam) ;
10011       PopN (NoOfParam + 1) ;  (* destroy arguments to this function *)
10012       PushTFtok (MakeConstLit (functok, MakeKey ('1.0'), CType), CType, functok)
10013    END
10014 END BuildCmplxFunction ;
10015
10016
10017 (*
10018    BuildAdrFunction - builds the pseudo function ADR
10019                       The Stack:
10020
10021
10022                       Entry                      Exit
10023
10024                Ptr ->
10025                       +----------------+
10026                       | NoOfParam      |
10027                       |----------------|
10028                       | Param 1        |
10029                       |----------------|
10030                       | Param 2        |
10031                       |----------------|
10032                       .                .
10033                       .                .
10034                       .                .
10035                       |----------------|
10036                       | Param #        |                        <- Ptr
10037                       |----------------|         +------------+
10038                       | ProcSym | Type |         | ReturnVar  |
10039                       |----------------|         |------------|
10040
10041 *)
10042
10043 PROCEDURE BuildAdrFunction ;
10044 VAR
10045    endtok,
10046    combinedTok,
10047    procTok,
10048    t,
10049    UnboundedSym,
10050    Dim,
10051    Field,
10052    noOfParameters,
10053    procSym,
10054    returnVar,
10055    Type, rw    : CARDINAL ;
10056 BEGIN
10057    DisplayStack ;
10058    PopT (noOfParameters) ;
10059    procSym := OperandT (noOfParameters + 1) ;
10060    procTok := OperandTok (noOfParameters + 1) ;  (* token of procedure ADR.  *)
10061    endtok := OperandTok (1) ;  (* last parameter.  *)
10062    combinedTok := MakeVirtualTok (procTok, procTok, endtok) ;
10063    IF noOfParameters # 1
10064    THEN
10065       MetaErrorNT0 (combinedTok,
10066                     'SYSTEM procedure ADR expects 1 parameter') ;
10067       PopN (noOfParameters + 1) ;    (* destroy the arguments and function *)
10068       PushTF (Nil, Address)
10069    ELSIF IsConstString (OperandT (1))
10070    THEN
10071       returnVar := MakeLeftValue (combinedTok, OperandT (1), RightValue,
10072                                   GetSType (procSym)) ;
10073       PopN (noOfParameters + 1) ;    (* destroy the arguments and function *)
10074       PushTFtok (returnVar, GetSType (returnVar), combinedTok)
10075    ELSIF (NOT IsVar(OperandT(1))) AND (NOT IsProcedure(OperandT(1)))
10076    THEN
10077       MetaErrorNT0 (combinedTok,
10078                     'SYSTEM procedure ADR expects a variable, procedure or a constant string as its parameter') ;
10079       PopN (noOfParameters + 1) ;    (* destroy the arguments and function *)
10080       PushTFtok (Nil, Address, combinedTok)
10081    ELSIF IsProcedure (OperandT (1))
10082    THEN
10083       returnVar := MakeLeftValue (combinedTok, OperandT (1), RightValue,
10084                                   GetSType (procSym)) ;
10085       PopN (noOfParameters + 1) ;    (* destroy the arguments and function *)
10086       PushTFtok (returnVar, GetSType (returnVar), combinedTok)
10087    ELSE
10088       Type := GetSType (OperandT (1)) ;
10089       Dim := OperandD (1) ;
10090       MarkArrayWritten (OperandT (1)) ;
10091       MarkArrayWritten (OperandA (1)) ;
10092       (* if the operand is an unbounded which has not been indexed
10093          then we will lookup its address from the unbounded record.
10094          Otherwise we obtain the address of the operand.
10095       *)
10096       IF IsUnbounded (Type) AND (Dim = 0)
10097       THEN
10098          (* we will reference the address field of the unbounded structure *)
10099          UnboundedSym := OperandT (1) ;
10100          rw := OperandRW (1) ;
10101          PushTFrw (UnboundedSym, GetSType (UnboundedSym), rw) ;
10102          Field := GetUnboundedAddressOffset (GetSType (UnboundedSym)) ;
10103          PushTF (Field, GetSType (Field)) ;
10104          PushT (1) ;
10105          BuildDesignatorRecord (combinedTok) ;
10106          PopTrw (returnVar, rw) ;
10107          IF GetMode (returnVar) = LeftValue
10108          THEN
10109             t := MakeTemporary (combinedTok, RightValue) ;
10110             PutVar (t, GetSType (procSym)) ;
10111             doIndrX (combinedTok, t, returnVar) ;
10112             returnVar := t
10113          ELSE
10114             (* we need to cast returnVar into ADDRESS *)
10115             t := MakeTemporary (combinedTok, RightValue) ;
10116             PutVar (t, GetSType (procSym)) ;
10117             GenQuadO (combinedTok, ConvertOp, t, GetSType (procSym), returnVar, FALSE) ;
10118             returnVar := t
10119          END
10120       ELSE
10121          returnVar := MakeTemporary (combinedTok, RightValue) ;
10122          PutVar (returnVar, GetSType (procSym)) ;
10123          IF GetMode (OperandT (1)) = LeftValue
10124          THEN
10125             PutVar (returnVar, GetSType (procSym)) ;
10126             GenQuadO (combinedTok, ConvertOp, returnVar, GetSType (procSym), OperandT (1), FALSE)
10127          ELSE
10128             GenQuadO (combinedTok, AddrOp, returnVar, NulSym, OperandT (1), FALSE)
10129          END ;
10130          PutWriteQuad (OperandT (1), GetMode (OperandT (1)), NextQuad-1) ;
10131          rw := OperandMergeRW (1) ;
10132          Assert (IsLegal (rw))
10133       END ;
10134       PopN (noOfParameters + 1) ;    (* destroy the arguments and function *)
10135       PushTFrwtok (returnVar, GetSType (returnVar), rw, combinedTok)
10136    END
10137 END BuildAdrFunction ;
10138
10139
10140 (*
10141    BuildSizeFunction - builds the pseudo function SIZE
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 PROCEDURE BuildSizeFunction ;
10166 VAR
10167    resulttok,
10168    paramtok,
10169    functok     : CARDINAL ;
10170    dim         : CARDINAL ;
10171    Type,
10172    NoOfParam,
10173    ProcSym,
10174    ReturnVar   : CARDINAL ;
10175 BEGIN
10176    PopT (NoOfParam) ;
10177    ProcSym := OperandT (NoOfParam + 1) ;
10178    functok := OperandTtok (NoOfParam + 1) ;
10179    IF NoOfParam # 1
10180    THEN
10181       MetaErrorT1 (functok,
10182                    '{%E} SYSTEM procedure function {%kSIZE} requires one parameter, seen {%1n}',
10183                    NoOfParam) ;
10184       resulttok := functok ;
10185       ReturnVar := MakeConstLit (resulttok, MakeKey('0'), Cardinal)
10186    ELSIF IsAModula2Type (OperandT (1))
10187    THEN
10188       paramtok := OperandTok (1) ;
10189       resulttok := MakeVirtualTok (functok, functok, paramtok) ;
10190       BuildSizeCheckEnd (ProcSym) ;   (* Quadruple generation now on.  *)
10191       ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
10192       GenQuadO (resulttok, SizeOp, ReturnVar, NulSym, OperandT(1), TRUE)
10193    ELSIF IsVar (OperandT (1))
10194    THEN
10195       BuildSizeCheckEnd (ProcSym) ;   (* Quadruple generation now on.  *)
10196       Type := GetSType (OperandT (1)) ;
10197       paramtok := OperandTok (1) ;
10198       resulttok := MakeVirtualTok (functok, functok, paramtok) ;
10199       IF IsUnbounded (Type)
10200       THEN
10201          (* Eg. SIZE(a) ; where a is unbounded dereference HIGH and multiply by the TYPE.  *)
10202          dim := OperandD (1) ;
10203          IF dim = 0
10204          THEN
10205             ReturnVar := calculateMultipicand (resulttok, OperandT (1), Type, dim)
10206          ELSE
10207             ReturnVar := calculateMultipicand (resulttok, OperandA (1), Type, dim)
10208          END
10209       ELSE
10210          ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
10211          IF Type = NulSym
10212          THEN
10213             MetaErrorT1 (resulttok,
10214                          'cannot get the type and size of {%1Ead}', OperandT (1))
10215          END ;
10216          GenQuadO (resulttok, SizeOp, ReturnVar, NulSym, Type, TRUE)
10217       END
10218    ELSE
10219       resulttok := functok ;
10220       MetaErrorT1 (resulttok,
10221                    '{%E}SYSTEM procedure {%kSIZE} expects a variable as its parameter, seen {%1Ed}',
10222                    OperandT (1)) ;
10223       ReturnVar := MakeConstLit (resulttok, MakeKey('0'), Cardinal)
10224    END ;
10225    PopN (NoOfParam+1) ;       (* Destroy the arguments and function.  *)
10226    PushTFtok (ReturnVar, GetSType(ProcSym), resulttok)
10227 END BuildSizeFunction ;
10228
10229
10230 (*
10231    BuildTSizeFunction - builds the pseudo function TSIZE
10232                         The Stack:
10233
10234
10235                         Entry                      Exit
10236
10237                  Ptr ->
10238                         +----------------+
10239                         | NoOfParam      |
10240                         |----------------|
10241                         | Param 1        |
10242                         |----------------|
10243                         | Param 2        |
10244                         |----------------|
10245                         .                .
10246                         .                .
10247                         .                .
10248                         |----------------|
10249                         | Param #        |                        <- Ptr
10250                         |----------------|         +------------+
10251                         | ProcSym | Type |         | ReturnVar  |
10252                         |----------------|         |------------|
10253
10254 *)
10255
10256 PROCEDURE BuildTSizeFunction ;
10257 VAR
10258    resulttok,
10259    paramtok,
10260    functok  : CARDINAL ;
10261    NoOfParam: CARDINAL ;
10262    ProcSym,
10263    Record,
10264    ReturnVar: CARDINAL ;
10265 BEGIN
10266    PopT (NoOfParam) ;
10267    ProcSym := OperandT (NoOfParam + 1) ;
10268    functok := OperandTtok (NoOfParam) ;
10269    BuildSizeCheckEnd (ProcSym) ;   (* quadruple generation now on *)
10270    IF NoOfParam = 1
10271    THEN
10272       paramtok := OperandTtok (1) ;
10273       resulttok := MakeVirtualTok (functok, functok, paramtok) ;
10274       IF IsAModula2Type (OperandT (1))
10275       THEN
10276          ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
10277          GenQuadO (resulttok, SizeOp, ReturnVar, NulSym, OperandT (1), FALSE)
10278       ELSIF IsVar (OperandT (1))
10279       THEN
10280          ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
10281          GenQuadO (resulttok, SizeOp, ReturnVar, NulSym, GetSType (OperandT (1)), FALSE)
10282       ELSE
10283          MetaErrorT1 (resulttok,
10284                       '{%E}SYSTEM procedure function {%kTSIZE} expects a variable as its first parameter, seen {%1Ed}',
10285                       OperandT (1)) ;
10286          ReturnVar := MakeConstLit (resulttok, MakeKey ('0'), Cardinal)
10287       END
10288    ELSIF NoOfParam = 0
10289    THEN
10290       resulttok := functok ;
10291       MetaErrorT0 (resulttok,
10292                    '{%E}SYSTEM procedure function {%kTSIZE} expects either one or two parameters, seen none') ;
10293       ReturnVar := MakeConstLit (resulttok, MakeKey ('0'), Cardinal)
10294    ELSE
10295       Record := OperandT (NoOfParam) ;
10296       paramtok := OperandTtok (1) ;
10297       resulttok := OperandTtok (NoOfParam) ;
10298       IF IsRecord (Record)
10299       THEN
10300          paramtok := OperandTtok (1) ;
10301          resulttok := MakeVirtualTok (functok, functok, paramtok) ;
10302          ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
10303          GenQuadO (resulttok, SizeOp, ReturnVar, NulSym, Record, FALSE)
10304       ELSE
10305          resulttok := MakeVirtualTok (functok, functok, paramtok) ;
10306          MetaErrorT1 (resulttok,
10307                       '{%E}SYSTEM procedure function {%kTSIZE} expects the first parameter to be a record type, seen {%1d}',
10308                       Record) ;
10309          ReturnVar := MakeConstLit (resulttok, MakeKey ('0'), Cardinal)
10310       END
10311    END ;
10312    PopN (NoOfParam+1) ;       (* destroy the arguments and function *)
10313    PushTFtok (ReturnVar, GetSType (ProcSym), resulttok)
10314 END BuildTSizeFunction ;
10315
10316
10317 (*
10318    BuildTBitSizeFunction - builds the pseudo function TBITSIZE
10319                            The Stack:
10320
10321
10322                            Entry                      Exit
10323
10324                    Ptr ->
10325                            +----------------+
10326                            | NoOfParam      |
10327                            |----------------|
10328                            | Param 1        |
10329                            |----------------|
10330                            | Param 2        |
10331                            |----------------|
10332                            .                .
10333                            .                .
10334                            .                .
10335                            |----------------|
10336                            | Param #        |                        <- Ptr
10337                            |----------------|         +------------+
10338                            | ProcSym | Type |         | ReturnVar  |
10339                            |----------------|         |------------|
10340
10341 *)
10342
10343 PROCEDURE BuildTBitSizeFunction ;
10344 VAR
10345    resulttok,
10346    paramtok,
10347    functok  : CARDINAL ;
10348    NoOfParam: CARDINAL ;
10349    ProcSym,
10350    Record,
10351    ReturnVar: CARDINAL ;
10352 BEGIN
10353    PopT (NoOfParam) ;
10354    ProcSym := OperandT (NoOfParam + 1) ;
10355    functok := OperandTtok (NoOfParam) ;
10356    BuildSizeCheckEnd (ProcSym) ;   (* quadruple generation now on *)
10357    IF NoOfParam = 1
10358    THEN
10359       paramtok := OperandTtok (1) ;
10360       resulttok := MakeVirtualTok (functok, functok, paramtok) ;
10361       IF IsAModula2Type (OperandT (1))
10362       THEN
10363          ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
10364          GenQuadO (resulttok, StandardFunctionOp, ReturnVar, ProcSym, OperandT (1), FALSE)
10365       ELSIF IsVar (OperandT (1))
10366       THEN
10367          ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
10368          GenQuadO (resulttok, StandardFunctionOp, ReturnVar, ProcSym, OperandT(1), FALSE)
10369       ELSE
10370          MetaErrorT1 (resulttok,
10371                       '{%E}SYSTEM procedure function {%kTBITSIZE} expects a variable as its first parameter, seen {%1d}',
10372                       OperandT (1)) ;
10373          ReturnVar := MakeConstLit (resulttok, MakeKey ('0'), Cardinal)
10374       END
10375    ELSIF NoOfParam = 0
10376    THEN
10377       resulttok := functok ;
10378       MetaErrorT0 (functok,
10379                    '{%E}SYSTEM procedure function {%kTBITSIZE} expects either one or two parameters, seen none') ;
10380       ReturnVar := MakeConstLit (functok, MakeKey ('0'), Cardinal)
10381    ELSE
10382       Record := OperandT (NoOfParam) ;
10383       paramtok := OperandTtok (1) ;
10384       resulttok := OperandTtok (NoOfParam) ;
10385       IF IsRecord (Record)
10386       THEN
10387          paramtok := OperandTtok (1) ;
10388          resulttok := MakeVirtualTok (functok, functok, paramtok) ;
10389          ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
10390          GenQuad(StandardFunctionOp, ReturnVar, ProcSym, OperandT(1)) ;
10391       ELSE
10392          resulttok := MakeVirtualTok (functok, functok, paramtok) ;
10393          MetaErrorT1 (resulttok,
10394                       '{%E}SYSTEM procedure function {%kTBITSIZE} expects the first parameter to be a record type, seen {%1d}',
10395                       Record) ;
10396          ReturnVar := MakeConstLit (resulttok, MakeKey ('0'), Cardinal)
10397       END
10398    END ;
10399    PopN (NoOfParam + 1) ;       (* destroy the arguments and function *)
10400    PushTFtok (ReturnVar, GetSType (ProcSym), resulttok)
10401 END BuildTBitSizeFunction ;
10402
10403
10404 (*
10405    ExpectingParameterType -
10406 *)
10407
10408 PROCEDURE ExpectingParameterType (BlockSym, Type: CARDINAL) ;
10409 BEGIN
10410    IF NOT IsAModula2Type (Type)
10411    THEN
10412       IF (Type = NulSym) OR IsPartialUnbounded (Type) OR IsUnknown (Type)
10413       THEN
10414          MetaError1 ('the type used in the formal parameter declaration in {%1Md} {%1a} is unknown',
10415                      BlockSym)
10416       ELSE
10417          MetaError2 ('the type {%1Ead} used in the formal parameter declaration in {%2Md} {%2a} was not declared as a type',
10418                      Type, BlockSym)
10419       END
10420    END
10421 END ExpectingParameterType ;
10422
10423
10424 (*
10425    ExpectingVariableType -
10426 *)
10427
10428 PROCEDURE ExpectingVariableType (BlockSym, Type: CARDINAL) ;
10429 BEGIN
10430    IF NOT IsAModula2Type(Type)
10431    THEN
10432       IF Type=NulSym
10433       THEN
10434          MetaError1 ('the type used during the variable declaration section in procedure {%1EMad} is unknown',
10435                      BlockSym) ;
10436          MetaError1 ('the type used during the variable declaration section in procedure {%1Ead} is unknown',
10437                      BlockSym)
10438       ELSIF IsPartialUnbounded(Type) OR IsUnknown(Type)
10439       THEN
10440          MetaError2 ('the type {%1EMad} used during variable declaration section in procedure {%2ad} is unknown',
10441                      Type, BlockSym) ;
10442          MetaError2 ('the type {%1Ead} used during variable declaration section in procedure {%2Mad} is unknown',
10443                      Type, BlockSym)
10444       ELSE
10445          MetaError2 ('the {%1d} {%1Ea} is not a type and therefore cannot be used to declare a variable in {%2d} {%2a}',
10446                      Type, BlockSym)
10447       END
10448    END
10449 END ExpectingVariableType ;
10450
10451
10452 (*
10453    CheckVariablesAndParameterTypesInBlock - checks to make sure that block, BlockSym, has
10454                                             parameters types and variable types which are legal.
10455 *)
10456
10457 PROCEDURE CheckVariablesAndParameterTypesInBlock (BlockSym: CARDINAL) ;
10458 VAR
10459    i, n,
10460    ParamNo: CARDINAL ;
10461 BEGIN
10462    IF IsProcedure(BlockSym)
10463    THEN
10464       ParamNo := NoOfParam(BlockSym)
10465    ELSE
10466       ParamNo := 0
10467    END ;
10468    i := 1 ;
10469    REPEAT
10470       n := GetNth(BlockSym, i) ;
10471       IF (n#NulSym) AND (NOT IsTemporary(n)) AND
10472          (IsProcedure(BlockSym) OR ((IsDefImp(BlockSym) AND (GetMainModule()=BlockSym)) OR IsModule(BlockSym)))
10473       THEN
10474          IF i<=ParamNo
10475          THEN
10476             (* n is a parameter *)
10477             ExpectingParameterType(BlockSym, GetSType(n))
10478          ELSE
10479             (* n is a local variable *)
10480             ExpectingVariableType(BlockSym, GetSType(n))
10481          END
10482       END ;
10483       INC(i)
10484    UNTIL n=NulSym ;
10485 END CheckVariablesAndParameterTypesInBlock ;
10486
10487
10488 (*
10489    BuildProcedureStart - Builds start of the procedure. Generates a
10490                          quadruple which indicated the start of
10491                          this procedure declarations scope.
10492                          The Stack is expected to contain:
10493
10494
10495                          Entry                   Exit
10496                          =====                   ====
10497
10498                  Ptr ->                                       <- Ptr
10499                         +------------+          +-----------+
10500                         | ProcSym    |          | ProcSym   |
10501                         |------------|          |-----------|
10502                         | Name       |          | Name      |
10503                         |------------|          |-----------|
10504
10505
10506                         Quadruples:
10507
10508                         q   ProcedureScopeOp  Line#  Scope  ProcSym
10509 *)
10510
10511 PROCEDURE BuildProcedureStart ;
10512 VAR
10513    ProcSym: CARDINAL ;
10514 BEGIN
10515    PopT(ProcSym) ;
10516    Assert(IsProcedure(ProcSym)) ;
10517    PutProcedureScopeQuad(ProcSym, NextQuad) ;
10518    GenQuad(ProcedureScopeOp, GetPreviousTokenLineNo(), GetScope(ProcSym), ProcSym) ;
10519    PushT(ProcSym)
10520 END BuildProcedureStart ;
10521
10522
10523 (*
10524    BuildProcedureBegin - determines the start of the BEGIN END block of
10525                          the procedure.
10526                          The Stack is expected to contain:
10527
10528
10529                          Entry                   Exit
10530                          =====                   ====
10531
10532                  Ptr ->                                       <- Ptr
10533                         +------------+          +-----------+
10534                         | ProcSym    |          | ProcSym   |
10535                         |------------|          |-----------|
10536                         | Name       |          | Name      |
10537                         |------------|          |-----------|
10538
10539
10540                         Quadruples:
10541
10542                         q   NewLocalVarOp  TokenNo(BEGIN)  _  ProcSym
10543 *)
10544
10545 PROCEDURE BuildProcedureBegin ;
10546 VAR
10547    ProcSym: CARDINAL ;
10548 BEGIN
10549    PopT(ProcSym) ;
10550    Assert(IsProcedure(ProcSym)) ;
10551    PutProcedureStartQuad(ProcSym, NextQuad) ;
10552    PutProcedureBegin(ProcSym, GetTokenNo()) ;
10553    GenQuad(NewLocalVarOp, GetTokenNo(), GetScope(ProcSym), ProcSym) ;
10554    CurrentProc := ProcSym ;
10555    PushWord(ReturnStack, 0) ;
10556    PushT(ProcSym) ;
10557    CheckVariablesAt(ProcSym) ;
10558    CheckNeedPriorityBegin(GetTokenNo(), ProcSym, GetCurrentModule()) ;
10559    PushWord(TryStack, NextQuad) ;
10560    PushWord(CatchStack, 0) ;
10561    IF HasExceptionBlock(ProcSym)
10562    THEN
10563       GenQuad(TryOp, NulSym, NulSym, 0)
10564    END
10565 END BuildProcedureBegin ;
10566
10567
10568 (*
10569    BuildProcedureEnd - Builds end of the procedure. Destroys space for
10570                        the local variables.
10571                        The Stack is expected to contain:
10572
10573
10574                        Entry                   Exit
10575                        =====                   ====
10576
10577                 Ptr ->                                       <- Ptr
10578                        +------------+          +-----------+
10579                        | ProcSym    |          | ProcSym   |
10580                        |------------|          |-----------|
10581                        | Name       |          | Name      |
10582                        |------------|          |-----------|
10583
10584
10585                        Quadruples:
10586
10587                        q   KillLocalVarOp  TokenNo(END)  _  ProcSym
10588 *)
10589
10590 PROCEDURE BuildProcedureEnd ;
10591 VAR
10592    tok    : CARDINAL ;
10593    ProcSym: CARDINAL ;
10594 BEGIN
10595    PopTtok(ProcSym, tok) ;
10596    IF HasExceptionBlock(ProcSym)
10597    THEN
10598       BuildRTExceptLeave(tok, TRUE) ;
10599       GenQuad(CatchEndOp, NulSym, NulSym, NulSym)
10600    END ;
10601    IF GetSType(ProcSym)#NulSym
10602    THEN
10603       BuildError(InitNoReturnRangeCheck())
10604    END ;
10605    BackPatch(PopWord(ReturnStack), NextQuad) ;
10606    CheckNeedPriorityEnd(tok, ProcSym, GetCurrentModule()) ;
10607    CurrentProc := NulSym ;
10608    PutProcedureEnd(ProcSym, GetTokenNo()-1) ;   (* --fixme-- *)
10609    GenQuad(KillLocalVarOp, GetTokenNo()-1, NulSym, ProcSym) ;
10610    PutProcedureEndQuad(ProcSym, NextQuad) ;
10611    GenQuad(ReturnOp, NulSym, NulSym, ProcSym) ;
10612    CheckFunctionReturn(ProcSym) ;
10613    CheckVariablesInBlock(ProcSym) ;
10614    RemoveTop (CatchStack) ;
10615    RemoveTop (TryStack) ;
10616    PushT(ProcSym)
10617 END BuildProcedureEnd ;
10618
10619
10620 (*
10621    IsNeverAltered - returns TRUE if variable, sym, is never altered
10622                     between quadruples: Start..End
10623 *)
10624
10625 PROCEDURE IsNeverAltered (sym: CARDINAL; Start, End: CARDINAL) : BOOLEAN ;
10626 VAR
10627    WriteStart, WriteEnd: CARDINAL ;
10628 BEGIN
10629    GetWriteLimitQuads (sym, GetMode (sym), Start, End, WriteStart, WriteEnd) ;
10630    RETURN( (WriteStart = 0) AND (WriteEnd = 0) )
10631 END IsNeverAltered ;
10632
10633
10634 (*
10635    IsConditionVariable - returns TRUE if the condition at quadruple, q, is variable.
10636 *)
10637
10638 PROCEDURE IsConditionVariable (q: CARDINAL; Start, End: CARDINAL) : BOOLEAN ;
10639 VAR
10640    op           : QuadOperator ;
10641    op1, op2, op3: CARDINAL ;
10642    LeftFixed,
10643    RightFixed   : BOOLEAN ;
10644 BEGIN
10645    GetQuad (q, op, op1, op2, op3) ;
10646    IF op = GotoOp
10647    THEN
10648       RETURN( FALSE )
10649    ELSE
10650       LeftFixed  := IsConst(op1) ;
10651       RightFixed := IsConst(op2) ;
10652       IF NOT LeftFixed
10653       THEN
10654          LeftFixed := IsNeverAltered(op1, Start, End)
10655       END ;
10656       IF NOT RightFixed
10657       THEN
10658          RightFixed := IsNeverAltered(op2, Start, End)
10659       END ;
10660       RETURN( NOT (LeftFixed AND RightFixed) )
10661    END
10662 END IsConditionVariable ;
10663
10664
10665 (*
10666    IsInfiniteLoop - returns TRUE if an infinite loop is found.
10667                     Given a backwards jump at, End, it returns a BOOLEAN which depends on
10668                     whether a jump is found to jump beyond, End. If a conditonal jump is found
10669                     to pass over, End, the condition is tested for global variables, procedure variables and
10670                     constants.
10671
10672                          constant        - ignored
10673                          variables       - tested to see whether they are altered inside the loop
10674                          global variable - the procedure tests to see whether it is altered as above
10675                                            but will also test to see whether this loop calls a procedure
10676                                            in which case it believes the loop NOT to be infinite
10677                                            (as this procedure call might alter the global variable)
10678
10679                     Note that this procedure can easily be fooled by the user altering variables
10680                     with pointers.
10681 *)
10682
10683 PROCEDURE IsInfiniteLoop (End: CARDINAL) : BOOLEAN ;
10684 VAR
10685    SeenCall,
10686    IsGlobal     : BOOLEAN ;
10687    Current,
10688    Start        : CARDINAL ;
10689    op           : QuadOperator ;
10690    op1, op2, op3: CARDINAL ;
10691 BEGIN
10692    SeenCall := FALSE ;
10693    IsGlobal := FALSE ;
10694    GetQuad(End, op, op1, op2, Start) ;
10695    Current := Start ;
10696    WHILE Current#End DO
10697       GetQuad(Current, op, op1, op2, op3) ;
10698       (* remember that this function is only called once we have optimized the redundant gotos and conditionals *)
10699       IF IsConditional(Current) AND (NOT IsGlobal)
10700       THEN
10701          IsGlobal := (IsVar(op1) AND (NOT IsProcedure(GetVarScope(op1)))) OR
10702                      (IsVar(op2) AND (NOT IsProcedure(GetVarScope(op2))))
10703       END ;
10704       IF op=CallOp
10705       THEN
10706          SeenCall := TRUE
10707       END ;
10708       IF (op=GotoOp) OR (IsConditional(Current) AND IsConditionVariable(Current, Start, End))
10709       THEN
10710          IF (op3>End) OR (op3<Start)
10711          THEN
10712             RETURN( FALSE )    (* may jump out of this loop, good *)
10713          END
10714       END ;
10715       Current := GetNextQuad(Current)
10716    END ;
10717    GetQuad(End, op, op1, op2, op3) ;
10718    IF IsConditional(End)
10719    THEN
10720       IF IsConditionVariable(End, Start, End)
10721       THEN
10722          RETURN( FALSE )
10723       ELSE
10724          IF NOT IsGlobal
10725          THEN
10726             IsGlobal := (IsVar(op1) AND (NOT IsProcedure(GetVarScope(op1)))) OR
10727                         (IsVar(op2) AND (NOT IsProcedure(GetVarScope(op2))))
10728          END
10729       END
10730    END ;
10731    (* we have found a likely infinite loop if no conditional uses a global and no procedure call was seen *)
10732    RETURN( NOT (IsGlobal AND SeenCall) )
10733 END IsInfiniteLoop ;
10734
10735
10736 (*
10737    LoopAnalysis - checks whether an infinite loop exists.
10738 *)
10739
10740 PROCEDURE LoopAnalysis (Scope: CARDINAL; Current, End: CARDINAL) ;
10741 VAR
10742    op           : QuadOperator ;
10743    op1, op2, op3: CARDINAL ;
10744 BEGIN
10745    IF Pedantic
10746    THEN
10747       WHILE (Current<=End) AND (Current#0) DO
10748          GetQuad(Current, op, op1, op2, op3) ;
10749          IF (op=GotoOp) OR IsConditional(Current)
10750          THEN
10751             IF op3<=Current
10752             THEN
10753                (* found a loop - ie a branch which goes back in quadruple numbers *)
10754                IF IsInfiniteLoop(Current)
10755                THEN
10756                   MetaErrorT1 (QuadToTokenNo(op3),
10757                                'it is very likely (although not absolutely certain) that the top of an infinite loop exists here in {%1Wad}',
10758                                Scope) ;
10759                   MetaErrorT1 (QuadToTokenNo(Current),
10760                                'and the bottom of the infinite loop is ends here in {%1Wad} or alternatively a component of this loop is never executed',
10761                                Scope) ;
10762 (*
10763                   WarnStringAt(InitString('it is very likely (although not absolutely certain) that the top of an infinite loop is here'),
10764                                QuadToTokenNo(op3)) ;
10765                   WarnStringAt(InitString('and the bottom of the infinite loop is ends here or alternatively a component of this loop is never executed'),
10766                                QuadToTokenNo(Current))
10767 *)
10768                END
10769             END
10770          END ;
10771          Current := GetNextQuad(Current)
10772       END
10773    END
10774 END LoopAnalysis ;
10775
10776
10777 (*
10778    CheckVariablesInBlock - given a block, BlockSym, check whether all variables are used.
10779 *)
10780
10781 PROCEDURE CheckVariablesInBlock (BlockSym: CARDINAL) ;
10782 BEGIN
10783    CheckVariablesAndParameterTypesInBlock (BlockSym)
10784 END CheckVariablesInBlock ;
10785
10786
10787 (*
10788    CheckFunctionReturn - checks to see that a RETURN statement was present in a function.
10789 *)
10790
10791 PROCEDURE CheckFunctionReturn (ProcSym: CARDINAL) ;
10792 VAR
10793    Op           : QuadOperator ;
10794    Op1, Op2, Op3,
10795    Scope,
10796    Start, End   : CARDINAL ;
10797 BEGIN
10798    IF GetSType(ProcSym)#NulSym
10799    THEN
10800       (* yes it is a function *)
10801       GetProcedureQuads(ProcSym, Scope, Start, End) ;
10802       GetQuad(Start, Op, Op1, Op2, Op3) ;
10803       IF Start=0
10804       THEN
10805          InternalError ('incorrect start quad')
10806       END ;
10807       WHILE (Start#End) AND (Op#ReturnValueOp) AND (Op#InlineOp) DO
10808          Start := GetNextQuad(Start) ;
10809          GetQuad(Start, Op, Op1, Op2, Op3)
10810       END ;
10811       IF (Op#ReturnValueOp) AND (Op#InlineOp)
10812       THEN
10813          (* an InlineOp can always be used to emulate a RETURN *)
10814          MetaError1 ('procedure function {%1Ea} does not RETURN a value', ProcSym)
10815       END
10816    END
10817 END CheckFunctionReturn ;
10818
10819
10820 (*
10821    CheckReturnType - checks to see that the return type from currentProc is
10822                      assignment compatible with actualType.
10823 *)
10824
10825 PROCEDURE CheckReturnType (tokno: CARDINAL; currentProc, actualVal, actualType: CARDINAL) ;
10826 VAR
10827    procType: CARDINAL ;
10828    s1, s2  : String ;
10829    n1, n2  : Name ;
10830 BEGIN
10831    procType := GetSType (currentProc) ;
10832    IF procType = NulSym
10833    THEN
10834       MetaError1 ('attempting to RETURN a value from procedure {%1Ea} which was not a declared as a procedure function', currentProc)
10835    ELSIF AssignmentRequiresWarning (actualType, GetSType (currentProc))
10836    THEN
10837       MetaError2 ('attempting to RETURN a value {%1Wa} with an incompatible type {%1Wtsa} from a procedure function {%1a} which returns {%1tsa}', actualVal, currentProc)
10838    ELSIF NOT IsAssignmentCompatible (actualType, procType)
10839    THEN
10840       n1 := GetSymName(actualType) ;
10841       n2 := GetSymName(procType) ;
10842       WriteFormat2('attempting to RETURN a value with an incompatible type (%a) from a function which returns (%a)',
10843                    n1, n2)
10844    ELSIF IsProcedure(actualVal) AND (NOT IsAssignmentCompatible(actualVal, procType))
10845    THEN
10846 (*
10847       MetaWarnings2('attempting to RETURN a value with an incompatible type {%1ad} from function {%2a} which returns {%2ta}',
10848                     actualVal, currentProc)
10849
10850       --fixme--  introduce MetaWarning, MetaWarning2, MetaWarning3 into M2MetaError
10851 *)
10852       s1 := InitStringCharStar(KeyToCharStar(GetSymName(actualVal))) ;
10853       s2 := InitStringCharStar(KeyToCharStar(GetSymName(procType))) ;
10854       ErrorString(NewWarning(GetTokenNo()),
10855                   Sprintf2(Mark(InitString('attempting to RETURN a value with a (possibly on other targets) incompatible type (%s) from a function which returns (%s)')),
10856                            s1, s2))
10857    ELSIF IsProcedure(actualVal) AND (NOT IsAssignmentCompatible(actualVal, GetSType(CurrentProc)))
10858    THEN
10859       n1 := GetSymName(actualVal) ;
10860       n2 := GetSymName(GetSType(currentProc)) ;
10861       WriteFormat2('attempting to RETURN a value with an incompatible type (%a) from a function which returns (%a)',
10862                    n1, n2)
10863    ELSE
10864       (* this checks the types are compatible, not the data contents.  *)
10865       BuildRange (InitTypesAssignmentCheck (tokno, currentProc, actualVal))
10866    END
10867 END CheckReturnType ;
10868
10869
10870 (*
10871    BuildReturn - Builds the Return part of the procedure.
10872                  tokreturn is the location of the RETURN keyword.
10873                  The Stack is expected to contain:
10874
10875
10876                  Entry                   Exit
10877                  =====                   ====
10878
10879          Ptr ->
10880                  +------------+
10881                  | e1         |          Empty
10882                  |------------|
10883 *)
10884
10885 PROCEDURE BuildReturn (tokreturn: CARDINAL) ;
10886 VAR
10887    tokcombined,
10888    tokexpr    : CARDINAL ;
10889    e2, t2,
10890    e1, t1,
10891    t, f,
10892    Des        : CARDINAL ;
10893 BEGIN
10894    IF IsBoolean (1)
10895    THEN
10896       PopBooltok (t, f, tokexpr) ;
10897       (* Des will be a boolean type *)
10898       Des := MakeTemporary (tokexpr, RightValue) ;
10899       PutVar (Des, Boolean) ;
10900       PushTFtok (Des, Boolean, tokexpr) ;
10901       PushBooltok (t, f, tokexpr) ;
10902       BuildAssignmentWithoutBounds (tokreturn, FALSE, TRUE) ;
10903       PushTFtok (Des, Boolean, tokexpr)
10904    END ;
10905    PopTFtok (e1, t1, tokexpr) ;
10906    tokcombined := MakeVirtualTok (tokreturn, tokreturn, tokexpr) ;
10907    IF e1 # NulSym
10908    THEN
10909       (* this will check that the type returned is compatible with
10910          the formal return type of the procedure.  *)
10911       CheckReturnType (tokcombined, CurrentProc, e1, t1) ;
10912       (* dereference LeftValue if necessary *)
10913       IF GetMode (e1) = LeftValue
10914       THEN
10915          t2 := GetSType (CurrentProc) ;
10916          e2 := MakeTemporary (tokexpr, RightValue) ;
10917          PutVar(e2, t2) ;
10918          CheckPointerThroughNil (tokexpr, e1) ;
10919          doIndrX (tokexpr, e2, e1) ;
10920          (* here we check the data contents to ensure no overflow.  *)
10921          BuildRange (InitReturnRangeCheck (tokcombined, CurrentProc, e2)) ;
10922          GenQuadOtok (tokcombined, ReturnValueOp, e2, NulSym, CurrentProc, FALSE,
10923                       tokcombined, UnknownTokenNo, GetDeclaredMod (CurrentProc))
10924       ELSE
10925          (* here we check the data contents to ensure no overflow.  *)
10926          BuildRange (InitReturnRangeCheck (tokcombined, CurrentProc, e1)) ;
10927          GenQuadOtok (tokcombined, ReturnValueOp, e1, NulSym, CurrentProc, FALSE,
10928                       tokcombined, UnknownTokenNo, GetDeclaredMod (CurrentProc))
10929       END
10930    END ;
10931    GenQuadO (tokcombined, GotoOp, NulSym, NulSym, PopWord (ReturnStack), FALSE) ;
10932    PushWord (ReturnStack, NextQuad-1)
10933 END BuildReturn ;
10934
10935
10936 (*
10937    IsReadOnly - a helper procedure function to detect constants.
10938 *)
10939
10940 PROCEDURE IsReadOnly (sym: CARDINAL) : BOOLEAN ;
10941 BEGIN
10942    RETURN IsConst (sym) OR (IsVar (sym) AND IsVarConst (sym))
10943 END IsReadOnly ;
10944
10945
10946 (*
10947    BuildDesignatorRecord - Builds the record referencing.
10948                            The Stack is expected to contain:
10949
10950
10951                            Entry                   Exit
10952                            =====                   ====
10953
10954                    Ptr ->
10955                            +--------------+
10956                            | n            |
10957                            |--------------|
10958                            | fld1 | type1 |
10959                            |--------------|
10960                            .              .
10961                            .              .
10962                            .              .
10963                            |--------------|
10964                            | fldn | typen |                        <- Ptr
10965                            |--------------|        +-------------+
10966                            | Sym  | Type  |        | S    | type1|
10967                            |--------------|        |-------------|
10968 *)
10969
10970 PROCEDURE BuildDesignatorRecord (dottok: CARDINAL) ;
10971 VAR
10972    RecordTok,
10973    FieldTok,
10974    combinedtok: CARDINAL ;
10975    n, rw,
10976    Field,
10977    FieldType,
10978    RecordSym,
10979    Res        : CARDINAL ;
10980 BEGIN
10981    PopT(n) ;
10982    RecordSym := OperandT (n+1) ;
10983    (* RecordType could be found by:  SkipType (OperandF (n+1)).  *)
10984    RecordTok := OperandTok (n+1) ;
10985    rw := OperandMergeRW (n+1) ;
10986    Assert (IsLegal (rw)) ;
10987    Field := OperandT (n) ;
10988    FieldType := SkipType (OperandF (n)) ;
10989    FieldTok := OperandTok (n) ;
10990    combinedtok := MakeVirtualTok (dottok, RecordTok, FieldTok) ;
10991    IF n>1
10992    THEN
10993       InternalError ('not expecting to see n>1')
10994    END ;
10995    IF IsUnused (Field)
10996    THEN
10997       MetaErrors1 ('record field {%1Dad} was declared as unused by a pragma',
10998                    'record field {%1ad} is being used after being declared as unused by a pragma', Field)
10999    END ;
11000    Res := MakeComponentRef (MakeComponentRecord (combinedtok,
11001                                                  RightValue, RecordSym), Field) ;
11002    PutVarConst (Res, IsReadOnly (RecordSym)) ;
11003    GenQuadO (combinedtok, RecordFieldOp, Res, RecordSym, Field, FALSE) ;
11004    PopN (n+1) ;
11005    PushTFrwtok (Res, FieldType, rw, combinedtok)
11006 END BuildDesignatorRecord ;
11007
11008
11009 (*
11010    BuildDesignatorError - removes the designator from the stack and replaces
11011                           it with an error symbol.
11012 *)
11013
11014 PROCEDURE BuildDesignatorError (message: ARRAY OF CHAR) ;
11015 VAR
11016    combinedTok,
11017    arrayTok,
11018    exprTok    : CARDINAL ;
11019    e, d, error,
11020    Sym,
11021    Type       : CARDINAL ;
11022 BEGIN
11023    PopTtok (e, exprTok) ;
11024    PopTFDtok (Sym, Type, d, arrayTok) ;
11025    combinedTok := MakeVirtualTok (arrayTok, arrayTok, exprTok) ;
11026    error := MakeError (combinedTok, MakeKey (message)) ;
11027    PushTFDtok (error, Type, d, arrayTok)
11028 END BuildDesignatorError ;
11029
11030
11031
11032 (*
11033    BuildDesignatorArray - Builds the array referencing.
11034                           The purpose of this procedure is to work out
11035                           whether the DesignatorArray is a static or
11036                           dynamic array and to call the appropriate
11037                           BuildRoutine.
11038
11039                           The Stack is expected to contain:
11040
11041
11042                           Entry                   Exit
11043                           =====                   ====
11044
11045                   Ptr ->
11046                           +--------------+
11047                           | e            |                        <- Ptr
11048                           |--------------|        +------------+
11049                           | Sym  | Type  |        | S    | T   |
11050                           |--------------|        |------------|
11051 *)
11052
11053 PROCEDURE BuildDesignatorArray ;
11054 VAR
11055    combinedTok,
11056    arrayTok,
11057    exprTok     : CARDINAL ;
11058    e, type, dim,
11059    result,
11060    Sym,
11061    Type        : CARDINAL ;
11062 BEGIN
11063    IF IsConst (OperandT (2))
11064    THEN
11065       type := GetDType (OperandT (2)) ;
11066       IF type = NulSym
11067       THEN
11068          InternalError ('constant type should have been resolved')
11069       ELSIF IsArray (type)
11070       THEN
11071          PopTtok (e, exprTok) ;
11072          PopTFDtok (Sym, Type, dim, arrayTok) ;
11073          result := MakeTemporary (exprTok, RightValue) ;
11074          PutVar (result, Type) ;
11075          PushTFtok (result, GetSType (result), exprTok) ;
11076          PushTtok (Sym, arrayTok) ;
11077          combinedTok := MakeVirtualTok (arrayTok, arrayTok, exprTok) ;
11078          PutVarConst (result, TRUE) ;
11079          BuildAssignConstant (combinedTok) ;
11080          PushTFDtok (result, GetDType (result), dim, arrayTok) ;
11081          PushTtok (e, exprTok)
11082       END
11083    END ;
11084    IF (NOT IsVar (OperandT (2))) AND (NOT IsTemporary (OperandT (2)))
11085    THEN
11086       MetaErrorT1 (OperandTtok (2),
11087                    'can only access arrays using variables or formal parameters not {%1Ead}',
11088                    OperandT (2)) ;
11089       BuildDesignatorError ('bad array access')
11090    END ;
11091    Sym := OperandT (2) ;
11092    Type := GetDType (Sym) ;
11093    arrayTok := OperandTtok (2) ;
11094    IF Type = NulSym
11095    THEN
11096       IF (arrayTok = UnknownTokenNo) OR (arrayTok = BuiltinTokenNo)
11097       THEN
11098          arrayTok := GetTokenNo ()
11099       END ;
11100       MetaErrorT0 (arrayTok, "type of array is undefined") ;
11101       BuildDesignatorError ('bad array access')
11102    ELSIF IsUnbounded (Type)
11103    THEN
11104       BuildDynamicArray
11105    ELSIF IsArray (Type)
11106    THEN
11107       BuildStaticArray
11108    ELSE
11109       MetaErrorT1 (arrayTok,
11110                    'can only index static or dynamic arrays, {%1Ead} is not an array but a {%tad}',
11111                    Sym) ;
11112       BuildDesignatorError ('bad array access')
11113    END
11114 END BuildDesignatorArray ;
11115
11116
11117 (*
11118    BuildStaticArray - Builds the array referencing for static arrays.
11119                       The Stack is expected to contain:
11120
11121
11122                       Entry                   Exit
11123                       =====                   ====
11124
11125               Ptr ->
11126                       +--------------+
11127                       | e            |                       <- Ptr
11128                       |--------------|        +------------+
11129                       | Sym  | Type  |        | S    | T   |
11130                       |--------------|        |------------|
11131 *)
11132
11133 PROCEDURE BuildStaticArray ;
11134 VAR
11135    combinedTok,
11136    indexTok,
11137    arrayTok   : CARDINAL ;
11138    rw,
11139    Dim,
11140    Array,
11141    Index,
11142    BackEndType,
11143    Type, Adr  : CARDINAL ;
11144 BEGIN
11145    Index := OperandT (1) ;
11146    indexTok := OperandTtok (1) ;
11147    Array  := OperandT (2) ;
11148    arrayTok := OperandTtok (2) ;
11149    Type := SkipType (OperandF (2)) ;
11150    rw := OperandMergeRW (2) ;
11151    Assert (IsLegal (rw)) ;
11152    Dim := OperandD (2) ;
11153    INC (Dim) ;
11154    IF GetMode (Index)=LeftValue
11155    THEN
11156       Index := MakeRightValue (indexTok, Index, GetSType (Index))
11157    END ;
11158    BuildRange (InitStaticArraySubscriptRangeCheck (GetArraySubscript (Type), Index, Dim)) ;
11159
11160    (* now make Adr point to the address of the indexed element *)
11161    combinedTok := MakeVirtualTok (arrayTok, arrayTok, indexTok) ;
11162    Adr := MakeTemporary (combinedTok, LeftValue) ;
11163    IF IsVar (Array)
11164    THEN
11165       (* BuildDesignatorArray may have detected des is a constant.  *)
11166       PutVarConst (Adr, IsVarConst (Array))
11167    END ;
11168    PutVarArrayRef (Adr, TRUE) ;
11169    (*
11170       From now on it must reference the array element by its lvalue
11171       - so we create the type of the referenced entity
11172    *)
11173
11174    BackEndType := MakePointer (combinedTok, NulName) ;
11175    PutPointer (BackEndType, GetDType (Type)) ;
11176    (* PutVar(Adr, BackEndType) ; *)
11177    PutLeftValueFrontBackType (Adr, GetDType (Type), BackEndType) ;
11178
11179    GenQuadO (combinedTok, ArrayOp, Adr, Index, Array, TRUE) ;
11180    PopN (2) ;   (* remove all parameters to this procedure *)
11181    PushTFDrwtok (Adr, GetSType (Adr), Dim, rw, combinedTok)
11182 END BuildStaticArray ;
11183
11184
11185 (*
11186    calculateMultipicand - generates quadruples which calculate the
11187                           multiplicand for the array at dimension, dim.
11188 *)
11189
11190 PROCEDURE calculateMultipicand (tok: CARDINAL;
11191                                 arraySym, arrayType: CARDINAL; dim: CARDINAL) : CARDINAL ;
11192 VAR
11193    ti, tj, tk, tl: CARDINAL ;
11194 BEGIN
11195    IF dim = GetDimension (arrayType)
11196    THEN
11197       (* ti has no type since constant *)
11198       ti := MakeTemporary (tok, ImmediateValue) ;
11199       PutVar (ti, Cardinal) ;
11200       GenQuadO (tok, ElementSizeOp, ti, arrayType, 1, TRUE)
11201    ELSE
11202       INC(dim) ;
11203       tk := MakeTemporary (tok, RightValue) ;
11204       PutVar (tk, Cardinal) ;
11205       GenHigh (tok, tk, dim, arraySym) ;
11206       tl := MakeTemporary (tok, RightValue) ;
11207       PutVar (tl, Cardinal) ;
11208       GenQuadO (tok, AddOp, tl, tk, MakeConstLit (tok, MakeKey ('1'), Cardinal), TRUE) ;
11209       tj := calculateMultipicand (tok, arraySym, arrayType, dim) ;
11210       ti := MakeTemporary (tok, RightValue) ;
11211       PutVar (ti, Cardinal) ;
11212       GenQuadO (tok, MultOp, ti, tj, tl, TRUE)
11213    END ;
11214    RETURN ti
11215 END calculateMultipicand ;
11216
11217
11218 (*
11219    BuildDynamicArray - Builds the array referencing for dynamic arrays.
11220                        The Stack is expected to contain:
11221
11222
11223                        Entry                          Exit
11224                        =====                          ====
11225
11226                Ptr ->
11227                        +-----------------------+
11228                        | Index                 |                                    <- Ptr
11229                        |-----------------------|      +---------------------------+
11230                        | ArraySym | Type | Dim |      | S  | T | ArraySym | Dim+1 |
11231                        |-----------------------|      |---------------------------|
11232
11233
11234    if Dim=1
11235    then
11236       S := base of ArraySym + TSIZE(Type)*Index
11237    else
11238       S := S + TSIZE(Type)*Index
11239    fi
11240 *)
11241
11242 PROCEDURE BuildDynamicArray ;
11243 VAR
11244    combinedTok,
11245    arrayTok,
11246    indexTok     : CARDINAL ;
11247    Sym, idx,
11248    Type, Adr,
11249    ArraySym,
11250    BackEndType,
11251    UnboundedType,
11252    PtrToBase,
11253    Base,
11254    Dim, rw,
11255    ti, tj, tk   : CARDINAL ;
11256 BEGIN
11257    DisplayStack ;
11258    Sym  := OperandT (2) ;
11259    Type := SkipType (OperandF (2)) ;
11260    arrayTok := OperandTok (2) ;
11261    indexTok := OperandTok (1) ;
11262    combinedTok := MakeVirtualTok (arrayTok, arrayTok, indexTok) ;
11263    Dim := OperandD (2) ;
11264    rw := OperandMergeRW (2) ;
11265    Assert (IsLegal (rw)) ;
11266    INC (Dim) ;
11267    IF Dim = 1
11268    THEN
11269       (*
11270          Base has type address since
11271          BuildDesignatorRecord references by address.
11272
11273          Build a record for retrieving the address of dynamic array.
11274          BuildDesignatorRecord will generate the required quadruples,
11275          therefore build sets up the stack for BuildDesignatorRecord
11276          which will generate the quads to access the record.
11277       *)
11278       ArraySym := Sym ;
11279       UnboundedType := GetUnboundedRecordType (GetSType (Sym)) ;
11280       PushTFrwtok (Sym, UnboundedType, rw, arrayTok) ;
11281       PushTF (GetUnboundedAddressOffset (GetSType (Sym)),
11282               GetSType (GetUnboundedAddressOffset (GetSType (Sym)))) ;
11283       PushT (1) ;  (* One record field to dereference *)
11284       BuildDesignatorRecord (combinedTok) ;
11285       PopT (PtrToBase) ;
11286       DisplayStack ;
11287       (* Now actually copy Unbounded.ArrayAddress into base *)
11288       IF GetMode(PtrToBase) = LeftValue
11289       THEN
11290          Base := MakeTemporary (arrayTok, RightValue) ;
11291          PutVar (Base, Address) ;           (* has type ADDRESS *)
11292          CheckPointerThroughNil (arrayTok, PtrToBase) ;
11293          GenQuad (IndrXOp, Base, Address, PtrToBase)           (* Base = *PtrToBase *)
11294       ELSE
11295          Assert (GetMode (PtrToBase) # ImmediateValue) ;
11296          Base := PtrToBase
11297       END
11298    ELSE
11299       (* Base already calculated previously and pushed to stack *)
11300       UnboundedType := SkipType (OperandF (2)) ;
11301       Base := Sym ;
11302       ArraySym := OperandA (2)
11303    END ;
11304    Assert (GetSType (Sym) = Type) ;
11305    ti := calculateMultipicand (indexTok, Sym, Type, Dim) ;
11306    idx := OperandT (1) ;
11307    IF IsConst (idx)
11308    THEN
11309       (* tj has no type since constant *)
11310       tj := MakeTemporary (indexTok, ImmediateValue) ;
11311       tk := MakeTemporary (indexTok, ImmediateValue) ;
11312       PutVar (tj, Cardinal) ;
11313       PutVar (tk, Cardinal)
11314    ELSE
11315       (* tj has Cardinal type since we have multiplied array indices *)
11316       tj := MakeTemporary (indexTok, RightValue) ;
11317       IF GetSType (idx) # Cardinal
11318       THEN
11319          PushTF (RequestSym (indexTok, MakeKey ('CONVERT')), NulSym) ;
11320          PushT (Cardinal) ;
11321          PushTtok (idx, indexTok) ;
11322          PushT(2) ;          (* Two parameters *)
11323          BuildConvertFunction ;
11324          PopT (idx)
11325       END ;
11326       PutVar (tj, Cardinal) ;
11327       tk := MakeTemporary (indexTok, RightValue) ;
11328       PutVar (tk, Cardinal)
11329    END ;
11330    BuildRange (InitDynamicArraySubscriptRangeCheck (ArraySym, idx, Dim)) ;
11331
11332    PushTtok (tj, indexTok) ;
11333    PushTtok (idx, indexTok) ;
11334    BuildAssignmentWithoutBounds (indexTok, FALSE, TRUE) ;
11335
11336    GenQuad (MultOp, tk, ti, tj) ;
11337    Adr := MakeTemporary (combinedTok, LeftValue) ;
11338    PutVarArrayRef (Adr, TRUE) ;
11339    (*
11340       Ok must reference by address
11341       - but we contain the type of the referenced entity
11342    *)
11343    BackEndType := MakePointer (combinedTok, NulName) ;
11344    PutPointer (BackEndType, GetSType (Type)) ;
11345
11346    IF Dim = GetDimension (Type)
11347    THEN
11348       PutLeftValueFrontBackType (Adr, GetSType(Type), BackEndType) ;
11349
11350       GenQuad (AddOp, Adr, Base, tk) ;
11351       PopN (2) ;
11352       PushTFADrwtok (Adr, GetSType(Adr), ArraySym, Dim, rw, combinedTok)
11353    ELSE
11354       (* more to index *)
11355       PutLeftValueFrontBackType (Adr, Type, BackEndType) ;
11356
11357       GenQuad (AddOp, Adr, Base, tk) ;
11358       PopN (2) ;
11359       PushTFADrwtok (Adr, GetSType(Adr), ArraySym, Dim, rw, combinedTok)
11360    END
11361 END BuildDynamicArray ;
11362
11363
11364 (*
11365    DebugLocation -
11366 *)
11367
11368 PROCEDURE DebugLocation (tok: CARDINAL; message: ARRAY OF CHAR) ;
11369 BEGIN
11370    IF DebugTokPos
11371    THEN
11372       WarnStringAt (InitString (message), tok)
11373    END
11374 END DebugLocation ;
11375
11376
11377 (*
11378    BuildDesignatorPointer - Builds a pointer reference.
11379                             The Stack is expected to contain:
11380
11381
11382                             Entry                   Exit
11383                             =====                   ====
11384
11385                     Ptr ->                                           <- Ptr
11386                             +--------------+        +--------------+
11387                             | Sym1  | Type1|        | Sym2  | Type2|
11388                             |--------------|        |--------------|
11389 *)
11390
11391 PROCEDURE BuildDesignatorPointer (ptrtok: CARDINAL) ;
11392 VAR
11393    combinedtok,
11394    exprtok    : CARDINAL ;
11395    rw,
11396    Sym1, Type1,
11397    Sym2, Type2: CARDINAL ;
11398 BEGIN
11399    PopTFrwtok (Sym1, Type1, rw, exprtok) ;
11400    DebugLocation (exprtok, "expression") ;
11401
11402    Type1 := SkipType (Type1) ;
11403    IF Type1 = NulSym
11404    THEN
11405       MetaErrorT1 (ptrtok, '{%1ad} has no type and therefore cannot be dereferenced by ^', Sym1)
11406    ELSIF IsUnknown (Sym1)
11407    THEN
11408       MetaError1 ('{%1EMad} is undefined and therefore {%1ad}^ cannot be resolved', Sym1)
11409    ELSIF IsPointer (Type1)
11410    THEN
11411       Type2 := GetSType (Type1) ;
11412       Sym2 := MakeTemporary (ptrtok, LeftValue) ;
11413       (*
11414          Ok must reference by address
11415          - but we contain the type of the referenced entity
11416       *)
11417       MarkAsRead (rw) ;
11418       PutVarPointerCheck (Sym1, TRUE) ;
11419       CheckPointerThroughNil (ptrtok, Sym1) ;
11420       IF GetMode (Sym1) = LeftValue
11421       THEN
11422          rw := NulSym ;
11423          PutLeftValueFrontBackType (Sym2, Type2, Type1) ;
11424          GenQuadO (ptrtok, IndrXOp, Sym2, Type1, Sym1, FALSE)    (* Sym2 := *Sym1 *)
11425       ELSE
11426          PutLeftValueFrontBackType (Sym2, Type2, NulSym) ;
11427          GenQuadO (ptrtok, BecomesOp, Sym2, NulSym, Sym1, FALSE) (* Sym2 :=  Sym1 *)
11428       END ;
11429       PutVarPointerCheck (Sym2, TRUE) ;       (* we should check this for *)
11430                                      (* Sym2 later on (pointer via NIL)   *)
11431       combinedtok := MakeVirtualTok (exprtok, exprtok, ptrtok) ;
11432       PushTFrwtok (Sym2, Type2, rw, combinedtok) ;
11433       DebugLocation (combinedtok, "pointer expression")
11434    ELSE
11435       MetaError2 ('{%1ad} is not a pointer type but a {%2d}', Sym1, Type1)
11436    END
11437 END BuildDesignatorPointer ;
11438
11439
11440 (*
11441    StartBuildWith - performs the with statement.
11442                     The Stack:
11443
11444                     Entry                    Exit
11445
11446                     +------------+
11447                     | Sym | Type |           Empty
11448                     |------------|
11449 *)
11450
11451 PROCEDURE StartBuildWith (withTok: CARDINAL) ;
11452 VAR
11453    tok      : CARDINAL ;
11454    Sym, Type,
11455    Ref      : CARDINAL ;
11456 BEGIN
11457    DebugLocation (withtok, "with") ;
11458    BuildStmtNoteTok (withTok) ;
11459    DisplayStack ;
11460    PopTFtok (Sym, Type, tok) ;
11461    DebugLocation (tok, "expression") ;
11462    Type := SkipType (Type) ;
11463
11464    Ref := MakeTemporary (tok, LeftValue) ;
11465    PutVar (Ref, Type) ;
11466    IF GetMode (Sym) = LeftValue
11467    THEN
11468       (* Copy LeftValue.  *)
11469       GenQuadO (tok, BecomesOp, Ref, NulSym, Sym, TRUE)
11470    ELSE
11471       (* Calculate the address of Sym.  *)
11472       GenQuadO (tok, AddrOp, Ref, NulSym, Sym, TRUE)
11473    END ;
11474
11475    PushWith (Sym, Type, Ref, tok) ;
11476    DebugLocation (tok, "with ref") ;
11477    IF Type = NulSym
11478    THEN
11479       MetaError1 ('{%1Ea} {%1d} has a no type, the {%kWITH} statement requires a variable or parameter of a {%kRECORD} type',
11480                   Sym)
11481    ELSIF NOT IsRecord(Type)
11482    THEN
11483       MetaError1 ('the {%kWITH} statement requires that {%1Ea} {%1d} be of a {%kRECORD} {%1tsa:type rather than {%1tsa}}',
11484                    Sym)
11485    END ;
11486    StartScope (Type)
11487  ; DisplayStack ;
11488 END StartBuildWith ;
11489
11490
11491 (*
11492    EndBuildWith - terminates the innermost with scope.
11493 *)
11494
11495 PROCEDURE EndBuildWith ;
11496 BEGIN
11497    DisplayStack ;
11498    EndScope ;
11499    PopWith
11500  ; DisplayStack ;
11501 END EndBuildWith ;
11502
11503
11504 (*
11505    PushWith - pushes sym and type onto the with stack. It checks for
11506               previous declaration of this record type.
11507 *)
11508
11509 PROCEDURE PushWith (Sym, Type, Ref, Tok: CARDINAL) ;
11510 VAR
11511    i, n: CARDINAL ;
11512    f   : WithFrame ;
11513 BEGIN
11514    IF Pedantic
11515    THEN
11516       n := NoOfItemsInStackAddress(WithStack) ;
11517       i := 1 ;  (* Top of the stack.  *)
11518       WHILE i <= n DO
11519          (* Search for other declarations of the with using Type.  *)
11520          f := PeepAddress(WithStack, i) ;
11521          IF f^.RecordSym=Type
11522          THEN
11523             MetaErrorT1 (Tok,
11524                          'cannot have nested {%kWITH} statements referencing the same {%kRECORD} {%1Ead}',
11525                          Sym) ;
11526             MetaErrorT1 (f^.RecordTokPos,
11527                          'cannot have nested {%kWITH} statements referencing the same {%kRECORD} {%1Ead}',
11528                          f^.RecordSym)
11529          END ;
11530          INC (i)
11531       END
11532    END ;
11533    NEW (f) ;
11534    WITH f^ DO
11535       RecordSym    := Sym ;
11536       RecordType   := Type ;
11537       RecordRef    := Ref ;
11538       rw           := Sym ;
11539       RecordTokPos := Tok
11540    END ;
11541    PushAddress (WithStack, f)
11542 END PushWith ;
11543
11544
11545 PROCEDURE PopWith ;
11546 VAR
11547    f: WithFrame ;
11548 BEGIN
11549    f := PopAddress (WithStack) ;
11550    DISPOSE (f)
11551 END PopWith ;
11552
11553
11554 (*
11555    CheckWithReference - performs the with statement.
11556                         The Stack:
11557
11558                         Entry                    Exit
11559
11560                         +------------+           +------------+
11561                         | Sym | Type |           | Sym | Type |
11562                         |------------|           |------------|
11563 *)
11564
11565 PROCEDURE CheckWithReference ;
11566 VAR
11567    f        : WithFrame ;
11568    tokpos,
11569    i, n, rw,
11570    Sym, Type: CARDINAL ;
11571 BEGIN
11572    n := NoOfItemsInStackAddress(WithStack) ;
11573    IF (n>0) AND (NOT SuppressWith)
11574    THEN
11575       PopTFrwtok (Sym, Type, rw, tokpos) ;
11576       Assert (tokpos # UnknownTokenNo) ;
11577       (* inner WITH always has precidence *)
11578       i := 1 ;  (* top of stack *)
11579       WHILE i<=n DO
11580          (* WriteString('Checking for a with') ; *)
11581          f := PeepAddress (WithStack, i) ;
11582          WITH f^ DO
11583             IF IsRecordField (Sym) AND (GetRecord (GetParent (Sym)) = RecordType)
11584             THEN
11585                IF IsUnused (Sym)
11586                THEN
11587                   MetaError1('record field {%1Dad} was declared as unused by a pragma', Sym)
11588                END ;
11589                (* Fake a RecordSym.op *)
11590                PushTFrwtok (RecordRef, RecordType, rw, RecordTokPos) ;
11591                PushTFtok (Sym, Type, tokpos) ;
11592                BuildAccessWithField ;
11593                PopTFrw (Sym, Type, rw) ;
11594                i := n+1  (* Finish loop.  *)
11595             ELSE
11596                INC (i)
11597             END
11598          END
11599       END ;
11600       PushTFrwtok (Sym, Type, rw, tokpos)
11601    END
11602 END CheckWithReference ;
11603
11604
11605 (*
11606    BuildAccessWithField - similar to BuildDesignatorRecord except it
11607                           does not perform the address operation.
11608                           The address will have been computed at the
11609                           beginning of the WITH statement.
11610                           It also stops the GenQuad procedure from examining the
11611                           with stack.
11612
11613                           The Stack
11614
11615                           Entry
11616
11617                    Ptr ->
11618                           +--------------+
11619                           | Field | Type1|                          <- Ptr
11620                           |-------|------|          +-------------+
11621                           | Adr   | Type2|          | Sym  | Type1|
11622                           |--------------|          |-------------|
11623 *)
11624
11625 PROCEDURE BuildAccessWithField ;
11626 VAR
11627    rectok, fieldtok  : CARDINAL ;
11628    OldSuppressWith   : BOOLEAN ;
11629    rw,
11630    Field, FieldType,
11631    Record, RecordType,
11632    Ref               : CARDINAL ;
11633 BEGIN
11634    OldSuppressWith := SuppressWith ;
11635    SuppressWith := TRUE ;
11636    (*
11637       now the WITH cannot look at the stack of outstanding WITH records.
11638    *)
11639    PopTFtok (Field, FieldType, fieldtok) ;
11640    PopTFrwtok (Record, RecordType, rw, rectok) ;
11641
11642    Ref := MakeComponentRef (MakeComponentRecord (fieldtok,
11643                                                  RightValue, Record), Field) ;
11644    PutVarConst (Ref, IsReadOnly (Record)) ;
11645    GenQuadO (fieldtok,
11646              RecordFieldOp, Ref, Record, Field, TRUE) ;
11647
11648    PushTFrwtok (Ref, FieldType, rw, fieldtok) ;
11649    SuppressWith := OldSuppressWith
11650 END BuildAccessWithField ;
11651
11652
11653 (*
11654    BuildNulExpression - Builds a nul expression on the stack.
11655                         The Stack:
11656
11657                         Entry             Exit
11658
11659                                                          <- Ptr
11660                         Empty             +------------+
11661                                           | NulSym     |
11662                                           |------------|
11663 *)
11664
11665 PROCEDURE BuildNulExpression ;
11666 BEGIN
11667    PushT(NulSym)
11668 END BuildNulExpression ;
11669
11670
11671 (*
11672    BuildTypeForConstructor - pushes the type implied by the current constructor.
11673                              If no constructor is currently being built then
11674                              it Pushes a Bitset type.
11675 *)
11676
11677 PROCEDURE BuildTypeForConstructor ;
11678 VAR
11679    c: ConstructorFrame ;
11680 BEGIN
11681    IF NoOfItemsInStackAddress(ConstructorStack)=0
11682    THEN
11683       PushT(Bitset)
11684    ELSE
11685       c := PeepAddress(ConstructorStack, 1) ;
11686       WITH c^ DO
11687          IF IsArray(type) OR IsSet(type)
11688          THEN
11689             PushT(GetSType(type))
11690          ELSIF IsRecord(type)
11691          THEN
11692             PushT(GetSType(GetNth(type, index)))
11693          ELSE
11694             MetaError1('{%1ad} is not a set, record or array type which is expected when constructing an aggregate entity',
11695                        type)
11696          END
11697       END
11698    END
11699 END BuildTypeForConstructor ;
11700
11701
11702 (*
11703    BuildSetStart - Pushes a Bitset type on the stack.
11704
11705                       The Stack:
11706
11707                       Entry             Exit
11708
11709                Ptr ->                                        <- Ptr
11710
11711                       Empty             +--------------+
11712                                         | Bitset       |
11713                                         |--------------|
11714 *)
11715
11716 PROCEDURE BuildSetStart ;
11717 BEGIN
11718    PushT(Bitset)
11719 END BuildSetStart ;
11720
11721
11722 (*
11723    BuildSetEnd - pops the set value and type from the stack
11724                  and pushes the value,type pair.
11725
11726                     Entry                   Exit
11727
11728              Ptr ->
11729                     +--------------+
11730                     | Set Value    |                         <- Ptr
11731                     |--------------|        +--------------+
11732                     | Set Type     |        | Value | Type |
11733                     |--------------|        |--------------|
11734 *)
11735
11736 PROCEDURE BuildSetEnd ;
11737 VAR
11738    v, t: CARDINAL ;
11739 BEGIN
11740    PopT(v) ;
11741    PopT(t) ;
11742    PushTF(v, t) ;
11743    Assert(IsSet(t))
11744 END BuildSetEnd ;
11745
11746
11747 (*
11748    BuildEmptySet - Builds an empty set on the stack.
11749                    The Stack:
11750
11751                    Entry             Exit
11752
11753                                                      <- Ptr
11754                                      +-------------+
11755             Ptr ->                   | Value       |
11756                    +-----------+     |-------------|
11757                    | SetType   |     | SetType     |
11758                    |-----------|     |-------------|
11759
11760 *)
11761
11762 PROCEDURE BuildEmptySet ;
11763 VAR
11764    n     : Name ;
11765    Type  : CARDINAL ;
11766    NulSet: CARDINAL ;
11767    tok   : CARDINAL ;
11768 BEGIN
11769    PopT(Type) ;  (* type of set we are building *)
11770    tok := GetTokenNo () ;
11771    IF (Type=NulSym) AND Pim
11772    THEN
11773       (* allowed generic {} in PIM Modula-2 *)
11774    ELSIF IsUnknown(Type)
11775    THEN
11776       n := GetSymName(Type) ;
11777       WriteFormat1('set type %a is undefined', n) ;
11778       Type := Bitset
11779    ELSIF NOT IsSet(SkipType(Type))
11780    THEN
11781       n := GetSymName(Type) ;
11782       WriteFormat1('expecting a set type %a', n) ;
11783       Type := Bitset
11784    ELSE
11785       Type := SkipType(Type) ;
11786       Assert((Type#NulSym))
11787    END ;
11788    NulSet := MakeTemporary(tok, ImmediateValue) ;
11789    PutVar(NulSet, Type) ;
11790    PutConstSet(NulSet) ;
11791    IF CompilerDebugging
11792    THEN
11793       n := GetSymName(Type) ;
11794       printf1('set type = %a\n', n)
11795    END ;
11796    PushNulSet(Type) ;   (* onto the ALU stack  *)
11797    PopValue(NulSet) ;   (* ALU -> symbol table *)
11798
11799    (* and now construct the M2Quads stack as defined by the comments above *)
11800    PushT(Type) ;
11801    PushT(NulSet) ;
11802    IF CompilerDebugging
11803    THEN
11804       n := GetSymName(Type) ;
11805       printf2('Type = %a  (%d)  built empty set\n', n, Type) ;
11806       DisplayStack    (* Debugging info *)
11807    END
11808 END BuildEmptySet ;
11809
11810
11811 (*
11812    BuildInclRange - includes a set range with a set.
11813
11814
11815                           Entry                   Exit
11816                           =====                   ====
11817
11818
11819                    Ptr ->
11820                           +------------+
11821                           | El2        |
11822                           |------------|
11823                           | El1        |                                 <- Ptr
11824                           |------------|           +-------------------+
11825                           | Set Value  |           | Value + {El1..El2}|
11826                           |------------|           |-------------------|
11827
11828                    No quadruples produced as the range info is contained within
11829                    the set value.
11830 *)
11831
11832 PROCEDURE BuildInclRange ;
11833 VAR
11834    n       : Name ;
11835    el1, el2,
11836    value   : CARDINAL ;
11837 BEGIN
11838    PopT(el2) ;
11839    PopT(el1) ;
11840    PopT(value) ;
11841    IF NOT IsConstSet(value)
11842    THEN
11843       n := GetSymName(el1) ;
11844       WriteFormat1('can only add bit ranges to a constant set, %a is not a constant set', n)
11845    END ;
11846    IF IsConst(el1) AND IsConst(el2)
11847    THEN
11848       PushValue(value) ;  (* onto ALU stack *)
11849       AddBitRange(GetTokenNo(), el1, el2) ;
11850       PopValue(value)     (* ALU -> symboltable *)
11851    ELSE
11852       IF NOT IsConst(el1)
11853       THEN
11854          n := GetSymName(el1) ;
11855          WriteFormat1('must use constants as ranges when defining a set constant, problem with the low value %a', n)
11856       END ;
11857       IF NOT IsConst(el2)
11858       THEN
11859          n := GetSymName(el2) ;
11860          WriteFormat1('must use constants as ranges when defining a set constant, problem with the high value %a', n)
11861       END
11862    END ;
11863    PushT(value)
11864 END BuildInclRange ;
11865
11866
11867 (*
11868    BuildInclBit - includes a bit into the set.
11869
11870                          Entry                   Exit
11871                          =====                   ====
11872
11873
11874                   Ptr ->
11875                          +------------+
11876                          | Element    |                         <- Ptr
11877                          |------------|          +------------+
11878                          | Value      |          | Value      |
11879                          |------------|          |------------|
11880
11881 *)
11882
11883 PROCEDURE BuildInclBit ;
11884 VAR
11885    tok         : CARDINAL ;
11886    el, value, t: CARDINAL ;
11887 BEGIN
11888    PopT(el) ;
11889    PopT(value) ;
11890    tok := GetTokenNo () ;
11891    IF IsConst(el)
11892    THEN
11893       PushValue(value) ;  (* onto ALU stack *)
11894       AddBit(tok, el) ;
11895       PopValue(value)    (* ALU -> symboltable *)
11896    ELSE
11897       IF GetMode(el)=LeftValue
11898       THEN
11899          t := MakeTemporary(tok, RightValue) ;
11900          PutVar(t, GetSType(el)) ;
11901          CheckPointerThroughNil (tok, el) ;
11902          doIndrX(tok, t, el) ;
11903          el := t
11904       END ;
11905       IF IsConst(value)
11906       THEN
11907          (* move constant into a variable to achieve the include *)
11908          t := MakeTemporary(tok, RightValue) ;
11909          PutVar(t, GetSType(value)) ;
11910          GenQuad(BecomesOp, t, NulSym, value) ;
11911          value := t
11912       END ;
11913       GenQuad(InclOp, value, NulSym, el)
11914    END ;
11915    PushT(value)
11916 END BuildInclBit ;
11917
11918
11919 (*
11920    PushConstructor -
11921 *)
11922
11923 PROCEDURE PushConstructor (sym: CARDINAL) ;
11924 VAR
11925    c: ConstructorFrame ;
11926 BEGIN
11927    NEW(c) ;
11928    WITH c^ DO
11929       type := SkipType(sym) ;
11930       index := 1
11931    END ;
11932    PushAddress(ConstructorStack, c)
11933 END PushConstructor ;
11934
11935
11936 (*
11937    PopConstructor - removes the top constructor from the top of stack.
11938 *)
11939
11940 PROCEDURE PopConstructor ;
11941 VAR
11942    c: ConstructorFrame ;
11943 BEGIN
11944    c := PopAddress (ConstructorStack) ;
11945    DISPOSE(c)
11946 END PopConstructor ;
11947
11948
11949 (*
11950    NextConstructorField - increments the top of constructor stacks index by one.
11951 *)
11952
11953 PROCEDURE NextConstructorField ;
11954 VAR
11955    c: ConstructorFrame ;
11956 BEGIN
11957    c := PeepAddress(ConstructorStack, 1) ;
11958    INC(c^.index)
11959 END NextConstructorField ;
11960
11961
11962 (*
11963    SilentBuildConstructor - places NulSym into the constructor fifo queue.
11964 *)
11965
11966 PROCEDURE SilentBuildConstructor ;
11967 BEGIN
11968    PutConstructorIntoFifoQueue (NulSym)
11969 END SilentBuildConstructor ;
11970
11971
11972 (*
11973    BuildConstructor - builds a constructor.
11974                       Stack
11975
11976                       Entry                 Exit
11977
11978                Ptr ->
11979                       +------------+
11980                       | Type       |                <- Ptr
11981                       |------------+
11982 *)
11983
11984 PROCEDURE BuildConstructor (tokcbrpos: CARDINAL) ;
11985 VAR
11986    tok       : CARDINAL ;
11987    constValue,
11988    type      : CARDINAL ;
11989 BEGIN
11990    PopTtok (type, tok) ;
11991    constValue := MakeTemporary (tok, ImmediateValue) ;
11992    PutVar (constValue, type) ;
11993    PutConstructor (constValue) ;
11994    PushValue (constValue) ;
11995    IF type = NulSym
11996    THEN
11997       MetaErrorT0 (tokcbrpos,
11998                    '{%E}constructor requires a type before the opening {')
11999    ELSE
12000       ChangeToConstructor (tok, type) ;
12001       PutConstructorFrom (constValue, type) ;
12002       PopValue (constValue) ;
12003       PutConstructorIntoFifoQueue (constValue)
12004    END ;
12005    PushConstructor (type)
12006 END BuildConstructor ;
12007
12008
12009 (*
12010    SilentBuildConstructorStart - removes an entry from the constructor fifo queue.
12011 *)
12012
12013 PROCEDURE SilentBuildConstructorStart ;
12014 VAR
12015    constValue: CARDINAL ;
12016 BEGIN
12017    GetConstructorFromFifoQueue (constValue)
12018 END SilentBuildConstructorStart ;
12019
12020
12021 (*
12022    BuildConstructorStart - builds a constructor.
12023                            Stack
12024
12025                            Entry                 Exit
12026
12027                     Ptr ->                                          <- Ptr
12028                            +------------+        +----------------+
12029                            | Type       |        | ConstructorSym |
12030                            |------------+        |----------------|
12031 *)
12032
12033 PROCEDURE BuildConstructorStart (cbratokpos: CARDINAL) ;
12034 VAR
12035    constValue,
12036    type      : CARDINAL ;
12037 BEGIN
12038    PopT (type) ;   (* we ignore the type as we already have the constructor symbol from pass C *)
12039    GetConstructorFromFifoQueue (constValue) ;
12040    IF type # GetSType (constValue)
12041    THEN
12042       MetaErrorT3 (cbratokpos,
12043                    '{%E}the constructor type is {%1ad} and this is different from the constant {%2ad} which has a type {%2tad}',
12044                    type, constValue, constValue)
12045    END ;
12046    PushTtok (constValue, cbratokpos) ;
12047    PushConstructor (type)
12048 END BuildConstructorStart ;
12049
12050
12051 (*
12052    BuildConstructorEnd - removes the current constructor frame from the
12053                          constructor stack (it does not effect the quad
12054                          stack)
12055
12056                          Entry                 Exit
12057
12058                   Ptr ->                                      <- Ptr
12059                          +------------+        +------------+
12060                          | const      |        | const      |
12061                          |------------|        |------------|
12062 *)
12063
12064 PROCEDURE BuildConstructorEnd (cbratokpos: CARDINAL) ;
12065 VAR
12066    typetok,
12067    value, valtok: CARDINAL ;
12068 BEGIN
12069    PopTtok (value, valtok) ;
12070    IF IsBoolean (1)
12071    THEN
12072       typetok := valtok
12073    ELSE
12074       typetok := OperandTtok (1)
12075    END ;
12076    valtok := MakeVirtualTok (typetok, typetok, cbratokpos) ;
12077    PutDeclared (valtok, value) ;
12078    PushTtok (value, valtok) ;   (* Use valtok as we now know it was a constructor.  *)
12079    PopConstructor
12080    (* ; ErrorStringAt (Mark (InitString ('aggregate constant')), valtok) *)
12081 END BuildConstructorEnd ;
12082
12083
12084 (*
12085    AddFieldTo - adds field, e, to, value.
12086 *)
12087
12088 PROCEDURE AddFieldTo (value, e: CARDINAL) : CARDINAL ;
12089 BEGIN
12090    IF IsSet(GetDType(value))
12091    THEN
12092       PutConstSet(value) ;
12093       PushT(value) ;
12094       PushT(e) ;
12095       BuildInclBit ;
12096       PopT(value)
12097    ELSE
12098       PushValue(value) ;
12099       AddField(GetTokenNo(), e) ;
12100       PopValue(value)
12101    END ;
12102    RETURN( value )
12103 END AddFieldTo ;
12104
12105
12106 (*
12107    BuildComponentValue -  builds a component value.
12108
12109                           Entry                 Exit
12110
12111                    Ptr ->                                      <- Ptr
12112
12113
12114                           +------------+        +------------+
12115                           | const      |        | const      |
12116                           |------------|        |------------|
12117 *)
12118
12119 PROCEDURE BuildComponentValue ;
12120 VAR
12121    const,
12122    e1, e2   : CARDINAL ;
12123    nuldotdot,
12124    nulby    : Name ;
12125 BEGIN
12126    PopT(nulby) ;
12127    IF nulby=NulTok
12128    THEN
12129       PopT(nuldotdot) ;
12130       IF nuldotdot=NulTok
12131       THEN
12132          PopT(e1) ;
12133          PopT(const) ;
12134          PushT(AddFieldTo(const, e1))
12135       ELSE
12136          PopT(e2) ;
12137          PopT(e1) ;
12138          PopT(const) ;
12139          PushValue(const) ;
12140          AddBitRange(GetTokenNo(), e1, e2) ;
12141          PopValue(const) ;
12142          PushT(const)
12143       END
12144    ELSE
12145       PopT(e1) ;
12146       PopT(nuldotdot) ;
12147       IF nuldotdot=NulTok
12148       THEN
12149          PopT(e2) ;
12150          PopT(const) ;
12151          PushValue(const) ;
12152          AddElements(GetTokenNo(), e2, e1) ;
12153          PopValue(const) ;
12154          PushT(const)
12155       ELSE
12156          PopT(e2) ;
12157          PopT(e1) ;
12158          PopT(const) ;
12159          WriteFormat0('the constant must be an array constructor or a set constructor but not both') ;
12160          PushT(const)
12161       END
12162    END
12163 END BuildComponentValue ;
12164
12165
12166 (*
12167    RecordOp - Records the operator passed on the stack.
12168               Checks for AND operator or OR operator
12169               if either of these operators are found then BackPatching
12170               takes place.
12171               The Expected Stack:
12172
12173               Entry                        Exit
12174
12175        Ptr ->                                               <- Ptr
12176               +-------------+               +-------------+
12177               | OperatorTok |               | OperatorTok |
12178               |-------------|               |-------------|
12179               | t    | f    |               | t    | f    |
12180               |-------------|               |-------------|
12181
12182
12183               If OperatorTok=AndTok
12184               Then
12185                  BackPatch(f, NextQuad)
12186               Elsif OperatorTok=OrTok
12187               Then
12188                  BackPatch(t, NextQuad)
12189               End
12190 *)
12191
12192 PROCEDURE RecordOp ;
12193 VAR
12194    Op   : Name ;
12195    tokno: CARDINAL ;
12196    t, f : CARDINAL ;
12197 BEGIN
12198    PopTtok(Op, tokno) ;
12199    IF (Op=AndTok) OR (Op=AmbersandTok)
12200    THEN
12201       CheckBooleanId ;
12202       PopBool(t, f) ;
12203       BackPatch(t, NextQuad) ;
12204       PushBool(0, f)
12205    ELSIF Op=OrTok
12206    THEN
12207       CheckBooleanId ;
12208       PopBool(t, f) ;
12209       BackPatch(f, NextQuad) ;
12210       PushBool(t, 0)
12211    END ;
12212    PushTtok(Op, tokno)
12213 END RecordOp ;
12214
12215
12216 (*
12217    CheckLogicalOperator - returns a logical operator if the operands imply
12218                           a logical operation should be performed.
12219 *)
12220
12221 PROCEDURE CheckLogicalOperator (Tok: Name; left, lefttype: CARDINAL) : Name ;
12222 BEGIN
12223    IF (Tok=PlusTok) OR (Tok=TimesTok) OR (Tok=DivideTok) OR (Tok=MinusTok)
12224    THEN
12225       (* --fixme-- when we add complex arithmetic, we must check constructor is not a complex constant.  *)
12226       IF ((lefttype#NulSym) AND IsSet(SkipType(lefttype))) OR
12227          IsConstSet(left) OR IsConstructor(left)
12228       THEN
12229          IF Tok=PlusTok
12230          THEN
12231             RETURN( LogicalOrTok )
12232          ELSIF Tok=DivideTok
12233          THEN
12234             RETURN( LogicalXorTok )
12235          ELSIF Tok=TimesTok
12236          THEN
12237             RETURN( LogicalAndTok )
12238          ELSIF Tok=MinusTok
12239          THEN
12240             RETURN( LogicalDifferenceTok )
12241          END
12242       END
12243    END ;
12244    RETURN( Tok )
12245 END CheckLogicalOperator ;
12246
12247
12248 (*
12249    doCheckGenericNulSet - checks to see whether e1 is a generic nul set and if so it alters it
12250                           to the nul set of t2.
12251 *)
12252
12253 (*
12254 PROCEDURE doCheckGenericNulSet (e1: CARDINAL; VAR t1: CARDINAL; t2: CARDINAL) ;
12255 BEGIN
12256    IF IsConstSet (e1)
12257    THEN
12258       IF NOT IsSet (t2)
12259       THEN
12260          MetaError2 ('incompatibility between a set constant {%1Ea} of type {%1tsa} and an object of type {%2sa}',
12261                      e1, t2)
12262       END ;
12263       PushValue (e1) ;
12264       IF IsGenericNulSet ()
12265       THEN
12266          PopValue (e1) ;
12267          PushNulSet (t2) ;
12268          t1 := t2
12269       END ;
12270       PopValue (e1)
12271    END
12272 END doCheckGenericNulSet ;
12273 *)
12274
12275
12276 (*
12277    CheckGenericNulSet - if e1 or e2 is the generic nul set then
12278                         alter it to the nul set of the other operands type.
12279 *)
12280
12281 (*
12282 PROCEDURE CheckGenericNulSet (e1, e2: CARDINAL; VAR t1, t2: CARDINAL) ;
12283 BEGIN
12284    IF t1#t2
12285    THEN
12286       doCheckGenericNulSet(e1, t1, t2) ;
12287       doCheckGenericNulSet(e2, t2, t1)
12288    END
12289 END CheckGenericNulSet ;
12290 *)
12291
12292
12293 (*
12294    CheckDivModRem - initiates calls to check the divisor for DIV, MOD, REM
12295                     expressions.
12296 *)
12297
12298 PROCEDURE CheckDivModRem (TokPos: CARDINAL; tok: Name; d, e: CARDINAL) ;
12299 BEGIN
12300    IF tok=DivTok
12301    THEN
12302       BuildRange (InitWholeZeroDivisionCheck (TokPos, d, e))
12303    ELSIF tok=ModTok
12304    THEN
12305       BuildRange (InitWholeZeroDivisionCheck (TokPos, d, e))
12306    ELSIF tok=RemTok
12307    THEN
12308       BuildRange (InitWholeZeroRemainderCheck (TokPos, d, e))
12309    END
12310 END CheckDivModRem ;
12311
12312
12313 (*
12314    doConvert - convert, sym, to a new symbol with, type.
12315                Return the new symbol.
12316 *)
12317
12318 PROCEDURE doConvert (type: CARDINAL; sym: CARDINAL) : CARDINAL ;
12319 BEGIN
12320    IF GetSType(sym)#type
12321    THEN
12322       PushTF(Convert, NulSym) ;
12323       PushT(type) ;
12324       PushT(sym) ;
12325       PushT(2) ;          (* Two parameters *)
12326       BuildConvertFunction ;
12327       PopT(sym)
12328    END ;
12329    RETURN( sym )
12330 END doConvert ;
12331
12332
12333 (*
12334    BuildBinaryOp   - Builds a binary operation from the quad stack.
12335                      Be aware that this procedure will check for
12336                      the overloading of the bitset operators + - \ *.
12337                      So do NOT call this procedure if you are building
12338                      a reference to an array which has a bitset type or
12339                      the address arithmetic will be wrongly coersed into
12340                      logical ORs.
12341
12342                      The Stack is expected to contain:
12343
12344
12345                      Entry                   Exit
12346                      =====                   ====
12347
12348               Ptr ->
12349                      +------------+
12350                      | Sym1       |
12351                      |------------|
12352                      | Operator   |                          <- Ptr
12353                      |------------|          +------------+
12354                      | Sym2       |          | Temporary  |
12355                      |------------|          |------------|
12356
12357
12358                      Quadruples Produced
12359
12360                      q     Operator  Temporary  Sym1  Sym2
12361
12362
12363                 OR
12364
12365
12366                      Entry                   Exit
12367                      =====                   ====
12368
12369               Ptr ->
12370                      +------------+
12371                      | T1   | F1  |
12372                      |------------|
12373                      | OrTok      |                          <- Ptr
12374                      |------------|          +------------+
12375                      | T2   | F2  |          | T1+T2| F1  |
12376                      |------------|          |------------|
12377
12378
12379                      Quadruples Produced
12380
12381 *)
12382
12383 PROCEDURE BuildBinaryOp ;
12384 BEGIN
12385    doBuildBinaryOp (TRUE, TRUE)
12386 END BuildBinaryOp ;
12387
12388
12389 (*
12390    doBuildBinaryOp - build the binary op, with or without type
12391                      checking.
12392 *)
12393
12394 PROCEDURE doBuildBinaryOp (checkTypes, checkOverflow: BOOLEAN) ;
12395 VAR
12396    s                  : String ;
12397    NewOp,
12398    Operator           : Name ;
12399    OperatorPos,
12400    OldPos,
12401    leftrw, rightrw,
12402    t1, f1,
12403    t2, f2,
12404    lefttype, righttype,
12405    left, right,
12406    leftpos, rightpos  : CARDINAL ;
12407    value              : CARDINAL ;
12408 BEGIN
12409    Operator := OperandT (2) ;
12410    IF Operator = OrTok
12411    THEN
12412       CheckBooleanId ;
12413       PopBool (t1, f1) ;
12414       PopTtok (Operator, OperatorPos) ;
12415       PopBool (t2, f2) ;
12416       Assert (f2=0) ;
12417       PushBool (Merge (t1, t2), f1)
12418    ELSIF (Operator = AndTok) OR (Operator = AmbersandTok)
12419    THEN
12420       CheckBooleanId ;
12421       PopBool (t1, f1) ;
12422       PopTtok (Operator, OperatorPos) ;
12423       PopBool (t2, f2) ;
12424       Assert (t2=0) ;
12425       PushBool (t1, Merge (f1, f2))
12426    ELSE
12427       PopTFrwtok (right, righttype, rightrw, rightpos) ;
12428       PopTtok (Operator, OperatorPos) ;
12429       PopTFrwtok (left, lefttype, leftrw, leftpos) ;
12430       MarkAsRead (rightrw) ;
12431       MarkAsRead (leftrw) ;
12432       NewOp := CheckLogicalOperator (Operator, (* right, righttype, *) left, lefttype) ;
12433       IF NewOp = Operator
12434       THEN
12435          (*
12436             BinaryOps and UnaryOps only work with immediate and
12437             offset addressing.  This is fine for calculating
12438             array and record offsets but we need to get the real
12439             values to perform normal arithmetic. Not address
12440             arithmetic.
12441
12442             However the set operators will dereference LValues
12443             (to optimize large set arithemetic)
12444          *)
12445          IF GetMode (right) = LeftValue
12446          THEN
12447             value := MakeTemporary (rightpos, RightValue) ;
12448             PutVar (value, righttype) ;
12449             CheckPointerThroughNil (rightpos, right) ;
12450             doIndrX (rightpos, value, right) ;
12451             right := value
12452          END ;
12453          IF GetMode (left) = LeftValue
12454          THEN
12455             value := MakeTemporary (leftpos, RightValue) ;
12456             PutVar (value, lefttype) ;
12457             CheckPointerThroughNil (leftpos, left) ;
12458             doIndrX (leftpos, value, left) ;
12459             left := value
12460          END
12461       ELSE
12462          (* CheckForGenericNulSet(e1, e2, t1, t2) *)
12463       END ;
12464       IF (Operator = PlusTok) AND IsConstString(left) AND IsConstString(right)
12465       THEN
12466          (* handle special addition for constant strings *)
12467          s := InitStringCharStar (KeyToCharStar (GetString (left))) ;
12468          s := ConCat (s, Mark (InitStringCharStar (KeyToCharStar (GetString (right))))) ;
12469          value := MakeConstLitString (OperatorPos, makekey (string (s))) ;
12470          s := KillString (s)
12471       ELSE
12472          OldPos := OperatorPos ;
12473          OperatorPos := MakeVirtualTok (OperatorPos, leftpos, rightpos) ;
12474          IF checkTypes
12475          THEN
12476             BuildRange (InitTypesExpressionCheck (OperatorPos, left, right, FALSE, FALSE))
12477          END ;
12478          value := MakeTemporaryFromExpressions (OperatorPos,
12479                                                 right, left,
12480                                                 AreConstant (IsConst (left) AND IsConst (right))) ;
12481
12482          CheckDivModRem (OperatorPos, NewOp, value, right) ;
12483
12484          IF DebugTokPos
12485          THEN
12486             s := InitStringCharStar (KeyToCharStar (GetTokenName (Operator))) ;
12487             WarnStringAt (s, OldPos) ;
12488             s := InitString ('left') ;
12489             WarnStringAt (s, leftpos) ;
12490             s := InitString ('right') ;
12491             WarnStringAt (s, rightpos) ;
12492             s := InitString ('caret') ;
12493             WarnStringAt (s, OldPos) ;
12494             s := InitString ('combined') ;
12495             WarnStringAt (s, OperatorPos) ;
12496             (* MetaErrorT1 (GetDeclaredMod (t), 'in binary with a {%1a}', t) *)
12497          END ;
12498          GenQuadOtok (OperatorPos, MakeOp (NewOp), value, left, right, checkOverflow,
12499                       OperatorPos, leftpos, rightpos)
12500       END ;
12501       PushTFtok (value, GetSType (value), OperatorPos)
12502    END
12503 END doBuildBinaryOp ;
12504
12505
12506 (*
12507    BuildUnaryOp   - Builds a unary operation from the quad stack.
12508                     The Stack is expected to contain:
12509
12510
12511                     Entry                   Exit
12512                     =====                   ====
12513
12514              Ptr ->
12515                     +------------+
12516                     | Sym        |
12517                     |------------|          +------------+
12518                     | Operator   |          | Temporary  | <- Ptr
12519                     |------------|          |------------|
12520
12521
12522                     Quadruples Produced
12523
12524                     q     Operator  Temporary  _ Sym
12525
12526 *)
12527
12528 PROCEDURE BuildUnaryOp ;
12529 VAR
12530    sympos,
12531    tokpos    : CARDINAL ;
12532    Tok       : Name ;
12533    type,
12534    Sym,
12535    SymT, r, t: CARDINAL ;
12536 BEGIN
12537    PopTrwtok (Sym, r, sympos) ;
12538    PopTtok (Tok, tokpos) ;
12539    IF Tok=MinusTok
12540    THEN
12541       MarkAsRead(r) ;
12542       type := NegateType (GetSType (Sym) (* , sympos *) ) ;
12543       tokpos := MakeVirtualTok (tokpos, tokpos, sympos) ;
12544
12545       t := MakeTemporary (tokpos, AreConstant(IsConst(Sym))) ;
12546       PutVar(t, type) ;
12547
12548       (*
12549          variables must have a type and REAL/LONGREAL constants must
12550          be typed
12551       *)
12552
12553       IF NOT IsConst(Sym)
12554       THEN
12555          IF (type#NulSym) AND IsSet(SkipType(type))
12556          THEN
12557             (* do not dereference set variables *)
12558          ELSIF GetMode(Sym)=LeftValue
12559          THEN
12560             (* dereference symbols which are not sets and which are variables *)
12561
12562             SymT := MakeTemporary (sympos, RightValue) ;
12563             PutVar (SymT, GetSType (Sym)) ;
12564             CheckPointerThroughNil (sympos, Sym) ;
12565             doIndrX (sympos, SymT, Sym) ;
12566             Sym := SymT
12567          END
12568       END ;
12569       GenQuadO (tokpos, NegateOp, t, NulSym, Sym, TRUE) ;
12570       PushTtok (t, tokpos)
12571    ELSIF Tok=PlusTok
12572    THEN
12573       tokpos := MakeVirtualTok (tokpos, tokpos, sympos) ;
12574       PushTrwtok (Sym, r, tokpos)
12575    ELSE
12576       MetaErrorNT1 (tokpos,
12577                     'expecting an unary operator, seen {%Ek%a}', Tok)
12578    END
12579 END BuildUnaryOp ;
12580
12581
12582 (*
12583    AreConstant - returns immediate addressing mode if b is true else
12584                  offset mode is returned. b determines whether the
12585                  operands are all constant - in which case we can use
12586                  a constant temporary variable.
12587 *)
12588
12589 PROCEDURE AreConstant (b: BOOLEAN) : ModeOfAddr ;
12590 BEGIN
12591    IF b
12592    THEN
12593       RETURN ImmediateValue
12594    ELSE
12595       RETURN RightValue
12596    END
12597 END AreConstant ;
12598
12599
12600 (*
12601    ConvertBooleanToVariable - converts a BoolStack(i) from a Boolean True|False
12602                               exit pair into a variable containing the value TRUE or
12603                               FALSE. The parameter, i, is relative to the top
12604                               of the stack.
12605 *)
12606
12607 PROCEDURE ConvertBooleanToVariable (tok: CARDINAL; i: CARDINAL) ;
12608 VAR
12609    Des: CARDINAL ;
12610    f  : BoolFrame ;
12611 BEGIN
12612    Assert (IsBoolean (i)) ;
12613    (*
12614       need to convert it to a variable containing the result.
12615       Des will be a boolean type
12616    *)
12617    Des := MakeTemporary (tok, RightValue) ;
12618    PutVar (Des, Boolean) ;
12619    PushTtok (Des, tok) ;   (* we have just increased the stack so we must use i+1 *)
12620    f := PeepAddress (BoolStack, i+1) ;
12621    PushBool (f^.TrueExit, f^.FalseExit) ;
12622    BuildAssignmentWithoutBounds (tok, FALSE, TRUE) ;  (* restored stack *)
12623    f := PeepAddress (BoolStack, i) ;
12624    WITH f^ DO
12625       TrueExit := Des ;  (* alter Stack(i) to contain the variable *)
12626       FalseExit := Boolean ;
12627       BooleanOp := FALSE ; (* no longer a Boolean True|False pair    *)
12628       Unbounded := NulSym ;
12629       Dimension := 0 ;
12630       ReadWrite := NulSym ;
12631       tokenno := tok ;
12632       Annotation := KillString (Annotation) ;
12633       Annotation := InitString ('%1s(%1d)|%2s(%2d)||boolean var|type')
12634    END
12635 END ConvertBooleanToVariable ;
12636
12637
12638 (*
12639    BuildBooleanVariable - tests to see whether top of stack is a boolean
12640                           conditional and if so it converts it into a boolean
12641                           variable.
12642 *)
12643
12644 PROCEDURE BuildBooleanVariable ;
12645 BEGIN
12646    IF IsBoolean (1)
12647    THEN
12648       ConvertBooleanToVariable (OperandTtok (1), 1)
12649    END
12650 END BuildBooleanVariable ;
12651
12652
12653 (*
12654    BuildRelOpFromBoolean - builds a relational operator sequence of quadruples
12655                            instead of using a temporary boolean variable.
12656                            This function can only be used when we perform
12657                            the following translation:
12658
12659                            (a=b) # (c=d)  alternatively   (a=b) = (c=d)
12660                                  ^                              ^
12661
12662                            it only allows # = to be used as >= <= > < all
12663                            assume a particular value for TRUE and FALSE.
12664                            (In which case the user should specify ORD)
12665
12666
12667                            before
12668
12669                            q    if r1      op1     op2     t2
12670                            q+1  Goto                       f2
12671                            q+2  if r2      op3     op4     t1
12672                            q+3  Goto                       f1
12673
12674                            after (in case of =)
12675
12676                            q    if r1      op1     op2     q+2
12677                            q+1  Goto                       q+4
12678                            q+2  if r2      op3     op4     t
12679                            q+3  Goto                       f
12680                            q+4  if r2      op3     op4     f
12681                            q+5  Goto                       t
12682
12683                            after (in case of #)
12684
12685                            q    if r1      op1     op2     q+2
12686                            q+1  Goto                       q+4
12687                            q+2  if r2      op3     op4     f
12688                            q+3  Goto                       t
12689                            q+4  if r2      op3     op4     t
12690                            q+5  Goto                       f
12691
12692                            The Stack is expected to contain:
12693
12694
12695                            Entry                   Exit
12696                            =====                   ====
12697
12698                     Ptr ->
12699                            +------------+
12700                            | t1 | f1    |
12701                            |------------|
12702                            | Operator   |                          <- Ptr
12703                            |------------|          +------------+
12704                            | t2 | f2    |          | t    | f   |
12705                            |------------|          |------------|
12706
12707
12708 *)
12709
12710 PROCEDURE BuildRelOpFromBoolean (tokpos: CARDINAL) ;
12711 VAR
12712    Tok,
12713    t1, f1,
12714    t2, f2: CARDINAL ;
12715    f     : QuadFrame ;
12716 BEGIN
12717    Assert (IsBoolean (1) AND IsBoolean (3)) ;
12718    IF OperandT (2) = EqualTok
12719    THEN
12720       (* are the two boolean expressions the same? *)
12721       PopBool (t1, f1) ;
12722       PopT (Tok) ;
12723       PopBool (t2, f2) ;
12724       (* give the false exit a second chance *)
12725       BackPatch (t2, t1) ;        (* q    if   _     _    q+2 *)
12726       BackPatch (f2, NextQuad) ;  (* q+1  if   _     _    q+4 *)
12727       Assert (NextQuad = f1+1) ;
12728       f := GetQF (t1) ;
12729       WITH f^ DO
12730          GenQuadO (tokpos, Operator, Operand1, Operand2, 0, FALSE)
12731       END ;
12732       GenQuadO (tokpos, GotoOp, NulSym, NulSym, 0, FALSE) ;
12733       PushBool (Merge (NextQuad-1, t1), Merge (NextQuad-2, f1))
12734    ELSIF (OperandT (2) = HashTok) OR (OperandT (2) = LessGreaterTok)
12735    THEN
12736       (* are the two boolean expressions the different? *)
12737       PopBool (t1, f1) ;
12738       PopT (Tok) ;
12739       PopBool (t2, f2) ;
12740       (* give the false exit a second chance *)
12741       BackPatch (t2, t1) ;        (* q    if   _     _    q+2 *)
12742       BackPatch (f2, NextQuad) ;  (* q+1  if   _     _    q+4 *)
12743       Assert (NextQuad = f1+1) ;
12744       f := GetQF (t1) ;
12745       WITH f^ DO
12746          GenQuadO (tokpos, Operator, Operand1, Operand2, 0, FALSE)
12747       END ;
12748       GenQuadO (tokpos, GotoOp, NulSym, NulSym, 0, FALSE) ;
12749       PushBool (Merge (NextQuad-2, f1), Merge (NextQuad-1, t1))
12750    ELSE
12751       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}')
12752    END
12753 END BuildRelOpFromBoolean ;
12754
12755
12756 (*
12757    CheckVariableOrConstantOrProcedure - checks to make sure sym is a variable, constant or procedure.
12758 *)
12759
12760 PROCEDURE CheckVariableOrConstantOrProcedure (tokpos: CARDINAL; sym: CARDINAL) ;
12761 VAR
12762    type: CARDINAL ;
12763 BEGIN
12764    type := GetSType (sym) ;
12765    IF IsUnknown (sym)
12766    THEN
12767       MetaErrorT1 (tokpos, '{%1EUad} has not been declared', sym) ;
12768       UnknownReported (sym)
12769    ELSIF IsPseudoSystemFunction (sym) OR IsPseudoBaseFunction (sym)
12770    THEN
12771       MetaErrorT1 (tokpos,
12772                    '{%1Ead} expected a variable, procedure, constant or expression, not an intrinsic procedure function',
12773                    sym)
12774    ELSIF (NOT IsConst(sym)) AND (NOT IsVar(sym)) AND
12775          (NOT IsProcedure(sym)) AND
12776          (NOT IsTemporary(sym)) AND (NOT MustNotCheckBounds)
12777    THEN
12778       MetaErrorsT1 (tokpos,
12779                     '{%1Ead} expected a variable, procedure, constant or expression',
12780                     'and it was declared as a {%1Dd}', sym) ;
12781    ELSIF (type#NulSym) AND IsArray(type)
12782    THEN
12783       MetaErrorsT1 (tokpos,
12784                     '{%1EU} not expecting an array variable as an operand for either comparison or binary operation',
12785                     'it was declared as a {%1Dd}', sym)
12786    ELSIF IsConstString(sym) AND (GetStringLength(sym)>1)
12787    THEN
12788       MetaErrorT1 (tokpos,
12789                    '{%1EU} not expecting a string constant as an operand for either comparison or binary operation',
12790                    sym)
12791    END
12792 END CheckVariableOrConstantOrProcedure ;
12793
12794
12795 (*
12796    BuildRelOp   - Builds a relative operation from the quad stack.
12797                   The Stack is expected to contain:
12798
12799
12800                   Entry                   Exit
12801                   =====                   ====
12802
12803            Ptr ->
12804                   +------------+
12805                   | e1         |
12806                   |------------|                          <- Ptr
12807                   | Operator   |
12808                   |------------|          +------------+
12809                   | e2         |          | t    | f   |
12810                   |------------|          |------------|
12811
12812
12813                     Quadruples Produced
12814
12815                     q     IFOperator  e2  e1  TrueExit    ; e2  e1 since
12816                     q+1   GotoOp              FalseExit   ; relation > etc
12817                                                           ; requires order.
12818 *)
12819
12820 PROCEDURE BuildRelOp (optokpos: CARDINAL) ;
12821 VAR
12822    combinedTok,
12823    rightpos,
12824    leftpos            : CARDINAL ;
12825    Op                 : Name ;
12826    t,
12827    rightType, leftType,
12828    right, left        : CARDINAL ;
12829    s                  : String ;
12830 BEGIN
12831    IF CompilerDebugging
12832    THEN
12833       DisplayStack    (* Debugging info *)
12834    END ;
12835    IF IsBoolean (1) AND IsBoolean (3)
12836    THEN
12837       (*
12838          we allow # and = to be used with Boolean expressions.
12839          we do not allow >  <  >=  <=  though
12840       *)
12841       BuildRelOpFromBoolean (optokpos)
12842    ELSE
12843       IF IsBoolean (1)
12844       THEN
12845          ConvertBooleanToVariable (OperandTtok (1), 1)
12846       END ;
12847       IF IsBoolean (3)
12848       THEN
12849          ConvertBooleanToVariable (OperandTtok (3), 3)
12850       END ;
12851       PopTFtok (right, rightType, rightpos) ;
12852       PopT (Op) ;
12853       PopTFtok (left, leftType, leftpos) ;
12854
12855       CheckVariableOrConstantOrProcedure (rightpos, right) ;
12856       CheckVariableOrConstantOrProcedure (leftpos, left) ;
12857       combinedTok := MakeVirtualTok (optokpos, leftpos, rightpos) ;
12858
12859       IF (left#NulSym) AND (right#NulSym)
12860       THEN
12861          (* BuildRange will check the expression later on once gcc knows about all data types.  *)
12862          BuildRange (InitTypesExpressionCheck (combinedTok, left, right, TRUE,
12863                                                Op = InTok))
12864       END ;
12865
12866       (* Must dereference LeftValue operands.  *)
12867       IF GetMode(right) = LeftValue
12868       THEN
12869          t := MakeTemporary (rightpos, RightValue) ;
12870          PutVar(t, GetSType(right)) ;
12871          CheckPointerThroughNil (rightpos, right) ;
12872          doIndrX (rightpos, t, right) ;
12873          right := t
12874       END ;
12875       IF GetMode(left) = LeftValue
12876       THEN
12877          t := MakeTemporary (leftpos, RightValue) ;
12878          PutVar (t, GetSType (left)) ;
12879          CheckPointerThroughNil (leftpos, left) ;
12880          doIndrX (leftpos, t, left) ;
12881          left := t
12882       END ;
12883
12884       IF DebugTokPos
12885       THEN
12886          s := InitStringCharStar (KeyToCharStar (GetTokenName (Op))) ;
12887          WarnStringAt (s, optokpos) ;
12888          s := InitString ('left') ;
12889          WarnStringAt (s, leftpos) ;
12890          s := InitString ('right') ;
12891          WarnStringAt (s, rightpos) ;
12892          s := InitString ('caret') ;
12893          WarnStringAt (s, optokpos) ;
12894          s := InitString ('combined') ;
12895          WarnStringAt (s, combinedTok)
12896       END ;
12897
12898       GenQuadOtok (combinedTok, MakeOp (Op), left, right, 0, FALSE,
12899                    leftpos, rightpos, UnknownTokenNo) ;  (* True  Exit *)
12900       GenQuadO (combinedTok, GotoOp, NulSym, NulSym, 0, FALSE) ;  (* False Exit *)
12901       PushBool (NextQuad-2, NextQuad-1)
12902    END
12903 END BuildRelOp ;
12904
12905
12906 (*
12907    BuildNot   - Builds a NOT operation from the quad stack.
12908                 The Stack is expected to contain:
12909
12910
12911                   Entry                   Exit
12912                   =====                   ====
12913
12914            Ptr ->                                        <- Ptr
12915                   +------------+          +------------+
12916                   | t    | f   |          | f    | t   |
12917                   |------------|          |------------|
12918 *)
12919
12920 PROCEDURE BuildNot (notTokPos: CARDINAL) ;
12921 VAR
12922    combinedTok,
12923    exprTokPos : CARDINAL ;
12924    t, f       : CARDINAL ;
12925 BEGIN
12926    CheckBooleanId ;
12927    PopBooltok (t, f, exprTokPos) ;
12928    combinedTok := MakeVirtualTok (notTokPos, notTokPos, exprTokPos) ;
12929    PushBooltok (f, t, combinedTok)
12930 END BuildNot ;
12931
12932
12933 (*
12934    MakeOp - returns the equalent quadruple operator to a token, t.
12935 *)
12936
12937 PROCEDURE MakeOp (t: Name) : QuadOperator ;
12938 BEGIN
12939    IF t=ArithPlusTok
12940    THEN
12941       RETURN ArithAddOp
12942    ELSIF t=PlusTok
12943    THEN
12944       RETURN( AddOp )
12945    ELSIF t=MinusTok
12946    THEN
12947       RETURN( SubOp )
12948    ELSIF t=DivTok
12949    THEN
12950       RETURN( DivM2Op )
12951    ELSIF t=DivideTok
12952    THEN
12953       RETURN( DivTruncOp )
12954    ELSIF t=RemTok
12955    THEN
12956       RETURN( ModTruncOp )
12957    ELSIF t=ModTok
12958    THEN
12959       RETURN( ModM2Op )
12960    ELSIF t=TimesTok
12961    THEN
12962       RETURN( MultOp )
12963    ELSIF t=HashTok
12964    THEN
12965       RETURN( IfNotEquOp )
12966    ELSIF t=LessGreaterTok
12967    THEN
12968       RETURN( IfNotEquOp )
12969    ELSIF t=GreaterEqualTok
12970    THEN
12971       RETURN( IfGreEquOp )
12972    ELSIF t=LessEqualTok
12973    THEN
12974       RETURN( IfLessEquOp )
12975    ELSIF t=EqualTok
12976    THEN
12977       RETURN( IfEquOp )
12978    ELSIF t=LessTok
12979    THEN
12980       RETURN( IfLessOp )
12981    ELSIF t=GreaterTok
12982    THEN
12983       RETURN( IfGreOp )
12984    ELSIF t=InTok
12985    THEN
12986       RETURN( IfInOp )
12987    ELSIF t=LogicalOrTok
12988    THEN
12989       RETURN( LogicalOrOp )
12990    ELSIF t=LogicalAndTok
12991    THEN
12992       RETURN( LogicalAndOp )
12993    ELSIF t=LogicalXorTok
12994    THEN
12995       RETURN( LogicalXorOp )
12996    ELSIF t=LogicalDifferenceTok
12997    THEN
12998       RETURN( LogicalDiffOp )
12999    ELSE
13000       InternalError('binary operation not implemented yet')
13001    END
13002 END MakeOp ;
13003
13004
13005 (*
13006    GenQuadO - generate a quadruple with Operation, Op1, Op2, Op3, overflow.
13007 *)
13008
13009 PROCEDURE GenQuadO (TokPos: CARDINAL;
13010                     Operation: QuadOperator;
13011                     Op1, Op2, Op3: CARDINAL; overflow: BOOLEAN) ;
13012 BEGIN
13013    GenQuadOTrash (TokPos, Operation, Op1, Op2, Op3, overflow, NulSym)
13014 END GenQuadO ;
13015
13016
13017 (*
13018    GenQuadOTrash - generate a quadruple with Operation, Op1, Op2, Op3, overflow.
13019 *)
13020
13021 PROCEDURE GenQuadOTrash (TokPos: CARDINAL;
13022                          Operation: QuadOperator;
13023                          Op1, Op2, Op3: CARDINAL;
13024                          overflow: BOOLEAN; trash: CARDINAL) ;
13025 VAR
13026    f: QuadFrame ;
13027 BEGIN
13028    (* WriteString('Potential Quad: ') ; *)
13029    IF QuadrupleGeneration
13030    THEN
13031       IF NextQuad # Head
13032       THEN
13033          f := GetQF (NextQuad-1) ;
13034          f^.Next := NextQuad
13035       END ;
13036       PutQuadO (NextQuad, Operation, Op1, Op2, Op3, overflow) ;
13037       f := GetQF (NextQuad) ;
13038       WITH f^ DO
13039          Trash := trash ;
13040          Next := 0 ;
13041          LineNo := GetLineNo () ;
13042          IF TokPos = UnknownTokenNo
13043          THEN
13044             TokenNo := GetTokenNo ()
13045          ELSE
13046             TokenNo := TokPos
13047          END
13048       END ;
13049       IF NextQuad=BreakAtQuad
13050       THEN
13051          stop
13052       END ;
13053       (* DisplayQuad(NextQuad) ; *)
13054       NewQuad (NextQuad)
13055    END
13056 END GenQuadOTrash ;
13057
13058
13059 (*
13060    GetQuadTrash - return the symbol associated with the trashed operand.
13061 *)
13062
13063 PROCEDURE GetQuadTrash (quad: CARDINAL) : CARDINAL ;
13064 VAR
13065    f: QuadFrame ;
13066 BEGIN
13067    f := GetQF (quad) ;
13068    LastQuadNo := quad ;
13069    RETURN f^.Trash
13070 END GetQuadTrash ;
13071
13072
13073 (*
13074    GenQuad - Generate a quadruple with Operation, Op1, Op2, Op3.
13075 *)
13076
13077 PROCEDURE GenQuad (Operation: QuadOperator;
13078                    Op1, Op2, Op3: CARDINAL) ;
13079 BEGIN
13080    GenQuadO (UnknownTokenNo, Operation, Op1, Op2, Op3, TRUE)
13081 END GenQuad ;
13082
13083
13084 (*
13085    GenQuadOtok - generate a quadruple with Operation, Op1, Op2, Op3, overflow.
13086 *)
13087
13088 PROCEDURE GenQuadOtok (TokPos: CARDINAL;
13089                        Operation: QuadOperator;
13090                        Op1, Op2, Op3: CARDINAL; overflow: BOOLEAN;
13091                        Op1Pos, Op2Pos, Op3Pos: CARDINAL) ;
13092 VAR
13093    f: QuadFrame ;
13094 BEGIN
13095    (* WriteString('Potential Quad: ') ; *)
13096    IF QuadrupleGeneration
13097    THEN
13098       IF NextQuad # Head
13099       THEN
13100          f := GetQF (NextQuad-1) ;
13101          f^.Next := NextQuad
13102       END ;
13103       PutQuadO (NextQuad, Operation, Op1, Op2, Op3, overflow) ;
13104       f := GetQF (NextQuad) ;
13105       WITH f^ DO
13106          Next := 0 ;
13107          LineNo := GetLineNo () ;
13108          IF TokPos = UnknownTokenNo
13109          THEN
13110             TokenNo := GetTokenNo ()
13111          ELSE
13112             TokenNo := TokPos
13113          END ;
13114          op1pos := Op1Pos ;
13115          op2pos := Op2Pos ;
13116          op3pos := Op3Pos
13117       END ;
13118       IF NextQuad=BreakAtQuad
13119       THEN
13120          stop
13121       END ;
13122       (* DisplayQuad(NextQuad) ; *)
13123       NewQuad (NextQuad)
13124    END
13125 END GenQuadOtok ;
13126
13127
13128 (*
13129    DisplayQuadList - displays all quads.
13130 *)
13131
13132 PROCEDURE DisplayQuadList ;
13133 VAR
13134    i: CARDINAL ;
13135    f: QuadFrame ;
13136 BEGIN
13137    printf0('Quadruples:\n') ;
13138    i := Head ;
13139    WHILE i#0 DO
13140       DisplayQuad(i) ;
13141       f := GetQF(i) ;
13142       i := f^.Next
13143    END
13144 END DisplayQuadList ;
13145
13146
13147 (*
13148    DisplayQuadRange - displays all quads in list range, start..end.
13149 *)
13150
13151 PROCEDURE DisplayQuadRange (scope: CARDINAL; start, end: CARDINAL) ;
13152 VAR
13153    f: QuadFrame ;
13154 BEGIN
13155    printf1 ('Quadruples for scope: %d\n', scope) ;
13156    WHILE (start <= end) AND (start # 0) DO
13157       DisplayQuad (start) ;
13158       f := GetQF (start) ;
13159       start := f^.Next
13160    END
13161 END DisplayQuadRange ;
13162
13163
13164 (*
13165    BackPatch - Makes each of the quadruples on the list pointed to by
13166                StartQuad, take quadruple Value as a target.
13167 *)
13168
13169 PROCEDURE BackPatch (QuadNo, Value: CARDINAL) ;
13170 VAR
13171    i: CARDINAL ;
13172    f: QuadFrame ;
13173 BEGIN
13174    IF QuadrupleGeneration
13175    THEN
13176       WHILE QuadNo#0 DO
13177          f := GetQF (QuadNo) ;
13178          WITH f^ DO
13179             i := Operand3 ;                       (* Next Link along the BackPatch *)
13180             ManipulateReference (QuadNo, Value)   (* Filling in the BackPatch.     *)
13181          END ;
13182          QuadNo := i
13183       END
13184    END
13185 END BackPatch ;
13186
13187
13188 (*
13189    Merge - joins two quad lists, QuadList2 to the end of QuadList1.
13190            A QuadList of value zero is a nul list.
13191 *)
13192
13193 PROCEDURE Merge (QuadList1, QuadList2: CARDINAL) : CARDINAL ;
13194 VAR
13195    i, j: CARDINAL ;
13196    f   : QuadFrame ;
13197 BEGIN
13198    IF QuadList1=0
13199    THEN
13200       RETURN( QuadList2 )
13201    ELSIF QuadList2=0
13202    THEN
13203       RETURN( QuadList1 )
13204    ELSE
13205       i := QuadList1 ;
13206       REPEAT
13207          j := i ;
13208          f := GetQF(i) ;
13209          i := f^.Operand3
13210       UNTIL i=0 ;
13211       ManipulateReference(j, QuadList2) ;
13212       RETURN( QuadList1 )
13213    END
13214 END Merge ;
13215
13216
13217 (*
13218    Annotate - annotate the top of stack.
13219 *)
13220
13221 PROCEDURE Annotate (a: ARRAY OF CHAR) ;
13222 VAR
13223    f: BoolFrame ;
13224 BEGIN
13225    IF DebugStackOn AND CompilerDebugging AND (NoOfItemsInStackAddress(BoolStack)>0)
13226    THEN
13227       f := PeepAddress(BoolStack, 1) ;    (* top of stack *)
13228       WITH f^ DO
13229          IF Annotation#NIL
13230          THEN
13231             Annotation := KillString(Annotation)
13232          END ;
13233          Annotation := InitString(a)
13234       END
13235    END
13236 END Annotate ;
13237
13238
13239 (*
13240    OperandAnno - returns the annotation string associated with the
13241                  position, n, on the stack.
13242 *)
13243
13244 PROCEDURE OperandAnno (n: CARDINAL) : String ;
13245 VAR
13246    f: BoolFrame ;
13247 BEGIN
13248    f := PeepAddress (BoolStack, n) ;
13249    RETURN f^.Annotation
13250 END OperandAnno ;
13251
13252
13253 (*
13254    DisplayStack - displays the compile time symbol stack.
13255 *)
13256
13257 PROCEDURE DisplayStack ;
13258 BEGIN
13259    IF DebugStackOn AND CompilerDebugging
13260    THEN
13261       DebugStack (NoOfItemsInStackAddress (BoolStack),
13262                   OperandTno, OperandFno, OperandA,
13263                   OperandD, OperandRW, OperandTok, OperandAnno)
13264    END
13265 END DisplayStack ;
13266
13267
13268 (*
13269    ds - tiny procedure name, useful for calling from the gdb shell.
13270 *)
13271
13272 (*
13273 PROCEDURE ds ;
13274 BEGIN
13275    DisplayStack
13276 END ds ;
13277 *)
13278
13279
13280 (*
13281    DisplayQuad - displays a quadruple, QuadNo.
13282 *)
13283
13284 PROCEDURE DisplayQuad (QuadNo: CARDINAL) ;
13285 BEGIN
13286    DSdbEnter ;
13287    printf1('%4d  ', QuadNo) ; WriteQuad(QuadNo) ; printf0('\n') ;
13288    DSdbExit
13289 END DisplayQuad ;
13290
13291
13292 (*
13293    DisplayProcedureAttributes -
13294 *)
13295
13296 PROCEDURE DisplayProcedureAttributes (proc: CARDINAL) ;
13297 BEGIN
13298    IF IsCtor (proc)
13299    THEN
13300       printf0 (" (ctor)")
13301    END ;
13302    IF IsPublic (proc)
13303    THEN
13304       printf0 (" (public)")
13305    END ;
13306    IF IsExtern (proc)
13307    THEN
13308       printf0 (" (extern)")
13309    END ;
13310    IF IsMonoName (proc)
13311    THEN
13312       printf0 (" (mononame)")
13313    END
13314 END DisplayProcedureAttributes ;
13315
13316
13317 (*
13318    WriteQuad - Writes out the Quad BufferQuad.
13319 *)
13320
13321 PROCEDURE WriteQuad (BufferQuad: CARDINAL) ;
13322 VAR
13323    n1, n2: Name ;
13324    f     : QuadFrame ;
13325    n     : Name ;
13326    l     : CARDINAL ;
13327 BEGIN
13328    f := GetQF(BufferQuad) ;
13329    WITH f^ DO
13330       WriteOperator(Operator) ;
13331       printf1('  [%d]    ', NoOfTimesReferenced) ;
13332       CASE Operator OF
13333
13334       HighOp           : WriteOperand(Operand1) ;
13335                          printf1('  %4d  ', Operand2) ;
13336                          WriteOperand(Operand3) |
13337       InitAddressOp,
13338       SavePriorityOp,
13339       RestorePriorityOp,
13340       SubrangeLowOp,
13341       SubrangeHighOp,
13342       BecomesOp,
13343       InclOp,
13344       ExclOp,
13345       UnboundedOp,
13346       ReturnValueOp,
13347       FunctValueOp,
13348       NegateOp,
13349       AddrOp            : WriteOperand(Operand1) ;
13350                           printf0('  ') ;
13351                           WriteOperand(Operand3) |
13352       ElementSizeOp,
13353       IfInOp,
13354       IfNotInOp,
13355       IfNotEquOp,
13356       IfEquOp,
13357       IfLessOp,
13358       IfGreOp,
13359       IfLessEquOp,
13360       IfGreEquOp        : WriteOperand(Operand1) ;
13361                           printf0('  ') ;
13362                           WriteOperand(Operand2) ;
13363                           printf1('  %4d', Operand3) |
13364
13365       InlineOp,
13366       RetryOp,
13367       TryOp,
13368       GotoOp            : printf1('%4d', Operand3) |
13369
13370       StatementNoteOp   : l := TokenToLineNo(Operand3, 0) ;
13371                           n := GetTokenName (Operand3) ;
13372                           printf4('%a:%d:%a (tokenno %d)', Operand1, l, n, Operand3) |
13373       LineNumberOp      : printf2('%a:%d', Operand1, Operand3) |
13374
13375       EndFileOp         : n1 := GetSymName(Operand3) ;
13376                           printf1('%a', n1) |
13377
13378       ThrowOp,
13379       ReturnOp,
13380       CallOp,
13381       KillLocalVarOp    : WriteOperand(Operand3) |
13382
13383       ProcedureScopeOp  : n1 := GetSymName(Operand2) ;
13384                           n2 := GetSymName(Operand3) ;
13385                           printf3('  %4d  %a  %a', Operand1, n1, n2) ;
13386                           DisplayProcedureAttributes (Operand3) |
13387       NewLocalVarOp,
13388       FinallyStartOp,
13389       FinallyEndOp,
13390       InitEndOp,
13391       InitStartOp       : n1 := GetSymName(Operand2) ;
13392                           n2 := GetSymName(Operand3) ;
13393                           printf3('  %4d  %a  %a', Operand1, n1, n2) |
13394
13395       ModuleScopeOp,
13396       StartModFileOp    : n1 := GetSymName(Operand3) ;
13397                           printf4('%a:%d  %a(%d)', Operand2, Operand1, n1, Operand3) |
13398
13399       StartDefFileOp    : n1 := GetSymName(Operand3) ;
13400                           printf2('  %4d  %a', Operand1, n1) |
13401
13402       OptParamOp,
13403       ParamOp           : printf1('%4d  ', Operand1) ;
13404                           WriteOperand(Operand2) ;
13405                           printf0('  ') ;
13406                           WriteOperand(Operand3) |
13407       SizeOp,
13408       RecordFieldOp,
13409       IndrXOp,
13410       XIndrOp,
13411       ArrayOp,
13412       LogicalShiftOp,
13413       LogicalRotateOp,
13414       LogicalOrOp,
13415       LogicalAndOp,
13416       LogicalXorOp,
13417       LogicalDiffOp,
13418       ArithAddOp,
13419       CoerceOp,
13420       ConvertOp,
13421       CastOp,
13422       AddOp,
13423       SubOp,
13424       MultOp,
13425       DivM2Op,
13426       ModM2Op,
13427       ModFloorOp,
13428       DivCeilOp,
13429       ModCeilOp,
13430       DivFloorOp,
13431       ModTruncOp,
13432       DivTruncOp        : WriteOperand(Operand1) ;
13433                           printf0('  ') ;
13434                           WriteOperand(Operand2) ;
13435                           printf0('  ') ;
13436                           WriteOperand(Operand3) |
13437       DummyOp,
13438       CodeOnOp,
13439       CodeOffOp,
13440       ProfileOnOp,
13441       ProfileOffOp,
13442       OptimizeOnOp,
13443       OptimizeOffOp     : |
13444       BuiltinConstOp    : WriteOperand(Operand1) ;
13445                           printf1('   %a', Operand3) |
13446       BuiltinTypeInfoOp : WriteOperand(Operand1) ;
13447                           printf1('   %a', Operand2) ;
13448                           printf1('   %a', Operand3) |
13449       StandardFunctionOp: WriteOperand(Operand1) ;
13450                           printf0('  ') ;
13451                           WriteOperand(Operand2) ;
13452                           printf0('  ') ;
13453                           WriteOperand(Operand3) |
13454       CatchBeginOp,
13455       CatchEndOp        : |
13456
13457       RangeCheckOp,
13458       ErrorOp           : WriteRangeCheck(Operand3) |
13459       SaveExceptionOp,
13460       RestoreExceptionOp: WriteOperand(Operand1) ;
13461                           printf0('  ') ;
13462                           WriteOperand(Operand3)
13463
13464       ELSE
13465          InternalError ('quadruple not recognised')
13466       END
13467    END
13468 END WriteQuad ;
13469
13470
13471 (*
13472    WriteOperator - writes the name of the quadruple operator.
13473 *)
13474
13475 PROCEDURE WriteOperator (Operator: QuadOperator) ;
13476 BEGIN
13477    CASE Operator OF
13478
13479    ArithAddOp               : printf0('Arith +           ') |
13480    InitAddressOp            : printf0('InitAddress       ') |
13481    LogicalOrOp              : printf0('Or                ') |
13482    LogicalAndOp             : printf0('And               ') |
13483    LogicalXorOp             : printf0('Xor               ') |
13484    LogicalDiffOp            : printf0('Ldiff             ') |
13485    LogicalShiftOp           : printf0('Shift             ') |
13486    LogicalRotateOp          : printf0('Rotate            ') |
13487    BecomesOp                : printf0('Becomes           ') |
13488    IndrXOp                  : printf0('IndrX             ') |
13489    XIndrOp                  : printf0('XIndr             ') |
13490    ArrayOp                  : printf0('Array             ') |
13491    ElementSizeOp            : printf0('ElementSize       ') |
13492    RecordFieldOp            : printf0('RecordField       ') |
13493    AddrOp                   : printf0('Addr              ') |
13494    SizeOp                   : printf0('Size              ') |
13495    IfInOp                   : printf0('If IN             ') |
13496    IfNotInOp                : printf0('If NOT IN         ') |
13497    IfNotEquOp               : printf0('If <>             ') |
13498    IfEquOp                  : printf0('If =              ') |
13499    IfLessEquOp              : printf0('If <=             ') |
13500    IfGreEquOp               : printf0('If >=             ') |
13501    IfGreOp                  : printf0('If >              ') |
13502    IfLessOp                 : printf0('If <              ') |
13503    GotoOp                   : printf0('Goto              ') |
13504    DummyOp                  : printf0('Dummy             ') |
13505    ModuleScopeOp            : printf0('ModuleScopeOp     ') |
13506    StartDefFileOp           : printf0('StartDefFile      ') |
13507    StartModFileOp           : printf0('StartModFile      ') |
13508    EndFileOp                : printf0('EndFileOp         ') |
13509    InitStartOp              : printf0('InitStart         ') |
13510    InitEndOp                : printf0('InitEnd           ') |
13511    FinallyStartOp           : printf0('FinallyStart      ') |
13512    FinallyEndOp             : printf0('FinallyEnd        ') |
13513    RetryOp                  : printf0('Retry             ') |
13514    TryOp                    : printf0('Try               ') |
13515    ThrowOp                  : printf0('Throw             ') |
13516    CatchBeginOp             : printf0('CatchBegin        ') |
13517    CatchEndOp               : printf0('CatchEnd          ') |
13518    AddOp                    : printf0('+                 ') |
13519    SubOp                    : printf0('-                 ') |
13520    DivM2Op                  : printf0('DIV M2            ') |
13521    ModM2Op                  : printf0('MOD M2            ') |
13522    DivCeilOp                : printf0('DIV ceil          ') |
13523    ModCeilOp                : printf0('MOD ceil          ') |
13524    DivFloorOp               : printf0('DIV floor         ') |
13525    ModFloorOp               : printf0('MOD floor         ') |
13526    DivTruncOp               : printf0('DIV trunc         ') |
13527    ModTruncOp               : printf0('MOD trunc         ') |
13528    MultOp                   : printf0('*                 ') |
13529    NegateOp                 : printf0('Negate            ') |
13530    InclOp                   : printf0('Incl              ') |
13531    ExclOp                   : printf0('Excl              ') |
13532    ReturnOp                 : printf0('Return            ') |
13533    ReturnValueOp            : printf0('ReturnValue       ') |
13534    FunctValueOp             : printf0('FunctValue        ') |
13535    CallOp                   : printf0('Call              ') |
13536    ParamOp                  : printf0('Param             ') |
13537    OptParamOp               : printf0('OptParam          ') |
13538    NewLocalVarOp            : printf0('NewLocalVar       ') |
13539    KillLocalVarOp           : printf0('KillLocalVar      ') |
13540    ProcedureScopeOp         : printf0('ProcedureScope    ') |
13541    UnboundedOp              : printf0('Unbounded         ') |
13542    CoerceOp                 : printf0('Coerce            ') |
13543    ConvertOp                : printf0('Convert           ') |
13544    CastOp                   : printf0('Cast              ') |
13545    HighOp                   : printf0('High              ') |
13546    CodeOnOp                 : printf0('CodeOn            ') |
13547    CodeOffOp                : printf0('CodeOff           ') |
13548    ProfileOnOp              : printf0('ProfileOn         ') |
13549    ProfileOffOp             : printf0('ProfileOff        ') |
13550    OptimizeOnOp             : printf0('OptimizeOn        ') |
13551    OptimizeOffOp            : printf0('OptimizeOff       ') |
13552    InlineOp                 : printf0('Inline            ') |
13553    StatementNoteOp          : printf0('StatementNote     ') |
13554    LineNumberOp             : printf0('LineNumber        ') |
13555    BuiltinConstOp           : printf0('BuiltinConst      ') |
13556    BuiltinTypeInfoOp        : printf0('BuiltinTypeInfo   ') |
13557    StandardFunctionOp       : printf0('StandardFunction  ') |
13558    SavePriorityOp           : printf0('SavePriority      ') |
13559    RestorePriorityOp        : printf0('RestorePriority   ') |
13560    RangeCheckOp             : printf0('RangeCheck        ') |
13561    ErrorOp                  : printf0('Error             ') |
13562    SaveExceptionOp          : printf0('SaveException     ') |
13563    RestoreExceptionOp       : printf0('RestoreException  ')
13564
13565    ELSE
13566       InternalError ('operator not expected')
13567    END
13568 END WriteOperator ;
13569
13570
13571 (*
13572    WriteOperand - displays the operands name, symbol id and mode of addressing.
13573 *)
13574
13575 PROCEDURE WriteOperand (Sym: CARDINAL) ;
13576 VAR
13577    n: Name ;
13578 BEGIN
13579    IF Sym = NulSym
13580    THEN
13581       printf0 ('<nulsym>')
13582    ELSE
13583       n := GetSymName (Sym) ;
13584       printf1 ('%a', n) ;
13585       IF IsVar (Sym) OR IsConst (Sym)
13586       THEN
13587          printf0 ('[') ; WriteMode (GetMode (Sym)) ; printf0(']')
13588       END ;
13589       printf1 ('(%d)', Sym)
13590    END
13591 END WriteOperand ;
13592
13593
13594 PROCEDURE WriteMode (Mode: ModeOfAddr) ;
13595 BEGIN
13596    CASE Mode OF
13597
13598    ImmediateValue: printf0('i') |
13599    NoValue       : printf0('n') |
13600    RightValue    : printf0('r') |
13601    LeftValue     : printf0('l')
13602
13603    ELSE
13604       InternalError ('unrecognised mode')
13605    END
13606 END WriteMode ;
13607
13608
13609 (*
13610    GetQuadOp - returns the operator for quad.
13611 *)
13612
13613 PROCEDURE GetQuadOp (quad: CARDINAL) : QuadOperator ;
13614 VAR
13615    f: QuadFrame ;
13616 BEGIN
13617    f := GetQF (quad) ;
13618    RETURN f^.Operator
13619 END GetQuadOp ;
13620
13621
13622 (*
13623    GetM2OperatorDesc - returns the Modula-2 string associated with the quad operator
13624                        (if possible).  It returns NIL if no there is not an obvious match
13625                        in Modula-2.  It is assummed that the string will be used during
13626                        construction of error messages and therefore keywords are
13627                        wrapped with a format specifier.
13628 *)
13629
13630 PROCEDURE GetM2OperatorDesc (op: QuadOperator) : String ;
13631 BEGIN
13632    CASE op OF
13633
13634    NegateOp    :  RETURN InitString ('-') |
13635    AddOp       :  RETURN InitString ('+') |
13636    SubOp       :  RETURN InitString ('-') |
13637    MultOp      :  RETURN InitString ('*') |
13638    DivM2Op,
13639    DivCeilOp,
13640    DivFloorOp,
13641    DivTruncOp  :  RETURN InitString ('{%kDIV}') |
13642    ModM2Op,
13643    ModCeilOp,
13644    ModFloorOp  :  RETURN InitString ('{%kMOD}') |
13645    ModTruncOp  :  RETURN InitString ('{%kREM}') |
13646    LogicalOrOp :  RETURN InitString ('{%kOR}') |
13647    LogicalAndOp:  RETURN InitString ('{%kAND}') |
13648    InclOp      :  RETURN InitString ('{%kINCL}') |
13649    ExclOp      :  RETURN InitString ('{%kEXCL}') |
13650    IfEquOp     :  RETURN InitString ('=') |
13651    IfLessEquOp :  RETURN InitString ('<=') |
13652    IfGreEquOp  :  RETURN InitString ('>=') |
13653    IfGreOp     :  RETURN InitString ('>') |
13654    IfLessOp    :  RETURN InitString ('<') |
13655    IfNotEquOp  :  RETURN InitString ('#') |
13656    IfInOp      :  RETURN InitString ('IN') |
13657    IfNotInOp   :  RETURN InitString ('NOT IN')
13658
13659    ELSE
13660       RETURN NIL
13661    END
13662 END GetM2OperatorDesc ;
13663
13664
13665
13666 (*
13667    PushExit - pushes the exit value onto the EXIT stack.
13668 *)
13669
13670 PROCEDURE PushExit (Exit: CARDINAL) ;
13671 BEGIN
13672    PushWord(ExitStack, Exit)
13673 END PushExit ;
13674
13675
13676 (*
13677    PopExit - pops the exit value from the EXIT stack.
13678 *)
13679
13680 PROCEDURE PopExit() : WORD ;
13681 BEGIN
13682    RETURN( PopWord(ExitStack) )
13683 END PopExit ;
13684
13685
13686 (*
13687    PushFor - pushes the exit value onto the FOR stack.
13688 *)
13689
13690 PROCEDURE PushFor (Exit: CARDINAL) ;
13691 BEGIN
13692    PushWord(ForStack, Exit)
13693 END PushFor ;
13694
13695
13696 (*
13697    PopFor - pops the exit value from the FOR stack.
13698 *)
13699
13700 PROCEDURE PopFor() : WORD ;
13701 BEGIN
13702    RETURN( PopWord(ForStack) )
13703 END PopFor ;
13704
13705
13706 (*
13707    OperandTno - returns the ident operand stored in the true position
13708                 on the boolean stack.  This is exactly the same as
13709                 OperandT but it has no IsBoolean checking.
13710 *)
13711
13712 PROCEDURE OperandTno (pos: CARDINAL) : WORD ;
13713 VAR
13714    f: BoolFrame ;
13715 BEGIN
13716    Assert(pos>0) ;
13717    f := PeepAddress(BoolStack, pos) ;
13718    RETURN( f^.TrueExit )
13719 END OperandTno ;
13720
13721
13722 (*
13723    OperandFno - returns the ident operand stored in the false position
13724                 on the boolean stack.  This is exactly the same as
13725                 OperandF but it has no IsBoolean checking.
13726 *)
13727
13728 PROCEDURE OperandFno (pos: CARDINAL) : WORD ;
13729 VAR
13730    f: BoolFrame ;
13731 BEGIN
13732    Assert(pos>0) ;
13733    f := PeepAddress (BoolStack, pos) ;
13734    RETURN f^.FalseExit
13735 END OperandFno ;
13736
13737
13738 (*
13739    OperandTtok - returns the token associated with the position, pos
13740                  on the boolean stack.
13741 *)
13742
13743 PROCEDURE OperandTtok (pos: CARDINAL) : CARDINAL ;
13744 VAR
13745    f: BoolFrame ;
13746 BEGIN
13747    Assert (pos > 0) ;
13748    f := PeepAddress (BoolStack, pos) ;
13749    RETURN f^.tokenno
13750 END OperandTtok ;
13751
13752
13753 (*
13754    PopBooltok - Pops a True and a False exit quad number from the True/False
13755                 stack.
13756 *)
13757
13758 PROCEDURE PopBooltok (VAR True, False: CARDINAL; VAR tokno: CARDINAL) ;
13759 VAR
13760    f: BoolFrame ;
13761 BEGIN
13762    f := PopAddress (BoolStack) ;
13763    WITH f^ DO
13764       True := TrueExit ;
13765       False := FalseExit ;
13766       tokno := tokenno ;
13767       Assert (BooleanOp)
13768    END ;
13769    DISPOSE (f)
13770 END PopBooltok ;
13771
13772
13773 (*
13774    PushBooltok - Push a True and a False exit quad numbers onto the
13775                  True/False stack.
13776 *)
13777
13778 PROCEDURE PushBooltok (True, False: CARDINAL; tokno: CARDINAL) ;
13779 VAR
13780    f: BoolFrame ;
13781 BEGIN
13782    Assert (True<=NextQuad) ;
13783    Assert (False<=NextQuad) ;
13784    f := newBoolFrame () ;
13785    WITH f^ DO
13786       TrueExit := True ;
13787       FalseExit := False ;
13788       BooleanOp := TRUE ;
13789       tokenno := tokno ;
13790       Annotation := NIL
13791    END ;
13792    PushAddress (BoolStack, f) ;
13793    Annotate ('<q%1d>|<q%2d>||true quad|false quad')
13794 END PushBooltok ;
13795
13796
13797 (*
13798    PopBool - Pops a True and a False exit quad number from the True/False
13799              stack.
13800 *)
13801
13802 PROCEDURE PopBool (VAR True, False: CARDINAL) ;
13803 VAR
13804    tokno: CARDINAL ;
13805 BEGIN
13806    PopBooltok (True, False, tokno)
13807 END PopBool ;
13808
13809
13810 (*
13811    PushBool - Push a True and a False exit quad numbers onto the
13812               True/False stack.
13813 *)
13814
13815 PROCEDURE PushBool (True, False: CARDINAL) ;
13816 BEGIN
13817    PushBooltok (True, False, UnknownTokenNo)
13818 END PushBool ;
13819
13820
13821 (*
13822    IsBoolean - returns true is the Stack position pos contains a Boolean
13823                Exit. False is returned if an Ident is stored.
13824 *)
13825
13826 PROCEDURE IsBoolean (pos: CARDINAL) : BOOLEAN ;
13827 VAR
13828    f: BoolFrame ;
13829 BEGIN
13830    Assert(pos>0) ;
13831    f := PeepAddress(BoolStack, pos) ;
13832    RETURN( f^.BooleanOp )
13833 END IsBoolean ;
13834
13835
13836 (*
13837    OperandD - returns possible array dimension associated with the ident
13838               operand stored on the boolean stack.
13839 *)
13840
13841 PROCEDURE OperandD (pos: CARDINAL) : WORD ;
13842 VAR
13843    f: BoolFrame ;
13844 BEGIN
13845    Assert(pos>0) ;
13846    Assert(NOT IsBoolean (pos)) ;
13847    f := PeepAddress(BoolStack, pos) ;
13848    RETURN( f^.Dimension )
13849 END OperandD ;
13850
13851
13852 (*
13853    OperandA - returns possible array symbol associated with the ident
13854               operand stored on the boolean stack.
13855 *)
13856
13857 PROCEDURE OperandA (pos: CARDINAL) : WORD ;
13858 VAR
13859    f: BoolFrame ;
13860 BEGIN
13861    Assert(pos>0) ;
13862    Assert(NOT IsBoolean (pos)) ;
13863    f := PeepAddress(BoolStack, pos) ;
13864    RETURN( f^.Unbounded )
13865 END OperandA ;
13866
13867
13868 (*
13869    OperandT - returns the ident operand stored in the true position on the boolean stack.
13870 *)
13871
13872 PROCEDURE OperandT (pos: CARDINAL) : WORD ;
13873 BEGIN
13874    Assert(NOT IsBoolean (pos)) ;
13875    RETURN( OperandTno(pos) )
13876 END OperandT ;
13877
13878
13879 (*
13880    OperandF - returns the ident operand stored in the false position on the boolean stack.
13881 *)
13882
13883 PROCEDURE OperandF (pos: CARDINAL) : WORD ;
13884 BEGIN
13885    Assert(NOT IsBoolean (pos)) ;
13886    RETURN( OperandFno(pos) )
13887 END OperandF ;
13888
13889
13890 (*
13891    OperandRW - returns the rw operand stored on the boolean stack.
13892 *)
13893
13894 PROCEDURE OperandRW (pos: CARDINAL) : WORD ;
13895 VAR
13896    f: BoolFrame ;
13897 BEGIN
13898    Assert(pos>0) ;
13899    Assert(NOT IsBoolean (pos)) ;
13900    f := PeepAddress(BoolStack, pos) ;
13901    RETURN( f^.ReadWrite )
13902 END OperandRW ;
13903
13904
13905 (*
13906    OperandMergeRW - returns the rw operand if not NulSym else it
13907                     returns True.
13908 *)
13909
13910 PROCEDURE OperandMergeRW (pos: CARDINAL) : WORD ;
13911 BEGIN
13912    IF OperandRW (pos) = NulSym
13913    THEN
13914       RETURN OperandT (pos)
13915    ELSE
13916       RETURN OperandRW (pos)
13917    END
13918 END OperandMergeRW ;
13919
13920
13921 (*
13922    OperandTok - returns the token associated with pos, on the stack.
13923 *)
13924
13925 PROCEDURE OperandTok (pos: CARDINAL) : WORD ;
13926 BEGIN
13927    Assert (NOT IsBoolean (pos)) ;
13928    RETURN OperandTtok (pos)
13929 END OperandTok ;
13930
13931
13932 (*
13933    BuildCodeOn - generates a quadruple declaring that code should be
13934                  emmitted from henceforth.
13935
13936                  The Stack is unnaffected.
13937 *)
13938
13939 PROCEDURE BuildCodeOn ;
13940 BEGIN
13941    GenQuad(CodeOnOp, NulSym, NulSym, NulSym)
13942 END BuildCodeOn ;
13943
13944
13945 (*
13946    BuildCodeOff - generates a quadruple declaring that code should not be
13947                   emmitted from henceforth.
13948
13949                   The Stack is unnaffected.
13950 *)
13951
13952 PROCEDURE BuildCodeOff ;
13953 BEGIN
13954    GenQuad(CodeOffOp, NulSym, NulSym, NulSym)
13955 END BuildCodeOff ;
13956
13957
13958 (*
13959    BuildProfileOn - generates a quadruple declaring that profile timings
13960                     should be emmitted from henceforth.
13961
13962                     The Stack is unnaffected.
13963 *)
13964
13965 PROCEDURE BuildProfileOn ;
13966 BEGIN
13967    GenQuad(ProfileOnOp, NulSym, NulSym, NulSym)
13968 END BuildProfileOn ;
13969
13970
13971 (*
13972    BuildProfileOn - generates a quadruple declaring that profile timings
13973                     should be emmitted from henceforth.
13974
13975                     The Stack is unnaffected.
13976 *)
13977
13978 PROCEDURE BuildProfileOff ;
13979 BEGIN
13980    GenQuad(ProfileOffOp, NulSym, NulSym, NulSym)
13981 END BuildProfileOff ;
13982
13983
13984 (*
13985    BuildOptimizeOn - generates a quadruple declaring that optimization
13986                      should occur from henceforth.
13987
13988                      The Stack is unnaffected.
13989 *)
13990
13991 PROCEDURE BuildOptimizeOn ;
13992 BEGIN
13993    GenQuad(OptimizeOnOp, NulSym, NulSym, NulSym)
13994 END BuildOptimizeOn ;
13995
13996
13997 (*
13998    BuildOptimizeOff - generates a quadruple declaring that optimization
13999                       should not occur from henceforth.
14000
14001                       The Stack is unnaffected.
14002 *)
14003
14004 PROCEDURE BuildOptimizeOff ;
14005 BEGIN
14006    GenQuad (OptimizeOffOp, NulSym, NulSym, NulSym)
14007 END BuildOptimizeOff ;
14008
14009
14010 (*
14011    BuildAsm - builds an Inline pseudo quadruple operator.
14012               The inline interface, Sym, is stored as the operand
14013               to the operator InlineOp.
14014
14015               The stack is expected to contain:
14016
14017
14018                         Entry                   Exit
14019                         =====                   ====
14020
14021               Ptr ->
14022                      +--------------+
14023                      | Sym          |        Empty
14024                      |--------------|
14025 *)
14026
14027 PROCEDURE BuildAsm (tok: CARDINAL) ;
14028 VAR
14029    Sym: CARDINAL ;
14030 BEGIN
14031    PopT (Sym) ;
14032    GenQuadO (tok, InlineOp, NulSym, NulSym, Sym, FALSE)
14033 END BuildAsm ;
14034
14035
14036 (*
14037    BuildLineNo - builds a LineNumberOp pseudo quadruple operator.
14038                  This quadruple indicates which source line has been
14039                  processed, these quadruples are only generated if we
14040                  are producing runtime debugging information.
14041
14042                  The stack is not affected, read or altered in any way.
14043
14044
14045                         Entry                   Exit
14046                         =====                   ====
14047
14048                  Ptr ->                              <- Ptr
14049 *)
14050
14051 PROCEDURE BuildLineNo ;
14052 VAR
14053    filename: Name ;
14054    f       : QuadFrame ;
14055 BEGIN
14056    IF (NextQuad#Head) AND (GenerateLineDebug OR GenerateDebugging) AND FALSE
14057    THEN
14058       filename := makekey (string (GetFileName ())) ;
14059       f := GetQF (NextQuad-1) ;
14060       IF NOT ((f^.Operator = LineNumberOp) AND (f^.Operand1 = WORD (filename)))
14061       THEN
14062          GenQuad (LineNumberOp, WORD (filename), NulSym, WORD (GetLineNo ()))
14063       END
14064    END
14065 END BuildLineNo ;
14066
14067
14068 (*
14069    UseLineNote - uses the line note and returns it to the free list.
14070 *)
14071
14072 PROCEDURE UseLineNote (l: LineNote) ;
14073 VAR
14074    f: QuadFrame ;
14075 BEGIN
14076    WITH l^ DO
14077       f := GetQF (NextQuad-1) ;
14078       IF (f^.Operator = LineNumberOp) AND (f^.Operand1 = WORD (File))
14079       THEN
14080          (* do nothing *)
14081       ELSE
14082          IF FALSE
14083          THEN
14084             GenQuad (LineNumberOp, WORD (File), NulSym, WORD (Line))
14085          END
14086       END ;
14087       Next := FreeLineList
14088    END ;
14089    FreeLineList := l
14090 END UseLineNote ;
14091
14092
14093 (*
14094    PopLineNo - pops a line note from the line stack.
14095 *)
14096
14097 PROCEDURE PopLineNo () : LineNote ;
14098 VAR
14099    l: LineNote ;
14100 BEGIN
14101    l := PopAddress(LineStack) ;
14102    IF l=NIL
14103    THEN
14104       InternalError ('no line note available')
14105    END ;
14106    RETURN( l  )
14107 END PopLineNo ;
14108
14109
14110 (*
14111    InitLineNote - creates a line note and initializes it to
14112                   contain, file, line.
14113 *)
14114
14115 PROCEDURE InitLineNote (file: Name; line: CARDINAL) : LineNote ;
14116 VAR
14117    l: LineNote ;
14118 BEGIN
14119    IF FreeLineList=NIL
14120    THEN
14121       NEW(l)
14122    ELSE
14123       l := FreeLineList ;
14124       FreeLineList := FreeLineList^.Next
14125    END ;
14126    WITH l^ DO
14127       File := file ;
14128       Line := line
14129    END ;
14130    RETURN( l )
14131 END InitLineNote ;
14132
14133
14134 (*
14135    PushLineNote -
14136 *)
14137
14138 PROCEDURE PushLineNote (l: LineNote) ;
14139 BEGIN
14140    PushAddress(LineStack, l)
14141 END PushLineNote ;
14142
14143
14144 (*
14145    PushLineNo - pushes the current file and line number to the stack.
14146 *)
14147
14148 PROCEDURE PushLineNo ;
14149 BEGIN
14150    PushLineNote(InitLineNote(makekey(string(GetFileName())), GetLineNo()))
14151 END PushLineNo ;
14152
14153
14154 (*
14155    BuildStmtNote - builds a StatementNoteOp pseudo quadruple operator.
14156                    This quadruple indicates which source line has been
14157                    processed and it represents the start of a statement
14158                    sequence.
14159                    It differs from LineNumberOp in that multiple successive
14160                    LineNumberOps will be removed and the final one is attached to
14161                    the next real GCC tree.  Whereas a StatementNoteOp is always left
14162                    alone.  Depending upon the debugging level it will issue a nop
14163                    instruction to ensure that the gdb single step will step into
14164                    this line.  Practically it allows pedalogical debugging to
14165                    occur when there is syntax sugar such as:
14166
14167
14168                          END  (* step *)
14169                       END  (* step *)
14170                    END ; (* step *)
14171                    a := 1 ; (* step *)
14172
14173                    REPEAT (* step *)
14174                       i := 1  (* step *)
14175
14176                    The stack is not affected, read or altered in any way.
14177
14178
14179                         Entry                   Exit
14180                         =====                   ====
14181
14182                  Ptr ->                              <- Ptr
14183 *)
14184
14185 PROCEDURE BuildStmtNote (offset: INTEGER) ;
14186 VAR
14187    tokenno: INTEGER ;
14188 BEGIN
14189    IF NextQuad#Head
14190    THEN
14191       tokenno := offset ;
14192       INC (tokenno, GetTokenNo ()) ;
14193       BuildStmtNoteTok (VAL(CARDINAL, tokenno))
14194    END
14195 END BuildStmtNote ;
14196
14197
14198 (*
14199    BuildStmtNoteTok - adds a nop (with an assigned tokenno location) to the code.
14200 *)
14201
14202 PROCEDURE BuildStmtNoteTok (tokenno: CARDINAL) ;
14203 VAR
14204    filename: Name ;
14205    f       : QuadFrame ;
14206 BEGIN
14207    f := GetQF (NextQuad-1) ;
14208    (* no need to have multiple notes at the same position.  *)
14209    IF (f^.Operator # StatementNoteOp) OR (f^.Operand3 # tokenno)
14210    THEN
14211       filename := makekey (string (GetFileName ())) ;
14212       GenQuad (StatementNoteOp, WORD (filename), NulSym, tokenno)
14213    END
14214 END BuildStmtNoteTok ;
14215
14216
14217 (*
14218    AddRecordToList - adds the record held on the top of stack to the
14219                      list of records and varient fields.
14220 *)
14221
14222 PROCEDURE AddRecordToList ;
14223 VAR
14224    r: CARDINAL ;
14225    n: CARDINAL ;
14226 BEGIN
14227    r := OperandT(1) ;
14228    Assert(IsRecord(r) OR IsFieldVarient(r)) ;
14229    (*
14230       r might be a field varient if the declaration consists of nested
14231       varients.  However ISO TSIZE can only utilise record types, we store
14232       a varient field anyway as the next pass would not know whether to
14233       ignore a varient field.
14234    *)
14235    PutItemIntoList (VarientFields, r) ;
14236    IF DebugVarients
14237    THEN
14238       n := NoOfItemsInList(VarientFields) ;
14239       IF IsRecord(r)
14240       THEN
14241          printf2('in list: record %d is %d\n', n, r)
14242       ELSE
14243          printf2('in list: varient field %d is %d\n', n, r)
14244       END
14245    END
14246 END AddRecordToList ;
14247
14248
14249 (*
14250    AddVarientToList - adds varient held on the top of stack to the list.
14251 *)
14252
14253 PROCEDURE AddVarientToList ;
14254 VAR
14255    v, n: CARDINAL ;
14256 BEGIN
14257    v := OperandT(1) ;
14258    Assert(IsVarient(v)) ;
14259    PutItemIntoList(VarientFields, v) ;
14260    IF DebugVarients
14261    THEN
14262       n := NoOfItemsInList(VarientFields) ;
14263       printf2('in list: varient %d is %d\n', n, v)
14264    END
14265 END AddVarientToList ;
14266
14267
14268 (*
14269    AddVarientFieldToList - adds varient field, f, to the list of all varient
14270                            fields created.
14271 *)
14272
14273 PROCEDURE AddVarientFieldToList (f: CARDINAL) ;
14274 VAR
14275    n: CARDINAL ;
14276 BEGIN
14277    Assert(IsFieldVarient(f)) ;
14278    PutItemIntoList(VarientFields, f) ;
14279    IF DebugVarients
14280    THEN
14281       n := NoOfItemsInList(VarientFields) ;
14282       printf2('in list: varient field %d is %d\n', n, f)
14283    END
14284 END AddVarientFieldToList ;
14285
14286
14287 (*
14288    GetRecordOrField -
14289 *)
14290
14291 PROCEDURE GetRecordOrField () : CARDINAL ;
14292 VAR
14293    f: CARDINAL ;
14294 BEGIN
14295    INC(VarientFieldNo) ;
14296    f := GetItemFromList(VarientFields, VarientFieldNo) ;
14297    IF DebugVarients
14298    THEN
14299       IF IsRecord(f)
14300       THEN
14301          printf2('out list: record %d is %d\n', VarientFieldNo, f)
14302       ELSE
14303          printf2('out list: varient field %d is %d\n', VarientFieldNo, f)
14304       END
14305    END ;
14306    RETURN( f )
14307 END GetRecordOrField ;
14308
14309
14310 (*
14311    BeginVarient - begin a varient record.
14312 *)
14313
14314 PROCEDURE BeginVarient ;
14315 VAR
14316    r, v: CARDINAL ;
14317 BEGIN
14318    r := GetRecordOrField() ;
14319    Assert(IsRecord(r) OR IsFieldVarient(r)) ;
14320    v := GetRecordOrField() ;
14321    Assert(IsVarient(v)) ;
14322    BuildRange(InitCaseBounds(PushCase(r, v, NulSym)))
14323 END BeginVarient ;
14324
14325
14326 (*
14327    EndVarient - end a varient record.
14328 *)
14329
14330 PROCEDURE EndVarient ;
14331 BEGIN
14332    PopCase
14333 END EndVarient ;
14334
14335
14336 (*
14337    ElseVarient - associate an ELSE clause with a varient record.
14338 *)
14339
14340 PROCEDURE ElseVarient ;
14341 VAR
14342    f: CARDINAL ;
14343 BEGIN
14344    f := GetRecordOrField() ;
14345    Assert(IsFieldVarient(f)) ;
14346    ElseCase(f)
14347 END ElseVarient ;
14348
14349
14350
14351 (*
14352    BeginVarientList - begin an ident list containing ranges belonging to a
14353                       varient list.
14354 *)
14355
14356 PROCEDURE BeginVarientList ;
14357 VAR
14358    f: CARDINAL ;
14359 BEGIN
14360    f := GetRecordOrField() ;
14361    Assert(IsFieldVarient(f)) ;
14362    BeginCaseList(f)
14363 END BeginVarientList ;
14364
14365
14366 (*
14367    EndVarientList - end a range list for a varient field.
14368 *)
14369
14370 PROCEDURE EndVarientList ;
14371 BEGIN
14372    EndCaseList
14373 END EndVarientList ;
14374
14375
14376 (*
14377    AddVarientRange - creates a range from the top two contant expressions
14378                      on the stack which are recorded with the current
14379                      varient field.  The stack is unaltered.
14380 *)
14381
14382 PROCEDURE AddVarientRange ;
14383 VAR
14384    r1, r2: CARDINAL ;
14385 BEGIN
14386    PopT(r2) ;
14387    PopT(r1) ;
14388    AddRange(r1, r2, GetTokenNo())
14389 END AddVarientRange ;
14390
14391
14392 (*
14393    AddVarientEquality - adds the contant expression on the top of the stack
14394                         to the current varient field being recorded.
14395                         The stack is unaltered.
14396 *)
14397
14398 PROCEDURE AddVarientEquality ;
14399 VAR
14400    r1: CARDINAL ;
14401 BEGIN
14402    PopT(r1) ;
14403    AddRange(r1, NulSym, GetTokenNo())
14404 END AddVarientEquality ;
14405
14406
14407 (*
14408    BuildAsmElement - the stack is expected to contain:
14409
14410
14411                         Entry                      Exit
14412                         =====                      ====
14413
14414                  Ptr ->
14415                         +------------------+
14416                         | expr | tokpos    |
14417                         |------------------|
14418                         | str              |
14419                         |------------------|
14420                         | name             |
14421                         |------------------|       +------------------+
14422                         | CurrentInterface |       | CurrentInterface |
14423                         |------------------|       |------------------|
14424                         | CurrentAsm       |       | CurrentAsm       |
14425                         |------------------|       |------------------|
14426                         | n                |       | n                |
14427                         |------------------|       |------------------|
14428 *)
14429
14430 PROCEDURE BuildAsmElement (input, output: BOOLEAN) ;
14431 CONST
14432    DebugAsmTokPos = FALSE ;
14433 VAR
14434    s                   : String ;
14435    n, str, expr, tokpos,
14436    CurrentInterface,
14437    CurrentAsm, name    : CARDINAL ;
14438 BEGIN
14439    PopTtok (expr, tokpos) ;
14440    PopT (str) ;
14441    PopT (name) ;
14442    PopT (CurrentInterface) ;
14443    PopT (CurrentAsm) ;
14444    Assert (IsGnuAsm (CurrentAsm) OR IsGnuAsmVolatile (CurrentAsm)) ;
14445    PopT (n) ;
14446    INC (n) ;
14447    IF CurrentInterface = NulSym
14448    THEN
14449       CurrentInterface := MakeRegInterface ()
14450    END ;
14451    IF input
14452    THEN
14453       PutRegInterface (tokpos, CurrentInterface, n, name, str, expr,
14454                        NextQuad, 0) ;
14455       IF DebugAsmTokPos
14456       THEN
14457          s := InitString ('input expression') ;
14458          WarnStringAt (s, tokpos)
14459       END
14460    END ;
14461    IF output
14462    THEN
14463       PutRegInterface (tokpos, CurrentInterface, n, name, str, expr,
14464                        0, NextQuad) ;
14465       IF DebugAsmTokPos
14466       THEN
14467          s := InitString ('output expression') ;
14468          WarnStringAt (s, tokpos)
14469       END
14470    END ;
14471    PushT (n) ;
14472    PushT (CurrentAsm) ;
14473    PushT (CurrentInterface)
14474 END BuildAsmElement ;
14475
14476
14477 (*
14478    BuildAsmTrash - the stack is expected to contain:
14479
14480
14481                         Entry                      Exit
14482                         =====                      ====
14483
14484                  Ptr ->
14485                         +------------------+
14486                         | expr | tokpos    |
14487                         |------------------|       +------------------+
14488                         | CurrentInterface |       | CurrentInterface |
14489                         |------------------|       |------------------|
14490                         | CurrentAsm       |       | CurrentAsm       |
14491                         |------------------|       |------------------|
14492                         | n                |       | n                |
14493                         |------------------|       |------------------|
14494 *)
14495
14496 PROCEDURE BuildAsmTrash ;
14497 VAR
14498    n, expr, tokpos,
14499    CurrentInterface,
14500    CurrentAsm      : CARDINAL ;
14501 BEGIN
14502    PopTtok (expr, tokpos) ;
14503    PopT (CurrentInterface) ;
14504    PopT (CurrentAsm) ;
14505    Assert (IsGnuAsm (CurrentAsm) OR IsGnuAsmVolatile (CurrentAsm)) ;
14506    PopT (n) ;
14507    INC (n) ;
14508    IF CurrentInterface = NulSym
14509    THEN
14510       CurrentInterface := MakeRegInterface ()
14511    END ;
14512    PutRegInterface (tokpos, CurrentInterface, n, NulName, NulSym, expr,
14513                     0, NextQuad) ;
14514    PushT (n) ;
14515    PushT (CurrentAsm) ;
14516    PushT (CurrentInterface)
14517 END BuildAsmTrash ;
14518
14519
14520 (*
14521    IncOperandD - increment the dimension number associated with symbol
14522                  at, pos, on the boolean stack.
14523 *)
14524
14525 (*
14526 PROCEDURE IncOperandD (pos: CARDINAL) ;
14527 VAR
14528    f: BoolFrame ;
14529 BEGIN
14530    f := PeepAddress(BoolStack, pos) ;
14531    INC(f^.Dimension)
14532 END IncOperandD ;
14533 *)
14534
14535
14536 (*
14537    PushTFA - Push True, False, Array, numbers onto the
14538              True/False stack.  True and False are assumed to
14539              contain Symbols or Ident etc.
14540 *)
14541
14542 PROCEDURE PushTFA (True, False, Array: WORD) ;
14543 VAR
14544    f: BoolFrame ;
14545 BEGIN
14546    f := newBoolFrame () ;
14547    WITH f^ DO
14548       TrueExit := True ;
14549       FalseExit := False ;
14550       Unbounded := Array
14551    END ;
14552    PushAddress(BoolStack, f)
14553 END PushTFA ;
14554
14555
14556 (*
14557    PushTFAD - Push True, False, Array, Dim, numbers onto the
14558               True/False stack.  True and False are assumed to
14559               contain Symbols or Ident etc.
14560 *)
14561
14562 PROCEDURE PushTFAD (True, False, Array, Dim: WORD) ;
14563 VAR
14564    f: BoolFrame ;
14565 BEGIN
14566    f := newBoolFrame () ;
14567    WITH f^ DO
14568       TrueExit := True ;
14569       FalseExit := False ;
14570       Unbounded := Array ;
14571       Dimension := Dim
14572    END ;
14573    PushAddress(BoolStack, f)
14574 END PushTFAD ;
14575
14576
14577 (*
14578    PushTFADtok - Push True, False, Array, Dim, numbers onto the
14579                  True/False stack.  True and False are assumed to
14580                  contain Symbols or Ident etc.
14581 *)
14582
14583 PROCEDURE PushTFADtok (True, False, Array, Dim: WORD; tokno: CARDINAL) ;
14584 VAR
14585    f: BoolFrame ;
14586 BEGIN
14587    f := newBoolFrame () ;
14588    WITH f^ DO
14589       TrueExit := True ;
14590       FalseExit := False ;
14591       Unbounded := Array ;
14592       Dimension := Dim ;
14593       tokenno := tokno
14594    END ;
14595    PushAddress (BoolStack, f)
14596 END PushTFADtok ;
14597
14598
14599 (*
14600    PushTFADrwtok - Push True, False, Array, Dim, rw, numbers onto the
14601                    True/False stack.  True and False are assumed to
14602                    contain Symbols or Ident etc.
14603 *)
14604
14605 PROCEDURE PushTFADrwtok (True, False, Array, Dim, rw: WORD; Tok: CARDINAL) ;
14606 VAR
14607    f: BoolFrame ;
14608 BEGIN
14609    f := newBoolFrame () ;
14610    WITH f^ DO
14611       TrueExit := True ;
14612       FalseExit := False ;
14613       Unbounded := Array ;
14614       Dimension := Dim ;
14615       ReadWrite := rw ;
14616       tokenno := Tok
14617    END ;
14618    PushAddress (BoolStack, f)
14619 END PushTFADrwtok ;
14620
14621
14622 (*
14623    PopTFrwtok - Pop a True and False number from the True/False stack.
14624                 True and False are assumed to contain Symbols or Ident etc.
14625 *)
14626
14627 PROCEDURE PopTFrwtok (VAR True, False, rw: WORD; VAR tokno: CARDINAL) ;
14628 VAR
14629    f: BoolFrame ;
14630 BEGIN
14631    f := PopAddress(BoolStack) ;
14632    WITH f^ DO
14633       True := TrueExit ;
14634       False := FalseExit ;
14635       Assert(NOT BooleanOp) ;
14636       rw := ReadWrite ;
14637       tokno := tokenno
14638    END ;
14639    DISPOSE(f)
14640 END PopTFrwtok ;
14641
14642
14643 (*
14644    PushTFrwtok - Push an item onto the stack in the T (true) position,
14645                  it is assummed to be a token and its token location is recorded.
14646 *)
14647
14648 PROCEDURE PushTFrwtok (True, False, rw: WORD; tokno: CARDINAL) ;
14649 VAR
14650    f: BoolFrame ;
14651 BEGIN
14652    f := newBoolFrame () ;
14653    WITH f^ DO
14654       TrueExit := True ;
14655       FalseExit := False ;
14656       ReadWrite := rw ;
14657       tokenno := tokno
14658    END ;
14659    PushAddress(BoolStack, f)
14660 END PushTFrwtok ;
14661
14662
14663 (*
14664    PushTFDtok - Push True, False, Dim, numbers onto the
14665                 True/False stack.  True and False are assumed to
14666                 contain Symbols or Ident etc.
14667 *)
14668
14669 PROCEDURE PushTFDtok (True, False, Dim: WORD; Tok: CARDINAL) ;
14670 VAR
14671    f: BoolFrame ;
14672 BEGIN
14673    f := newBoolFrame () ;
14674    WITH f^ DO
14675       TrueExit := True ;
14676       FalseExit := False ;
14677       Dimension := Dim ;
14678       tokenno := Tok
14679    END ;
14680    PushAddress (BoolStack, f)
14681 END PushTFDtok ;
14682
14683
14684 (*
14685    PopTFDtok - Pop a True, False, Dim number from the True/False stack.
14686                True and False are assumed to contain Symbols or Ident etc.
14687 *)
14688
14689 PROCEDURE PopTFDtok (VAR True, False, Dim: WORD; VAR Tok: CARDINAL) ;
14690 VAR
14691    f: BoolFrame ;
14692 BEGIN
14693    f := PopAddress(BoolStack) ;
14694    WITH f^ DO
14695       True := TrueExit ;
14696       False := FalseExit ;
14697       Dim := Dimension ;
14698       Tok := tokenno ;
14699       Assert(NOT BooleanOp)
14700    END ;
14701    DISPOSE(f)
14702 END PopTFDtok ;
14703
14704
14705 (*
14706    PushTFDrwtok - Push True, False, Dim, numbers onto the
14707                   True/False stack.  True and False are assumed to
14708                   contain Symbols or Ident etc.
14709 *)
14710
14711 PROCEDURE PushTFDrwtok (True, False, Dim, rw: WORD; Tok: CARDINAL) ;
14712 VAR
14713    f: BoolFrame ;
14714 BEGIN
14715    f := newBoolFrame () ;
14716    WITH f^ DO
14717       TrueExit := True ;
14718       FalseExit := False ;
14719       Dimension := Dim ;
14720       ReadWrite := rw ;
14721       tokenno := Tok
14722    END ;
14723    PushAddress (BoolStack, f)
14724 END PushTFDrwtok ;
14725
14726
14727 (*
14728    PushTFrw - Push a True and False numbers onto the True/False stack.
14729               True and False are assumed to contain Symbols or Ident etc.
14730               It also pushes the higher level symbol which is associated
14731               with the True symbol.  Eg record variable or array variable.
14732 *)
14733
14734 PROCEDURE PushTFrw (True, False: WORD; rw: CARDINAL) ;
14735 VAR
14736    f: BoolFrame ;
14737 BEGIN
14738    f := newBoolFrame () ;
14739    WITH f^ DO
14740       TrueExit := True ;
14741       FalseExit := False ;
14742       ReadWrite := rw
14743    END ;
14744    PushAddress(BoolStack, f)
14745 END PushTFrw ;
14746
14747
14748 (*
14749    PopTFrw - Pop a True and False number from the True/False stack.
14750              True and False are assumed to contain Symbols or Ident etc.
14751 *)
14752
14753 PROCEDURE PopTFrw (VAR True, False, rw: WORD) ;
14754 VAR
14755    f: BoolFrame ;
14756 BEGIN
14757    f := PopAddress(BoolStack) ;
14758    WITH f^ DO
14759       True := TrueExit ;
14760       False := FalseExit ;
14761       Assert(NOT BooleanOp) ;
14762       rw := ReadWrite
14763    END ;
14764    DISPOSE(f)
14765 END PopTFrw ;
14766
14767
14768 (*
14769    PushTF - Push a True and False numbers onto the True/False stack.
14770             True and False are assumed to contain Symbols or Ident etc.
14771 *)
14772
14773 PROCEDURE PushTF (True, False: WORD) ;
14774 VAR
14775    f: BoolFrame ;
14776 BEGIN
14777    f := newBoolFrame () ;
14778    WITH f^ DO
14779       TrueExit := True ;
14780       FalseExit := False
14781    END ;
14782    PushAddress(BoolStack, f)
14783 END PushTF ;
14784
14785
14786 (*
14787    PopTF - Pop a True and False number from the True/False stack.
14788            True and False are assumed to contain Symbols or Ident etc.
14789 *)
14790
14791 PROCEDURE PopTF (VAR True, False: WORD) ;
14792 VAR
14793    f: BoolFrame ;
14794 BEGIN
14795    f := PopAddress(BoolStack) ;
14796    WITH f^ DO
14797       True := TrueExit ;
14798       False := FalseExit ;
14799       Assert(NOT BooleanOp)
14800    END ;
14801    DISPOSE(f)
14802 END PopTF ;
14803
14804
14805 (*
14806    newBoolFrame - creates a new BoolFrame with all fields initialised to their defaults.
14807 *)
14808
14809 PROCEDURE newBoolFrame () : BoolFrame ;
14810 VAR
14811    f: BoolFrame ;
14812 BEGIN
14813    NEW (f) ;
14814    WITH f^ DO
14815       TrueExit   := 0 ;
14816       FalseExit  := 0 ;
14817       Unbounded  := NulSym ;
14818       BooleanOp  := FALSE ;
14819       Dimension  := 0 ;
14820       ReadWrite  := NulSym ;
14821       name       := NulSym ;
14822       Annotation := NIL ;
14823       tokenno    := UnknownTokenNo
14824    END ;
14825    RETURN f
14826 END newBoolFrame ;
14827
14828
14829 (*
14830    PushTtok - Push an item onto the stack in the T (true) position,
14831               it is assummed to be a token and its token location is recorded.
14832 *)
14833
14834 PROCEDURE PushTtok (True: WORD; tokno: CARDINAL) ;
14835 VAR
14836    f: BoolFrame ;
14837 BEGIN
14838    (* PrintTokenNo (tokno) ; *)
14839    f := newBoolFrame () ;
14840    WITH f^ DO
14841       TrueExit := True ;
14842       tokenno := tokno
14843    END ;
14844    PushAddress (BoolStack, f)
14845 END PushTtok ;
14846
14847
14848 (*
14849    PushT - Push an item onto the stack in the T (true) position.
14850 *)
14851
14852 PROCEDURE PushT (True: WORD) ;
14853 VAR
14854    f: BoolFrame ;
14855 BEGIN
14856    f := newBoolFrame () ;
14857    WITH f^ DO
14858       TrueExit := True
14859    END ;
14860    PushAddress (BoolStack, f)
14861 END PushT ;
14862
14863
14864 (*
14865    PopT - Pops the T value from the stack.
14866 *)
14867
14868 PROCEDURE PopT (VAR True: WORD) ;
14869 VAR
14870    f: BoolFrame ;
14871 BEGIN
14872    f := PopAddress (BoolStack) ;
14873    WITH f^ DO
14874       True := TrueExit ;
14875       Assert(NOT BooleanOp)
14876    END ;
14877    DISPOSE(f)
14878 END PopT ;
14879
14880
14881 (*
14882    PopTtok - Pops the T value from the stack and token position.
14883 *)
14884
14885 PROCEDURE PopTtok (VAR True: WORD; VAR tok: CARDINAL) ;
14886 VAR
14887    f: BoolFrame ;
14888 BEGIN
14889    f := PopAddress(BoolStack) ;
14890    WITH f^ DO
14891       True := TrueExit ;
14892       tok := tokenno ;
14893       Assert(NOT BooleanOp)
14894    END ;
14895    DISPOSE(f)
14896 END PopTtok ;
14897
14898
14899 (*
14900    PushTrw - Push an item onto the True/False stack. The False value will be zero.
14901 *)
14902
14903 (*
14904 PROCEDURE PushTrw (True: WORD; rw: WORD) ;
14905 VAR
14906    f: BoolFrame ;
14907 BEGIN
14908    f := newBoolFrame () ;
14909    WITH f^ DO
14910       TrueExit := True ;
14911       ReadWrite := rw
14912    END ;
14913    PushAddress(BoolStack, f)
14914 END PushTrw ;
14915 *)
14916
14917
14918 (*
14919    PushTrwtok - Push an item onto the True/False stack. The False value will be zero.
14920 *)
14921
14922 PROCEDURE PushTrwtok (True: WORD; rw: WORD; tok: CARDINAL) ;
14923 VAR
14924    f: BoolFrame ;
14925 BEGIN
14926    f := newBoolFrame () ;
14927    WITH f^ DO
14928       TrueExit := True ;
14929       ReadWrite := rw ;
14930       tokenno := tok
14931    END ;
14932    PushAddress(BoolStack, f)
14933 END PushTrwtok ;
14934
14935
14936 (*
14937    PopTrw - Pop a True field and rw symbol from the stack.
14938 *)
14939
14940 PROCEDURE PopTrw (VAR True, rw: WORD) ;
14941 VAR
14942    f: BoolFrame ;
14943 BEGIN
14944    f := PopAddress(BoolStack) ;
14945    WITH f^ DO
14946       True := TrueExit ;
14947       Assert(NOT BooleanOp) ;
14948       rw := ReadWrite
14949    END ;
14950    DISPOSE(f)
14951 END PopTrw ;
14952
14953
14954 (*
14955    PopTrwtok - Pop a True field and rw symbol from the stack.
14956 *)
14957
14958 PROCEDURE PopTrwtok (VAR True, rw: WORD; VAR tok: CARDINAL) ;
14959 VAR
14960    f: BoolFrame ;
14961 BEGIN
14962    f := PopAddress(BoolStack) ;
14963    WITH f^ DO
14964       True := TrueExit ;
14965       Assert(NOT BooleanOp) ;
14966       rw := ReadWrite ;
14967       tok := tokenno
14968    END ;
14969    DISPOSE(f)
14970 END PopTrwtok ;
14971
14972
14973 (*
14974    PushTFn - Push a True and False numbers onto the True/False stack.
14975              True and False are assumed to contain Symbols or Ident etc.
14976 *)
14977
14978 PROCEDURE PushTFn (True, False, n: WORD) ;
14979 VAR
14980    f: BoolFrame ;
14981 BEGIN
14982    f := newBoolFrame () ;
14983    WITH f^ DO
14984       TrueExit  := True ;
14985       FalseExit := False ;
14986       name      := n
14987    END ;
14988    PushAddress(BoolStack, f)
14989 END PushTFn ;
14990
14991
14992 (*
14993    PushTFntok - Push a True and False numbers onto the True/False stack.
14994                 True and False are assumed to contain Symbols or Ident etc.
14995 *)
14996
14997 PROCEDURE PushTFntok (True, False, n: WORD; tokno: CARDINAL) ;
14998 VAR
14999    f: BoolFrame ;
15000 BEGIN
15001    f := newBoolFrame () ;
15002    WITH f^ DO
15003       TrueExit  := True ;
15004       FalseExit := False ;
15005       name      := n ;
15006       tokenno   := tokno
15007    END ;
15008    PushAddress (BoolStack, f)
15009 END PushTFntok ;
15010
15011
15012 (*
15013    PopTFn - Pop a True and False number from the True/False stack.
15014             True and False are assumed to contain Symbols or Ident etc.
15015 *)
15016
15017 PROCEDURE PopTFn (VAR True, False, n: WORD) ;
15018 VAR
15019    f: BoolFrame ;
15020 BEGIN
15021    f := PopAddress(BoolStack) ;
15022    WITH f^ DO
15023       True := TrueExit ;
15024       False := FalseExit ;
15025       n := name ;
15026       Assert(NOT BooleanOp)
15027    END ;
15028    DISPOSE(f)
15029 END PopTFn ;
15030
15031
15032 (*
15033    PopNothing - pops the top element on the boolean stack.
15034 *)
15035
15036 PROCEDURE PopNothing ;
15037 VAR
15038    f: BoolFrame ;
15039 BEGIN
15040    f := PopAddress(BoolStack) ;
15041    DISPOSE(f)
15042 END PopNothing ;
15043
15044
15045 (*
15046    PopN - pops multiple elements from the BoolStack.
15047 *)
15048
15049 PROCEDURE PopN (n: CARDINAL) ;
15050 BEGIN
15051    WHILE n>0 DO
15052       PopNothing ;
15053       DEC(n)
15054    END
15055 END PopN ;
15056
15057
15058 (*
15059    PushTFtok - Push an item onto the stack in the T (true) position,
15060                it is assummed to be a token and its token location is recorded.
15061 *)
15062
15063 PROCEDURE PushTFtok (True, False: WORD; tokno: CARDINAL) ;
15064 VAR
15065    f: BoolFrame ;
15066 BEGIN
15067    f := newBoolFrame () ;
15068    WITH f^ DO
15069       TrueExit := True ;
15070       FalseExit := False ;
15071       tokenno := tokno
15072    END ;
15073    PushAddress(BoolStack, f)
15074 END PushTFtok ;
15075
15076
15077 (*
15078    PopTFtok - Pop T/F/tok from the stack.
15079 *)
15080
15081 PROCEDURE PopTFtok (VAR True, False: WORD; VAR tokno: CARDINAL) ;
15082 VAR
15083    f: BoolFrame ;
15084 BEGIN
15085    f := PopAddress(BoolStack) ;
15086    WITH f^ DO
15087       True := TrueExit ;
15088       False := FalseExit ;
15089       tokno := tokenno
15090    END
15091 END PopTFtok ;
15092
15093
15094 (*
15095    PushTFAtok - Push T/F/A/tok to the stack.
15096 *)
15097
15098 PROCEDURE PushTFAtok (True, False, Array: WORD; tokno: CARDINAL) ;
15099 VAR
15100    f: BoolFrame ;
15101 BEGIN
15102    f := newBoolFrame () ;
15103    WITH f^ DO
15104       TrueExit := True ;
15105       FalseExit := False ;
15106       Unbounded := Array ;
15107       tokenno := tokno
15108    END ;
15109    PushAddress(BoolStack, f)
15110 END PushTFAtok ;
15111
15112
15113 (*
15114    Top - returns the no of items held in the stack.
15115 *)
15116
15117 PROCEDURE Top () : CARDINAL ;
15118 BEGIN
15119    RETURN( NoOfItemsInStackAddress(BoolStack) )
15120 END Top ;
15121
15122
15123 (*
15124    PushAutoOn - push the auto flag and then set it to TRUE.
15125                 Any call to ident in the parser will result in the token being pushed.
15126 *)
15127
15128 PROCEDURE PushAutoOn ;
15129 BEGIN
15130    PushWord(AutoStack, IsAutoOn) ;
15131    IsAutoOn := TRUE
15132 END PushAutoOn ;
15133
15134
15135 (*
15136    PushAutoOff - push the auto flag and then set it to FALSE.
15137 *)
15138
15139 PROCEDURE PushAutoOff ;
15140 BEGIN
15141    PushWord(AutoStack, IsAutoOn) ;
15142    IsAutoOn := FALSE
15143 END PushAutoOff ;
15144
15145
15146 (*
15147    IsAutoPushOn - returns the value of the current Auto ident push flag.
15148 *)
15149
15150 PROCEDURE IsAutoPushOn () : BOOLEAN ;
15151 BEGIN
15152    RETURN( IsAutoOn )
15153 END IsAutoPushOn ;
15154
15155
15156 (*
15157    PopAuto - restores the previous value of the Auto flag.
15158 *)
15159
15160 PROCEDURE PopAuto ;
15161 BEGIN
15162    IsAutoOn := PopWord(AutoStack)
15163 END PopAuto ;
15164
15165
15166 (*
15167    PushInConstExpression - push the InConstExpression flag and then set it to TRUE.
15168 *)
15169
15170 PROCEDURE PushInConstExpression ;
15171 BEGIN
15172    PushWord(ConstStack, InConstExpression) ;
15173    InConstExpression := TRUE
15174 END PushInConstExpression ;
15175
15176
15177 (*
15178    PopInConstExpression - restores the previous value of the InConstExpression.
15179 *)
15180
15181 PROCEDURE PopInConstExpression ;
15182 BEGIN
15183    InConstExpression := PopWord(ConstStack)
15184 END PopInConstExpression ;
15185
15186
15187 (*
15188    IsInConstExpression - returns the value of the InConstExpression.
15189 *)
15190
15191 PROCEDURE IsInConstExpression () : BOOLEAN ;
15192 BEGIN
15193    RETURN( InConstExpression )
15194 END IsInConstExpression ;
15195
15196
15197 (*
15198    MustCheckOverflow - returns TRUE if the quadruple should test for overflow.
15199 *)
15200
15201 PROCEDURE MustCheckOverflow (q: CARDINAL) : BOOLEAN ;
15202 VAR
15203    f: QuadFrame ;
15204 BEGIN
15205    f := GetQF(q) ;
15206    RETURN( f^.CheckOverflow )
15207 END MustCheckOverflow ;
15208
15209
15210 (*
15211    StressStack -
15212 *)
15213
15214 (*
15215 PROCEDURE StressStack ;
15216 CONST
15217    Maxtries = 1000 ;
15218 VAR
15219    n, i, j: CARDINAL ;
15220 BEGIN
15221    PushT(1) ;
15222    PopT(i) ;
15223    Assert(i=1) ;
15224    FOR n := 1 TO Maxtries DO
15225       FOR i := n TO 1 BY -1 DO
15226          PushT(i)
15227       END ;
15228       FOR i := n TO 1 BY -1 DO
15229          Assert(OperandT(i)=i)
15230       END ;
15231       FOR i := 1 TO n DO
15232          Assert(OperandT(i)=i)
15233       END ;
15234       FOR i := 1 TO n BY 10 DO
15235          Assert(OperandT(i)=i)
15236       END ;
15237       IF (n>1) AND (n MOD 2 = 0)
15238       THEN
15239          FOR i := 1 TO n DIV 2 DO
15240             PopT(j) ;
15241             Assert(j=i)
15242          END ;
15243          FOR i := n DIV 2 TO 1 BY -1 DO
15244             PushT(i)
15245          END
15246       END ;
15247       FOR i := 1 TO n DO
15248          PopT(j) ;
15249          Assert(j=i)
15250       END
15251    END
15252 END StressStack ;
15253 *)
15254
15255
15256 (*
15257    Init - initialize the M2Quads module, all the stacks, all the lists
15258           and the quads list.
15259 *)
15260
15261 PROCEDURE Init ;
15262 BEGIN
15263    LogicalOrTok := MakeKey('_LOR') ;
15264    LogicalAndTok := MakeKey('_LAND') ;
15265    LogicalXorTok := MakeKey('_LXOR') ;
15266    LogicalDifferenceTok := MakeKey('_LDIFF') ;
15267    ArithPlusTok := MakeKey ('_ARITH_+') ;
15268    QuadArray := InitIndex (1) ;
15269    FreeList := 1 ;
15270    NewQuad(NextQuad) ;
15271    Assert(NextQuad=1) ;
15272    BoolStack := InitStackAddress() ;
15273    ExitStack := InitStackWord() ;
15274    RepeatStack := InitStackWord() ;
15275    WhileStack := InitStackWord() ;
15276    ForStack := InitStackWord() ;
15277    WithStack := InitStackAddress() ;
15278    ReturnStack := InitStackWord() ;
15279    LineStack := InitStackAddress() ;
15280    PriorityStack := InitStackWord() ;
15281    TryStack := InitStackWord() ;
15282    CatchStack := InitStackWord() ;
15283    ExceptStack := InitStackWord() ;
15284    ConstructorStack := InitStackAddress() ;
15285    ConstStack := InitStackWord() ;
15286    (* StressStack ; *)
15287    SuppressWith := FALSE ;
15288    Head := 1 ;
15289    LastQuadNo := 0 ;
15290    MustNotCheckBounds := FALSE ;
15291    InitQuad := 0 ;
15292    GrowInitialization := 0 ;
15293    ForInfo := InitIndex (1) ;
15294    QuadrupleGeneration := TRUE ;
15295    BuildingHigh := FALSE ;
15296    BuildingSize := FALSE ;
15297    AutoStack := InitStackWord() ;
15298    IsAutoOn := TRUE ;
15299    InConstExpression := FALSE ;
15300    FreeLineList := NIL ;
15301    InitList(VarientFields) ;
15302    VarientFieldNo := 0 ;
15303    NoOfQuads := 0
15304 END Init ;
15305
15306
15307 BEGIN
15308    Init
15309 END M2Quads.