gcc/m2/gm2-compiler/P0SymBuild.mod

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