gcc/m2/mc/mcMetaError.mod

   1 (* Copyright (C) 2015-2024 Free Software Foundation, Inc.  *)
   2 (* This file is part of GNU Modula-2.
   3
   4 GNU Modula-2 is free software; you can redistribute it and/or modify it under
   5 the terms of the GNU General Public License as published by the Free
   6 Software Foundation; either version 3, or (at your option) any later
   7 version.
   8
   9 GNU Modula-2 is distributed in the hope that it will be useful, but WITHOUT ANY
  10 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  11 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  12 for more details.
  13
  14 You should have received a copy of the GNU General Public License along
  15 with gm2; see the file COPYING.  If not, write to the Free Software
  16 Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.  *)
  17
  18 IMPLEMENTATION MODULE mcMetaError ;
  19
  20
  21 FROM nameKey IMPORT Name, keyToCharStar, NulName ;
  22 FROM StrLib IMPORT StrLen ;
  23 FROM mcLexBuf IMPORT getTokenNo ;
  24 FROM mcError IMPORT error, newError, newWarning, errorString, internalError, chainError, flushErrors ;
  25 FROM FIO IMPORT StdOut, WriteLine ;
  26 FROM SFIO IMPORT WriteS ;
  27 FROM StringConvert IMPORT ctos ;
  28 FROM varargs IMPORT vararg ;
  29
  30 IMPORT varargs ;
  31
  32 FROM DynamicStrings IMPORT String, InitString, InitStringCharStar,
  33                            ConCat, ConCatChar, Mark, string, KillString,
  34                            Dup, char, Length, Mult ;
  35
  36 FROM decl IMPORT node, isType, isTemporary, getType, getSymName, getScope, isDef,
  37                  isExported, isZtype, isRtype, skipType, getDeclaredMod, getDeclaredDef,
  38                  getFirstUsed, isLiteral, isConst, isConstSet, isArray, isVar,
  39                  isEnumeration, isEnumerationField, isUnbounded, isProcType, isProcedure,
  40                  isPointer, isParameter, isVarParam, isRecord, isRecordField,
  41                  isVarient, isModule, isImp, isSet, isSubrange ;
  42
  43 TYPE
  44    errorType = (newerror, newwarning, chained) ;
  45
  46
  47 (*
  48    ebnf := { percent
  49              | lbra
  50              | any                  % copy ch %
  51            }
  52          =:
  53
  54    percent := '%' anych             % copy anych %
  55             =:
  56
  57    lbra := '{' [ '!' ] percenttoken '}' =:
  58
  59    percenttoken := '%' (
  60                          '1'        % doOperand(1) %
  61                              op
  62                        | '2'        % doOperand(2) %
  63                              op
  64                        | '3'        % doOperand(3) %
  65                              op
  66                        | '4'        % doOperand(4) %
  67                              op
  68                        )
  69                        } =:
  70
  71    op := {'a'|'q'|'t'|'d'|'n'|'s'|'D'|'I'|'U'|'E'|'W'} then =:
  72
  73    then := [ ':' ebnf ] =:
  74 *)
  75
  76
  77 (*
  78    internalFormat - produces an informative internal error.
  79 *)
  80
  81 PROCEDURE internalFormat (s: String; i: INTEGER; m: ARRAY OF CHAR) ;
  82 VAR
  83    e: error ;
  84 BEGIN
  85    e := newError (getTokenNo()) ;
  86    s := WriteS (StdOut, s) ;
  87    WriteLine (StdOut) ;
  88    s := KillString (s) ;
  89    IF i>0
  90    THEN
  91       DEC(i)
  92    END ;
  93    s := Mult (InitString (' '), i) ;
  94    s := ConCatChar (s, '^') ;
  95    s := WriteS (StdOut, s) ;
  96    WriteLine (StdOut) ;
  97    internalError (m, __FILE__, __LINE__)
  98 END internalFormat ;
  99
 100
 101 (*
 102    x - checks to see that a=b.
 103 *)
 104
 105 PROCEDURE x (a, b: String) : String ;
 106 BEGIN
 107    IF a#b
 108    THEN
 109       internalError('different string returned', __FILE__, __LINE__)
 110    END ;
 111    RETURN a
 112 END x ;
 113
 114
 115 (*
 116    isWhite - returns TRUE if, ch, is a space.
 117 *)
 118
 119 PROCEDURE isWhite (ch: CHAR) : BOOLEAN ;
 120 BEGIN
 121    RETURN ch=' '
 122 END isWhite ;
 123
 124
 125 (*
 126    then := [ ':' ebnf ] =:
 127 *)
 128
 129 PROCEDURE then (VAR e: error; VAR t: errorType;
 130                 VAR r: String; s: String;
 131                 sym: vararg;
 132                 VAR i: INTEGER; l: INTEGER;
 133                 o: String; positive: BOOLEAN) ;
 134 BEGIN
 135    IF char (s, i) = ':'
 136    THEN
 137       INC (i) ;
 138       ebnf (e, t, r, s, sym, i, l) ;
 139       IF (i<l) AND (char (s, i) # '}')
 140       THEN
 141          internalFormat (s, i, 'expecting to see }')
 142       END
 143    END
 144 END then ;
 145
 146
 147 (*
 148    doNumber -
 149 *)
 150
 151 PROCEDURE doNumber (bol: CARDINAL;
 152                     sym: vararg; o: String;
 153                     VAR quotes: BOOLEAN) : String ;
 154 VAR
 155    c: CARDINAL ;
 156 BEGIN
 157    IF Length(o) > 0
 158    THEN
 159       RETURN o
 160    ELSE
 161       quotes := FALSE ;
 162       varargs.next (sym, bol) ;
 163       varargs.arg (sym, c) ;
 164       RETURN ConCat (o, ctos (c, 0, ' '))
 165    END
 166 END doNumber ;
 167
 168
 169 (*
 170    doCount -
 171 *)
 172
 173 PROCEDURE doCount (bol: CARDINAL;
 174                    sym: vararg; o: String;
 175                    VAR quotes: BOOLEAN) : String ;
 176 VAR
 177    c: CARDINAL ;
 178 BEGIN
 179    IF Length(o) > 0
 180    THEN
 181       RETURN o
 182    ELSE
 183       quotes := FALSE ;
 184       varargs.next (sym, bol) ;
 185       varargs.arg (sym, c) ;
 186       o := ConCat (o, ctos (c, 0, ' ')) ;
 187       CASE c MOD 100 OF
 188
 189       11..13:  o := ConCat (o, Mark (InitString ('th')))
 190
 191       ELSE
 192          CASE c MOD 10 OF
 193
 194          1:  o := ConCat (o, Mark (InitString ('st'))) |
 195          2:  o := ConCat (o, Mark (InitString ('nd'))) |
 196          3:  o := ConCat (o, Mark (InitString ('rd')))
 197
 198          ELSE
 199             o := ConCat (o, Mark (InitString ('th')))
 200          END
 201       END ;
 202       RETURN o
 203    END
 204 END doCount ;
 205
 206
 207 PROCEDURE doAscii (bol: CARDINAL; sym: vararg; o: String) : String ;
 208 VAR
 209    n: node ;
 210 BEGIN
 211    varargs.next (sym, bol) ;
 212    varargs.arg (sym, n) ;
 213    IF (Length (o) > 0) OR isTemporary (n)
 214    THEN
 215       RETURN o
 216    ELSE
 217       RETURN ConCat (o, InitStringCharStar (keyToCharStar (getSymName (n))))
 218    END
 219 END doAscii ;
 220
 221
 222 PROCEDURE doName (bol: CARDINAL; sym: vararg; o: String; VAR quotes: BOOLEAN) : String ;
 223 VAR
 224    n: node ;
 225 BEGIN
 226    varargs.next (sym, bol) ;
 227    varargs.arg (sym, n) ;
 228    IF (Length (o) > 0) OR isTemporary (n)
 229    THEN
 230       RETURN o
 231    ELSE
 232       IF isZtype (n)
 233       THEN
 234          quotes := FALSE ;
 235          RETURN ConCat (o, Mark (InitString ('the ZType')))
 236       ELSIF isRtype (n)
 237       THEN
 238          quotes := FALSE ;
 239          RETURN ConCat (o, Mark (InitString ('the RType')))
 240       ELSIF getSymName (n) # NulName
 241       THEN
 242          RETURN ConCat (o, InitStringCharStar (keyToCharStar (getSymName (n))))
 243       ELSE
 244          RETURN o
 245       END
 246    END
 247 END doName ;
 248
 249
 250 PROCEDURE doQualified (bol: CARDINAL; sym: vararg; o: String) : String ;
 251 VAR
 252    s, n: node ;
 253    mod : vararg ;
 254 BEGIN
 255    varargs.next (sym, bol) ;
 256    varargs.arg (sym, n) ;
 257    IF (Length (o) > 0) OR isTemporary (n)
 258    THEN
 259       RETURN o
 260    ELSE
 261       s := getScope (n) ;
 262       mod := varargs.start1 (s) ;
 263       IF isDef(s) AND isExported(n)
 264       THEN
 265          o := x (o, doAscii (0, mod, o)) ;
 266          o := x (o, ConCatChar (o, '.')) ;
 267          o := x (o, ConCat (o, InitStringCharStar (keyToCharStar (getSymName (n)))))
 268       ELSE
 269          o := x (o, doAscii (bol, sym, o))
 270       END ;
 271       varargs.end (mod) ;
 272       RETURN o
 273    END
 274 END doQualified ;
 275
 276
 277 (*
 278    doType - returns a string containing the type name of
 279             sym.  It will skip pseudonym types.  It also
 280             returns the type symbol found.
 281 *)
 282
 283 PROCEDURE doType (bol: CARDINAL;
 284                   VAR sym: vararg; o: String) : String ;
 285 VAR
 286    n: node ;
 287 BEGIN
 288    varargs.next (sym, bol) ;
 289    varargs.arg (sym, n) ;
 290    IF (Length (o) > 0) OR (getType (n) = NIL)
 291    THEN
 292       RETURN o
 293    ELSE
 294       n := skipType (getType (n)) ;
 295       varargs.next (sym, bol) ;
 296       varargs.replace (sym, n) ;
 297       RETURN x (o, doAscii (bol, sym, o))
 298    END
 299 END doType ;
 300
 301
 302 (*
 303    doSkipType - will skip all pseudonym types.  It also
 304                 returns the type symbol found and name.
 305 *)
 306
 307 PROCEDURE doSkipType (bol: CARDINAL; VAR sym: vararg; o: String) : String ;
 308 VAR
 309    n: node ;
 310 BEGIN
 311    varargs.next (sym, bol) ;
 312    varargs.arg (sym, n) ;
 313    IF Length (o) > 0
 314    THEN
 315       RETURN o
 316    ELSE
 317       n := skipType (getType (n)) ;
 318       varargs.next (sym, bol) ;
 319       varargs.replace (sym, n) ;
 320       IF getSymName(n) = NulName
 321       THEN
 322          RETURN o
 323       ELSE
 324          RETURN x (o, doAscii (bol, sym, o))
 325       END
 326    END
 327 END doSkipType ;
 328
 329
 330 PROCEDURE doKey (bol: CARDINAL; sym: vararg; o: String) : String ;
 331 VAR
 332    n: Name ;
 333 BEGIN
 334    IF Length (o) > 0
 335    THEN
 336       RETURN o
 337    ELSE
 338       varargs.next (sym, bol) ;
 339       varargs.arg (sym, n) ;
 340       RETURN ConCat (o, InitStringCharStar (keyToCharStar (n)))
 341    END
 342 END doKey ;
 343
 344
 345 (*
 346    doError - creates and returns an error note.
 347 *)
 348
 349 PROCEDURE doError (e: error; t: errorType; tok: CARDINAL) : error ;
 350 BEGIN
 351    CASE t OF
 352
 353    chained:    IF e=NIL
 354                THEN
 355                   internalError ('should not be chaining an error onto an empty error note', __FILE__, __LINE__)
 356                ELSE
 357                   e := chainError (tok, e)
 358                END |
 359    newerror:   IF e=NIL
 360                THEN
 361                   e := newError (tok)
 362                END |
 363    newwarning: IF e=NIL
 364                THEN
 365                   e := newWarning (tok)
 366                END
 367
 368    ELSE
 369       internalError ('unexpected enumeration value', __FILE__, __LINE__)
 370    END ;
 371    RETURN e
 372 END doError ;
 373
 374
 375 (*
 376    doDeclaredDef - creates an error note where sym[bol] was declared.
 377 *)
 378
 379 PROCEDURE doDeclaredDef (e: error; t: errorType;
 380                          bol: CARDINAL;
 381                          sym: vararg) : error ;
 382 VAR
 383    n: node ;
 384 BEGIN
 385    IF bol <= varargs.nargs (sym)
 386    THEN
 387       varargs.next (sym, bol) ;
 388       varargs.arg (sym, n) ;
 389       e := doError (e, t, getDeclaredDef (n))
 390    END ;
 391    RETURN e
 392 END doDeclaredDef ;
 393
 394
 395 (*
 396    doDeclaredMod - creates an error note where sym[bol] was declared.
 397 *)
 398
 399 PROCEDURE doDeclaredMod (e: error; t: errorType;
 400                          bol: CARDINAL;
 401                          sym: vararg) : error ;
 402 VAR
 403    n: node ;
 404 BEGIN
 405    IF bol <= varargs.nargs (sym)
 406    THEN
 407       varargs.next (sym, bol) ;
 408       varargs.arg (sym, n) ;
 409       e := doError (e, t, getDeclaredMod (n))
 410    END ;
 411    RETURN e
 412 END doDeclaredMod ;
 413
 414
 415 (*
 416    doUsed - creates an error note where sym[bol] was first used.
 417 *)
 418
 419 PROCEDURE doUsed (e: error; t: errorType;
 420                   bol: CARDINAL;
 421                   sym: vararg) : error ;
 422 VAR
 423    n: node ;
 424 BEGIN
 425    IF bol <= varargs.nargs (sym)
 426    THEN
 427       varargs.next (sym, bol) ;
 428       varargs.arg (sym, n) ;
 429       e := doError (e, t, getFirstUsed (n))
 430    END ;
 431    RETURN e
 432 END doUsed ;
 433
 434
 435 (*
 436    ConCatWord - joins sentances, a, b, together.
 437 *)
 438
 439 PROCEDURE ConCatWord (a, b: String) : String ;
 440 BEGIN
 441    IF (Length(a) = 1) AND (char (a, 0) = 'a')
 442    THEN
 443       a := x (a, ConCatChar (a, 'n'))
 444    ELSIF (Length(a) > 1) AND (char (a, -1) = 'a') AND isWhite (char (a, -2))
 445    THEN
 446       a := x (a, ConCatChar (a, 'n'))
 447    END ;
 448    IF (Length(a) > 0) AND (NOT isWhite (char (a, -1)))
 449    THEN
 450       a := x (a, ConCatChar (a, ' '))
 451    END ;
 452    RETURN x (a, ConCat (a, b))
 453 END ConCatWord ;
 454
 455
 456 (*
 457    symDesc -
 458 *)
 459
 460 PROCEDURE symDesc (n: node; o: String) : String ;
 461 BEGIN
 462    IF isLiteral (n)
 463    THEN
 464       RETURN ConCatWord (o, Mark (InitString ('literal')))
 465    ELSIF isConstSet (n)
 466    THEN
 467       RETURN ConCatWord (o, Mark (InitString ('constant set')))
 468 (*
 469    ELSIF IsConstructor(n)
 470    THEN
 471       RETURN( ConCatWord (o, Mark (InitString ('constructor'))) )
 472 *)
 473    ELSIF isConst (n)
 474    THEN
 475       RETURN ConCatWord (o, Mark (InitString ('constant')))
 476    ELSIF isArray (n)
 477    THEN
 478       RETURN ConCatWord (o, Mark (InitString ('array')))
 479    ELSIF isVar (n)
 480    THEN
 481       RETURN ConCatWord (o, Mark (InitString ('variable')))
 482    ELSIF isEnumeration (n)
 483    THEN
 484       RETURN ConCatWord (o, Mark (InitString ('enumeration type')))
 485    ELSIF isEnumerationField (n)
 486    THEN
 487       RETURN ConCatWord (o, Mark (InitString ('enumeration field')))
 488    ELSIF isUnbounded (n)
 489    THEN
 490       RETURN ConCatWord (o, Mark (InitString ('unbounded parameter')))
 491    ELSIF isProcType (n)
 492    THEN
 493       RETURN ConCatWord (o, Mark (InitString ('procedure type')))
 494    ELSIF isProcedure (n)
 495    THEN
 496       RETURN ConCatWord (o, Mark (InitString ('procedure')))
 497    ELSIF isPointer (n)
 498    THEN
 499       RETURN ConCatWord (o, Mark (InitString ('pointer')))
 500    ELSIF isParameter (n)
 501    THEN
 502       IF isVarParam (n)
 503       THEN
 504          RETURN ConCatWord (o, Mark (InitString ('var parameter')))
 505       ELSE
 506          RETURN ConCatWord (o, Mark (InitString ('parameter')))
 507       END
 508    ELSIF isType (n)
 509    THEN
 510       RETURN ConCatWord (o, Mark (InitString ('type')))
 511    ELSIF isRecord (n)
 512    THEN
 513       RETURN ConCatWord (o, Mark (InitString ('record')))
 514    ELSIF isRecordField (n)
 515    THEN
 516       RETURN ConCatWord (o, Mark (InitString ('record field')))
 517    ELSIF isVarient (n)
 518    THEN
 519       RETURN ConCatWord (o, Mark (InitString ('varient record')))
 520    ELSIF isModule(n)
 521    THEN
 522       RETURN ConCatWord (o, Mark (InitString ('module')))
 523    ELSIF isDef(n)
 524    THEN
 525       RETURN ConCatWord (o, Mark (InitString ('definition module')))
 526    ELSIF isImp(n)
 527    THEN
 528       RETURN ConCatWord (o, Mark (InitString ('implementation module')))
 529    ELSIF isSet (n)
 530    THEN
 531       RETURN ConCatWord(o, Mark (InitString ('set')))
 532    ELSIF isSubrange (n)
 533    THEN
 534       RETURN ConCatWord(o, Mark (InitString ('subrange')))
 535    ELSE
 536       RETURN o
 537    END
 538 END symDesc ;
 539
 540
 541 (*
 542    doDesc -
 543 *)
 544
 545 PROCEDURE doDesc (bol: CARDINAL;
 546                   sym: vararg; o: String;
 547                   VAR quotes: BOOLEAN) : String ;
 548 VAR
 549    n: node ;
 550 BEGIN
 551    IF Length (o) = 0
 552    THEN
 553       varargs.next (sym, bol) ;
 554       varargs.arg (sym, n) ;
 555       o := symDesc (n, o) ;
 556       IF Length (o) > 0
 557       THEN
 558          quotes := FALSE
 559       END
 560    END ;
 561    RETURN o
 562 END doDesc ;
 563
 564
 565 (*
 566    addQuoted - if, o, is not empty then add it to, r.
 567 *)
 568
 569 PROCEDURE addQuoted (r, o: String; quotes: BOOLEAN) : String ;
 570 BEGIN
 571    IF Length (o) > 0
 572    THEN
 573       IF NOT isWhite (char (r, -1))
 574       THEN
 575          r := x (r, ConCatChar (r, " "))
 576       END ;
 577       IF quotes
 578       THEN
 579          r := x (r, ConCatChar (r, "'"))
 580       END ;
 581       r := x (r, ConCat (r, o)) ;
 582       IF quotes
 583       THEN
 584          r := x (r, ConCatChar (r, "'"))
 585       END
 586    END ;
 587    RETURN r
 588 END addQuoted ;
 589
 590
 591 (*
 592    op := {'a'|'q'|'t'|'d'|'k'|'n'|'s'|'D'|'I'|'U'|'E'|'W'} then =:
 593 *)
 594
 595 PROCEDURE op (VAR e: error; VAR t: errorType;
 596               VAR r: String; s: String;
 597               sym: vararg;
 598               VAR i: INTEGER; l: INTEGER;
 599               bol: CARDINAL; positive: BOOLEAN) ;
 600 VAR
 601    o     : String ;
 602    c     : vararg ;
 603    quotes: BOOLEAN ;
 604 BEGIN
 605    c := varargs.copy (sym) ;
 606    o := InitString ('') ;
 607    quotes := TRUE ;
 608    WHILE (i<l) AND (char (s, i)#'}') DO
 609       CASE char(s, i) OF
 610
 611       'a':  o := x(o, doName (bol, sym, o, quotes)) |
 612       'q':  o := x(o, doQualified (bol, sym, o)) |
 613       't':  o := x(o, doType (bol, sym, o)) |
 614       'd':  o := x(o, doDesc (bol, sym, o, quotes)) |
 615       'n':  o := x(o, doNumber (bol, sym, o, quotes)) |
 616       'N':  o := x(o, doCount (bol, sym, o, quotes)) |
 617       's':  o := x(o, doSkipType (bol, sym, o)) |
 618       'k':  o := x(o, doKey (bol, sym, o)) |
 619       'D':  e := doDeclaredDef (e, t, bol, sym) |
 620       'M':  e := doDeclaredMod (e, t, bol, sym) |
 621       'U':  e := doUsed (e, t, bol, sym) |
 622       'E':  t := newerror |
 623       'W':  t := newwarning |
 624       ':':  varargs.end (sym) ;
 625             sym := varargs.copy (c) ;
 626             then (e, t, r, s, sym, i, l, o, positive) ;
 627             o := KillString (o) ;
 628             o := InitString ('') ;
 629             IF (i<l) AND (char (s, i) # '}')
 630             THEN
 631                internalFormat (s, i, 'expecting to see }')
 632             END ;
 633             DEC (i)
 634
 635       ELSE
 636          internalFormat (s, i, 'expecting one of [aqtdnNsDUEW:]')
 637       END ;
 638       INC (i) ;
 639    END ;
 640    r := x (r, addQuoted (r, o, quotes)) ;
 641    o := KillString (o)
 642 END op ;
 643
 644
 645 (*
 646    percenttoken := '%' (
 647                          '1'        % doOperand(1) %
 648                              op
 649                        | '2'        % doOperand(2) %
 650                              op
 651                        | '3'        % doOperand(3) %
 652                              op
 653                        | '4'        % doOperand(4) %
 654                              op
 655                        )
 656                        } =:
 657 *)
 658
 659 PROCEDURE percenttoken (VAR e: error; t: errorType;
 660                         VAR r: String; s: String;
 661                         sym: vararg;
 662                         VAR i: INTEGER; l: INTEGER; positive: BOOLEAN) ;
 663 BEGIN
 664    IF char (s, i) = '%'
 665    THEN
 666       INC (i) ;
 667       CASE char (s, i) OF
 668
 669       '1':  INC (i) ;
 670             op (e, t, r, s, sym, i, l, 0, positive) |
 671       '2':  INC (i) ;
 672             op (e, t, r, s, sym, i, l, 1, positive) |
 673       '3':  INC (i) ;
 674             op (e, t, r, s, sym, i, l, 2, positive) |
 675       '4':  INC (i) ;
 676             op (e, t, r, s, sym, i, l, 3, positive)
 677
 678       ELSE
 679          internalFormat (s, i, 'expecting one of [123]')
 680       END ;
 681       IF (i<l) AND (char (s, i) # '}')
 682       THEN
 683          internalFormat (s, i, 'expecting to see }')
 684       END
 685    END
 686 END percenttoken ;
 687
 688
 689 (*
 690    percent := '%' anych           % copy anych %
 691             =:
 692 *)
 693
 694 PROCEDURE percent (VAR r: String; s: String;
 695                    sym: vararg;
 696                    VAR i: INTEGER; l: INTEGER) ;
 697 BEGIN
 698    IF char(s, i)='%'
 699    THEN
 700       INC (i) ;
 701       IF i<l
 702       THEN
 703          r := x (r, ConCatChar (r, char (s, i))) ;
 704          INC (i)
 705       END
 706    END
 707 END percent ;
 708
 709
 710 (*
 711    lbra := '{' [ '!' ] percenttoken '}' =:
 712 *)
 713
 714 PROCEDURE lbra (VAR e: error; VAR t: errorType;
 715                 VAR r: String; s: String;
 716                 sym: vararg;
 717                 VAR i: INTEGER; l: INTEGER) ;
 718 VAR
 719    positive: BOOLEAN ;
 720 BEGIN
 721    IF char (s, i) = '{'
 722    THEN
 723       positive := TRUE ;
 724       INC (i) ;
 725       IF char (s, i) = '!'
 726       THEN
 727          positive := FALSE ;
 728          INC (i) ;
 729       END ;
 730       IF char (s, i) # '%'
 731       THEN
 732          internalFormat (s, i, 'expecting to see %')
 733       END ;
 734       percenttoken (e, t, r, s, sym, i, l, positive) ;
 735       IF (i<l) AND (char (s, i) # '}')
 736       THEN
 737          internalFormat (s, i, 'expecting to see }')
 738       END
 739    END
 740 END lbra ;
 741
 742
 743 PROCEDURE stop ; BEGIN END stop ;
 744
 745 (*
 746    ebnf := { percent
 747              | lbra
 748              | any                    % copy ch %
 749            }
 750          =:
 751 *)
 752
 753 PROCEDURE ebnf (VAR e: error; VAR t: errorType;
 754                 VAR r: String; s: String;
 755                 sym: vararg;
 756                 VAR i: INTEGER; l: INTEGER) ;
 757 BEGIN
 758    WHILE i<l DO
 759       CASE char(s, i) OF
 760
 761       '%':  percent (r, s, sym, i, l) |
 762       '{':  lbra (e, t, r, s, sym, i, l) ;
 763             IF (i<l) AND (char (s, i) # '}')
 764             THEN
 765                internalFormat (s, i, 'expecting to see }')
 766             END |
 767       '}':  RETURN
 768
 769       ELSE
 770          IF ((isWhite (char(s, i)) AND (Length (r) > 0) AND (NOT isWhite (char (r, -1)))) OR
 771             (NOT isWhite (char (s, i))))
 772          THEN
 773             r := x (r, ConCatChar (r, char (s, i)))
 774          END
 775       END ;
 776       INC (i)
 777    END
 778 END ebnf ;
 779
 780
 781 (*
 782    doFormat -
 783 *)
 784
 785 PROCEDURE doFormat (VAR e: error; VAR t: errorType;
 786                     s: String; sym: vararg) : String ;
 787 VAR
 788    r   : String ;
 789    i, l: INTEGER ;
 790 BEGIN
 791    r := InitString ('') ;
 792    i := 0 ;
 793    l := Length (s) ;
 794    ebnf (e, t, r, s, sym, i, l) ;
 795    s := KillString (s) ;
 796    RETURN r
 797 END doFormat ;
 798
 799
 800 PROCEDURE metaErrorStringT1 (tok: CARDINAL; m: String; s: ARRAY OF BYTE) ;
 801 VAR
 802    str: String ;
 803    e  : error ;
 804    sym: vararg ;
 805    t  : errorType ;
 806 BEGIN
 807    e := NIL ;
 808    sym := varargs.start1 (s) ;
 809    t := newerror ;
 810    str := doFormat (e, t, m, sym) ;
 811    e := doError (e, t, tok) ;
 812    errorString (e, str) ;
 813    varargs.end (sym)
 814 END metaErrorStringT1 ;
 815
 816
 817 PROCEDURE metaErrorT1 (tok: CARDINAL; m: ARRAY OF CHAR; s: ARRAY OF BYTE) ;
 818 BEGIN
 819    metaErrorStringT1 (tok, InitString (m), s)
 820 END metaErrorT1 ;
 821
 822
 823 PROCEDURE metaErrorStringT2 (tok: CARDINAL; m: String; s1, s2: ARRAY OF BYTE) ;
 824 VAR
 825    str: String ;
 826    e  : error ;
 827    sym: vararg ;
 828    t  : errorType ;
 829 BEGIN
 830    e := NIL ;
 831    sym := varargs.start2 (s1, s2) ;
 832    t := newerror ;
 833    str := doFormat (e, t, m, sym) ;
 834    e := doError (e, t, tok) ;
 835    errorString (e, str) ;
 836    varargs.end (sym)
 837 END metaErrorStringT2 ;
 838
 839
 840 PROCEDURE metaErrorT2 (tok: CARDINAL; m: ARRAY OF CHAR; s1, s2: ARRAY OF BYTE) ;
 841 BEGIN
 842    metaErrorStringT2 (tok, InitString (m), s1, s2)
 843 END metaErrorT2 ;
 844
 845
 846 PROCEDURE metaErrorStringT3 (tok: CARDINAL; m: String; s1, s2, s3: ARRAY OF BYTE) ;
 847 VAR
 848    str: String ;
 849    e  : error ;
 850    sym: vararg ;
 851    t  : errorType ;
 852 BEGIN
 853    e := NIL ;
 854    sym := varargs.start3 (s1, s2, s3) ;
 855    t := newerror ;
 856    str := doFormat (e, t, m, sym) ;
 857    e := doError (e, t, tok) ;
 858    errorString (e, str) ;
 859    varargs.end (sym)
 860 END metaErrorStringT3 ;
 861
 862
 863 PROCEDURE metaErrorT3 (tok: CARDINAL; m: ARRAY OF CHAR; s1, s2, s3: ARRAY OF BYTE) ;
 864 BEGIN
 865    metaErrorStringT3 (tok, InitString (m), s1, s2, s3)
 866 END metaErrorT3 ;
 867
 868
 869 PROCEDURE metaErrorStringT4 (tok: CARDINAL; m: String; s1, s2, s3, s4: ARRAY OF BYTE) ;
 870 VAR
 871    str: String ;
 872    e  : error ;
 873    sym: vararg ;
 874    t  : errorType ;
 875 BEGIN
 876    e := NIL ;
 877    sym := varargs.start4 (s1, s2, s3, s4) ;
 878    t := newerror ;
 879    str := doFormat (e, t, m, sym) ;
 880    e := doError (e, t, tok) ;
 881    errorString (e, str) ;
 882    varargs.end (sym)
 883 END metaErrorStringT4 ;
 884
 885
 886 PROCEDURE metaErrorT4 (tok: CARDINAL; m: ARRAY OF CHAR;
 887                        s1, s2, s3, s4: ARRAY OF BYTE) ;
 888 BEGIN
 889    metaErrorStringT4 (tok, InitString (m), s1, s2, s3, s4)
 890 END metaErrorT4 ;
 891
 892
 893 PROCEDURE metaError1 (m: ARRAY OF CHAR; s: ARRAY OF BYTE) ;
 894 BEGIN
 895    metaErrorT1 (getTokenNo (), m, s)
 896 END metaError1 ;
 897
 898
 899 PROCEDURE metaError2 (m: ARRAY OF CHAR; s1, s2: ARRAY OF BYTE) ;
 900 BEGIN
 901    metaErrorT2 (getTokenNo (), m, s1, s2)
 902 END metaError2 ;
 903
 904
 905 PROCEDURE metaError3 (m: ARRAY OF CHAR; s1, s2, s3: ARRAY OF BYTE) ;
 906 BEGIN
 907    metaErrorT3 (getTokenNo (), m, s1, s2, s3)
 908 END metaError3 ;
 909
 910
 911 PROCEDURE metaError4 (m: ARRAY OF CHAR; s1, s2, s3, s4: ARRAY OF BYTE) ;
 912 BEGIN
 913    metaErrorT4 (getTokenNo (), m, s1, s2, s3, s4)
 914 END metaError4 ;
 915
 916
 917 (*
 918    wrapErrors -
 919 *)
 920
 921 PROCEDURE wrapErrors (tok: CARDINAL;
 922                       m1, m2: ARRAY OF CHAR;
 923                       sym: vararg) ;
 924 VAR
 925    e, f: error ;
 926    str : String ;
 927    t   : errorType ;
 928 BEGIN
 929    e := NIL ;
 930    t := newerror ;
 931    str := doFormat (e, t, InitString(m1), sym) ;
 932    e := doError (e, t, tok) ;
 933    errorString (e, str) ;
 934    f := e ;
 935    t := chained ;
 936    str := doFormat (f, t, InitString (m2), sym) ;
 937    IF e=f
 938    THEN
 939       t := chained ;
 940       f := doError (e, t, tok)
 941    END ;
 942    errorString (f, str)
 943 END wrapErrors ;
 944
 945
 946 PROCEDURE metaErrorsT1 (tok: CARDINAL; m1, m2: ARRAY OF CHAR; s: ARRAY OF BYTE) ;
 947 VAR
 948    sym: vararg ;
 949 BEGIN
 950    sym := varargs.start1 (s) ;
 951    wrapErrors (tok, m1, m2, sym) ;
 952    varargs.end (sym)
 953 END metaErrorsT1 ;
 954
 955
 956 PROCEDURE metaErrorsT2 (tok: CARDINAL; m1, m2: ARRAY OF CHAR; s1, s2: ARRAY OF BYTE) ;
 957 VAR
 958    sym: vararg ;
 959 BEGIN
 960    sym := varargs.start2 (s1, s2) ;
 961    wrapErrors (tok, m1, m2, sym) ;
 962    varargs.end (sym)
 963 END metaErrorsT2 ;
 964
 965
 966 PROCEDURE metaErrorsT3 (tok: CARDINAL; m1, m2: ARRAY OF CHAR; s1, s2, s3: ARRAY OF BYTE) ;
 967 VAR
 968    sym: vararg ;
 969 BEGIN
 970    sym := varargs.start3 (s1, s2, s3) ;
 971    wrapErrors (tok, m1, m2, sym) ;
 972    varargs.end (sym)
 973 END metaErrorsT3 ;
 974
 975
 976 PROCEDURE metaErrorsT4 (tok: CARDINAL; m1, m2: ARRAY OF CHAR; s1, s2, s3, s4: ARRAY OF BYTE) ;
 977 VAR
 978    sym: vararg ;
 979 BEGIN
 980    sym := varargs.start4 (s1, s2, s3, s4) ;
 981    wrapErrors (tok, m1, m2, sym) ;
 982    varargs.end (sym)
 983 END metaErrorsT4 ;
 984
 985
 986 PROCEDURE metaErrors1 (m1, m2: ARRAY OF CHAR; s: ARRAY OF BYTE) ;
 987 BEGIN
 988    metaErrorsT1 (getTokenNo (), m1, m2, s)
 989 END metaErrors1 ;
 990
 991
 992 PROCEDURE metaErrors2 (m1, m2: ARRAY OF CHAR; s1, s2: ARRAY OF BYTE) ;
 993 BEGIN
 994    metaErrorsT2 (getTokenNo (), m1, m2, s1, s2)
 995 END metaErrors2 ;
 996
 997
 998 PROCEDURE metaErrors3 (m1, m2: ARRAY OF CHAR; s1, s2, s3: ARRAY OF BYTE) ;
 999 BEGIN
1000    metaErrorsT3 (getTokenNo (), m1, m2, s1, s2, s3)
1001 END metaErrors3 ;
1002
1003
1004 PROCEDURE metaErrors4 (m1, m2: ARRAY OF CHAR; s1, s2, s3, s4: ARRAY OF BYTE) ;
1005 BEGIN
1006    metaErrorsT4 (getTokenNo (), m1, m2, s1, s2, s3, s4)
1007 END metaErrors4 ;
1008
1009
1010 PROCEDURE metaErrorString1 (m: String; s: ARRAY OF BYTE) ;
1011 BEGIN
1012    metaErrorStringT1 (getTokenNo (), m, s)
1013 END metaErrorString1 ;
1014
1015
1016 PROCEDURE metaErrorString2 (m: String; s1, s2: ARRAY OF BYTE) ;
1017 BEGIN
1018    metaErrorStringT2 (getTokenNo (), m, s1, s2)
1019 END metaErrorString2 ;
1020
1021
1022 PROCEDURE metaErrorString3 (m: String; s1, s2, s3: ARRAY OF BYTE) ;
1023 BEGIN
1024    metaErrorStringT3 (getTokenNo (), m, s1, s2, s3)
1025 END metaErrorString3 ;
1026
1027
1028 PROCEDURE metaErrorString4 (m: String; s1, s2, s3, s4: ARRAY OF BYTE) ;
1029 BEGIN
1030    metaErrorStringT4 (getTokenNo (), m, s1, s2, s3, s4)
1031 END metaErrorString4 ;
1032
1033
1034 END mcMetaError.