gcc/m2/gm2-compiler/P0SymBuild.mod

   1 (* P0SymBuild.mod pass 0 symbol creation.
   2
   3 Copyright (C) 2011-2021 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 P0SymBuild ;
  23
  24 FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
  25 FROM M2Printf IMPORT printf0, printf1, printf2 ;
  26 FROM Lists IMPORT List, InitList, KillList, IncludeItemIntoList, RemoveItemFromList, NoOfItemsInList, GetItemFromList, IsItemInList ;
  27 FROM M2Batch IMPORT MakeDefinitionSource, MakeProgramSource, MakeImplementationSource ;
  28 FROM SymbolTable IMPORT NulSym, MakeInnerModule, SetCurrentModule, SetFileModule, MakeError ;
  29 FROM NameKey IMPORT Name, NulName ;
  30 FROM M2Quads IMPORT PushT, PushTF, PopT, PopTF, PopN, OperandT, PopTtok, PushTtok ;
  31 FROM M2Reserved IMPORT ImportTok ;
  32 FROM M2Debug IMPORT Assert ;
  33 FROM M2MetaError IMPORT MetaErrorT1, MetaErrorT2, MetaError1, MetaError2 ;
  34 FROM M2LexBuf IMPORT GetTokenNo, UnknownTokenNo ;
  35 IMPORT M2Error ;
  36
  37
  38 CONST
  39    Debugging = FALSE ;
  40
  41 TYPE
  42    Kind = (module, program, defimp, inner, procedure, universe, unknown) ;
  43
  44    BlockInfoPtr = POINTER TO RECORD
  45                      name           : Name ;
  46                      kind           : Kind ;
  47                      sym            : CARDINAL ;
  48                      level          : CARDINAL ;
  49                      token          : CARDINAL ;      (* where the block starts.  *)
  50                      LocalModules,                    (* locally declared modules at the current level  *)
  51                      ImportedModules: List ;          (* current list of imports for the scanned module *)
  52                      toPC,
  53                      toReturn,
  54                      toNext,                          (* next in same level *)
  55                      toUp,                            (* return to outer level *)
  56                      toDown         : BlockInfoPtr ;  (* first of the inner level *)
  57                   END ;
  58
  59 VAR
  60    headBP,
  61    curBP : BlockInfoPtr ;
  62    Level : CARDINAL ;
  63
  64
  65 (*
  66    nSpaces -
  67 *)
  68
  69 PROCEDURE nSpaces (n: CARDINAL) ;
  70 BEGIN
  71    WHILE n>0 DO
  72       printf0(" ") ;
  73       DEC(n)
  74    END
  75 END nSpaces ;
  76
  77
  78 (*
  79    DisplayB -
  80 *)
  81
  82 PROCEDURE DisplayB (b: BlockInfoPtr) ;
  83 BEGIN
  84    CASE b^.kind OF
  85
  86    program  :  printf1("MODULE %a ;\n", b^.name) |
  87    defimp   :  printf1("DEFIMP %a ;\n", b^.name) |
  88    inner    :  printf1("INNER MODULE %a ;\n", b^.name) |
  89    procedure:  printf1("PROCEDURE %a ;\n", b^.name)
  90
  91    ELSE
  92       HALT
  93    END
  94 END DisplayB ;
  95
  96
  97 (*
  98    DisplayBlock -
  99 *)
 100
 101 PROCEDURE DisplayBlock (b: BlockInfoPtr; l: CARDINAL) ;
 102 VAR
 103    a: BlockInfoPtr ;
 104 BEGIN
 105    nSpaces(l) ;
 106    DisplayB(b) ;
 107    a := b^.toDown ;
 108    INC(l, 3) ;
 109    WHILE a#NIL DO
 110       DisplayBlock(a, l) ;
 111       a := a^.toNext
 112    END ;
 113    DEC(l, 3) ;
 114    nSpaces(l) ;
 115    printf1("END %a\n", b^.name)
 116 END DisplayBlock ;
 117
 118
 119 (*
 120    pc - an interactive debugging aid callable from gdb.
 121 *)
 122
 123 (*
 124 PROCEDURE pc ;
 125 BEGIN
 126    DisplayB(curBP)
 127 END pc ;
 128 *)
 129
 130
 131 (*
 132    Display -
 133 *)
 134
 135 PROCEDURE Display ;
 136 VAR
 137    b: BlockInfoPtr ;
 138 BEGIN
 139    printf0("Universe of Modula-2 modules\n") ;
 140    IF headBP#NIL
 141    THEN
 142       b := headBP^.toDown ;
 143       WHILE b#NIL DO
 144          DisplayBlock(b, 0) ;
 145          b := b^.toNext
 146       END
 147    END
 148 END Display ;
 149
 150
 151 (*
 152    addDown - adds, b, to the down link of, a.
 153 *)
 154
 155 PROCEDURE addDown (a, b: BlockInfoPtr) ;
 156 BEGIN
 157    IF a^.toDown=NIL
 158    THEN
 159       a^.toDown := b
 160    ELSE
 161       a := a^.toDown ;
 162       WHILE a^.toNext#NIL DO
 163          a := a^.toNext
 164       END ;
 165       a^.toNext := b
 166    END
 167 END addDown ;
 168
 169
 170 (*
 171    GraftBlock - add a new block, b, into the tree in the correct order.
 172 *)
 173
 174 PROCEDURE GraftBlock (b: BlockInfoPtr) ;
 175 BEGIN
 176    Assert(curBP#NIL) ;
 177    Assert(ABS(Level-curBP^.level)<=1) ;
 178    CASE Level-curBP^.level OF
 179
 180    -1:  (* returning up to the outer scope *)
 181         curBP := curBP^.toUp ;
 182         Assert(curBP^.toNext=NIL) ;
 183         curBP^.toNext := b |
 184     0:  (* add toNext *)
 185         Assert(curBP^.toNext=NIL) ;
 186         curBP^.toNext := b ;
 187         b^.toUp := curBP^.toUp |
 188    +1:  (* insert down a level *)
 189         b^.toUp := curBP ;  (* save return value *)
 190         addDown(curBP, b)
 191
 192    ELSE
 193       HALT
 194    END ;
 195    curBP := b
 196 END GraftBlock ;
 197
 198
 199 (*
 200    BeginBlock - denotes the start of the next block.  We remember all imports and
 201                 local modules and procedures created in this block.
 202 *)
 203
 204 PROCEDURE BeginBlock (n: Name; k: Kind; s: CARDINAL; tok: CARDINAL) ;
 205 VAR
 206    b: BlockInfoPtr ;
 207 BEGIN
 208    NEW(b) ;
 209    WITH b^ DO
 210       name := n ;
 211       kind := k ;
 212       sym := s ;
 213       InitList(LocalModules) ;
 214       InitList(ImportedModules) ;
 215       toPC := NIL ;
 216       toReturn := NIL ;
 217       toNext := NIL ;
 218       toDown := NIL ;
 219       toUp := NIL ;
 220       level := Level ;
 221       token := tok
 222    END ;
 223    GraftBlock(b)
 224 END BeginBlock ;
 225
 226
 227 (*
 228    InitUniverse -
 229 *)
 230
 231 PROCEDURE InitUniverse ;
 232 BEGIN
 233    NEW(curBP) ;
 234    WITH curBP^ DO
 235       name := NulName ;
 236       kind := universe ;
 237       sym := NulSym ;
 238       InitList(LocalModules) ;
 239       InitList(ImportedModules) ;
 240       toNext := NIL ;
 241       toDown := NIL ;
 242       toUp := curBP ;
 243       level := Level
 244    END ;
 245    headBP := curBP
 246 END InitUniverse ;
 247
 248
 249 (*
 250    FlushImports -
 251 *)
 252
 253 PROCEDURE FlushImports (b: BlockInfoPtr) ;
 254 VAR
 255    i, n   : CARDINAL ;
 256    modname: Name ;
 257 BEGIN
 258    WITH b^ DO
 259       i := 1 ;
 260       n := NoOfItemsInList (ImportedModules) ;
 261       WHILE i<=n DO
 262          modname := GetItemFromList (ImportedModules, i) ;
 263          sym := MakeDefinitionSource (GetTokenNo (), modname) ;
 264          Assert (sym # NulSym) ;
 265          INC (i)
 266       END
 267    END
 268 END FlushImports ;
 269
 270
 271 (*
 272    EndBlock - shutdown the module and create definition symbols for all imported
 273               modules.
 274 *)
 275
 276 PROCEDURE EndBlock ;
 277 BEGIN
 278    FlushImports(curBP) ;
 279    curBP := curBP^.toUp ;
 280    DEC(Level) ;
 281    IF Level=0
 282    THEN
 283       FlushImports(curBP)
 284    END
 285 END EndBlock ;
 286
 287
 288 (*
 289    RegisterLocalModule - register, n, as a local module.
 290 *)
 291
 292 PROCEDURE RegisterLocalModule (n: Name) ;
 293 BEGIN
 294    (* printf1('seen local module %a\n', n) ; *)
 295    WITH curBP^ DO
 296       IncludeItemIntoList(LocalModules, n) ;
 297       RemoveItemFromList(ImportedModules, n)
 298    END
 299 END RegisterLocalModule ;
 300
 301
 302 (*
 303    RegisterImport - register, n, as a module imported from either a local scope or definition module.
 304 *)
 305
 306 PROCEDURE RegisterImport (n: Name) ;
 307 VAR
 308    bp: BlockInfoPtr ;
 309 BEGIN
 310    (* printf1('register import from module %a\n', n) ; *)
 311    Assert(curBP#NIL) ;
 312    Assert(curBP^.toUp#NIL) ;
 313    bp := curBP^.toUp ;   (* skip over current module *)
 314    WITH bp^ DO
 315       IF NOT IsItemInList(LocalModules, n)
 316       THEN
 317          IncludeItemIntoList(ImportedModules, n)
 318       END
 319    END
 320 END RegisterImport ;
 321
 322
 323 (*
 324    RegisterImports -
 325 *)
 326
 327 PROCEDURE RegisterImports ;
 328 VAR
 329    i, n: CARDINAL ;
 330 BEGIN
 331    PopT(n) ;       (* n   = # of the Ident List *)
 332    IF OperandT(n+1)=ImportTok
 333    THEN
 334       (* Ident list contains Module Names *)
 335       i := 1 ;
 336       WHILE i<=n DO
 337          RegisterImport(OperandT(n+1-i)) ;
 338          INC(i)
 339       END
 340    ELSE
 341       (* Ident List contains list of objects *)
 342       RegisterImport(OperandT(n+1))
 343    END ;
 344    PopN(n+1)   (* clear stack *)
 345 END RegisterImports ;
 346
 347
 348 (*
 349    RegisterInnerImports -
 350 *)
 351
 352 PROCEDURE RegisterInnerImports ;
 353 VAR
 354    n: CARDINAL ;
 355 BEGIN
 356    PopT(n) ;       (* n   = # of the Ident List *)
 357    IF OperandT(n+1)=ImportTok
 358    THEN
 359       (* Ident list contains list of objects, which will be seen outside the scope of this module *)
 360 (*
 361       i := 1 ;
 362       WHILE i<=n DO
 363          RegisterImport(OperandT(n+1-i)) ;
 364          INC(i)
 365       END
 366 *)
 367    ELSE
 368       (* Ident List contains list of objects, but we are importing directly from a module OperandT(n+1) *)
 369       RegisterImport(OperandT(n+1))
 370    END ;
 371    PopN(n+1)   (* clear stack *)
 372 END RegisterInnerImports ;
 373
 374
 375 (*
 376    RegisterProgramModule - register the top of stack as a program module.
 377 *)
 378
 379 PROCEDURE RegisterProgramModule ;
 380 VAR
 381    n  : Name ;
 382    sym: CARDINAL ;
 383    tok: CARDINAL ;
 384 BEGIN
 385    Assert (Level=0) ;
 386    INC (Level) ;
 387    PopTtok (n, tok) ;
 388    PushTtok (n, tok) ;
 389    sym := MakeProgramSource (tok, n) ;
 390    SetCurrentModule (sym) ;
 391    SetFileModule (sym) ;
 392    BeginBlock (n, program, sym, tok) ;
 393    M2Error.EnterProgramScope (n)
 394 END RegisterProgramModule ;
 395
 396
 397 (*
 398    RegisterImplementationModule - register the top of stack as an implementation module.
 399 *)
 400
 401 PROCEDURE RegisterImplementationModule ;
 402 VAR
 403    n  : Name ;
 404    sym: CARDINAL ;
 405    tok: CARDINAL ;
 406 BEGIN
 407    Assert (Level=0) ;
 408    INC (Level) ;
 409    PopTtok (n, tok) ;
 410    PushTtok (n, tok) ;
 411    sym := MakeImplementationSource (tok, n) ;
 412    SetCurrentModule (sym) ;
 413    SetFileModule (sym) ;
 414    BeginBlock (n, defimp, sym, tok) ;
 415    M2Error.EnterImplementationScope (n)
 416 END RegisterImplementationModule ;
 417
 418
 419 (*
 420    RegisterDefinitionModule - register the top of stack as a definition module.
 421 *)
 422
 423 PROCEDURE RegisterDefinitionModule ;
 424 VAR
 425    n  : Name ;
 426    sym: CARDINAL ;
 427    tok: CARDINAL ;
 428 BEGIN
 429    Assert(Level=0) ;
 430    INC(Level) ;
 431    PopTtok (n, tok) ;
 432    PushTtok (n, tok) ;
 433    sym := MakeDefinitionSource (tok, n) ;
 434    SetCurrentModule (sym) ;
 435    SetFileModule (sym) ;
 436    BeginBlock (n, defimp, sym, tok) ;
 437    M2Error.EnterDefinitionScope (n)
 438 END RegisterDefinitionModule ;
 439
 440
 441 (*
 442    RegisterInnerModule - register the top of stack as an inner module, this module name
 443                          will be removed from the list of outstanding imports in the
 444                          current module block.
 445 *)
 446
 447 PROCEDURE RegisterInnerModule ;
 448 VAR
 449    n  : Name ;
 450    tok: CARDINAL ;
 451 BEGIN
 452    INC(Level) ;
 453    PopTtok (n, tok) ;
 454    PushTtok (n, tok) ;
 455    RegisterLocalModule (n) ;
 456    BeginBlock (n, inner, NulSym, tok) ;
 457    M2Error.EnterModuleScope (n)
 458 END RegisterInnerModule ;
 459
 460
 461 (*
 462    RegisterProcedure - register the top of stack as a procedure.
 463 *)
 464
 465 PROCEDURE RegisterProcedure ;
 466 VAR
 467    n  : Name ;
 468    tok: CARDINAL ;
 469 BEGIN
 470    INC (Level) ;
 471    PopTtok (n, tok) ;
 472    PushTtok (n, tok) ;
 473    BeginBlock (n, procedure, NulSym, tok) ;
 474    M2Error.EnterProcedureScope (n)
 475 END RegisterProcedure ;
 476
 477
 478 (*
 479    EndBuildProcedure - ends building a Procedure.
 480 *)
 481
 482 PROCEDURE EndProcedure ;
 483 VAR
 484    NameEnd, NameStart: Name ;
 485    end, start        : CARDINAL ;
 486 BEGIN
 487    PopTtok (NameEnd, end) ;
 488    PopTtok (NameStart, start) ;
 489    Assert (start # UnknownTokenNo) ;
 490    Assert (end # UnknownTokenNo) ;
 491    IF NameEnd # NameStart
 492    THEN
 493       IF NameEnd = NulName
 494       THEN
 495          MetaErrorT1 (start,
 496                       'procedure name at beginning {%1Ea} does not match the name at end',
 497                       MakeError (start, NameStart)) ;
 498          MetaError1 ('procedure name at end does not match the name at beginning {%1Ea}',
 499                      MakeError (start, NameStart))
 500       ELSE
 501          MetaErrorT2 (start,
 502                       'procedure name at beginning {%1Ea} does not match the name at end {%2a}',
 503                       MakeError (start, curBP^.name), MakeError (end, NameEnd)) ;
 504          MetaErrorT2 (end,
 505                       'procedure name at end {%1Ea} does not match the name at beginning {%2Ea}',
 506                       MakeError (end, NameEnd), MakeError (start, curBP^.name))
 507       END
 508    END ;
 509    EndBlock ;
 510    M2Error.LeaveErrorScope
 511 END EndProcedure ;
 512
 513
 514 (*
 515    EndModule -
 516 *)
 517
 518 PROCEDURE EndModule ;
 519 VAR
 520    NameEnd, NameStart: Name ;
 521    end, start        : CARDINAL ;
 522 BEGIN
 523    PopTtok (NameEnd, end) ;
 524    PopTtok (NameStart, start) ;
 525    Assert (start # UnknownTokenNo) ;
 526    Assert (end # UnknownTokenNo) ;
 527    IF NameEnd # NameStart
 528    THEN
 529       IF NameEnd = NulName
 530       THEN
 531          MetaErrorT1 (start,
 532                       'module name at beginning {%1Ea} does not match the name at end',
 533                       MakeError (start, NameStart)) ;
 534          MetaError1 ('module name at end does not match the name at beginning {%1Ea}',
 535                      MakeError (start, NameStart))
 536       ELSE
 537          MetaErrorT2 (start,
 538                       'module name at beginning {%1Ea} does not match the name at end {%2a}',
 539                       MakeError (start, curBP^.name), MakeError (end, NameEnd)) ;
 540          MetaErrorT2 (end,
 541                       'module name at end {%1Ea} does not match the name at beginning {%2Ea}',
 542                       MakeError (end, NameEnd), MakeError (start, curBP^.name))
 543       END
 544    END ;
 545    EndBlock ;
 546    M2Error.LeaveErrorScope
 547 END EndModule ;
 548
 549
 550 (*
 551    DeclareModules - declare all inner modules seen at the current block level.
 552 *)
 553
 554 PROCEDURE DeclareModules ;
 555 VAR
 556    b: BlockInfoPtr ;
 557    s: CARDINAL ;
 558 BEGIN
 559    b := curBP^.toDown ;
 560    WHILE b # NIL DO
 561       IF b^.kind = inner
 562       THEN
 563          IF Debugging
 564          THEN
 565             printf1 ("***  declaring inner module %a\n", b^.name)
 566          END ;
 567          s := MakeInnerModule (curBP^.token, b^.name) ;
 568          Assert (s # NulSym)
 569       END ;
 570       b := b^.toNext
 571    END
 572 END DeclareModules ;
 573
 574
 575 (****
 576 (*
 577    MoveNext -
 578 *)
 579
 580 PROCEDURE MoveNext ;
 581 VAR
 582    b: BlockInfoPtr ;
 583 BEGIN
 584    IF curBP^.toNext#NIL
 585    THEN
 586       b := curBP^.toUp ;
 587       (* moving to next *)
 588       curBP := curBP^.toNext ;
 589       (* remember our return *)
 590       curBP^.toUp := b
 591    END
 592 END MoveNext ;
 593
 594
 595 (*
 596    MoveDown -
 597 *)
 598
 599 PROCEDURE MoveDown ;
 600 VAR
 601    b: BlockInfoPtr ;
 602 BEGIN
 603    (* move down a level *)
 604    (* remember where we came from *)
 605    b := curBP ;
 606    curBP := curBP^.toDown ;
 607    curBP^.toUp := b
 608 END MoveDown ;
 609
 610
 611 (*
 612    MoveUp -
 613 *)
 614
 615 PROCEDURE MoveUp ;
 616 BEGIN
 617    (* move up to the outer scope *)
 618    curBP := curBP^.toUp ;
 619 END MoveUp ;
 620 ***** *)
 621
 622
 623 (*
 624    Move -
 625 *)
 626
 627 PROCEDURE Move ;
 628 VAR
 629    b: BlockInfoPtr ;
 630 BEGIN
 631    IF Level=curBP^.level
 632    THEN
 633       b := curBP^.toReturn ;
 634       (* moving to next *)
 635       curBP := curBP^.toNext ;
 636       (* remember our return *)
 637       curBP^.toReturn := b
 638    ELSE
 639       WHILE Level#curBP^.level DO
 640          IF Level<curBP^.level
 641          THEN
 642             (* move up to the outer scope *)
 643             b := curBP ;
 644             curBP := curBP^.toReturn ;
 645             curBP^.toPC := b^.toNext   (* remember where we reached *)
 646          ELSE
 647             (* move down a level *)
 648             (* remember where we came from *)
 649             b := curBP ;
 650             IF curBP^.toPC=NIL
 651             THEN
 652                Assert(curBP^.toDown#NIL) ;
 653                curBP^.toPC := curBP^.toDown
 654             END ;
 655             Assert(curBP^.toPC#NIL) ;
 656             curBP := curBP^.toPC ;
 657             curBP^.toReturn := b
 658          END
 659       END
 660    END
 661 END Move ;
 662
 663
 664 (*
 665    EnterBlock -
 666 *)
 667
 668 PROCEDURE EnterBlock (n: Name) ;
 669 BEGIN
 670    Assert(curBP#NIL) ;
 671    INC(Level) ;
 672    Move ;
 673    IF Debugging
 674    THEN
 675       nSpaces(Level*3) ;
 676       IF n=curBP^.name
 677       THEN
 678          printf1('block %a\n', n)
 679       ELSE
 680          printf2('seen block %a but tree has recorded %a\n', n, curBP^.name)
 681       END
 682    END ;
 683    Assert((n=curBP^.name) OR (curBP^.name=NulName)) ;
 684    DeclareModules
 685 END EnterBlock ;
 686
 687
 688 (*
 689    LeaveBlock -
 690 *)
 691
 692 PROCEDURE LeaveBlock ;
 693 BEGIN
 694    IF Debugging
 695    THEN
 696       printf1('leaving block %a ', curBP^.name)
 697    END ;
 698    DEC(Level) ;
 699    Move
 700 END LeaveBlock ;
 701
 702
 703 (*
 704    P0Init -
 705 *)
 706
 707 PROCEDURE P0Init ;
 708 BEGIN
 709    headBP := NIL ;
 710    curBP := NIL ;
 711    Level := 0 ;
 712    InitUniverse
 713 END P0Init ;
 714
 715
 716 (*
 717    P1Init -
 718 *)
 719
 720 PROCEDURE P1Init ;
 721 BEGIN
 722    IF Debugging
 723    THEN
 724       Display
 725    END ;
 726    (* curBP := headBP^.toDown ; *)
 727    curBP := headBP ;
 728    Assert(curBP#NIL) ;
 729    curBP^.toPC := curBP^.toDown ;
 730    curBP^.toReturn := curBP ;
 731    Level := 0
 732 END P1Init ;
 733
 734
 735 END P0SymBuild.