gcc/m2/gm2-compiler/PCSymBuild.mod

   1 (* PCSymBuild.mod pass C symbol creation.
   2
   3 Copyright (C) 2001-2023 Free Software Foundation, Inc.
   4 Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
   5
   6 This file is part of GNU Modula-2.
   7
   8 GNU Modula-2 is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 3, or (at your option)
  11 any later version.
  12
  13 GNU Modula-2 is distributed in the hope that it will be useful, but
  14 WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Modula-2; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  *)
  21
  22 IMPLEMENTATION MODULE PCSymBuild ;
  23
  24
  25 FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
  26 FROM NameKey IMPORT Name, WriteKey, MakeKey, NulName ;
  27 FROM StrIO IMPORT WriteString, WriteLn ;
  28 FROM NumberIO IMPORT WriteCard ;
  29 FROM M2Debug IMPORT Assert, WriteDebug ;
  30 FROM M2Error IMPORT WriteFormat0, WriteFormat1, WriteFormat2, FlushErrors, InternalError, NewError, ErrorFormat0 ;
  31 FROM M2MetaError IMPORT MetaError1, MetaErrorT1 ;
  32 FROM M2LexBuf IMPORT GetTokenNo ;
  33 FROM M2Reserved IMPORT NulTok, ImportTok ;
  34 FROM M2Const IMPORT constType ;
  35 FROM Indexing IMPORT Index, InitIndex, GetIndice, PutIndice, InBounds, IncludeIndiceIntoIndex, HighIndice ;
  36
  37 FROM M2Quads IMPORT PushT, PopT, OperandT, PopN, PopTF, PushTF, IsAutoPushOn,
  38                     PopNothing, PushTFn, PopTFn, PushTtok, PopTtok, PushTFtok, PopTFtok, OperandTok ;
  39
  40 FROM M2Options IMPORT Iso ;
  41 FROM StdIO IMPORT Write ;
  42 FROM M2System IMPORT IsPseudoSystemFunctionConstExpression ;
  43
  44 FROM M2Base IMPORT MixTypes,
  45                    ZType, RType, Char, Boolean, Val, Max, Min, Convert,
  46                    IsPseudoBaseFunction, IsRealType, IsComplexType, IsOrdinalType ;
  47
  48 FROM M2Reserved IMPORT PlusTok, MinusTok, TimesTok, DivTok, ModTok,
  49                        DivideTok, RemTok,
  50                        OrTok, AndTok, AmbersandTok,
  51                        EqualTok, LessEqualTok, GreaterEqualTok,
  52                        LessTok, GreaterTok, HashTok, LessGreaterTok,
  53                        InTok, NotTok ;
  54
  55 FROM SymbolTable IMPORT NulSym, ModeOfAddr,
  56                         StartScope, EndScope, GetScope, GetCurrentScope,
  57                         GetModuleScope,
  58                         SetCurrentModule, GetCurrentModule, SetFileModule,
  59                         GetExported,
  60                         IsDefImp, IsModule,
  61                         RequestSym,
  62                         IsProcedure, PutOptArgInit, IsEnumeration,
  63                         CheckForUnknownInModule,
  64                         GetFromOuterModule,
  65                         CheckForEnumerationInCurrentModule,
  66                         GetMode, PutVariableAtAddress, ModeOfAddr, SkipType,
  67                         IsSet, PutConstSet,
  68                         IsConst, IsConstructor, PutConst, PutConstructor,
  69                         PopValue, PushValue,
  70                         MakeTemporary, PutVar,
  71                         PutSubrange,
  72                         GetSymName,
  73                         CheckAnonymous,
  74                         IsProcedureBuiltin,
  75                         MakeProcType,
  76                         NoOfParam,
  77                         GetParam,
  78                         IsParameterVar, PutProcTypeParam,
  79                         PutProcTypeVarParam, IsParameterUnbounded,
  80                         PutFunction, PutProcTypeParam,
  81                         GetType,
  82                         IsAModula2Type, GetDeclaredMod ;
  83
  84 FROM M2Batch IMPORT MakeDefinitionSource,
  85                     MakeImplementationSource,
  86                     MakeProgramSource,
  87                     LookupModule, LookupOuterModule ;
  88
  89 FROM M2Comp IMPORT CompilingDefinitionModule,
  90                    CompilingImplementationModule,
  91                    CompilingProgramModule ;
  92
  93 FROM M2StackAddress IMPORT StackOfAddress, InitStackAddress, KillStackAddress,
  94                            PushAddress, PopAddress, PeepAddress,
  95                            IsEmptyAddress, NoOfItemsInStackAddress ;
  96
  97 FROM M2StackWord IMPORT StackOfWord, InitStackWord, KillStackWord,
  98                         PushWord, PopWord, PeepWord,
  99                         IsEmptyWord, NoOfItemsInStackWord ;
 100
 101 IMPORT M2Error ;
 102
 103
 104 CONST
 105    Debugging = FALSE ;
 106
 107 TYPE
 108    tagType = (leaf, unary, binary, designator, expr, convert, function) ;
 109
 110    exprNode = POINTER TO eNode ;
 111
 112    eDes = RECORD
 113              type: CARDINAL ;
 114              meta: constType ;
 115              sym : CARDINAL ;
 116              left: exprNode ;
 117           END ;
 118
 119    eLeaf = RECORD
 120               type: CARDINAL ;
 121               meta: constType ;
 122               sym: CARDINAL ;
 123            END ;
 124
 125    eUnary = RECORD
 126                type: CARDINAL ;
 127                meta: constType ;
 128                left: exprNode ;
 129                op  : Name ;
 130             END ;
 131
 132    eBinary = RECORD
 133                 type: CARDINAL ;
 134                 meta: constType ;
 135                 left,
 136                 right: exprNode ;
 137                 op   : Name ;
 138              END ;
 139
 140    eExpr = RECORD
 141               type: CARDINAL ;
 142               meta: constType ;
 143               left: exprNode ;
 144            END ;
 145
 146    eFunction = RECORD
 147                   type  : CARDINAL ;
 148                   meta  : constType ;
 149                   func  : CARDINAL ;
 150                   first,
 151                   second: exprNode ;
 152                   third : BOOLEAN ;
 153                END ;
 154
 155    eConvert = RECORD
 156                  type  : CARDINAL ;
 157                  meta  : constType ;
 158                  totype: exprNode ;
 159                  expr  : exprNode ;
 160               END ;
 161
 162    eNode    = RECORD
 163                  CASE tag: tagType OF
 164
 165                  designator:  edes     : eDes |
 166                  leaf      :  eleaf    : eLeaf |
 167                  unary     :  eunary   : eUnary |
 168                  binary    :  ebinary  : eBinary |
 169                  expr      :  eexpr    : eExpr |
 170                  function  :  efunction: eFunction |
 171                  convert   :  econvert : eConvert
 172
 173                  END
 174               END ;
 175
 176
 177 VAR
 178    exprStack   : StackOfAddress ;
 179    constList   : Index ;
 180    constToken  : CARDINAL ;
 181    desStack    : StackOfWord ;
 182    inDesignator: BOOLEAN ;
 183
 184
 185 (*
 186    GetSkippedType -
 187 *)
 188
 189 PROCEDURE GetSkippedType (sym: CARDINAL) : CARDINAL ;
 190 BEGIN
 191    RETURN( SkipType(GetType(sym)) )
 192 END GetSkippedType ;
 193
 194
 195 (*
 196    StartBuildDefinitionModule - Creates a definition module and starts
 197                                 a new scope.
 198
 199                                 The Stack is expected:
 200
 201                                 Entry                 Exit
 202
 203                          Ptr ->                                     <- Ptr
 204                                 +------------+        +-----------+
 205                                 | NameStart  |        | NameStart |
 206                                 |------------|        |-----------|
 207
 208 *)
 209
 210 PROCEDURE PCStartBuildDefModule ;
 211 VAR
 212    tok      : CARDINAL ;
 213    name     : Name ;
 214    ModuleSym: CARDINAL ;
 215 BEGIN
 216    PopTtok(name, tok) ;
 217    ModuleSym := MakeDefinitionSource(tok, name) ;
 218    SetCurrentModule(ModuleSym) ;
 219    SetFileModule(ModuleSym) ;
 220    StartScope(ModuleSym) ;
 221    Assert(IsDefImp(ModuleSym)) ;
 222    Assert(CompilingDefinitionModule()) ;
 223    PushT(name) ;
 224    M2Error.EnterDefinitionScope (name)
 225 END PCStartBuildDefModule ;
 226
 227
 228 (*
 229    EndBuildDefinitionModule - Destroys the definition module scope and
 230                               checks for correct name.
 231
 232                               The Stack is expected:
 233
 234                               Entry                 Exit
 235
 236                        Ptr ->
 237                               +------------+        +-----------+
 238                               | NameEnd    |        |           |
 239                               |------------|        |-----------|
 240                               | NameStart  |        |           | <- Ptr
 241                               |------------|        |-----------|
 242 *)
 243
 244 PROCEDURE PCEndBuildDefModule ;
 245 VAR
 246    NameStart,
 247    NameEnd  : CARDINAL ;
 248 BEGIN
 249    Assert(CompilingDefinitionModule()) ;
 250    CheckForUnknownInModule ;
 251    EndScope ;
 252    PopT(NameEnd) ;
 253    PopT(NameStart) ;
 254    IF NameStart#NameEnd
 255    THEN
 256       WriteFormat2('inconsistant definition module was named (%a) and concluded as (%a)',
 257                    NameStart, NameEnd)
 258    END ;
 259    M2Error.LeaveErrorScope
 260 END PCEndBuildDefModule ;
 261
 262
 263 (*
 264    StartBuildImplementationModule - Creates an implementation module and starts
 265                                     a new scope.
 266
 267                                     The Stack is expected:
 268
 269                                     Entry                 Exit
 270
 271                              Ptr ->                                     <- Ptr
 272                                     +------------+        +-----------+
 273                                     | NameStart  |        | NameStart |
 274                                     |------------|        |-----------|
 275
 276 *)
 277
 278 PROCEDURE PCStartBuildImpModule ;
 279 VAR
 280    tok      : CARDINAL ;
 281    name     : Name ;
 282    ModuleSym: CARDINAL ;
 283 BEGIN
 284    PopTtok(name, tok) ;
 285    ModuleSym := MakeImplementationSource(tok, name) ;
 286    SetCurrentModule(ModuleSym) ;
 287    SetFileModule(ModuleSym) ;
 288    StartScope(ModuleSym) ;
 289    Assert(IsDefImp(ModuleSym)) ;
 290    Assert(CompilingImplementationModule()) ;
 291    PushTtok(name, tok) ;
 292    M2Error.EnterImplementationScope (name)
 293 END PCStartBuildImpModule ;
 294
 295
 296 (*
 297    EndBuildImplementationModule - Destroys the implementation module scope and
 298                                   checks for correct name.
 299
 300                                   The Stack is expected:
 301
 302                                   Entry                 Exit
 303
 304                            Ptr ->
 305                                   +------------+        +-----------+
 306                                   | NameEnd    |        |           |
 307                                   |------------|        |-----------|
 308                                   | NameStart  |        |           | <- Ptr
 309                                   |------------|        |-----------|
 310 *)
 311
 312 PROCEDURE PCEndBuildImpModule ;
 313 VAR
 314    NameStart,
 315    NameEnd  : Name ;
 316 BEGIN
 317    Assert(CompilingImplementationModule()) ;
 318    CheckForUnknownInModule ;
 319    EndScope ;
 320    PopT(NameEnd) ;
 321    PopT(NameStart) ;
 322    IF NameStart#NameEnd
 323    THEN
 324       (* we dont issue an error based around incorrect module names as this is done in P1 and P2.
 325          If we get here then something has gone wrong with our error recovery in PC, so we bail out.
 326       *)
 327       WriteFormat0('too many errors in pass 3') ;
 328       FlushErrors
 329    END ;
 330    M2Error.LeaveErrorScope
 331 END PCEndBuildImpModule ;
 332
 333
 334 (*
 335    StartBuildProgramModule - Creates a program module and starts
 336                              a new scope.
 337
 338                              The Stack is expected:
 339
 340                              Entry                 Exit
 341
 342                       Ptr ->                                     <- Ptr
 343                              +------------+        +-----------+
 344                              | NameStart  |        | NameStart |
 345                              |------------|        |-----------|
 346
 347 *)
 348
 349 PROCEDURE PCStartBuildProgModule ;
 350 VAR
 351    tok      : CARDINAL ;
 352    name     : Name ;
 353    ModuleSym: CARDINAL ;
 354 BEGIN
 355    (* WriteString('StartBuildProgramModule') ; WriteLn ; *)
 356    PopTtok(name, tok) ;
 357    ModuleSym := MakeProgramSource(tok, name) ;
 358    SetCurrentModule(ModuleSym) ;
 359    SetFileModule(ModuleSym) ;
 360    (* WriteString('MODULE - ') ; WriteKey(GetSymName(ModuleSym)) ; WriteLn ; *)
 361    StartScope(ModuleSym) ;
 362    Assert(CompilingProgramModule()) ;
 363    Assert(NOT IsDefImp(ModuleSym)) ;
 364    PushTtok(name, tok) ;
 365    M2Error.EnterProgramScope (name)
 366 END PCStartBuildProgModule ;
 367
 368
 369 (*
 370    EndBuildProgramModule - Destroys the program module scope and
 371                            checks for correct name.
 372
 373                            The Stack is expected:
 374
 375                            Entry                 Exit
 376
 377                     Ptr ->
 378                            +------------+        +-----------+
 379                            | NameEnd    |        |           |
 380                            |------------|        |-----------|
 381                            | NameStart  |        |           | <- Ptr
 382                            |------------|        |-----------|
 383 *)
 384
 385 PROCEDURE PCEndBuildProgModule ;
 386 VAR
 387    NameStart,
 388    NameEnd  : Name ;
 389 BEGIN
 390    Assert(CompilingProgramModule()) ;
 391    CheckForUnknownInModule ;
 392    EndScope ;
 393    PopT(NameEnd) ;
 394    PopT(NameStart) ;
 395    IF NameStart#NameEnd
 396    THEN
 397       (* we dont issue an error based around incorrect module names this would be done in P1 and P2.
 398          If we get here then something has gone wrong with our error recovery in PC, so we bail out.
 399       *)
 400       WriteFormat0('too many errors in pass 3') ;
 401       FlushErrors
 402    END ;
 403    M2Error.LeaveErrorScope
 404 END PCEndBuildProgModule ;
 405
 406
 407 (*
 408    StartBuildInnerModule - Creates an Inner module and starts
 409                            a new scope.
 410
 411                            The Stack is expected:
 412
 413                            Entry                 Exit
 414
 415                     Ptr ->                                     <- Ptr
 416                            +------------+        +-----------+
 417                            | NameStart  |        | NameStart |
 418                            |------------|        |-----------|
 419
 420 *)
 421
 422 PROCEDURE PCStartBuildInnerModule ;
 423 VAR
 424    name     : Name ;
 425    tok      : CARDINAL ;
 426    ModuleSym: CARDINAL ;
 427 BEGIN
 428    PopTtok(name, tok) ;
 429    ModuleSym := RequestSym(tok, name) ;
 430    Assert(IsModule(ModuleSym)) ;
 431    StartScope(ModuleSym) ;
 432    Assert(NOT IsDefImp(ModuleSym)) ;
 433    SetCurrentModule(ModuleSym) ;
 434    PushTtok(name, tok) ;
 435    M2Error.EnterModuleScope (name)
 436 END PCStartBuildInnerModule ;
 437
 438
 439 (*
 440    EndBuildInnerModule - Destroys the Inner module scope and
 441                          checks for correct name.
 442
 443                          The Stack is expected:
 444
 445                          Entry                 Exit
 446
 447                   Ptr ->
 448                          +------------+        +-----------+
 449                          | NameEnd    |        |           |
 450                          |------------|        |-----------|
 451                          | NameStart  |        |           | <- Ptr
 452                          |------------|        |-----------|
 453 *)
 454
 455 PROCEDURE PCEndBuildInnerModule ;
 456 VAR
 457    NameStart,
 458    NameEnd  : Name ;
 459 BEGIN
 460    CheckForUnknownInModule ;
 461    EndScope ;
 462    PopT(NameEnd) ;
 463    PopT(NameStart) ;
 464    IF NameStart#NameEnd
 465    THEN
 466       (* we dont issue an error based around incorrect module names this would be done in P1 and P2.
 467          If we get here then something has gone wrong with our error recovery in PC, so we bail out.
 468       *)
 469       WriteFormat0('too many errors in pass 3') ;
 470       FlushErrors
 471    END ;
 472    SetCurrentModule(GetModuleScope(GetCurrentModule())) ;
 473    M2Error.LeaveErrorScope
 474 END PCEndBuildInnerModule ;
 475
 476
 477 (*
 478    BuildImportOuterModule - Builds imported identifiers into an outer module
 479                             from a definition module.
 480
 481                             The Stack is expected:
 482
 483                             Entry           OR    Entry
 484
 485                      Ptr ->                Ptr ->
 486                             +------------+        +-----------+
 487                             | #          |        | #         |
 488                             |------------|        |-----------|
 489                             | Id1        |        | Id1       |
 490                             |------------|        |-----------|
 491                             .            .        .           .
 492                             .            .        .           .
 493                             .            .        .           .
 494                             |------------|        |-----------|
 495                             | Id#        |        | Id#       |
 496                             |------------|        |-----------|
 497                             | ImportTok  |        | Ident     |
 498                             |------------|        |-----------|
 499
 500                             IMPORT Id1, .. Id# ;  FROM Ident IMPORT Id1 .. Id# ;
 501
 502
 503                             Exit
 504
 505                             All above stack discarded
 506 *)
 507
 508 PROCEDURE PCBuildImportOuterModule ;
 509 VAR
 510    Sym, ModSym,
 511    i, n       : CARDINAL ;
 512 BEGIN
 513    PopT (n) ;       (* n   = # of the Ident List *)
 514    IF OperandT (n+1) # ImportTok
 515    THEN
 516       (* Ident List contains list of objects imported from ModSym *)
 517       ModSym := LookupModule (OperandTok (n+1), OperandT (n+1)) ;
 518       i := 1 ;
 519       WHILE i<=n DO
 520          Sym := GetExported (OperandTok (i), ModSym, OperandT (i)) ;
 521          CheckForEnumerationInCurrentModule (Sym) ;
 522          INC (i)
 523       END
 524    END ;
 525    PopN (n+1)   (* clear stack *)
 526 END PCBuildImportOuterModule ;
 527
 528
 529 (*
 530    BuildImportInnerModule - Builds imported identifiers into an inner module
 531                             from the last level of module.
 532
 533                             The Stack is expected:
 534
 535                             Entry           OR    Entry
 536
 537                      Ptr ->                Ptr ->
 538                             +------------+        +-----------+
 539                             | #          |        | #         |
 540                             |------------|        |-----------|
 541                             | Id1        |        | Id1       |
 542                             |------------|        |-----------|
 543                             .            .        .           .
 544                             .            .        .           .
 545                             .            .        .           .
 546                             |------------|        |-----------|
 547                             | Id#        |        | Id#       |
 548                             |------------|        |-----------|
 549                             | ImportTok  |        | Ident     |
 550                             |------------|        |-----------|
 551
 552                             IMPORT Id1, .. Id# ;  FROM Ident IMPORT Id1 .. Id# ;
 553
 554                             Exit
 555
 556                             All above stack discarded
 557 *)
 558
 559 PROCEDURE PCBuildImportInnerModule ;
 560 VAR
 561    Sym, ModSym,
 562    n, i       : CARDINAL ;
 563 BEGIN
 564    PopT (n) ;       (* i   = # of the Ident List *)
 565    IF OperandT (n+1) = ImportTok
 566    THEN
 567       (* Ident List contains list of objects *)
 568       i := 1 ;
 569       WHILE i<=n DO
 570          Sym := GetFromOuterModule (OperandTok (i), OperandT (i)) ;
 571          CheckForEnumerationInCurrentModule (Sym) ;
 572          INC (i)
 573       END
 574    ELSE
 575       (* Ident List contains list of objects imported from ModSym *)
 576       ModSym := LookupOuterModule (OperandTok (n+1), OperandT (n+1)) ;
 577       i := 1 ;
 578       WHILE i<=n DO
 579          Sym := GetExported (OperandTok (i), ModSym, OperandT (i)) ;
 580          CheckForEnumerationInCurrentModule (Sym) ;
 581          INC (i)
 582       END
 583    END ;
 584    PopN (n+1)   (* Clear Stack *)
 585 END PCBuildImportInnerModule ;
 586
 587
 588 (*
 589    StartBuildProcedure - Builds a Procedure.
 590
 591                          The Stack:
 592
 593                          Entry                 Exit
 594
 595                                                               <- Ptr
 596                                                +------------+
 597                   Ptr ->                       | ProcSym    |
 598                          +------------+        |------------|
 599                          | Name       |        | Name       |
 600                          |------------|        |------------|
 601 *)
 602
 603 PROCEDURE PCStartBuildProcedure ;
 604 VAR
 605    name    : Name ;
 606    ProcSym : CARDINAL ;
 607    tok     : CARDINAL ;
 608 BEGIN
 609    PopTtok(name, tok) ;
 610    PushTtok(name, tok) ;  (* Name saved for the EndBuildProcedure name check *)
 611    ProcSym := RequestSym (tok, name) ;
 612    Assert (IsProcedure (ProcSym)) ;
 613    PushTtok (ProcSym, tok) ;
 614    StartScope (ProcSym) ;
 615    M2Error.EnterProcedureScope (name)
 616 END PCStartBuildProcedure ;
 617
 618
 619 (*
 620    EndBuildProcedure - Ends building a Procedure.
 621                        It checks the start procedure name matches the end
 622                        procedure name.
 623
 624                        The Stack:
 625
 626                        (Procedure Not Defined in definition module)
 627
 628                        Entry                 Exit
 629
 630                 Ptr ->
 631                        +------------+
 632                        | NameEnd    |
 633                        |------------|
 634                        | ProcSym    |
 635                        |------------|
 636                        | NameStart  |
 637                        |------------|
 638                                              Empty
 639 *)
 640
 641 PROCEDURE PCEndBuildProcedure ;
 642 VAR
 643    ProcSym  : CARDINAL ;
 644    NameEnd,
 645    NameStart: Name ;
 646 BEGIN
 647    PopT(NameEnd) ;
 648    PopT(ProcSym) ;
 649    PopT(NameStart) ;
 650    IF NameEnd#NameStart
 651    THEN
 652       (* we dont issue an error based around incorrect module names this would be done in P1 and P2.
 653          If we get here then something has gone wrong with our error recovery in PC, so we bail out.
 654       *)
 655       WriteFormat0('too many errors in pass 3') ;
 656       FlushErrors
 657    END ;
 658    EndScope ;
 659    M2Error.LeaveErrorScope
 660 END PCEndBuildProcedure ;
 661
 662
 663 (*
 664    BuildProcedureHeading - Builds a procedure heading for the definition
 665                            module procedures.
 666
 667                            Operation only performed if compiling a
 668                            definition module.
 669
 670                            The Stack:
 671
 672                            Entry                       Exit
 673
 674                     Ptr ->
 675                            +------------+
 676                            | ProcSym    |
 677                            |------------|
 678                            | NameStart  |
 679                            |------------|
 680                                                        Empty
 681
 682 *)
 683
 684 PROCEDURE PCBuildProcedureHeading ;
 685 VAR
 686    ProcSym  : CARDINAL ;
 687    NameStart: Name ;
 688 BEGIN
 689    IF CompilingDefinitionModule ()
 690    THEN
 691       PopT (ProcSym) ;
 692       PopT (NameStart) ;
 693       EndScope
 694    END
 695 END PCBuildProcedureHeading ;
 696
 697
 698 (*
 699    BuildNulName - Pushes a NulKey onto the top of the stack.
 700                   The Stack:
 701
 702
 703                   Entry                    Exit
 704
 705                                                           <- Ptr
 706                   Empty                    +------------+
 707                                            | NulKey     |
 708                                            |------------|
 709 *)
 710
 711 PROCEDURE BuildNulName ;
 712 BEGIN
 713    PushT (NulName)
 714 END BuildNulName ;
 715
 716
 717 (*
 718    BuildConst - builds a constant.
 719                 Stack
 720
 721                 Entry                 Exit
 722
 723          Ptr ->                                      <- Ptr
 724                 +------------+        +------------+
 725                 | Name       |        | Sym        |
 726                 |------------+        |------------|
 727 *)
 728
 729 PROCEDURE BuildConst ;
 730 VAR
 731    name: Name ;
 732    tok : CARDINAL ;
 733    Sym : CARDINAL ;
 734 BEGIN
 735    PopTtok (name, tok) ;
 736    Sym := RequestSym (tok, name) ;
 737    PushTtok (Sym, tok)
 738 END BuildConst ;
 739
 740
 741 (*
 742    BuildVarAtAddress - updates the symbol table entry of, variable sym, to be declared
 743                        at address, address.
 744
 745                        Stack
 746
 747                        Entry                 Exit
 748
 749                 Ptr ->
 750                        +--------------+
 751                        | Expr | EType |                         <- Ptr
 752                        |--------------+        +--------------+
 753                        | name | SType |        | name | SType |
 754                        |--------------+        |--------------|
 755 *)
 756
 757 (*
 758 PROCEDURE BuildVarAtAddress ;
 759 VAR
 760    name      : Name ;
 761    Sym, SType,
 762    Exp, EType: CARDINAL ;
 763    etok, ntok: CARDINAL ;
 764 BEGIN
 765    PopTFtok (Exp, EType, etok) ;
 766    PopTFtok (name, SType, ntok) ;
 767    PushTFtok (name, SType, ntok) ;
 768    Sym := RequestSym (ntok, name) ;
 769    IF GetMode(Sym)=LeftValue
 770    THEN
 771       PutVariableAtAddress(Sym, Exp)
 772    ELSE
 773       InternalError ('expecting lvalue for this variable which is declared at an explicit address')
 774    END
 775 END BuildVarAtAddress ;
 776 *)
 777
 778
 779 (*
 780    BuildOptArgInitializer - assigns the constant value symbol, const, to be the
 781                             initial value of the optional parameter should it be
 782                             absent.
 783
 784                             Ptr ->
 785                                    +------------+
 786                                    | const      |
 787                                    |------------|                      <- Ptr
 788 *)
 789
 790 (*
 791 PROCEDURE BuildOptArgInitializer ;
 792 VAR
 793    const: CARDINAL ;
 794 BEGIN
 795    PopT(const) ;
 796    PutOptArgInit(GetCurrentScope(), const)
 797 END BuildOptArgInitializer ;
 798 *)
 799
 800
 801 (*
 802    InitDesExpr -
 803 *)
 804
 805 PROCEDURE InitDesExpr (des: CARDINAL) ;
 806 VAR
 807    e: exprNode ;
 808 BEGIN
 809    NEW(e) ;
 810    WITH e^ DO
 811       tag := designator ;
 812       CASE tag OF
 813
 814       designator:  WITH edes DO
 815                       type := NulSym ;
 816                       meta := unknown ;
 817                       tag := designator ;
 818                       sym := des ;
 819                       left := NIL
 820                    END
 821
 822       END
 823    END ;
 824    PushAddress (exprStack, e)
 825 END InitDesExpr ;
 826
 827
 828 (*
 829    DebugNode -
 830 *)
 831
 832 PROCEDURE DebugNode (d: exprNode) ;
 833 BEGIN
 834    IF Debugging AND (d#NIL)
 835    THEN
 836       WITH d^ DO
 837          CASE tag OF
 838
 839          designator:  DebugDes(d) |
 840          expr      :  DebugExpr(d) |
 841          leaf      :  DebugLeaf(d) |
 842          unary     :  DebugUnary(d) |
 843          binary    :  DebugBinary(d) |
 844          function  :  DebugFunction(d) |
 845          convert   :  DebugConvert(d)
 846
 847          END
 848       END
 849    END
 850 END DebugNode ;
 851
 852
 853 (*
 854    DebugDes -
 855 *)
 856
 857 PROCEDURE DebugDes (d: exprNode) ;
 858 BEGIN
 859    WITH d^ DO
 860       WITH edes DO
 861          DebugSym(sym) ; Write(':') ; DebugMeta(meta) ; Write(':') ; DebugType(type) ;
 862          WriteString(' = ') ;
 863          DebugNode(left) ;
 864          WriteLn
 865       END
 866    END
 867 END DebugDes ;
 868
 869
 870 (*
 871    DebugSym -
 872 *)
 873
 874 PROCEDURE DebugSym (sym: CARDINAL) ;
 875 VAR
 876    n: Name ;
 877 BEGIN
 878    n := GetSymName(sym) ;
 879    IF n#NulName
 880    THEN
 881       WriteKey(n)
 882    END ;
 883    Write(':') ; WriteCard(sym, 0)
 884 END DebugSym ;
 885
 886
 887 (*
 888    DebugMeta -
 889 *)
 890
 891 PROCEDURE DebugMeta (m: constType) ;
 892 BEGIN
 893    CASE m OF
 894
 895    unknown    :  WriteString('unknown') |
 896    set        :  WriteString('set') |
 897    str        :  WriteString('str') |
 898    constructor:  WriteString('constructor') |
 899    array      :  WriteString('array') |
 900    cast       :  WriteString('cast') |
 901    boolean    :  WriteString('boolean') |
 902    ztype      :  WriteString('ztype') |
 903    rtype      :  WriteString('rtype') |
 904    ctype      :  WriteString('ctype') |
 905    procedure  :  WriteString('procedure') |
 906    char       :  WriteString('ctype')
 907
 908    END
 909 END DebugMeta ;
 910
 911
 912 (*
 913    DebugType -
 914 *)
 915
 916 PROCEDURE DebugType (type: CARDINAL) ;
 917 VAR
 918    n: Name ;
 919 BEGIN
 920    WriteString('[type:') ;
 921    IF type=NulSym
 922    THEN
 923       WriteString('<nulsym>')
 924    ELSE
 925       n := GetSymName(type) ;
 926       IF n#NulSym
 927       THEN
 928          WriteKey(n)
 929       END ;
 930       Write(':') ; WriteCard(type, 0)
 931    END ;
 932    Write(']')
 933 END DebugType ;
 934
 935
 936 (*
 937    DebugExpr -
 938 *)
 939
 940 PROCEDURE DebugExpr (e: exprNode) ;
 941 BEGIN
 942    WITH e^.eexpr DO
 943       WriteString('expr (') ;
 944       DebugType(type) ; Write(':') ;
 945       DebugMeta(meta) ; Write(' ') ;
 946       DebugNode(left) ;
 947       WriteString(') ')
 948    END
 949 END DebugExpr ;
 950
 951
 952 (*
 953    DebugFunction -
 954 *)
 955
 956 PROCEDURE DebugFunction (f: exprNode) ;
 957 BEGIN
 958    WITH f^.efunction DO
 959       WriteKey(GetSymName(func)) ;
 960       Write('(') ;
 961       IF first#NIL
 962       THEN
 963          DebugNode(first) ;
 964          IF second#NIL
 965          THEN
 966             WriteString(', ') ;
 967             DebugNode(second) ;
 968             IF third
 969             THEN
 970                WriteString(', ...')
 971             END
 972          END
 973       END ;
 974       Write(')')
 975    END
 976 END DebugFunction ;
 977
 978
 979 (*
 980    DebugConvert -
 981 *)
 982
 983 PROCEDURE DebugConvert (f: exprNode) ;
 984 BEGIN
 985    WITH f^.econvert DO
 986       DebugNode(totype) ;
 987       Write('(') ;
 988       DebugNode(expr) ;
 989       Write(')')
 990    END
 991 END DebugConvert ;
 992
 993
 994 (*
 995    DebugLeaf -
 996 *)
 997
 998 PROCEDURE DebugLeaf (l: exprNode) ;
 999 BEGIN
1000    WITH l^.eleaf DO
1001       WriteString('leaf (') ;
1002       DebugType(type) ; Write(':') ;
1003       DebugMeta(meta) ; Write(':') ;
1004       DebugSym(sym) ;
1005       WriteString(') ')
1006    END
1007 END DebugLeaf ;
1008
1009
1010 (*
1011    DebugUnary -
1012 *)
1013
1014 PROCEDURE DebugUnary (l: exprNode) ;
1015 BEGIN
1016    WITH l^.eunary DO
1017       WriteString('unary (') ;
1018       DebugType(type) ; Write(':') ;
1019       DebugMeta(meta) ; Write(' ') ;
1020       DebugOp(op) ; Write(' ') ;
1021       DebugNode(left) ;
1022       WriteString(') ')
1023    END
1024 END DebugUnary ;
1025
1026
1027 (*
1028    DebugBinary -
1029 *)
1030
1031 PROCEDURE DebugBinary (l: exprNode) ;
1032 BEGIN
1033    WITH l^.ebinary DO
1034       WriteString('unary (') ;
1035       DebugType(type) ; Write(':') ;
1036       DebugMeta(meta) ; Write(' ') ;
1037       DebugNode(left) ;
1038       DebugOp(op) ; Write(' ') ;
1039       DebugNode(right) ;
1040       WriteString(') ')
1041    END
1042 END DebugBinary ;
1043
1044
1045 (*
1046    DebugOp -
1047 *)
1048
1049 PROCEDURE DebugOp (op: Name) ;
1050 BEGIN
1051    WriteKey(op)
1052 END DebugOp ;
1053
1054
1055 (*
1056    PushInConstructor -
1057 *)
1058
1059 PROCEDURE PushInConstructor ;
1060 BEGIN
1061    PushWord(desStack, inDesignator) ;
1062    inDesignator := FALSE
1063 END PushInConstructor ;
1064
1065
1066 (*
1067    PopInConstructor -
1068 *)
1069
1070 PROCEDURE PopInConstructor ;
1071 BEGIN
1072    inDesignator := PopWord(desStack)
1073 END PopInConstructor ;
1074
1075
1076 (*
1077    StartDesConst -
1078 *)
1079
1080 PROCEDURE StartDesConst ;
1081 VAR
1082    name: Name ;
1083    tok : CARDINAL ;
1084 BEGIN
1085    inDesignator := TRUE ;
1086    exprStack := KillStackAddress (exprStack) ;
1087    exprStack := InitStackAddress () ;
1088    PopTtok (name, tok) ;
1089    InitDesExpr (RequestSym (tok, name))
1090 END StartDesConst ;
1091
1092
1093 (*
1094    EndDesConst -
1095 *)
1096
1097 PROCEDURE EndDesConst ;
1098 VAR
1099    d, e: exprNode ;
1100 BEGIN
1101    e := PopAddress (exprStack) ;
1102    d := PopAddress (exprStack) ;
1103    Assert(d^.tag=designator) ;
1104    d^.edes.left := e ;
1105    IncludeIndiceIntoIndex(constList, d) ;
1106    inDesignator := FALSE
1107 END EndDesConst ;
1108
1109
1110 (*
1111    fixupProcedureType - creates a proctype from a procedure.
1112 *)
1113
1114 PROCEDURE fixupProcedureType (p: CARDINAL) : CARDINAL ;
1115 VAR
1116    tok : CARDINAL ;
1117    par,
1118    t   : CARDINAL ;
1119    n, i: CARDINAL ;
1120 BEGIN
1121    IF IsProcedure(p)
1122    THEN
1123       tok := GetTokenNo () ;
1124       t := MakeProcType (tok, CheckAnonymous (NulName)) ;
1125       i := 1 ;
1126       n := NoOfParam(p) ;
1127       WHILE i<=n DO
1128          par := GetParam (p, i) ;
1129          IF IsParameterVar (par)
1130          THEN
1131             PutProcTypeVarParam (t, GetType (par), IsParameterUnbounded (par))
1132          ELSE
1133             PutProcTypeParam (t, GetType (par), IsParameterUnbounded (par))
1134          END ;
1135          INC(i)
1136       END ;
1137       IF GetType (p) # NulSym
1138       THEN
1139          PutFunction (t, GetType (p))
1140       END ;
1141       RETURN( t )
1142    ELSE
1143       InternalError ('expecting a procedure')
1144    END ;
1145    RETURN( NulSym )
1146 END fixupProcedureType ;
1147
1148
1149 (*
1150    InitFunction -
1151 *)
1152
1153 PROCEDURE InitFunction (m: constType; p, t: CARDINAL; f, s: exprNode; more: BOOLEAN) ;
1154 VAR
1155    n: exprNode ;
1156 BEGIN
1157    NEW(n) ;
1158    WITH n^ DO
1159       tag := function ;
1160       CASE tag OF
1161
1162       function:  WITH efunction DO
1163                     meta := m ;
1164                     type := t ;
1165                     func := p ;
1166                     first := f ;
1167                     second := s ;
1168                     third := more
1169                  END
1170
1171       END
1172    END ;
1173    PushAddress(exprStack, n)
1174 END InitFunction ;
1175
1176
1177 (*
1178    InitConvert -
1179 *)
1180
1181 PROCEDURE InitConvert (m: constType; t: CARDINAL; to, e: exprNode) ;
1182 VAR
1183    n: exprNode ;
1184 BEGIN
1185    NEW(n) ;
1186    WITH n^ DO
1187       tag := convert ;
1188       CASE tag OF
1189
1190       convert:  WITH econvert DO
1191                    type := t ;
1192                    meta := m ;
1193                    totype := to ;
1194                    expr := e
1195                  END
1196
1197       END
1198    END ;
1199    PushAddress(exprStack, n)
1200 END InitConvert ;
1201
1202
1203 (*
1204    InitLeaf -
1205 *)
1206
1207 PROCEDURE InitLeaf (m: constType; s, t: CARDINAL) ;
1208 VAR
1209    l: exprNode ;
1210 BEGIN
1211    NEW(l) ;
1212    WITH l^ DO
1213       tag := leaf ;
1214       CASE tag OF
1215
1216       leaf:  WITH eleaf DO
1217                 type := t ;
1218                 meta := m ;
1219                 sym := s
1220              END
1221
1222       END
1223    END ;
1224    PushAddress(exprStack, l)
1225 END InitLeaf ;
1226
1227
1228 (*
1229    InitProcedure -
1230 *)
1231
1232 PROCEDURE InitProcedure (s: CARDINAL) ;
1233 BEGIN
1234    InitLeaf(procedure, s, fixupProcedureType(s))
1235 END InitProcedure ;
1236
1237
1238 (*
1239    InitCharType -
1240 *)
1241
1242 PROCEDURE InitCharType (s: CARDINAL) ;
1243 BEGIN
1244    InitLeaf(char, s, Char)
1245 END InitCharType ;
1246
1247
1248 (*
1249    InitZType -
1250 *)
1251
1252 PROCEDURE InitZType (s: CARDINAL) ;
1253 BEGIN
1254    InitLeaf(ztype, s, ZType)
1255 END InitZType ;
1256
1257
1258 (*
1259    InitRType -
1260 *)
1261
1262 PROCEDURE InitRType (s: CARDINAL) ;
1263 BEGIN
1264    InitLeaf(rtype, s, RType)
1265 END InitRType ;
1266
1267
1268 (*
1269    InitUnknown -
1270 *)
1271
1272 PROCEDURE InitUnknown (s: CARDINAL) ;
1273 BEGIN
1274    InitLeaf(unknown, s, NulSym)
1275 END InitUnknown ;
1276
1277
1278 (*
1279    InitBooleanType -
1280 *)
1281
1282 PROCEDURE InitBooleanType (s: CARDINAL) ;
1283 BEGIN
1284    InitLeaf(boolean, s, Boolean)
1285 END InitBooleanType ;
1286
1287
1288 (*
1289    PushConstType - pushes a constant to the expression stack.
1290 *)
1291
1292 PROCEDURE PushConstType ;
1293 VAR
1294    c: CARDINAL ;
1295 BEGIN
1296    PopT(c) ;
1297    PushT(c) ;
1298    IF inDesignator
1299    THEN
1300       IF c=NulSym
1301       THEN
1302          WriteFormat0('module or symbol in qualident is not known') ;
1303          FlushErrors ;
1304          InitUnknown(c)
1305       ELSIF IsProcedure(c)
1306       THEN
1307          InitProcedure(c)
1308       ELSIF GetSkippedType(c)=RType
1309       THEN
1310          InitRType(c)
1311       ELSIF GetSkippedType(c)=ZType
1312       THEN
1313          InitZType(c)
1314       ELSIF GetSkippedType(c)=Boolean
1315       THEN
1316          InitBooleanType(c)
1317       ELSE
1318          InitUnknown(c)
1319       END
1320    END
1321 END PushConstType ;
1322
1323
1324 (*
1325    PushConstructorCastType -
1326 *)
1327
1328 PROCEDURE PushConstructorCastType ;
1329 BEGIN
1330    IF inDesignator
1331    THEN
1332       InitConvert (cast, OperandT (1), NIL, NIL)
1333    END
1334 END PushConstructorCastType ;
1335
1336
1337 (*
1338    TypeToMeta -
1339 *)
1340
1341 PROCEDURE TypeToMeta (type: CARDINAL) : constType ;
1342 BEGIN
1343    IF type=Char
1344    THEN
1345       RETURN( char )
1346    ELSIF type=Boolean
1347    THEN
1348       RETURN( boolean )
1349    ELSIF IsRealType(type)
1350    THEN
1351       RETURN( rtype )
1352    ELSIF IsComplexType(type)
1353    THEN
1354       RETURN( ctype )
1355    ELSIF IsOrdinalType(type)
1356    THEN
1357       RETURN( ztype )
1358    ELSE
1359       RETURN( unknown )
1360    END
1361 END TypeToMeta ;
1362
1363
1364 (*
1365    buildConstFunction - we are only concerned about resolving the return type o
1366                         a function, so we can ignore all parameters - except
1367                         the first one in the case of VAL(type, foo).
1368                         buildConstFunction uses a unary exprNode to represent
1369                         a function.
1370 *)
1371
1372 PROCEDURE buildConstFunction (func: CARDINAL; n: CARDINAL) ;
1373 VAR
1374    i   : CARDINAL ;
1375    f, s: exprNode ;
1376 BEGIN
1377    f := NIL ;
1378    s := NIL ;
1379    IF n=1
1380    THEN
1381       f := PopAddress(exprStack)
1382    ELSIF n>=2
1383    THEN
1384       i := n ;
1385       WHILE i>2 DO
1386          s := PopAddress(exprStack) ;
1387          DISPOSE(s) ;
1388          DEC(i)
1389       END ;
1390       s := PopAddress(exprStack) ;
1391       f := PopAddress(exprStack)
1392    END ;
1393    IF func=Val
1394    THEN
1395       InitConvert(cast, NulSym, f, s)
1396    ELSIF (func=Max) OR (func=Min)
1397    THEN
1398       InitFunction(unknown, func, NulSym, f, s, FALSE)
1399    ELSE
1400       InitFunction(TypeToMeta(GetSkippedType(func)), func, GetSkippedType(func), f, s, n>2)
1401    END
1402 END buildConstFunction ;
1403
1404
1405 (*
1406    PushConstFunctionType -
1407 *)
1408
1409 PROCEDURE PushConstFunctionType ;
1410 VAR
1411    functok,
1412    func   : CARDINAL ;
1413    n      : CARDINAL ;
1414 BEGIN
1415    PopT (n) ;
1416    PopTtok (func, functok) ;
1417    IF inDesignator
1418    THEN
1419       IF (func#Convert) AND
1420          (IsPseudoBaseFunction(func) OR
1421           IsPseudoSystemFunctionConstExpression(func) OR
1422           (IsProcedure(func) AND IsProcedureBuiltin(func)))
1423       THEN
1424          buildConstFunction (func, n)
1425       ELSIF IsAModula2Type(func)
1426       THEN
1427          IF n=1
1428          THEN
1429             (* the top element on the expression stack is the first and only parameter to the cast *)
1430             InitUnary(cast, func, GetSymName(func))
1431          ELSE
1432             WriteFormat0('a constant type conversion can only have one argument')
1433          END
1434       ELSE
1435          IF Iso
1436          THEN
1437             MetaErrorT1 (functok,
1438                          'the only functions permissible in a constant expression are: CAP, CHR, CMPLX, FLOAT, HIGH, IM, LENGTH, MAX, MIN, ODD, ORD, RE, SIZE, TSIZE, TRUNC, VAL and gcc builtins, but not {%1Ead}',
1439                         func)
1440          ELSE
1441             MetaErrorT1 (functok,
1442                          'the only functions permissible in a constant expression are: CAP, CHR, FLOAT, HIGH, MAX, MIN, ODD, ORD, SIZE, TSIZE, TRUNC, VAL and gcc builtins, but not {%1Ead}',
1443                         func)
1444          END
1445       END
1446    END ;
1447    PushTtok (func, functok)
1448 END PushConstFunctionType ;
1449
1450
1451 (*
1452    PushIntegerType -
1453 *)
1454
1455 PROCEDURE PushIntegerType ;
1456 VAR
1457    sym: CARDINAL ;
1458    m  : constType ;
1459 BEGIN
1460    PopT(sym) ;
1461    IF inDesignator
1462    THEN
1463       m := TypeToMeta(GetSkippedType(sym)) ;
1464       IF m=char
1465       THEN
1466          InitCharType(sym)
1467       ELSE
1468          InitZType(sym)
1469       END
1470    END
1471 END PushIntegerType ;
1472
1473
1474 (*
1475    PushRType -
1476 *)
1477
1478 PROCEDURE PushRType ;
1479 VAR
1480    sym: CARDINAL ;
1481 BEGIN
1482    PopT(sym) ;
1483    IF inDesignator
1484    THEN
1485       InitRType(sym)
1486    END
1487 END PushRType ;
1488
1489
1490 (*
1491    PushStringType -
1492 *)
1493
1494 PROCEDURE PushStringType ;
1495 VAR
1496    sym: CARDINAL ;
1497 BEGIN
1498    PopT(sym) ;
1499    IF inDesignator
1500    THEN
1501       InitLeaf(str, sym, NulSym)
1502    END
1503 END PushStringType ;
1504
1505
1506 (*
1507    InitBinary -
1508 *)
1509
1510 PROCEDURE InitBinary (m: constType; t: CARDINAL; o: Name) ;
1511 VAR
1512    l, r, b: exprNode ;
1513 BEGIN
1514    r := PopAddress(exprStack) ;
1515    l := PopAddress(exprStack) ;
1516    NEW(b) ;
1517    WITH b^ DO
1518       tag := binary ;
1519       CASE tag OF
1520
1521       binary:  WITH ebinary DO
1522                   meta := m ;
1523                   type := t ;
1524                   left := l ;
1525                   right := r ;
1526                   op := o
1527                END
1528       END
1529    END ;
1530    PushAddress(exprStack, b)
1531 END InitBinary ;
1532
1533
1534 (*
1535    BuildRelationConst - builds a relationship binary operation.
1536 *)
1537
1538 PROCEDURE BuildRelationConst ;
1539 VAR
1540    op: Name ;
1541 BEGIN
1542    PopT(op) ;
1543    IF inDesignator
1544    THEN
1545       InitBinary(boolean, Boolean, op)
1546    END
1547 END BuildRelationConst ;
1548
1549
1550 (*
1551    BuildBinaryConst - builds a binary operator node.
1552 *)
1553
1554 PROCEDURE BuildBinaryConst ;
1555 VAR
1556    op: Name ;
1557 BEGIN
1558    PopT(op) ;
1559    IF inDesignator
1560    THEN
1561       InitBinary(unknown, NulSym, op)
1562    END
1563 END BuildBinaryConst ;
1564
1565
1566 (*
1567    InitUnary -
1568 *)
1569
1570 PROCEDURE InitUnary (m: constType; t: CARDINAL; o: Name) ;
1571 VAR
1572    l, b: exprNode ;
1573 BEGIN
1574    l := PopAddress(exprStack) ;
1575    NEW(b) ;
1576    WITH b^ DO
1577       tag := unary ;
1578       CASE tag OF
1579
1580       unary:  WITH eunary DO
1581                  meta := m ;
1582                  type := t ;
1583                  left := l ;
1584                  op := o
1585               END
1586
1587       END
1588    END ;
1589    PushAddress(exprStack, b)
1590 END InitUnary ;
1591
1592
1593 (*
1594    BuildUnaryConst - builds a unary operator node.
1595 *)
1596
1597 PROCEDURE BuildUnaryConst ;
1598 VAR
1599    op: Name ;
1600 BEGIN
1601    PopT(op) ;
1602    IF inDesignator
1603    THEN
1604       InitUnary(unknown, NulSym, op)
1605    END
1606 END BuildUnaryConst ;
1607
1608
1609 (*
1610    isTypeResolved -
1611 *)
1612
1613 PROCEDURE isTypeResolved (e: exprNode) : BOOLEAN ;
1614 BEGIN
1615    WITH e^ DO
1616       CASE tag OF
1617
1618       leaf      :  RETURN( (eleaf.type#NulSym) OR (eleaf.meta=str) ) |
1619       unary     :  RETURN( (eunary.type#NulSym) OR (eunary.meta=str) ) |
1620       binary    :  RETURN( (ebinary.type#NulSym) OR (ebinary.meta=str) ) |
1621       designator:  RETURN( (edes.type#NulSym) OR (edes.meta=str) ) |
1622       expr      :  RETURN( (eexpr.type#NulSym) OR (eexpr.meta=str) ) |
1623       convert   :  RETURN( (econvert.type#NulSym) OR (econvert.meta=str) ) |
1624       function  :  RETURN( (efunction.type#NulSym) OR (efunction.meta=str) )
1625
1626       END
1627    END
1628 END isTypeResolved ;
1629
1630
1631 (*
1632    getEtype -
1633 *)
1634
1635 PROCEDURE getEtype (e: exprNode) : CARDINAL ;
1636 BEGIN
1637    WITH e^ DO
1638       CASE tag OF
1639
1640       leaf      :  RETURN( eleaf.type ) |
1641       unary     :  RETURN( eunary.type ) |
1642       binary    :  RETURN( ebinary.type ) |
1643       designator:  RETURN( edes.type ) |
1644       expr      :  RETURN( eexpr.type ) |
1645       convert   :  RETURN( econvert.type ) |
1646       function  :  RETURN( efunction.type )
1647
1648       END
1649    END
1650 END getEtype ;
1651
1652
1653 (*
1654    getEmeta -
1655 *)
1656
1657 PROCEDURE getEmeta (e: exprNode) : constType ;
1658 BEGIN
1659    WITH e^ DO
1660       CASE tag OF
1661
1662       leaf      :  RETURN( eleaf.meta ) |
1663       unary     :  RETURN( eunary.meta ) |
1664       binary    :  RETURN( ebinary.meta ) |
1665       designator:  RETURN( edes.meta ) |
1666       expr      :  RETURN( eexpr.meta ) |
1667       convert   :  RETURN( econvert.meta ) |
1668       function  :  RETURN( efunction.meta )
1669
1670       END
1671    END
1672 END getEmeta ;
1673
1674
1675 (*
1676    assignTM -
1677 *)
1678
1679 PROCEDURE assignTM (VAR td: CARDINAL; VAR md: constType; te: CARDINAL; me: constType) ;
1680 BEGIN
1681    md := me ;
1682    td := te
1683 END assignTM ;
1684
1685
1686 (*
1687    assignType -
1688 *)
1689
1690 PROCEDURE assignType (d, e: exprNode) ;
1691 VAR
1692    t: CARDINAL ;
1693    m: constType ;
1694 BEGIN
1695    m := getEmeta(e) ;
1696    t := getEtype(e) ;
1697    WITH d^ DO
1698       CASE tag OF
1699
1700       leaf      :  assignTM(eleaf.type, eleaf.meta, t, m) |
1701       unary     :  assignTM(eunary.type, eunary.meta, t, m) |
1702       binary    :  assignTM(ebinary.type, ebinary.meta, t, m) |
1703       designator:  assignTM(edes.type, edes.meta, t, m) |
1704       expr      :  assignTM(eexpr.type, eexpr.meta, t, m) |
1705       convert   :  assignTM(econvert.type, econvert.meta, t, m) |
1706       function  :  assignTM(efunction.type, efunction.meta, t, m)
1707
1708       END
1709    END
1710 END assignType ;
1711
1712
1713 (*
1714    deduceTypes - works out the type and metatype given, l, and, r.
1715 *)
1716
1717 PROCEDURE deduceTypes (VAR t: CARDINAL;
1718                        VAR m: constType;
1719                        l, r: exprNode; op: Name) ;
1720 BEGIN
1721    IF r=NIL
1722    THEN
1723       (* function or cast *)
1724       t := getEtype(l) ;
1725       m := getEmeta(l)
1726    ELSIF (op=EqualTok) OR (op=HashTok) OR (op=LessGreaterTok) OR
1727       (op=LessTok) OR (op=LessEqualTok) OR (op=GreaterTok) OR
1728       (op=GreaterEqualTok) OR (op=InTok) OR (op=OrTok) OR
1729       (op=AndTok) OR (op=NotTok) OR (op=AmbersandTok)
1730    THEN
1731       t := Boolean ;
1732       m := boolean
1733    ELSIF (op=PlusTok) OR (op=MinusTok) OR (op=TimesTok) OR (op=ModTok) OR
1734          (op=DivTok) OR (op=RemTok) OR (op=DivideTok)
1735    THEN
1736       t := MixTypes(getEtype(l), getEtype(r), constToken) ;
1737       m := getEmeta(l) ;
1738       IF m=unknown
1739       THEN
1740          m := getEmeta(r)
1741       ELSIF (getEmeta(r)#unknown) AND (m#getEmeta(r))
1742       THEN
1743          ErrorFormat0(NewError(constToken),
1744                       'the operands to a binary constant expression have different types')
1745       END
1746    ELSE
1747       InternalError ('unexpected operator')
1748    END
1749 END deduceTypes ;
1750
1751
1752 (*
1753    WalkConvert -
1754 *)
1755
1756 PROCEDURE WalkConvert (e: exprNode) : BOOLEAN ;
1757 BEGIN
1758    IF isTypeResolved(e)
1759    THEN
1760       RETURN( FALSE )
1761    ELSE
1762       WITH e^.econvert DO
1763          IF isTypeResolved(totype)
1764          THEN
1765             assignType(e, totype) ;
1766             RETURN( TRUE )
1767          END ;
1768          RETURN( doWalkNode(totype) )
1769       END
1770    END
1771 END WalkConvert ;
1772
1773
1774 (*
1775    WalkFunctionParam -
1776 *)
1777
1778 PROCEDURE WalkFunctionParam (func: CARDINAL; e: exprNode) : BOOLEAN ;
1779 BEGIN
1780    IF isTypeResolved(e)
1781    THEN
1782       RETURN( FALSE )
1783    ELSE
1784       IF e^.tag=leaf
1785       THEN
1786          WITH e^.eleaf DO
1787             IF (sym#NulSym) AND (type=NulSym)
1788             THEN
1789                IF (func=Min) OR (func=Max)
1790                THEN
1791                   IF IsEnumeration(sym) OR IsSet(sym)
1792                   THEN
1793                      type := SkipType(GetType(sym))
1794                   ELSE
1795                      (* sym is the type required for MAX, MIN and VAL *)
1796                      type := sym
1797                   END
1798                ELSE
1799                   Assert(func=Val) ;
1800                   type := sym
1801                END ;
1802                meta := TypeToMeta(sym) ;
1803                RETURN( TRUE )
1804             END
1805          END
1806       END
1807    END ;
1808    RETURN( FALSE )
1809 END WalkFunctionParam ;
1810
1811
1812 (*
1813    WalkFunction -
1814 *)
1815
1816 PROCEDURE WalkFunction (e: exprNode) : BOOLEAN ;
1817 BEGIN
1818    IF isTypeResolved(e)
1819    THEN
1820       RETURN( FALSE )
1821    ELSE
1822       WITH e^.efunction DO
1823          IF (func=Max) OR (func=Min) OR (func=Val)
1824          THEN
1825             IF isTypeResolved(first)
1826             THEN
1827                IF getEmeta(first)=str
1828                THEN
1829                   MetaError1('a string parameter cannot be passed to function {%1Dad}', func) ;
1830                   RETURN( FALSE )
1831                END ;
1832                type := getEtype(first) ;
1833                RETURN( TRUE )
1834             END ;
1835             RETURN( WalkFunctionParam(func, first) )
1836          ELSE
1837             MetaError1('not expecting this function inside a constant expression {%1Dad}', func)
1838          END
1839       END
1840    END
1841 END WalkFunction ;
1842
1843
1844 (*
1845    doWalkNode -
1846 *)
1847
1848 PROCEDURE doWalkNode (e: exprNode) : BOOLEAN ;
1849 BEGIN
1850    WITH e^ DO
1851       CASE tag OF
1852
1853       expr    :  RETURN( WalkExpr(e) ) |
1854       leaf    :  RETURN( WalkLeaf(e) ) |
1855       unary   :  RETURN( WalkUnary(e) ) |
1856       binary  :  RETURN( WalkBinary(e) ) |
1857       convert :  RETURN( WalkConvert(e) ) |
1858       function:  RETURN( WalkFunction(e) )
1859
1860       ELSE
1861          InternalError ('unexpected tag value')
1862       END
1863    END ;
1864    RETURN( FALSE )
1865 END doWalkNode ;
1866
1867
1868 (*
1869    WalkLeaf -
1870 *)
1871
1872 PROCEDURE WalkLeaf (e: exprNode) : BOOLEAN ;
1873 VAR
1874    c: exprNode ;
1875 BEGIN
1876    IF isTypeResolved(e)
1877    THEN
1878       RETURN( FALSE )
1879    ELSE
1880       WITH e^.eleaf DO
1881          IF IsConst(sym) AND (GetType(sym)#NulSym)
1882          THEN
1883             type := GetSkippedType(sym) ;
1884             RETURN( TRUE )
1885          END ;
1886          IF IsAModula2Type(sym)
1887          THEN
1888             type := sym ;
1889             RETURN( TRUE )
1890          END ;
1891          c := findConstDes(sym) ;
1892          IF (c#NIL) AND isTypeResolved(c)
1893          THEN
1894             assignType(e, c) ;
1895             RETURN( TRUE )
1896          END
1897       END
1898    END ;
1899    RETURN( FALSE )
1900 END WalkLeaf ;
1901
1902
1903 (*
1904    WalkUnary -
1905 *)
1906
1907 PROCEDURE WalkUnary (e: exprNode) : BOOLEAN ;
1908 BEGIN
1909    IF isTypeResolved(e)
1910    THEN
1911       RETURN( FALSE )
1912    ELSE
1913       WITH e^.eunary DO
1914          IF isTypeResolved(left)
1915          THEN
1916             deduceTypes(type, meta, left, left, op) ;
1917             RETURN( TRUE )
1918          END ;
1919          RETURN( doWalkNode(left) )
1920       END
1921    END
1922 END WalkUnary ;
1923
1924
1925 (*
1926    WalkBinary -
1927 *)
1928
1929 PROCEDURE WalkBinary (e: exprNode) : BOOLEAN ;
1930 VAR
1931    changed: BOOLEAN ;
1932 BEGIN
1933    IF isTypeResolved(e)
1934    THEN
1935       RETURN( FALSE )
1936    ELSE
1937       WITH e^.ebinary DO
1938          IF isTypeResolved(left) AND isTypeResolved(right)
1939          THEN
1940             deduceTypes(type, meta, left, right, op) ;
1941             RETURN( TRUE )
1942          END ;
1943          changed := doWalkNode(left) ;
1944          RETURN( doWalkNode(right) OR changed )
1945       END
1946    END
1947 END WalkBinary ;
1948
1949
1950 (*
1951    WalkExpr -
1952 *)
1953
1954 PROCEDURE WalkExpr (e: exprNode) : BOOLEAN ;
1955 BEGIN
1956    IF isTypeResolved(e)
1957    THEN
1958       RETURN( FALSE )
1959    ELSE
1960       WITH e^.eexpr DO
1961          IF isTypeResolved(left)
1962          THEN
1963             assignType(e, left) ;
1964             RETURN( TRUE )
1965          END ;
1966          RETURN( doWalkNode(left) )
1967       END
1968    END
1969 END WalkExpr ;
1970
1971
1972 (*
1973    doWalkDesExpr - returns TRUE if the expression trees, d, or, e, are changed.
1974 *)
1975
1976 PROCEDURE doWalkDesExpr (d, e: exprNode) : BOOLEAN ;
1977 BEGIN
1978    IF isTypeResolved(e)
1979    THEN
1980       WITH d^.edes DO
1981          type := getEtype(e) ;
1982          IF type=NulSym
1983          THEN
1984             meta := getEmeta(e) ;
1985             IF meta=str
1986             THEN
1987                (* PutConstString(sym, getString(e)) *)
1988             END
1989          ELSE
1990             PutConst(sym, type)
1991          END ;
1992          RETURN( TRUE )
1993       END
1994    END ;
1995    RETURN( doWalkNode(e) )
1996 END doWalkDesExpr ;
1997
1998
1999 (*
2000    doWalkDes - return TRUE if expression, e, is changed.
2001 *)
2002
2003 PROCEDURE doWalkDes (d: exprNode) : BOOLEAN ;
2004 BEGIN
2005    IF isTypeResolved(d)
2006    THEN
2007       RETURN( FALSE )
2008    ELSE
2009       WITH d^ DO
2010          CASE tag OF
2011
2012          designator:  WITH edes DO
2013                          constToken := GetDeclaredMod(sym) ;
2014                          RETURN( doWalkDesExpr(d, left) )
2015                       END
2016
2017          ELSE
2018             InternalError ('unexpected tag value')
2019          END
2020       END
2021    END
2022 END doWalkDes ;
2023
2024
2025 (*
2026    findConstDes -
2027 *)
2028
2029 PROCEDURE findConstDes (sym: CARDINAL) : exprNode ;
2030 VAR
2031    i: CARDINAL ;
2032    e: exprNode ;
2033 BEGIN
2034    i := 1 ;
2035    WHILE i<=HighIndice(constList) DO
2036       e := GetIndice(constList, i) ;
2037       WITH e^ DO
2038          CASE tag OF
2039
2040          designator:  IF edes.sym=sym
2041                       THEN
2042                          RETURN( e )
2043                       END
2044
2045          ELSE
2046          END
2047       END ;
2048       INC(i)
2049    END ;
2050    RETURN( NIL )
2051 END findConstDes ;
2052
2053
2054 (*
2055    WalkDes - return TRUE if expression, e, is changed.
2056 *)
2057
2058 PROCEDURE WalkDes (d: exprNode) : BOOLEAN ;
2059 BEGIN
2060    IF d=NIL
2061    THEN
2062       RETURN( FALSE )
2063    ELSE
2064       RETURN( doWalkDes(d) )
2065    END
2066 END WalkDes ;
2067
2068
2069 (*
2070    WalkConst - returns TRUE if the constant tree associated with, sym,
2071                is changed.
2072 *)
2073
2074 (*
2075 PROCEDURE WalkConst (sym: CARDINAL) : BOOLEAN ;
2076 BEGIN
2077    RETURN( WalkDes(findConstDes(sym)) )
2078 END WalkConst ;
2079 *)
2080
2081
2082 (*
2083    WalkConsts - walk over the constant trees and return TRUE if any tree was changed.
2084                 (As a result of a type resolution).
2085 *)
2086
2087 PROCEDURE WalkConsts () : BOOLEAN ;
2088 VAR
2089    changed: BOOLEAN ;
2090    i      : CARDINAL ;
2091 BEGIN
2092    changed := FALSE ;
2093    i := 1 ;
2094    WHILE i<=HighIndice(constList) DO
2095       IF WalkDes(GetIndice(constList, i))
2096       THEN
2097          changed := TRUE
2098       END ;
2099       INC(i)
2100    END ;
2101    RETURN( changed )
2102 END WalkConsts ;
2103
2104
2105 (*
2106    DebugNodes -
2107 *)
2108
2109 PROCEDURE DebugNodes ;
2110 VAR
2111    i: CARDINAL ;
2112 BEGIN
2113    i := 1 ;
2114    WHILE i<=HighIndice(constList) DO
2115       IF isTypeResolved(GetIndice(constList, i))
2116       THEN
2117          WriteString('resolved ')
2118       ELSE
2119          WriteString('unresolved ')
2120       END ;
2121       DebugNode(GetIndice(constList, i)) ; WriteLn ;
2122       INC(i)
2123    END
2124 END DebugNodes ;
2125
2126
2127 (*
2128    findAlias -
2129 *)
2130
2131 PROCEDURE findAlias (sym: CARDINAL; e: exprNode) : CARDINAL ;
2132 BEGIN
2133    CASE e^.tag OF
2134
2135    designator:  RETURN( findAlias(sym, e^.edes.left) ) |
2136    leaf      :  RETURN( e^.eleaf.sym ) |
2137    expr      :  RETURN( findAlias(sym, e^.eexpr.left) ) |
2138    unary,
2139    binary    :  RETURN( sym )
2140
2141    ELSE
2142       InternalError ('not expecting this tag value')
2143    END
2144 END findAlias ;
2145
2146
2147 (*
2148    SkipConst - returns an alias to constant, sym, if one exists.
2149                Otherwise sym is returned.
2150 *)
2151
2152 PROCEDURE SkipConst (sym: CARDINAL) : CARDINAL ;
2153 VAR
2154    i: CARDINAL ;
2155    e: exprNode ;
2156 BEGIN
2157    i := 1 ;
2158    WHILE i<=HighIndice(constList) DO
2159       e := GetIndice(constList, i) ;
2160       IF (e^.tag=designator) AND (e^.edes.sym=sym)
2161       THEN
2162          RETURN( findAlias(sym, e) )
2163       END ;
2164       INC(i)
2165    END ;
2166    RETURN( sym )
2167 END SkipConst ;
2168
2169
2170 (*
2171    PushConstAttributeType -
2172 *)
2173
2174 PROCEDURE PushConstAttributeType ;
2175 VAR
2176    n: Name ;
2177 BEGIN
2178    PopT(n) ;
2179    PushT(n) ;
2180    InitZType(NulSym) ;
2181    IF (n=MakeKey('BITS_PER_UNIT')) OR (n=MakeKey('BITS_PER_WORD')) OR
2182       (n=MakeKey('BITS_PER_CHAR')) OR (n=MakeKey('UNITS_PER_WORD'))
2183    THEN
2184       (* all ok *)
2185    ELSE
2186       WriteFormat1("unknown constant attribute value '%a'", n)
2187    END
2188 END PushConstAttributeType ;
2189
2190
2191 (*
2192    PushConstAttributePairType -
2193 *)
2194
2195 PROCEDURE PushConstAttributePairType ;
2196 VAR
2197    q, n: Name ;
2198 BEGIN
2199    PopT(n) ;
2200    PopT(q) ;
2201    PushT(q) ;
2202    PushT(n) ;
2203    IF (n=MakeKey('IEC559')) OR (n=MakeKey('LIA1')) OR (n=MakeKey('IEEE')) OR
2204       (n=MakeKey('ISO')) OR (n=MakeKey('rounds')) OR (n=MakeKey('gUnderflow')) OR
2205       (n=MakeKey('exception')) OR (n=MakeKey('extend'))
2206    THEN
2207       InitBooleanType(NulSym)
2208    ELSIF (n=MakeKey('radix')) OR (n=MakeKey('places')) OR (n=MakeKey('expoMin')) OR
2209          (n=MakeKey('expoMax')) OR (n=MakeKey('nModes'))
2210    THEN
2211       InitZType(NulSym)
2212    ELSIF (n=MakeKey('large')) OR (n=MakeKey('small'))
2213    THEN
2214       InitRType(NulSym)
2215    ELSE
2216       WriteFormat1("unknown constant attribute value '%a'", n) ;
2217       InitUnknown(NulSym)
2218    END
2219 END PushConstAttributePairType ;
2220
2221
2222 (*
2223    CheckConsts -
2224 *)
2225
2226 PROCEDURE CheckConsts ;
2227 VAR
2228    i: CARDINAL ;
2229    e: exprNode ;
2230 BEGIN
2231    i := 1 ;
2232    WHILE i<=HighIndice(constList) DO
2233       e := GetIndice(constList, i) ;
2234       IF NOT isTypeResolved(e)
2235       THEN
2236          WITH e^ DO
2237             CASE tag OF
2238
2239             designator:  MetaError1('the type of the constant declaration {%1Dad} cannot be determined', edes.sym)
2240
2241             ELSE
2242             END
2243          END
2244       END ;
2245       INC(i)
2246    END
2247 END CheckConsts ;
2248
2249
2250 (*
2251    ResolveConstTypes - resolves the types of all designator declared constants.
2252 *)
2253
2254 PROCEDURE ResolveConstTypes ;
2255 BEGIN
2256    IF Debugging
2257    THEN
2258       WriteString('initially') ; WriteLn ;
2259       DebugNodes
2260    END ;
2261    WHILE WalkConsts() DO
2262       IF Debugging
2263       THEN
2264          WriteString('iteration') ; WriteLn ;
2265          DebugNodes
2266       END
2267    END ;
2268    IF Debugging
2269    THEN
2270       WriteString('finally') ; WriteLn ;
2271       DebugNodes
2272    END ;
2273    CheckConsts
2274 END ResolveConstTypes ;
2275
2276
2277 (*
2278    Init -
2279 *)
2280
2281 PROCEDURE Init ;
2282 BEGIN
2283    exprStack := InitStackAddress () ;
2284    constList := InitIndex (1) ;
2285    desStack := InitStackWord () ;
2286    inDesignator := FALSE
2287 END Init ;
2288
2289
2290 BEGIN
2291    Init
2292 END PCSymBuild.