gcc/m2/gm2-compiler/M2Error.mod

   1 (* M2Error.mod error reporting interface.
   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 M2Error ;
  23
  24 FROM NameKey IMPORT NulName, Name, KeyToCharStar ;
  25 FROM DynamicStrings IMPORT String, InitString, InitStringCharStar, ConCat, ConCatChar, Mark, string, KillString, Dup ;
  26 FROM FIO IMPORT StdOut, WriteNBytes, Close, FlushBuffer ;
  27 FROM StrLib IMPORT StrLen, StrEqual ;
  28 FROM FormatStrings IMPORT Sprintf0, Sprintf1, Sprintf2, Sprintf3 ;
  29 FROM M2LexBuf IMPORT FindFileNameFromToken, TokenToLineNo, TokenToColumnNo, GetTokenNo ;
  30 FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
  31 FROM M2Printf IMPORT printf0, printf1, printf2, printf3 ;
  32 FROM M2Options IMPORT Xcode ;
  33 FROM M2RTS IMPORT ExitOnHalt ;
  34 FROM SYSTEM IMPORT ADDRESS ;
  35 FROM M2Emit IMPORT EmitError ;
  36 FROM M2LexBuf IMPORT UnknownTokenNo ;
  37 FROM M2StackAddress IMPORT StackOfAddress, InitStackAddress, PushAddress, PopAddress, NoOfItemsInStackAddress ;
  38 FROM Indexing IMPORT Index, HighIndice, InitIndex, GetIndice, PutIndice ;
  39 FROM M2Debug IMPORT Assert ;
  40 FROM M2Pass IMPORT IsPass0, IsPass1 ;
  41 FROM SymbolTable IMPORT NulSym ;
  42
  43 FROM M2ColorString IMPORT filenameColor, endColor, errorColor, warningColor, noteColor,
  44                           range1Color, range2Color, quoteOpen, quoteClose ;
  45
  46 IMPORT M2Emit ;
  47
  48
  49 CONST
  50    Debugging  =  TRUE ;
  51    DebugTrace = FALSE ;
  52    DebugError = FALSE ;
  53
  54 TYPE
  55    Error = POINTER TO RECORD
  56                          parent,
  57                          child,
  58                          next     : Error ;
  59                          note,
  60                          fatal    : BOOLEAN ;
  61                          s        : String ;
  62                          (* index of token causing the error *)
  63                          token    : CARDINAL ;
  64                          color    : BOOLEAN ;
  65                          scope    : ErrorScope ;
  66                       END ;
  67
  68    KindScope = (noscope, definition, implementation, program, module, procedure) ;
  69
  70    ErrorScope = POINTER TO RECORD
  71                               scopeKind: KindScope ;
  72                               scopeName: Name ;
  73                               symbol   : CARDINAL ;   (* symbol table entry.  *)
  74                            END ;
  75
  76
  77 VAR
  78    head        : Error ;
  79    InInternal  : BOOLEAN ;
  80    lastScope   : ErrorScope ;
  81    scopeIndex  : CARDINAL ;
  82    scopeArray  : Index ;
  83    currentScope: ErrorScope ;
  84    scopeStack  : StackOfAddress ;
  85
  86
  87 (*
  88    SetColor - informs the error module that this error will have had colors
  89               assigned to it.  If an error is issued without colors assigned
  90               then the default colors will be assigned to the legacy error
  91               messages.
  92 *)
  93
  94 PROCEDURE SetColor (e: Error) : Error ;
  95 BEGIN
  96    e^.color := TRUE ;
  97    RETURN e
  98 END SetColor ;
  99
 100
 101 (*
 102    Cast - casts a := b
 103 *)
 104
 105 PROCEDURE Cast (VAR a: ARRAY OF BYTE; b: ARRAY OF BYTE) ;
 106 VAR
 107    i: CARDINAL ;
 108 BEGIN
 109    IF HIGH(a)=HIGH(b)
 110    THEN
 111       FOR i := 0 TO HIGH(a) DO
 112          a[i] := b[i]
 113       END
 114    END
 115 END Cast ;
 116
 117
 118 (*
 119    TranslateNameToString - takes a format specification string, a, and
 120                            if they consist of of %a then this is translated
 121                            into a String and %a is replaced by %s.
 122 *)
 123
 124 PROCEDURE TranslateNameToCharStar (VAR a: ARRAY OF CHAR;
 125                                    n: CARDINAL) : BOOLEAN ;
 126 VAR
 127    argno,
 128    i, h : CARDINAL ;
 129 BEGIN
 130    argno := 1 ;
 131    i := 0 ;
 132    h := StrLen(a) ;
 133    WHILE i<h DO
 134       IF (a[i]='%') AND (i+1<h)
 135       THEN
 136          IF (a[i+1]='a') AND (argno=n)
 137          THEN
 138             a[i+1] := 's' ;
 139             RETURN( TRUE )
 140          END ;
 141          INC(argno) ;
 142          IF argno>n
 143          THEN
 144             (* all done *)
 145             RETURN( FALSE )
 146          END
 147       END ;
 148       INC(i)
 149    END ;
 150    RETURN( FALSE )
 151 END TranslateNameToCharStar ;
 152
 153
 154 (*
 155    InternalError - displays an internal error message together with the compiler source
 156                    file and line number.
 157                    This function is not buffered and is used when the compiler is about
 158                    to give up.
 159 *)
 160
 161 PROCEDURE InternalError (message: ARRAY OF CHAR) <* noreturn *> ;
 162 BEGIN
 163    IF NOT InInternal
 164    THEN
 165       InInternal := TRUE ;
 166       FlushErrors
 167    END ;
 168    M2Emit.InternalError (message) ;
 169    HALT
 170 END InternalError ;
 171
 172
 173 (* ***************************************************************************
 174    The following routines are used for normal syntax and semantic error reporting
 175    *************************************************************************** *)
 176
 177
 178 (*
 179    WriteFormat0 - displays the source module and line together
 180                   with the encapsulated format string.
 181                   Used for simple error messages tied to the current token.
 182 *)
 183
 184 PROCEDURE WriteFormat0 (a: ARRAY OF CHAR) ;
 185 VAR
 186    e: Error ;
 187 BEGIN
 188    e := NewError(GetTokenNo()) ;
 189    WITH e^ DO
 190       s := Sprintf0(Mark(InitString(a)))
 191    END
 192 END WriteFormat0 ;
 193
 194
 195 (*
 196    WarnFormat0 - displays the source module and line together
 197                  with the encapsulated format string.
 198                  Used for simple warning messages tied to the current token.
 199 *)
 200
 201 PROCEDURE WarnFormat0 (a: ARRAY OF CHAR) ;
 202 VAR
 203    e: Error ;
 204 BEGIN
 205    e := NewWarning(GetTokenNo()) ;
 206    WITH e^ DO
 207       s := Sprintf0(Mark(InitString(a)))
 208    END
 209 END WarnFormat0 ;
 210
 211
 212 (*
 213    DoFormat1 -
 214 *)
 215
 216 PROCEDURE DoFormat1 (a: ARRAY OF CHAR; w: ARRAY OF BYTE) : String ;
 217 VAR
 218    s: String ;
 219    n: Name ;
 220 BEGIN
 221    n := NulName ;
 222    IF TranslateNameToCharStar(a, 1)
 223    THEN
 224       Cast(n, w) ;
 225       s := Mark(InitStringCharStar(KeyToCharStar(n))) ;
 226       s := Sprintf1(Mark(InitString(a)), s)
 227    ELSE
 228       s := Sprintf1(Mark(InitString(a)), w)
 229    END ;
 230    RETURN( s )
 231 END DoFormat1 ;
 232
 233
 234 (*
 235    WriteFormat1 - displays the source module and line together
 236                   with the encapsulated format string.
 237                   Used for simple error messages tied to the current token.
 238 *)
 239
 240 PROCEDURE WriteFormat1 (a: ARRAY OF CHAR; w: ARRAY OF BYTE) ;
 241 VAR
 242    e: Error ;
 243 BEGIN
 244    e := NewError(GetTokenNo()) ;
 245    e^.s := DoFormat1(a, w)
 246 END WriteFormat1 ;
 247
 248
 249 (*
 250    WarnFormat1 - displays the source module and line together
 251                  with the encapsulated format string.
 252                  Used for simple warning messages tied to the current token.
 253 *)
 254
 255 PROCEDURE WarnFormat1 (a: ARRAY OF CHAR; w: ARRAY OF BYTE) ;
 256 VAR
 257    e: Error ;
 258 BEGIN
 259    e := NewWarning(GetTokenNo()) ;
 260    e^.s := DoFormat1(a, w)
 261 END WarnFormat1 ;
 262
 263
 264 (*
 265    DoFormat2 -
 266 *)
 267
 268 PROCEDURE DoFormat2 (a: ARRAY OF CHAR; w1, w2: ARRAY OF BYTE) : String ;
 269 VAR
 270    n     : Name ;
 271    s,
 272    s1, s2: String ;
 273    b     : BITSET ;
 274 BEGIN
 275    b := {} ;
 276    n := NulName ;
 277    IF TranslateNameToCharStar(a, 1)
 278    THEN
 279       Cast(n, w1) ;
 280       s1 := Mark(InitStringCharStar(KeyToCharStar(n))) ;
 281       INCL(b, 1)
 282    END ;
 283    IF TranslateNameToCharStar(a, 2)
 284    THEN
 285       Cast(n, w2) ;
 286       s2 := Mark(InitStringCharStar(KeyToCharStar(n))) ;
 287       INCL(b, 2)
 288    END ;
 289    CASE b OF
 290
 291    {}   :  s := Sprintf2(Mark(InitString(a)), w1, w2) |
 292    {1}  :  s := Sprintf2(Mark(InitString(a)), s1, w2) |
 293    {2}  :  s := Sprintf2(Mark(InitString(a)), w1, s2) |
 294    {1,2}:  s := Sprintf2(Mark(InitString(a)), s1, s2)
 295
 296    ELSE
 297       HALT
 298    END ;
 299    RETURN( s )
 300 END DoFormat2 ;
 301
 302
 303 (*
 304    WriteFormat2 - displays the module and line together with the encapsulated
 305                   format strings.
 306                   Used for simple error messages tied to the current token.
 307 *)
 308
 309 PROCEDURE WriteFormat2 (a: ARRAY OF CHAR; w1, w2: ARRAY OF BYTE) ;
 310 VAR
 311    e: Error ;
 312 BEGIN
 313    e := NewError(GetTokenNo()) ;
 314    e^.s := DoFormat2(a, w1, w2)
 315 END WriteFormat2 ;
 316
 317
 318 PROCEDURE DoFormat3 (a: ARRAY OF CHAR; w1, w2, w3: ARRAY OF BYTE) : String ;
 319 VAR
 320    n            : Name ;
 321    s, s1, s2, s3: String ;
 322    b            : BITSET ;
 323 BEGIN
 324    b := {} ;
 325    n := NulName ;
 326    IF TranslateNameToCharStar(a, 1)
 327    THEN
 328       Cast(n, w1) ;
 329       s1 := Mark(InitStringCharStar(KeyToCharStar(n))) ;
 330       INCL(b, 1)
 331    END ;
 332    IF TranslateNameToCharStar(a, 2)
 333    THEN
 334       Cast(n, w2) ;
 335       s2 := Mark(InitStringCharStar(KeyToCharStar(n))) ;
 336       INCL(b, 2)
 337    END ;
 338    IF TranslateNameToCharStar(a, 3)
 339    THEN
 340       Cast(n, w3) ;
 341       s3 := Mark(InitStringCharStar(KeyToCharStar(n))) ;
 342       INCL(b, 3)
 343    END ;
 344    CASE b OF
 345
 346    {}     :  s := Sprintf3(Mark(InitString(a)), w1, w2, w3) |
 347    {1}    :  s := Sprintf3(Mark(InitString(a)), s1, w2, w3) |
 348    {2}    :  s := Sprintf3(Mark(InitString(a)), w1, s2, w3) |
 349    {1,2}  :  s := Sprintf3(Mark(InitString(a)), s1, s2, w3) |
 350    {3}    :  s := Sprintf3(Mark(InitString(a)), w1, w2, s3) |
 351    {1,3}  :  s := Sprintf3(Mark(InitString(a)), s1, w2, s3) |
 352    {2,3}  :  s := Sprintf3(Mark(InitString(a)), w1, s2, s3) |
 353    {1,2,3}:  s := Sprintf3(Mark(InitString(a)), s1, s2, s3)
 354
 355    ELSE
 356       HALT
 357    END ;
 358    RETURN( s )
 359 END DoFormat3 ;
 360
 361
 362 (*
 363    WriteFormat3 - displays the module and line together with the encapsulated
 364                   format strings.
 365                   Used for simple error messages tied to the current token.
 366 *)
 367
 368 PROCEDURE WriteFormat3 (a: ARRAY OF CHAR; w1, w2, w3: ARRAY OF BYTE) ;
 369 VAR
 370    e: Error ;
 371 BEGIN
 372    e := NewError(GetTokenNo()) ;
 373    e^.s := DoFormat3(a, w1, w2, w3)
 374 END WriteFormat3 ;
 375
 376
 377 (*
 378    MoveError - repositions an error, e, to token, AtTokenNo, and returns, e.
 379 *)
 380
 381 PROCEDURE MoveError (e: Error; AtTokenNo: CARDINAL) : Error ;
 382 BEGIN
 383    IF e # NIL
 384    THEN
 385       e^.token := AtTokenNo
 386    END ;
 387    RETURN e
 388 END MoveError ;
 389
 390
 391 (*
 392    NewError - creates and returns a new error handle.
 393 *)
 394
 395 PROCEDURE NewError (AtTokenNo: CARDINAL) : Error ;
 396 VAR
 397    e, f: Error ;
 398 BEGIN
 399    IF AtTokenNo = UnknownTokenNo
 400    THEN
 401       (* this could be used as a useful debugging hook as the front end
 402          has forgotten the token no.  This can occur if a complex record
 403          structure or array is used for example.  *)
 404       AtTokenNo := GetTokenNo ()
 405    END ;
 406    NEW(e) ;
 407    WITH e^ DO
 408       s      := NIL ;
 409       token  := AtTokenNo ;
 410       next   := NIL ;
 411       parent := NIL ;
 412       child  := NIL ;
 413       note   := FALSE ;
 414       fatal  := TRUE ;
 415       color  := FALSE ;
 416    END ;
 417    (* Assert (scopeKind # noscope) ;  *)
 418    e^.scope := currentScope ;
 419    IF (head=NIL) OR (head^.token>AtTokenNo)
 420    THEN
 421       e^.next := head ;
 422       head    := e
 423    ELSE
 424       f := head ;
 425       WHILE (f^.next#NIL) AND (f^.next^.token<AtTokenNo) DO
 426          f := f^.next
 427       END ;
 428       e^.next := f^.next ;
 429       f^.next := e
 430    END ;
 431    RETURN( e )
 432 END NewError ;
 433
 434
 435 (*
 436    NewWarning - creates and returns a new error handle suitable for a warning.
 437                 A warning will not stop compilation.
 438 *)
 439
 440 PROCEDURE NewWarning (AtTokenNo: CARDINAL) : Error ;
 441 VAR
 442    e: Error ;
 443 BEGIN
 444    e := NewError(AtTokenNo) ;
 445    e^.fatal := FALSE ;
 446    e^.note  := FALSE ;
 447    RETURN e
 448 END NewWarning ;
 449
 450
 451 (*
 452    NewNote - creates and returns a new error handle suitable for a note.
 453              A note will not stop compilation.
 454 *)
 455
 456 PROCEDURE NewNote (AtTokenNo: CARDINAL) : Error ;
 457 VAR
 458    e: Error ;
 459 BEGIN
 460    e := NewError(AtTokenNo) ;
 461    e^.fatal := FALSE ;
 462    e^.note  := TRUE ;
 463    RETURN e
 464 END NewNote ;
 465
 466
 467 (*
 468    ChainError - creates and returns a new error handle, this new error
 469                 is associated with, e, and is chained onto the end of, e.
 470                 If, e, is NIL then the result to NewError is returned.
 471 *)
 472
 473 PROCEDURE ChainError (AtTokenNo: CARDINAL; e: Error) : Error ;
 474 VAR
 475    f: Error ;
 476 BEGIN
 477    IF e=NIL
 478    THEN
 479       RETURN NewError (AtTokenNo)
 480    ELSE
 481       NEW (f) ;
 482       WITH f^ DO
 483          s         := NIL ;
 484          token     := AtTokenNo ;
 485          next      := e^.child ;
 486          parent    := e ;
 487          child     := NIL ;
 488          fatal     := e^.fatal ;
 489          scope     := e^.scope
 490       END ;
 491       e^.child := f
 492    END ;
 493    RETURN f
 494 END ChainError ;
 495
 496
 497 (*
 498    ErrorFormat routines provide a printf capability for the error handle.
 499 *)
 500
 501 PROCEDURE ErrorFormat0 (e: Error; a: ARRAY OF CHAR) ;
 502 BEGIN
 503    WITH e^ DO
 504       IF s=NIL
 505       THEN
 506          s := Sprintf0(Mark(InitString(a)))
 507       ELSE
 508          s := ConCat(s, Mark(Sprintf0(Mark(InitString(a)))))
 509       END
 510    END
 511 END ErrorFormat0 ;
 512
 513
 514 PROCEDURE ErrorFormat1 (e: Error; a: ARRAY OF CHAR; w: ARRAY OF BYTE) ;
 515 VAR
 516    s1: String ;
 517 BEGIN
 518    s1 := DoFormat1(a, w) ;
 519    WITH e^ DO
 520       IF s=NIL
 521       THEN
 522          s := s1
 523       ELSE
 524          s := ConCat(s, Mark(s1))
 525       END
 526    END
 527 END ErrorFormat1 ;
 528
 529
 530 PROCEDURE ErrorFormat2 (e: Error; a: ARRAY OF CHAR; w1, w2: ARRAY OF BYTE) ;
 531 VAR
 532    s1: String ;
 533 BEGIN
 534    s1 := DoFormat2(a, w1, w2) ;
 535    WITH e^ DO
 536       IF s=NIL
 537       THEN
 538          s := s1
 539       ELSE
 540          s := ConCat(s, Mark(s1))
 541       END
 542    END
 543 END ErrorFormat2 ;
 544
 545
 546 PROCEDURE ErrorFormat3 (e: Error; a: ARRAY OF CHAR;
 547                         w1, w2, w3: ARRAY OF BYTE) ;
 548 VAR
 549    s1: String ;
 550 BEGIN
 551    s1 := DoFormat3(a, w1, w2, w3) ;
 552    WITH e^ DO
 553       IF s=NIL
 554       THEN
 555          s := s1
 556       ELSE
 557          s := ConCat(s, Mark(s1))
 558       END
 559    END
 560 END ErrorFormat3 ;
 561
 562
 563 PROCEDURE ErrorString (e: Error; str: String) ;
 564 BEGIN
 565    WITH e^ DO
 566       s := str
 567    END
 568 END ErrorString ;
 569
 570
 571 (*
 572    Init - initializes the error list.
 573 *)
 574
 575 PROCEDURE Init ;
 576 BEGIN
 577    head := NIL ;
 578    InInternal := FALSE ;
 579    scopeStack := InitStackAddress () ;
 580    scopeArray := InitIndex (1) ;
 581    currentScope := NIL ;
 582    scopeIndex := 0
 583 END Init ;
 584
 585
 586 (*
 587    CheckIncludes - generates a sequence of error messages which determine the relevant
 588                    included file and line number.
 589                    For example:
 590
 591                    gcc a.c
 592                    In file included from b.h:1,
 593                                     from a.c:1:
 594                    c.h:1: parse error before `and'
 595
 596                    where a.c is: #include "b.h"
 597                          b.h is: #include "c.h"
 598                          c.h is: and this and that
 599
 600                    we attempt to follow the error messages that gcc issues.
 601 *)
 602
 603 PROCEDURE CheckIncludes (token: CARDINAL; depth: CARDINAL) ;
 604 VAR
 605    included: String ;
 606    lineno  : CARDINAL ;
 607 BEGIN
 608    included := FindFileNameFromToken(token, depth+1) ;
 609    IF included#NIL
 610    THEN
 611       lineno := TokenToLineNo(token, depth+1) ;
 612       IF depth=0
 613       THEN
 614          printf2('In file included from %s:%d', included, lineno)
 615       ELSE
 616          printf2('                 from %s:%d', included, lineno)
 617       END ;
 618       IF FindFileNameFromToken(token, depth+2)=NIL
 619       THEN
 620          printf0(':\n')
 621       ELSE
 622          printf0(',\n')
 623       END ;
 624       CheckIncludes(token, depth+1)
 625    END
 626 END CheckIncludes ;
 627
 628
 629 (*
 630    FlushAll - flushes all errors in list, e.
 631 *)
 632
 633 PROCEDURE FlushAll (e: Error; FatalStatus: BOOLEAN) : BOOLEAN ;
 634 VAR
 635    f      : Error ;
 636    written: BOOLEAN ;
 637 BEGIN
 638    written := FALSE ;
 639    IF e#NIL
 640    THEN
 641       REPEAT
 642          WITH e^ DO
 643             IF (FatalStatus=fatal) AND (s#NIL)
 644             THEN
 645                currentScope := scope ;
 646                CheckIncludes (token, 0) ;
 647                EmitError (fatal, note, token, AnnounceScope (e, s)) ;
 648                IF (child#NIL) AND FlushAll (child, FatalStatus)
 649                THEN
 650                END ;
 651                s := NIL ;
 652                written := TRUE
 653             END
 654          END ;
 655          f := e ;
 656          e := e^.next ;
 657          IF NOT Debugging
 658          THEN
 659             WITH f^ DO
 660                s := KillString (s)
 661             END ;
 662             DISPOSE (f)
 663          END ;
 664       UNTIL e=NIL
 665    END ;
 666    RETURN written
 667 END FlushAll ;
 668
 669
 670 (*
 671    FlushErrors - switches the output channel to the error channel
 672                  and then writes out all errors.
 673 *)
 674
 675 PROCEDURE FlushErrors ;
 676 BEGIN
 677    IF DebugTrace
 678    THEN
 679       printf0('\nFlushing all errors\n') ;
 680       printf0('===================\n')
 681    END ;
 682    IF FlushAll (head, TRUE)
 683    THEN
 684       ExitOnHalt(1) ;
 685       HALT
 686    END
 687 END FlushErrors ;
 688
 689
 690 (*
 691    FlushWarnings - switches the output channel to the error channel
 692                    and then writes out all warnings.
 693                    If an error is present the compilation is terminated,
 694                    if warnings only were emitted then compilation will
 695                    continue.
 696 *)
 697
 698 PROCEDURE FlushWarnings ;
 699 BEGIN
 700    IF FlushAll (head, FALSE)
 701    THEN
 702    END
 703 END FlushWarnings ;
 704
 705
 706 (*
 707    ErrorStringsAt2 - given error strings, s1, and, s2, it places these
 708                      strings at token positions, tok1 and tok2, respectively.
 709                      Both strings are consumed.
 710 *)
 711
 712 PROCEDURE ErrorStringsAt2 (s1, s2: String; tok1, tok2: CARDINAL) ;
 713 VAR
 714    e: Error ;
 715 BEGIN
 716    IF s1=s2
 717    THEN
 718       s2 := Dup(s1)
 719    END ;
 720    e := NewError(tok1) ;
 721    ErrorString(e, s1) ;
 722    ErrorString(ChainError(tok2, e), s2)
 723 END ErrorStringsAt2 ;
 724
 725
 726 (*
 727    ErrorStringAt2 - given an error string, s, it places this
 728                     string at token positions, tok1 and tok2, respectively.
 729                     The string is consumed.
 730 *)
 731
 732 PROCEDURE ErrorStringAt2 (s: String; tok1, tok2: CARDINAL) ;
 733 BEGIN
 734    ErrorStringsAt2(s, s, tok1, tok2)
 735 END ErrorStringAt2 ;
 736
 737
 738 (*
 739    ErrorStringAt - given an error string, s, it places this
 740                    string at token position, tok.
 741                    The string is consumed.
 742 *)
 743
 744 PROCEDURE ErrorStringAt (s: String; tok: CARDINAL) ;
 745 VAR
 746    e: Error ;
 747 BEGIN
 748    e := NewError(tok) ;
 749    ErrorString(e, s) ;
 750 END ErrorStringAt ;
 751
 752
 753 (*
 754    WarnStringsAt2 - given warning strings, s1, and, s2, it places these
 755                     strings at token positions, tok1 and tok2, respectively.
 756                     Both strings are consumed.
 757 *)
 758
 759 PROCEDURE WarnStringsAt2 (s1, s2: String; tok1, tok2: CARDINAL) ;
 760 VAR
 761    e: Error ;
 762 BEGIN
 763    IF s1=s2
 764    THEN
 765       s2 := Dup(s1)
 766    END ;
 767    e := NewWarning(tok1) ;
 768    ErrorString(e, s1) ;
 769    ErrorString(ChainError(tok2, e), s2)
 770 END WarnStringsAt2 ;
 771
 772
 773 (*
 774    WarnStringAt2 - given an warning string, s, it places this
 775                    string at token positions, tok1 and tok2, respectively.
 776                    The string is consumed.
 777 *)
 778
 779 PROCEDURE WarnStringAt2 (s: String; tok1, tok2: CARDINAL) ;
 780 BEGIN
 781    WarnStringsAt2(s, s, tok1, tok2)
 782 END WarnStringAt2 ;
 783
 784
 785 (*
 786    WarnStringAt - given an error string, s, it places this
 787                   string at token position, tok.
 788                   The string is consumed.
 789 *)
 790
 791 PROCEDURE WarnStringAt (s: String; tok: CARDINAL) ;
 792 VAR
 793    e: Error ;
 794 BEGIN
 795    e := NewWarning(tok) ;
 796    ErrorString(e, s) ;
 797 END WarnStringAt ;
 798
 799
 800 (*
 801    ErrorAbort0 - aborts compiling, it flushes all warnings and errors before aborting.
 802 *)
 803
 804 PROCEDURE ErrorAbort0 (a: ARRAY OF CHAR) ;
 805 BEGIN
 806    FlushWarnings ;
 807    IF NOT StrEqual(a, '')
 808    THEN
 809       WriteFormat0(a)
 810    END ;
 811    IF NOT FlushAll (head, TRUE)
 812    THEN
 813       WriteFormat0('unidentified error') ;
 814       IF FlushAll (head, TRUE)
 815       THEN
 816       END
 817    END ;
 818    ExitOnHalt(1) ;
 819    HALT
 820 END ErrorAbort0 ;
 821
 822
 823 (*
 824    IsErrorScopeNul - returns TRUE if es is NIL or it has a NulName.
 825 *)
 826
 827 PROCEDURE IsErrorScopeNul (es: ErrorScope) : BOOLEAN ;
 828 BEGIN
 829    RETURN (es = NIL) OR (es^.scopeName = NulName)
 830 END IsErrorScopeNul ;
 831
 832
 833 (*
 834    GetAnnounceScope - return message with the error scope attached to message.
 835                       filename and message are treated as read only by this
 836                       procedure function.
 837 *)
 838
 839 PROCEDURE GetAnnounceScope (filename, message: String) : String ;
 840 VAR
 841    pre,
 842    fmt,
 843    desc,
 844    quoted: String ;
 845 BEGIN
 846    IF filename = NIL
 847    THEN
 848       pre := InitString ('')
 849    ELSE
 850       pre := Sprintf1 (Mark (InitString ("%s: ")), filename)
 851    END ;
 852
 853    IF NOT IsErrorScopeNul (currentScope)
 854    THEN
 855       quoted := InitString ('') ;
 856       quoted := quoteOpen (quoted) ;
 857       quoted := ConCat (quoted, Mark (InitStringCharStar (KeyToCharStar (currentScope^.scopeName)))) ;
 858       quoted := quoteClose (quoted)
 859    END ;
 860
 861    IF currentScope = NIL
 862    THEN
 863       desc := InitString ("no scope active")
 864    ELSE
 865       CASE currentScope^.scopeKind OF
 866
 867       definition    :   desc := InitString ("In definition module") |
 868       implementation:   desc := InitString ("In implementation module") |
 869       program       :   desc := InitString ("In program module") |
 870       module        :   desc := InitString ("In inner module") |
 871       procedure     :   desc := InitString ("In procedure")
 872
 873       END
 874    END ;
 875    fmt := ConCat (pre, Mark (desc)) ;
 876    IF IsErrorScopeNul (currentScope)
 877    THEN
 878       fmt := ConCat (fmt, Sprintf0 (Mark (InitString (": "))))
 879    ELSE
 880       fmt := ConCat (fmt, Sprintf1 (Mark (InitString (" %s: ")), quoted))
 881    END ;
 882    RETURN ConCat (fmt, message)
 883 END GetAnnounceScope ;
 884
 885
 886 (*
 887    IsSameScope - return TRUE if a and b refer to the same scope.
 888 *)
 889
 890 PROCEDURE IsSameScope (a, b: ErrorScope) : BOOLEAN ;
 891 BEGIN
 892    IF a = b
 893    THEN
 894       RETURN TRUE
 895    ELSIF (a = NIL) OR (b = NIL)
 896    THEN
 897       RETURN FALSE
 898    ELSE
 899       (* this does not compare the symbol field.  *)
 900       RETURN (a^.scopeKind = b^.scopeKind) AND (a^.scopeName = b^.scopeName)
 901    END
 902 END IsSameScope ;
 903
 904
 905 (*
 906    AnnounceScope - return the error string s with a scope description prepended
 907                    assuming that scope has changed.
 908 *)
 909
 910 PROCEDURE AnnounceScope (e: Error; message: String) : String ;
 911 BEGIN
 912    IF NOT IsSameScope (lastScope, e^.scope)
 913    THEN
 914       lastScope := e^.scope ;
 915       IF IsErrorScopeNul (lastScope)
 916       THEN
 917          RETURN ConCat (InitString ("no scope active: "), message)
 918       ELSE
 919          Assert ((e^.scope # NIL) AND (e^.scope^.scopeKind # noscope)) ;
 920          (* filename := FindFileNameFromToken (e^.token, 0) ; *)
 921          message := GetAnnounceScope (NIL, message)
 922       END
 923    END ;
 924    RETURN message
 925 END AnnounceScope ;
 926
 927
 928 (*
 929    newErrorScope - create an ErrorScope of kindScope and return the object.
 930                    It is also added the a dynamic array.
 931 *)
 932
 933 PROCEDURE newErrorScope (kind: KindScope) : ErrorScope ;
 934 VAR
 935    es: ErrorScope ;
 936    c : CARDINAL ;
 937 BEGIN
 938    IF IsPass0 ()
 939    THEN
 940       NEW (es) ;
 941       es^.scopeKind := kind ;
 942       es^.scopeName := NulName ;
 943       es^.symbol := NulSym ;
 944       PutIndice (scopeArray, HighIndice (scopeArray) + 1, es) ;
 945       IF DebugError
 946       THEN
 947          c := HighIndice (scopeArray) ;
 948          printf2 ("pass 0:  %d  %d\n", c, kind)
 949       END
 950    ELSE
 951       INC (scopeIndex) ;
 952       es := GetIndice (scopeArray, scopeIndex) ;
 953       IF DebugError
 954       THEN
 955          IF IsPass1 ()
 956          THEN
 957             printf3 ("pass 1:  %d  %d  %d\n", scopeIndex, es^.scopeKind, kind)
 958          ELSE
 959             printf3 ("pass 2:  %d  %d  %d\n", scopeIndex, es^.scopeKind, kind)
 960          END
 961       END ;
 962       Assert (es^.scopeKind = kind)
 963    END ;
 964    RETURN es
 965 END newErrorScope ;
 966
 967
 968 (*
 969    DefaultProgramModule - sets up an unnamed program scope before the Ident is seen.
 970 *)
 971
 972 PROCEDURE DefaultProgramModule ;
 973 BEGIN
 974    PushAddress (scopeStack, currentScope) ;
 975    currentScope := newErrorScope (program)
 976 END DefaultProgramModule ;
 977
 978
 979 (*
 980    DefaultImplementationModule - sets up an unnamed implementation
 981                                  scope before the Ident is seen.
 982 *)
 983
 984 PROCEDURE DefaultImplementationModule ;
 985 BEGIN
 986    PushAddress (scopeStack, currentScope) ;
 987    currentScope := newErrorScope (implementation)
 988 END DefaultImplementationModule ;
 989
 990
 991 (*
 992    DefaultDefinitionModule - sets up an unnamed definition
 993                              scope before the Ident is seen.
 994 *)
 995
 996 PROCEDURE DefaultDefinitionModule ;
 997 BEGIN
 998    PushAddress (scopeStack, currentScope) ;
 999    currentScope := newErrorScope (definition)
1000 END DefaultDefinitionModule ;
1001
1002
1003 (*
1004    DefaultInnerModule - sets up an unnamed inner
1005                         scope before the Ident is seen.
1006 *)
1007
1008 PROCEDURE DefaultInnerModule ;
1009 BEGIN
1010    PushAddress (scopeStack, currentScope) ;
1011    currentScope := newErrorScope (module)
1012 END DefaultInnerModule ;
1013
1014
1015 (*
1016    DefaultProcedure - sets up an unnamed procedure
1017                       scope before the Ident is seen.
1018 *)
1019
1020 PROCEDURE DefaultProcedure ;
1021 BEGIN
1022    PushAddress (scopeStack, currentScope) ;
1023    currentScope := newErrorScope (procedure)
1024 END DefaultProcedure ;
1025
1026
1027 (*
1028    EnterImplementationScope - signifies to the error routines that the front end
1029                               has started to compile implementation module scopeName.
1030 *)
1031
1032 PROCEDURE EnterImplementationScope (scopename: Name) ;
1033 BEGIN
1034    Assert (currentScope # NIL) ;
1035    Assert (currentScope^.scopeKind = implementation) ;
1036    IF currentScope^.scopeName = NulName
1037    THEN
1038       IF DebugError
1039       THEN
1040          printf1 ("seen implementation: %a\n", scopename)
1041       END ;
1042       currentScope^.scopeName := scopename
1043    END
1044 END EnterImplementationScope ;
1045
1046
1047 (*
1048    EnterProgramScope - signifies to the error routines that the front end
1049                        has started to compile program module scopeName.
1050 *)
1051
1052 PROCEDURE EnterProgramScope (scopename: Name) ;
1053 BEGIN
1054    Assert (currentScope # NIL) ;
1055    Assert (currentScope^.scopeKind = program) ;
1056    IF currentScope^.scopeName = NulName
1057    THEN
1058       IF DebugError
1059       THEN
1060          printf1 ("seen program: %a\n", scopename)
1061       END ;
1062       currentScope^.scopeName := scopename
1063    END
1064 END EnterProgramScope ;
1065
1066
1067 (*
1068    EnterModuleScope - signifies to the error routines that the front end
1069                       has started to compile an inner module scopeName.
1070 *)
1071
1072 PROCEDURE EnterModuleScope (scopename: Name) ;
1073 BEGIN
1074    Assert (currentScope # NIL) ;
1075    Assert (currentScope^.scopeKind = module) ;
1076    IF currentScope^.scopeName = NulName
1077    THEN
1078       IF DebugError
1079       THEN
1080          printf1 ("seen module: %a\n", scopename)
1081       END ;
1082       currentScope^.scopeName := scopename
1083    END
1084 END EnterModuleScope ;
1085
1086
1087 (*
1088    EnterDefinitionScope - signifies to the error routines that the front end
1089                           has started to compile definition module scopeName.
1090 *)
1091
1092 PROCEDURE EnterDefinitionScope (scopename: Name) ;
1093 BEGIN
1094    Assert (currentScope # NIL) ;
1095    Assert (currentScope^.scopeKind = definition) ;
1096    IF currentScope^.scopeName = NulName
1097    THEN
1098       IF DebugError
1099       THEN
1100          printf1 ("seen definition: %a\n", scopename)
1101       END ;
1102       currentScope^.scopeName := scopename
1103    END
1104 END EnterDefinitionScope ;
1105
1106
1107 (*
1108    EnterProcedureScope - signifies to the error routines that the front end
1109                          has started to compile definition module scopeName.
1110 *)
1111
1112 PROCEDURE EnterProcedureScope (scopename: Name) ;
1113 BEGIN
1114    Assert (currentScope # NIL) ;
1115    Assert (currentScope^.scopeKind = procedure) ;
1116    IF currentScope^.scopeName = NulName
1117    THEN
1118       IF DebugError
1119       THEN
1120          printf1 ("seen procedure: %a\n", scopename)
1121       END ;
1122       currentScope^.scopeName := scopename
1123    END
1124 END EnterProcedureScope ;
1125
1126
1127 (*
1128    LeaveErrorScope - leave the current scope and pop into the previous one.
1129 *)
1130
1131 PROCEDURE LeaveErrorScope ;
1132 BEGIN
1133    currentScope := PopAddress (scopeStack)
1134 END LeaveErrorScope ;
1135
1136
1137 (*
1138    EnterErrorScope - pushes the currentScope and sets currentScope to scope.
1139 *)
1140
1141 PROCEDURE EnterErrorScope (scope: ErrorScope) ;
1142 BEGIN
1143    PushAddress (scopeStack, currentScope) ;
1144    currentScope := scope
1145 END EnterErrorScope ;
1146
1147
1148 (*
1149    GetCurrentErrorScope - returns currentScope.
1150 *)
1151
1152 PROCEDURE GetCurrentErrorScope () : ErrorScope ;
1153 BEGIN
1154    RETURN currentScope
1155 END GetCurrentErrorScope ;
1156
1157
1158 (*
1159    DepthScope - returns the depth of the scope stack.
1160 *)
1161
1162 PROCEDURE DepthScope () : CARDINAL ;
1163 BEGIN
1164    RETURN NoOfItemsInStackAddress (scopeStack)
1165 END DepthScope ;
1166
1167
1168 (*
1169    ResetErrorScope - should be called at the start of each pass to
1170                      reset the error scope index.
1171 *)
1172
1173 PROCEDURE ResetErrorScope ;
1174 BEGIN
1175    scopeIndex := 0
1176 END ResetErrorScope ;
1177
1178
1179 BEGIN
1180    Init
1181 END M2Error.