gpcp/CPascalErrors.cp

   1 (* ==================================================================== *)
   2 (*                                                                      *)
   3 (*  Error Module for the Gardens Point Component Pascal Compiler.       *)
   4 (*      Copyright (c) John Gough 1999, 2000.                            *)
   5 (*                                                                      *)
   6 (* ==================================================================== *)
   7
   8 MODULE CPascalErrors;
   9
  10   IMPORT
  11         GPCPcopyright,
  12         GPTextFiles,
  13         Console,
  14         FileNames,
  15         Scnr := CPascalS,
  16         LitValue,
  17         GPText;
  18
  19 (* ============================================================ *)
  20
  21   CONST
  22     consoleWidth = 80;
  23     listingWidth = 128;
  24     listingMax   = listingWidth-1;
  25
  26   TYPE
  27     ParseHandler* = POINTER TO RECORD (Scnr.ErrorHandler)
  28                     END;
  29     SemanticHdlr* = POINTER TO RECORD (Scnr.ErrorHandler)
  30                     END;
  31
  32   TYPE
  33       Message = LitValue.CharOpen;
  34
  35       Err     = POINTER TO ErrDesc;
  36       ErrDesc = RECORD
  37                   num, lin, col: INTEGER;
  38                   msg: Message;
  39                 END;
  40       ErrBuff = POINTER TO ARRAY OF Err;
  41
  42   VAR
  43       parsHdlr : ParseHandler;
  44       semaHdlr : SemanticHdlr;
  45       eBuffer  : ErrBuff;       (* Invariant: eBuffer[eTide] = NIL *)
  46       eLimit   : INTEGER;       (* High index of dynamic array.    *)
  47       eTide    : INTEGER;       (* Next index for insertion in buf *)
  48       prompt*  : BOOLEAN;       (* Emit error message immediately  *)
  49       nowarn*  : BOOLEAN;       (* Don't store warning messages    *)
  50       srcNam   : FileNames.NameString;
  51       forVisualStudio* : BOOLEAN;
  52       xmlErrors* : BOOLEAN;
  53
  54 (* ============================================================ *)
  55
  56   PROCEDURE StoreError (eNum, linN, colN : INTEGER; mesg: Message);
  57   (* Store an error message for later printing *)
  58     VAR
  59       nextErr: Err;
  60
  61     (* -------------------------------------- *)
  62
  63     PROCEDURE append(b : ErrBuff; n : Err) : ErrBuff;
  64       VAR s : ErrBuff;
  65           i : INTEGER;
  66     BEGIN
  67       IF eTide = eLimit THEN (* must expand *)
  68         s := b;
  69         eLimit := eLimit * 2 + 1;
  70         NEW(b, eLimit+1);
  71         FOR i := 0 TO eTide DO b[i] := s[i] END;
  72       END;
  73       b[eTide] := n; INC(eTide); b[eTide] := NIL;
  74       RETURN b;
  75     END append;
  76
  77     (* -------------------------------------- *)
  78
  79   BEGIN
  80     NEW(nextErr);
  81     nextErr.num := eNum;
  82     nextErr.msg := mesg;
  83     nextErr.col := colN;
  84     nextErr.lin := linN;
  85     eBuffer := append(eBuffer, nextErr);
  86   END StoreError;
  87
  88 (* ============================================================ *)
  89
  90   PROCEDURE QuickSort(min, max : INTEGER);
  91     VAR i,j : INTEGER;
  92         key : INTEGER;
  93         tmp : Err;
  94    (* ------------------------------------------------- *)
  95     PROCEDURE keyVal(i : INTEGER) : INTEGER;
  96     BEGIN
  97       IF (eBuffer[i].col <= 0) OR (eBuffer[i].col >= listingWidth) THEN
  98         eBuffer[i].col := listingMax;
  99       END;
 100       RETURN eBuffer[i].lin * 256 + eBuffer[i].col;
 101     END keyVal;
 102    (* ------------------------------------------------- *)
 103   BEGIN
 104     i := min; j := max;
 105     key := keyVal((min+max) DIV 2);
 106     REPEAT
 107       WHILE keyVal(i) < key DO INC(i) END;
 108       WHILE keyVal(j) > key DO DEC(j) END;
 109       IF i <= j THEN
 110         tmp := eBuffer[i]; eBuffer[i] := eBuffer[j]; eBuffer[j] := tmp;
 111         INC(i); DEC(j);
 112       END;
 113     UNTIL i > j;
 114     IF min < j THEN QuickSort(min,j) END;
 115     IF i < max THEN QuickSort(i,max) END;
 116   END QuickSort;
 117
 118 (* ============================================================ *)
 119
 120   PROCEDURE (h : ParseHandler)Report*(num,lin,col : INTEGER);
 121     VAR str : ARRAY 128 OF CHAR;
 122         msg : Message;
 123         idx : INTEGER;
 124         len : INTEGER;
 125   BEGIN
 126     CASE num OF
 127     |  0: str := "EOF expected";
 128     |  1: str := "ident expected";
 129     |  2: str := "integer expected";
 130     |  3: str := "real expected";
 131     |  4: str := "CharConstant expected";
 132     |  5: str := "string expected";
 133     |  6: str := "'*' expected";
 134     |  7: str := "'-' expected";
 135     |  8: str := "'!' expected";
 136     |  9: str := "'.' expected";
 137     | 10: str := "'=' expected";
 138     | 11: str := "'ARRAY' expected";
 139     | 12: str := "',' expected";
 140     | 13: str := "'OF' expected";
 141     | 14: str := "'ABSTRACT' expected";
 142     | 15: str := "'EXTENSIBLE' expected";
 143     | 16: str := "'LIMITED' expected";
 144     | 17: str := "'RECORD' expected";
 145     | 18: str := "'(' expected";
 146     | 19: str := "'+' expected";
 147     | 20: str := "')' expected";
 148     | 21: str := "'END' expected";
 149     | 22: str := "';' expected";
 150     | 23: str := "':' expected";
 151     | 24: str := "'POINTER' expected";
 152     | 25: str := "'TO' expected";
 153     | 26: str := "'PROCEDURE' expected";
 154     | 27: str := "'[' expected";
 155     | 28: str := "']' expected";
 156     | 29: str := "'^' expected";
 157     | 30: str := "'$' expected";
 158     | 31: str := "'#' expected";
 159     | 32: str := "'<' expected";
 160     | 33: str := "'<=' expected";
 161     | 34: str := "'>' expected";
 162     | 35: str := "'>=' expected";
 163     | 36: str := "'IN' expected";
 164     | 37: str := "'IS' expected";
 165     | 38: str := "'OR' expected";
 166     | 39: str := "'/' expected";
 167     | 40: str := "'DIV' expected";
 168     | 41: str := "'MOD' expected";
 169     | 42: str := "'&' expected";
 170     | 43: str := "'NIL' expected";
 171     | 44: str := "'~' expected";
 172     | 45: str := "'{' expected";
 173     | 46: str := "'}' expected";
 174     | 47: str := "'..' expected";
 175     | 48: str := "'EXIT' expected";
 176     | 49: str := "'RETURN' expected";
 177     | 50: str := "'NEW' expected";
 178     | 51: str := "':=' expected";
 179     | 52: str := "'IF' expected";
 180     | 53: str := "'THEN' expected";
 181     | 54: str := "'ELSIF' expected";
 182     | 55: str := "'ELSE' expected";
 183     | 56: str := "'CASE' expected";
 184     | 57: str := "'|' expected";
 185     | 58: str := "'WHILE' expected";
 186     | 59: str := "'DO' expected";
 187     | 60: str := "'REPEAT' expected";
 188     | 61: str := "'UNTIL' expected";
 189     | 62: str := "'FOR' expected";
 190     | 63: str := "'BY' expected";
 191     | 64: str := "'LOOP' expected";
 192     | 65: str := "'WITH' expected";
 193     | 66: str := "'EMPTY' expected";
 194     | 67: str := "'BEGIN' expected";
 195     | 68: str := "'CONST' expected";
 196     | 69: str := "'TYPE' expected";
 197     | 70: str := "'VAR' expected";
 198     | 71: str := "'OUT' expected";
 199     | 72: str := "'IMPORT' expected";
 200     | 73: str := "'MODULE' expected";
 201     | 74: str := "'CLOSE' expected";
 202     | 75: str := "'JAVACLASS' expected";
 203     | 76: str := "not expected";
 204     | 77: str := "error in OtherAtts";
 205     | 78: str := "error in MethAttributes";
 206     | 79: str := "error in ProcedureStuff";
 207     | 80: str := "this symbol not expected in StatementSequence";
 208     | 81: str := "this symbol not expected in StatementSequence";
 209     | 82: str := "error in IdentStatement";
 210     | 83: str := "error in MulOperator";
 211     | 84: str := "error in Factor";
 212     | 85: str := "error in AddOperator";
 213     | 86: str := "error in Relation";
 214     | 87: str := "error in OptAttr";
 215     | 88: str := "error in ProcedureType";
 216     | 89: str := "error in Type";
 217     | 90: str := "error in Module";
 218     | 91: str := "invalid lexical token";
 219     END;
 220     len := LEN(str$);
 221     NEW(msg, len+1);
 222     FOR idx := 0 TO len-1 DO
 223       msg[idx] := str[idx];
 224     END;
 225     msg[len] := 0X;
 226     StoreError(num,lin,col,msg);
 227     INC(Scnr.errors);
 228   END Report;
 229
 230 (* ============================================================ *)
 231
 232   PROCEDURE (h : ParseHandler)RepSt1*(num       : INTEGER;
 233                                         IN s1   : ARRAY OF CHAR;
 234                                         lin,col : INTEGER),EMPTY;
 235   PROCEDURE (h : ParseHandler)RepSt2*(num       : INTEGER;
 236                                        IN s1,s2 : ARRAY OF CHAR;
 237                                         lin,col : INTEGER),EMPTY;
 238
 239 (* ============================================================ *)
 240
 241   PROCEDURE (h : SemanticHdlr)Report*(num,lin,col : INTEGER);
 242     VAR str : ARRAY 128 OF CHAR;
 243         msg : Message;
 244         idx : INTEGER;
 245         len : INTEGER;
 246   BEGIN
 247     CASE num OF
 248     (* ======================= ERRORS ========================= *)
 249     |  -1: str := "invalid character";
 250     |   0: RETURN;                      (* just a placeholder *)
 251     |   1: str := "Name after 'END' does not match";
 252     |   2: str := "Identifier not known in this scope";
 253     |   3: str := "Identifier not known in qualified scope";
 254     |   4: str := "This name already known in this scope";
 255     |   5: str := "This identifier is not a type name";
 256     |   6: str := "This fieldname clashes with previous fieldname";
 257     |   7: str := "Qualified identifier is not a type name";
 258     |   8: str := "Not a record type, so you cannot select a field";
 259     |   9: str := "Identifier is not a fieldname of the current type";
 260
 261     |  10: str := "Not an array type, so you cannot index into it";
 262     |  11: str := "Too many indices for the dimension of the array";
 263     |  12: str := "Not a pointer type, so you cannot dereference it";
 264     |  13: str := "Not a procedure call or type guard";
 265     |  14: str := "Basetype is not record or pointer type";
 266     |  15: str := "Typename not a subtype of the current type";
 267     |  16: str := "Basetype was not declared ABSTRACT or EXTENSIBLE";
 268     |  17: str := "Not dynamically typed, so you cannot have type-guard";
 269     |  18: str := "The type-guard must be a record type here";
 270     |  19: str := "This constant token not known";
 271
 272     |  20: str := "Name of formal is not unique";
 273     |  21: str := "Actual parameter is not compatible with formal type";
 274     |  22: str := "Too few actual parameters";
 275     |  23: str := "Too many actual parameters";
 276     |  24: str := "Attempt to use a proper procedure when function needed";
 277     |  25: str := "Expression is not constant";
 278     |  26: str := "Range of the numerical type exceeded";
 279     |  27: str := "String literal too long for destination type";
 280     |  28: str := "Low value of range not in SET base-type range";
 281     |  29: str := "High value of range not in SET base-type range";
 282
 283     |  30: str := "Low value of range cannot be greater than high value";
 284     |  31: str := "Array index not of an integer type";
 285     |  32: str := "Literal array index is outside array bounds";
 286     |  33: str := "Literal value is not in SET base-type range";
 287     |  34: str := "Typename is not a subtype of the type of destination";
 288     |  35: str := "Expression is not of SET type";
 289     |  36: str := "Expression is not of BOOLEAN type";
 290     |  37: str := "Expression is not of an integer type";
 291     |  38: str := "Expression is not of a numeric type";
 292     |  39: str := "Overflow of negation of literal value";
 293
 294     |  40: str := "Expression is not of ARRAY type";
 295     |  41: str := "Expression is not of character array type";
 296     |  42: str := "Expression is not a standard function";
 297     |  43: str := "Expression is not of character type";
 298     |  44: str := "Literal expression is not in CHAR range";
 299     |  45: str := "Expression is not of REAL type";
 300     |  46: str := "Optional param of LEN must be a positive integer constant";
 301     |  47: str := "LONG cannot be applied to this type";
 302     |  48: str := "Name is not the name of a basic type";
 303     |  49: str := "MAX and MIN not applicable to this type";
 304
 305     |  50: str := "ORD only applies to SET and CHAR types";
 306     |  51: str := "SHORT cannot be applied to this type";
 307     |  52: str := "Both operands must be numeric, SET or CHAR types";
 308     |  53: str := "Character constant outside CHAR range";
 309     |  54: str := "Bad conversion type";
 310     |  55: str := "Numeric overflow in constant evaluation";
 311     |  56: str := "BITS only applies to expressions of type INTEGER";
 312     |  57: str := "Operands in '=' or '#' test are not type compatible";
 313     |  58: str := "EXIT is only permitted inside a LOOP";
 314     |  59: str := "BY expression must be a constant expression";
 315
 316     |  60: str := "Case label is not an integer or character constant";
 317     |  61: str := "Method attributes don't apply to ordinary procedure";
 318     |  62: str := "Forward type-bound method elaborated as static procedure";
 319     |  63: str := "Forward static procedure elaborated as type-bound method";
 320     |  64: str := "Forward method had different receiver mode";
 321     |  65: str := "Forward procedure had non-matching formal types";
 322     |  66: str := "Forward method had different attributes";
 323     |  67: str := "Variable cannot have open array type";
 324     |  68: str := "Arrays must have at least one element";
 325     |  69: str := "Fixed array cannot have open array element type";
 326
 327     |  70: str := "Forward procedure had different names for formals";
 328     |  71: str := "This imported type is LIMITED, and cannot be instantiated";
 329     |  72: str := "Forward procedure was not elaborated by end of block";
 330     |  73: str := "RETURN is not legal in a module body";
 331     |  74: str := "This is a proper procedure, it cannot return a value";
 332     |  75: str := "This is a function, it must return a value";
 333     |  76: str := "RETURN value not assign-compatible with function type";
 334     |  77: str := "Actual for VAR formal must be a writeable variable";
 335     |  78: str := "Functions cannot return record types";
 336     |  79: str := "Functions cannot return array types";
 337
 338     |  80: str := "This designator is not the name of a proper procedure";
 339     |  81: str := "FOR loops cannot have zero step size";
 340     |  82: str := "This fieldname clashes with an inherited fieldname";
 341     |  83: str := "Expression not assign-compatible with destination";
 342     |  84: str := "FOR loop control variable must be of integer type";
 343     |  85: str := "Identifier is not the name of a variable";
 344     |  86: str := "Typename is not an extension of the variable type";
 345     |  87: str := "The selected identifier is not of dynamic type";
 346     |  88: str := "Case select expression is not of integer or CHAR type";
 347     |  89: str := "Case select value is duplicated for this statement";
 348
 349     |  90: str := "Variables of ABSTRACT type cannot be instantiated";
 350     |  91: str := "Optional param of ASSERT must be an integer constant";
 351     |  92: str := "This is not a standard procedure";
 352     |  93: str := "The param of HALT must be a constant integer";
 353     |  94: str := "This variable is not of pointer or vector type";
 354     |  95: str := "NEW requires a length param for open arrays and vectors";
 355     |  96: str := "NEW only applies to pointers to records and arrays";
 356     |  97: str := "This call of NEW has too many lengths specified";
 357     |  98: str := "Length for an open array NEW must be an integer type";
 358     |  99: str := "Length only applies to open arrays and vectors";
 359
 360     | 100: str := "This call of NEW needs more length params";
 361     | 101: str := "Numeric literal is too large, even for long type";
 362     | 102: str := "Only ABSTRACT basetypes can have abstract extensions";
 363     | 103: str := "This expression is read-only";
 364     | 104: str := "Receiver type must be a record, or pointer to record";
 365     | 105: str := "This method is not a redefinition, you must use NEW";
 366     | 106: str := "This method is a redefinition, you must not use NEW";
 367     | 107: str := "Receivers of record type must be VAR or IN mode";
 368     | 108: str := "Final method cannot be redefined";
 369     | 109: str := "Only ABSTRACT method can have ABSTRACT redefinition";
 370
 371     | 110: str := "This type has ABSTRACT method, must be ABSTRACT";
 372     | 111: str := "Type has NEW,EMPTY method, must be ABSTRACT or EXTENSIBLE";
 373     | 112: str := "Only EMPTY or ABSTRACT method can be redefined EMPTY";
 374     | 113: str := "This redefinition of exported method must be exported";
 375     | 114: str := "This is an EMPTY method, and cannot have OUT parameters";
 376     | 115: str := "This is an EMPTY method, and cannot return a value";
 377     | 116: str := "Redefined method must have consistent return type";
 378     | 117: str := "Type has EXTENSIBLE method, must be ABSTRACT or EXTENSIBLE";
 379     | 118: str := "Empty or abstract methods cannot be called by super-call";
 380     | 119: str := "Super-call is invalid here";
 381
 382     | 120: str := "There is no overridden method with this name";
 383     | 121: str := "Not all abstract methods were implemented";
 384     | 122: str := "This procedure is not at module scope, cannot be a method";
 385     | 123: str := "There is a cycle in the base-type declarations";
 386     | 124: str := "There is a cycle in the field-type declarations";
 387     | 125: str := "Cycle in typename equivalence declarations";
 388     | 126: str := "There is a cycle in the array element type declarations";
 389     | 127: str := "This is an implement-only method, and cannot be called";
 390     | 128: str := "Only declarations at module level can be exported";
 391     | 129: str := "Cannot open symbol file";
 392
 393     | 130: str := "Bad magic number in symbol file";
 394     | 131: str := "This type is an INTERFACE, and cannot be instantiated";
 395     | 132: str := "Corrupted symbol file";
 396     | 133: str := "Inconsistent module keys";
 397     | 134: str := "Types can only be public or fully private";
 398     | 135: str := "This variable may be uninitialized";
 399     | 136: str := "Not all paths to END contain a RETURN statement";
 400     | 137: str := "This type tries to directly include itself";
 401     | 138: str := "Not all paths to END in RESCUE contain a RETURN statement";
 402     | 139: str := "Not all OUT parameters have been assigned to";
 403
 404     | 140: str := "Pointer bound type can only be RECORD or ARRAY";
 405     | 141: str := "GPCP restriction: select expression cannot be LONGINT";
 406     | 142: str := "Cannot assign entire open array";
 407     | 143: str := "Cannot assign entire extensible or abstract record";
 408     | 144: str := "Foreign modules must be compiled with '-special'";
 409     | 145: str := "This type tries to indirectly include itself";
 410     | 146: str := "Constructors are declared without receiver";
 411     | 147: str := "Multiple supertype constructors match these parameters";
 412     | 148: str := "This type has another constructor with equal signature";
 413     | 149: str := "This procedure needs parameters";
 414
 415     | 150: str := "Parameter types of exported procedures must be exported";
 416     | 151: str := "Return types of exported procedures must be exported";
 417     | 152: str := "Bound type of foreign reference type cannot be assigned";
 418     | 153: str := "Bound type of foreign reference type cannot be value param";
 419     | 154: str := "It is not possible to extend an interface type";
 420     | 155: str := "NEW illegal unless foreign supertype has no-arg constructor";
 421     | 156: str := "Interfaces can't extend anything. Leave blank or use ANYREC";
 422     | 157: str := "Only extensions of Foreign classes can implement interfaces";
 423     | 158: str := "Additional base types must be interface types";
 424     | 159: str := "Not all interface methods were implemented";
 425
 426     | 160: str := "Inherited procedure had non-matching formal types";
 427     | 161: str := "Only foreign procs and fields can have protected mode";
 428     | 162: str := "This name only accessible in extensions of defining type";
 429     | 163: str := "Interface implementation has wrong export mode";
 430 (**)| 164: str := "Non-locally accessed variable may be uninitialized";
 431     | 165: str := "This procedure cannot be used as a procedure value";
 432     | 166: str := "Super calls are only valid on the current receiver";
 433     | 167: str := "SIZE is not meaningful in this implementation";
 434     | 168: str := "Character literal outside SHORTCHAR range";
 435     | 169: str := "Module exporting this type is not imported";
 436
 437     | 170: str := "This module has already been directly imported";
 438     | 171: str := "Invalid binary operation on these types";
 439     | 172: str := "Name clash in imported scope";
 440     | 173: str := "This module indirectly imported with different key";
 441     | 174: str := "Actual for IN formal must be record, array or string";
 442     | 175: str := "The module exporting this name has not been imported";
 443     | 176: str := "The current type is opaque and cannot be selected further";
 444     | 177: str := "File creation error";
 445     | 178: str := "This record field is read-only";
 446     | 179: str := "This IN parameter is read-only";
 447
 448     | 180: str := "This variable is read-only";
 449     | 181: str := "This identifier is read-only";
 450     | 182: str := "Attempt to use a function when a proper procedure needed";
 451     | 183: str := "This record is private, you cannot export this field";
 452     | 184: str := "This record is readonly, this field cannot be public";
 453     | 185: str := "Static members can only be defined with -special";
 454     | 186: str := 'Ids with "$", "@" or "`" can only be defined with -special';
 455     | 187: str := "Idents escaped with ` must have length >= 2";
 456     | 188: str := "Methods of INTERFACE types must be ABSTRACT";
 457     | 189: str := "Non-local access to byref param of value type";
 458
 459     | 190: str := "Temporary restriction: non-locals not allowed";
 460     | 191: str := "Temporary restriction: only name equivalence here";
 461     | 192: str := "Only '=' or ':' can go here";
 462     | 193: str := "THROW needs a string or native exception object";
 463     | 194: str := 'Only "UNCHECKED_ARITHMETIC" can go here';
 464     | 195: str := "NEW method cannot be exported if receiver type is private";
 465     | 196: str := "Only static fields can select on a type-name";
 466     | 197: str := "Only static methods can select on a type-name";
 467     | 198: str := "Static fields can only select on a type-name";
 468     | 199: str := "Static methods can only select on a type-name";
 469
 470     | 200: str := "Constructors cannot be declared for imported types";
 471     | 201: str := "Constructors must return POINTER TO RECORD type";
 472     | 202: str := "Base type does not have a matching constructor";
 473     | 203: str := "Base type does not allow a no-arg constructor";
 474     | 204: str := "Constructors only allowed for extensions of foreign types";
 475     | 205: str := "Methods can only be declared for local record types";
 476     | 206: str := "Receivers of pointer type must have value mode";
 477     | 207: str := "Feature with this name already known in binding scope";
 478     | 208: str := "EVENT types only valid for .NET target";
 479     | 209: str := "Events must have a valid formal parameter list";
 480
 481     | 210: str := "REGISTER expects an EVENT type here";
 482     | 211: str := "Only procedure literals allowed here";
 483     | 212: str := "Event types cannot be local to procedures";
 484     | 213: str := "Temporary restriction: no proc. variables with JVM";
 485     | 214: str := "Interface types cannot be anonymous";
 486     | 215: str := "Interface types must be exported";
 487     | 216: str := "Interface methods must be exported";
 488     | 217: str := "Covariant OUT parameters unsafe removed from language";
 489     | 218: str := "No procedure of this name with matching parameters";
 490     | 219: str := "Multiple overloaded procedure signatures match this call";
 491
 492     | 220: RETURN;                                  (* BEWARE PREMATURE EXIT *)
 493     | 221: str := "Non-standard construct, not allowed with /strict";
 494     | 222: str := "This is not a value: thus cannot end with a type guard";
 495     | 223: str := "Override of imp-only in exported type must be imp-only";
 496     | 224: str := "This designator is not a procedure or a function call";
 497     | 225: str := "Non-empty constructors can only return SELF";
 498     | 226: str := "USHORT cannot be applied to this type";
 499     | 227: str := "Cannot import SYSTEM without /unsafe option";
 500     | 228: str := "Cannot import SYSTEM unless target=net";
 501     | 229: str := "Designator is not of VECTOR type";
 502
 503     | 230: str := "Type is incompatible with element type";
 504     | 231: str := "Vectors are always one-dimensional only";
 505     | 232: str := 'Hex constant too big, use suffix "L" instead';
 506     | 233: str := "Literal constant too big, even for LONGINT";
 507     | 234: str := "Extension of LIMITED type must be limited";
 508     | 235: str := "LIMITED types can only be extended in the same module";
 509     | 236: str := "Cannot resolve CLR name of this type";
 510     | 237: str := "Invalid hex escape sequence in this string";
 511     | 238: str := "STA is illegal unless target is NET";
 512     | 239: str := "This module can only be accessed via an alias";
 513     | 240: str := "This module already has an alias";
 514
 515     | 298: str := "ILASM failed to assemble IL file";
 516     | 299: str := "Compiler raised an internal exception";
 517     (* ===================== END ERRORS ======================= *)
 518     (* ====================== WARNINGS ======================== *)
 519     | 300: str := "Warning: Super calls are deprecated";
 520     | 301: str := "Warning: Procedure variables are deprecated";
 521     | 302: str := "Warning: Non-local variable access here";
 522     | 303: str := "Warning: Numeric literal is not in the SET range [0 .. 31]";
 523     | 304: str := "Warning: This procedure is not exported, called or assigned";
 524     | 305: str := "Warning: Another constructor has an equal signature";
 525     | 306: str := "Warning: Covariant OUT parameters unsafe when aliassed";
 526     | 307: str := "Warning: Multiple overloaded procedure signatures match this call";
 527     | 308: str := "Warning: Default static class has name clash";
 528     | 309: str := "Warning: Looking for an automatically renamed module";
 529
 530     | 310,
 531       311: str := "Warning: This variable is accessed from nested procedure";
 532     | 312,
 533       313: RETURN;                                  (* BEWARE PREMATURE EXIT *)
 534     | 314: str := "The anonymous record type is incomptible with all values";
 535     | 315: str := "The anonymous array type is incomptible with all values";
 536     | 316: str := "This pointer type may still have its default NIL value";
 537     | 317: str := "Empty CASE statement will trap if control reaches here";
 538     | 318: str := "Empty WITH statement will trap if control reaches here";
 539     | 319: str := "STA has no effect without CPmain or WinMain";
 540     | 320: str := "Procedure variables with JVM target are experimental";
 541     (* ==================== END WARNINGS ====================== *)
 542     ELSE
 543       str := "Semantic error: " + LitValue.intToCharOpen(num)^;
 544     END;
 545     len := LEN(str$);
 546     NEW(msg, len+1);
 547     FOR idx := 0 TO len-1 DO
 548       msg[idx] := str[idx];
 549     END;
 550     msg[len] := 0X;
 551     IF num < 300 THEN
 552       INC(Scnr.errors);
 553       StoreError(num,lin,col,msg);
 554     ELSIF ~nowarn THEN
 555       INC(Scnr.warnings);
 556       StoreError(num,lin,col,msg);
 557     END;
 558
 559     IF prompt THEN
 560       IF num < 300 THEN
 561         Console.WriteString("Error");
 562       ELSE
 563         Console.WriteString("Warning");
 564       END;
 565       Console.WriteInt(num,0);
 566       Console.WriteString("@ line:");
 567       Console.WriteInt(lin,0);
 568       Console.WriteString(", col:");
 569       Console.WriteInt(col,0);
 570       Console.WriteLn;
 571       Console.WriteString(str);
 572       Console.WriteLn;
 573     END;
 574
 575   END Report;
 576
 577 (* ============================================================ *)
 578
 579   PROCEDURE (h : SemanticHdlr)RepSt1*(num     : INTEGER;
 580                                       IN s1   : ARRAY OF CHAR;
 581                                       lin,col : INTEGER);
 582     VAR msg : Message;
 583   BEGIN
 584     CASE num OF
 585     |   0: msg := LitValue.strToCharOpen("Expected: END " + s1);
 586     |   1: msg := LitValue.strToCharOpen("Expected: " + s1);
 587     |  89: msg := LitValue.strToCharOpen("Duplicated selector values <"
 588                                                 + s1 + ">");
 589     |   9,
 590       169: msg := LitValue.strToCharOpen("Current type was <"
 591                         + s1 + '>');
 592     | 117: msg := LitValue.strToCharOpen("Type <"
 593                         + s1 + "> must be extensible");
 594     | 121: msg := LitValue.strToCharOpen("Missing methods <" + s1 + '>');
 595     | 145: msg := LitValue.strToCharOpen("Types on cycle <" + s1 + '>');
 596     | 129,
 597       130,
 598       132: msg := LitValue.strToCharOpen("Filename <" + s1 + '>');
 599     | 133: msg := LitValue.strToCharOpen("Module <"
 600                         + s1 + "> already imported with different key");
 601     | 138: msg := LitValue.strToCharOpen('<'
 602                         + s1 + '> not assigned before "RETURN"');
 603     | 139: msg := LitValue.strToCharOpen('<'
 604                         + s1 + '> not assigned before end of procedure');
 605     | 154: msg := LitValue.strToCharOpen('<'
 606                         + s1 + "> is a Foreign interface type");
 607     | 157: msg := LitValue.strToCharOpen('<'
 608                         + s1 + "> is not a Foreign type");
 609     | 158: msg := LitValue.strToCharOpen('<'
 610                         + s1 + "> is not a foreign language interface type");
 611     | 159: msg := LitValue.strToCharOpen("Missing interface methods <"
 612                                                 + s1 + '>');
 613     | 162: msg := LitValue.strToCharOpen('<'
 614                         + s1 + "> is a protected, foreign-language feature");
 615     | 164: msg := LitValue.strToCharOpen('<'
 616                         + s1 + "> not assigned before this call");
 617     | 172: msg := LitValue.strToCharOpen('Name <'
 618                         + s1 + '> clashes in imported scope');
 619     | 175,
 620       176: msg := LitValue.strToCharOpen("Module "
 621                         + '<' + s1 + "> is not imported");
 622     | 189: msg := LitValue.strToCharOpen('Non-local access to <'
 623                         + s1 + '> cannot be verified on .NET');
 624     | 205,
 625       207: msg := LitValue.strToCharOpen(
 626                        "Binding scope of feature is record type <" + s1 + ">");
 627     | 236: msg := LitValue.strToCharOpen(
 628                        "Cannot resolve CLR name of type : " + s1);
 629     | 239,
 630           240: msg := LitValue.strToCharOpen(
 631                            'This module has alias name "' + s1 + '"');
 632     | 299: msg := LitValue.strToCharOpen("Exception: " + s1);
 633     | 308: msg := LitValue.strToCharOpen(
 634                        "Renaming static class to <" + s1 + ">");
 635     | 310: msg := LitValue.strToCharOpen('Access to <'
 636                        + s1 + '> has copying not reference semantics');
 637     | 311: msg := LitValue.strToCharOpen('Access to variable <'
 638                        + s1 + '> will be inefficient');
 639     | 220,
 640       312: msg := LitValue.strToCharOpen("Matches with - " + s1);
 641     | 313: msg := LitValue.strToCharOpen("Bound to - " + s1);
 642     END;
 643     IF ~nowarn OR                        (* If warnings are on OR  *)
 644        (num < 300) THEN                  (* this is an error then  *)
 645       StoreError(num,lin,0,msg);         (* (1) Store THIS message *)
 646       h.Report(num,lin,col);             (* (2) Generate other msg *)
 647     END;
 648 (*
 649  *  IF (num # 251) & (num # 252) THEN
 650  *    StoreError(num,lin,col,msg);
 651  *    h.Report(num,lin,col);
 652  *  ELSIF ~nowarn THEN
 653  *    StoreError(num,lin,col,msg);
 654  *  END;
 655  *)
 656   END RepSt1;
 657
 658 (* ============================================================ *)
 659
 660   PROCEDURE (h : SemanticHdlr)RepSt2*(num      : INTEGER;
 661                                       IN s1,s2 : ARRAY OF CHAR;
 662                                       lin,col  : INTEGER);
 663 (*
 664  *  VAR str : ARRAY 128 OF CHAR;
 665  *      msg : Message;
 666  *      idx : INTEGER;
 667  *      len : INTEGER;
 668  *)
 669     VAR msg : Message;
 670   BEGIN
 671     CASE num OF
 672     |  21,
 673       217,
 674       306: msg := LitValue.strToCharOpen(
 675                   "Actual par-type was " + s1 + ", Formal type was " + s2);
 676     |  76: msg := LitValue.strToCharOpen(
 677                   "Expr-type was " + s2 + ", should be " + s1);
 678     |  57,
 679        83: msg := LitValue.strToCharOpen(
 680                   "LHS type was " + s1 + ", RHS type was " + s2);
 681     | 116: msg := LitValue.strToCharOpen(
 682                   "Inherited retType is " + s1 + ", this retType " + s2);
 683     | 131: msg := LitValue.strToCharOpen(
 684                   "Module name in file <" + s1 + ".cps> was <" + s2 + '>');
 685     | 172: msg := LitValue.strToCharOpen(
 686                   'Name <' + s1 + '> clashes in scope <' + s2 + '>');
 687     | 230: msg := LitValue.strToCharOpen(
 688                   "Expression type is " + s2 + ", element type is " + s1);
 689     | 309: msg := LitValue.strToCharOpen(
 690                   'Looking for module "' + s1 + '" in file <' + s2 + '>');
 691     END;
 692 (*
 693  *  len := LEN(str$);
 694  *  NEW(msg, len+1);
 695  *  FOR idx := 0 TO len-1 DO
 696  *    msg[idx] := str[idx];
 697  *  END;
 698  *  msg[len] := 0X;
 699  *)
 700     StoreError(num,lin,col,msg);
 701     h.Report(num,lin,col);
 702   END RepSt2;
 703
 704 (* ============================================================ *)
 705
 706     PROCEDURE GetLine (VAR pos  : INTEGER;
 707                        OUT line : ARRAY OF CHAR;
 708                        OUT eof  : BOOLEAN);
 709     (** Read a source line. Return empty line if eof *)
 710       CONST
 711         cr  = 0DX;
 712         lf  = 0AX;
 713         tab = 09X;
 714       VAR
 715         ch: CHAR;
 716         i:  INTEGER;
 717       BEGIN
 718         ch := Scnr.charAt(pos); INC(pos);
 719         i := 0;
 720         eof := FALSE;
 721         WHILE (ch # lf) & (ch # 0X) DO
 722           IF ch = cr THEN (* skip *)
 723           ELSIF ch = tab THEN
 724             REPEAT line[MIN(i,listingMax)] := ' '; INC(i) UNTIL i MOD 8 = 0;
 725           ELSE
 726             line[MIN(i,listingMax)] := ch; INC(i);
 727           END;
 728           ch := Scnr.charAt(pos); INC(pos);
 729         END;
 730         eof := (i = 0) & (ch = 0X); line[MIN(i,listingMax)] := 0X;
 731       END GetLine;
 732
 733 (* ============================================================ *)
 734
 735     PROCEDURE PrintErr(IN desc : ErrDesc);
 736     (** Print an error message *)
 737       VAR mLen : INTEGER;
 738           indx : INTEGER;
 739     BEGIN
 740       GPText.WriteString(Scnr.lst, "**** ");
 741       mLen := LEN(desc.msg$);
 742       IF desc.col = listingMax THEN (* write field of width (col-2) *)
 743         GPText.WriteString(Scnr.lst, desc.msg);
 744       ELSIF mLen < desc.col-1 THEN (* write field of width (col-2) *)
 745         GPText.WriteFiller(Scnr.lst, desc.msg, "-", desc.col-1);
 746         GPText.Write(Scnr.lst, "^");
 747       ELSIF mLen + desc.col + 5 < consoleWidth THEN
 748         GPText.WriteFiller(Scnr.lst, "", "-", desc.col-1);
 749         GPText.WriteString(Scnr.lst, "^ ");
 750         GPText.WriteString(Scnr.lst, desc.msg);
 751       ELSE
 752         GPText.WriteFiller(Scnr.lst, "", "-", desc.col-1);
 753         GPText.Write(Scnr.lst, "^");
 754         GPText.WriteLn(Scnr.lst);
 755         GPText.WriteString(Scnr.lst, "**** ");
 756         GPText.WriteString(Scnr.lst, desc.msg);
 757       END;
 758       GPText.WriteLn(Scnr.lst);
 759     END PrintErr;
 760
 761 (* ============================================================ *)
 762
 763     PROCEDURE Display (IN desc : ErrDesc);
 764     (** Display an error message *)
 765       VAR mLen : INTEGER;
 766           indx : INTEGER;
 767     BEGIN
 768       Console.WriteString("**** ");
 769       mLen := LEN(desc.msg$);
 770       IF desc.col = listingMax THEN
 771         Console.WriteString(desc.msg);
 772       ELSIF mLen < desc.col-1 THEN
 773         Console.WriteString(desc.msg);
 774         FOR indx := mLen TO desc.col-2 DO Console.Write("-") END;
 775         Console.Write("^");
 776       ELSIF mLen + desc.col + 5 < consoleWidth THEN
 777         FOR indx := 2 TO desc.col DO Console.Write("-") END;
 778         Console.WriteString("^ ");
 779         Console.WriteString(desc.msg);
 780       ELSE
 781         FOR indx := 2 TO desc.col DO Console.Write("-") END;
 782         Console.Write("^");
 783         Console.WriteLn;
 784         Console.WriteString("**** ");
 785         Console.WriteString(desc.msg);
 786       END;
 787       Console.WriteLn;
 788     END Display;
 789
 790 (* ============================================================ *)
 791
 792     PROCEDURE DisplayVS (IN desc : ErrDesc);
 793     (** Display an error message for Visual Studio *)
 794       VAR mLen : INTEGER;
 795           indx : INTEGER;
 796     BEGIN
 797       Console.WriteString(srcNam);
 798       Console.Write("(");
 799       Console.WriteInt(desc.lin,1);
 800       Console.Write(",");
 801       Console.WriteInt(desc.col,1);
 802       Console.WriteString(") : ");
 803       IF desc.num < 300 THEN
 804         Console.WriteString("error : ");
 805       ELSE
 806         Console.WriteString("warning : ");
 807       END;
 808       Console.WriteString(desc.msg);
 809       Console.WriteLn;
 810     END DisplayVS;
 811
 812 (* ============================================================ *)
 813
 814     PROCEDURE DisplayXMLHeader ();
 815     BEGIN
 816       Console.WriteString('<?xml version="1.0"?>');
 817       Console.WriteLn;
 818       Console.WriteString('<compilererrors errorsContained="yes">');
 819       Console.WriteLn;
 820     END DisplayXMLHeader;
 821
 822     PROCEDURE DisplayXMLEnd ();
 823     BEGIN
 824       Console.WriteString('</compilererrors>');
 825       Console.WriteLn;
 826     END DisplayXMLEnd;
 827
 828     PROCEDURE DisplayXML (IN desc : ErrDesc);
 829     (** Display an error message in xml format (for eclipse) *)
 830     (*  <?xml version="1.0"?>
 831      *  <compilererrors errorsContained="yes">
 832      *    <error>
 833      *      <line> 1 </line>
 834      *      <position> 34 </position>
 835      *      <description> ; expected </description>
 836      *    </error>
 837      * ...
 838      *  </compilererrors>
 839      *)
 840
 841       VAR mLen : INTEGER;
 842           indx : INTEGER;
 843         isWarn : BOOLEAN;
 844     BEGIN
 845       isWarn := desc.num >= 300;
 846       IF isWarn THEN
 847         Console.WriteString("  <warning> ");
 848       ELSE
 849         Console.WriteString("  <error> ");
 850       END;
 851       Console.WriteLn;
 852       Console.WriteString("    <line> ");
 853       Console.WriteInt(desc.lin,1);
 854       Console.WriteString(" </line>"); Console.WriteLn;
 855       Console.WriteString("    <position> ");
 856       Console.WriteInt(desc.col,1);
 857       Console.WriteString(" </position>"); Console.WriteLn;
 858       Console.WriteString("    <description> ");
 859       IF isWarn THEN
 860         Console.WriteString("warning : ");
 861       ELSE
 862         Console.WriteString("error : ");
 863       END;
 864       Console.WriteString(desc.msg);
 865       Console.WriteString(" </description> ");  Console.WriteLn;
 866       IF isWarn THEN
 867         Console.WriteString("  </warning> ");
 868       ELSE
 869         Console.WriteString("  </error> ");
 870       END;
 871       Console.WriteLn;
 872     END DisplayXML;
 873
 874 (* ============================================================ *)
 875
 876     PROCEDURE PrintLine(n : INTEGER; IN l : ARRAY OF CHAR);
 877     BEGIN
 878       GPText.WriteInt(Scnr.lst, n, 4); GPText.Write(Scnr.lst, " ");
 879       GPText.WriteString(Scnr.lst, l); GPText.WriteLn(Scnr.lst);
 880     END PrintLine;
 881
 882 (* ============================================================ *)
 883
 884     PROCEDURE DisplayLn(n : INTEGER; IN l : ARRAY OF CHAR);
 885     BEGIN
 886       Console.WriteInt(n, 4); Console.Write(" ");
 887       Console.WriteString(l); Console.WriteLn;
 888     END DisplayLn;
 889
 890 (* ============================================================ *)
 891
 892     PROCEDURE PrintListing*(list : BOOLEAN);
 893     (** Print a source listing with error messages *)
 894       VAR
 895         nextErr : Err;          (* next error descriptor *)
 896         nextLin : INTEGER;      (* line num of nextErr   *)
 897         eof     : BOOLEAN;      (* end of file found     *)
 898         lnr     : INTEGER;      (* current line number   *)
 899         errC    : INTEGER;      (* current error index   *)
 900         srcPos  : INTEGER;      (* postion in sourceFile *)
 901         line    : ARRAY listingWidth OF CHAR;
 902       BEGIN
 903         IF xmlErrors THEN DisplayXMLHeader(); END;
 904         nextLin := 0;
 905         IF eTide > 0 THEN QuickSort(0, eTide-1) END;
 906         IF list THEN
 907           GPText.WriteString(Scnr.lst, "Listing:");
 908           GPText.WriteLn(Scnr.lst); GPText.WriteLn(Scnr.lst);
 909         END;
 910         srcPos := 0; nextErr := eBuffer[0];
 911         GetLine(srcPos, line, eof); lnr := 1; errC := 0;
 912         WHILE ~ eof DO
 913           IF nextErr # NIL THEN nextLin := nextErr.lin END;
 914           IF list THEN PrintLine(lnr, line) END;
 915           IF ~forVisualStudio & ~xmlErrors & (~list OR (lnr = nextLin)) THEN
 916             DisplayLn(lnr, line)
 917           END;
 918           WHILE (nextErr # NIL) & (nextErr.lin = lnr) DO
 919             IF list THEN PrintErr(nextErr) END;
 920             IF forVisualStudio THEN
 921               DisplayVS(nextErr);
 922             ELSIF xmlErrors THEN
 923               DisplayXML(nextErr);
 924             ELSE
 925               Display(nextErr);
 926             END;
 927             INC(errC);
 928             nextErr := eBuffer[errC];
 929           END;
 930           GetLine(srcPos, line, eof); INC(lnr);
 931         END;
 932         WHILE nextErr # NIL DO
 933           IF list THEN PrintErr(nextErr) END;
 934           IF forVisualStudio THEN
 935             DisplayVS(nextErr);
 936           ELSE
 937             Display(nextErr);
 938           END;
 939           INC(errC);
 940           nextErr := eBuffer[errC];
 941         END;
 942 (*
 943  *      IF list THEN
 944  *        GPText.WriteLn(Scnr.lst);
 945  *        GPText.WriteInt(Scnr.lst, errC, 5);
 946  *        GPText.WriteString(Scnr.lst, " error");
 947  *        IF errC # 1 THEN GPText.Write(Scnr.lst, "s") END;
 948  *        GPText.WriteLn(Scnr.lst);
 949  *        GPText.WriteLn(Scnr.lst);
 950  *        GPText.WriteLn(Scnr.lst);
 951  *      END;
 952  *)
 953         IF list THEN
 954           GPText.WriteLn(Scnr.lst);
 955           GPText.WriteString(Scnr.lst, "There were: ");
 956           IF Scnr.errors = 0 THEN
 957             GPText.WriteString(Scnr.lst, "No errors");
 958           ELSE
 959             GPText.WriteInt(Scnr.lst, Scnr.errors, 0);
 960             GPText.WriteString(Scnr.lst, " error");
 961             IF Scnr.errors # 1 THEN GPText.Write(Scnr.lst, "s") END;
 962           END;
 963           GPText.WriteString(Scnr.lst, ", and ");
 964           IF Scnr.warnings = 0 THEN
 965             GPText.WriteString(Scnr.lst, "No warnings");
 966           ELSE
 967             GPText.WriteInt(Scnr.lst, Scnr.warnings, 0);
 968             GPText.WriteString(Scnr.lst, " warning");
 969             IF Scnr.warnings # 1 THEN GPText.Write(Scnr.lst, "s") END;
 970           END;
 971           GPText.WriteLn(Scnr.lst);
 972           GPText.WriteLn(Scnr.lst);
 973           GPText.WriteLn(Scnr.lst);
 974         END;
 975         IF xmlErrors THEN DisplayXMLEnd(); END;
 976       END PrintListing;
 977
 978       PROCEDURE ResetErrorList*();
 979       BEGIN
 980         eTide := 0;
 981         eBuffer[0] := NIL;
 982       END ResetErrorList;
 983
 984 (* ============================================================ *)
 985
 986       PROCEDURE Init*;
 987       BEGIN
 988         NEW(parsHdlr); Scnr.ParseErr := parsHdlr;
 989         NEW(semaHdlr); Scnr.SemError := semaHdlr;
 990       END Init;
 991
 992 (* ============================================================ *)
 993
 994     PROCEDURE SetSrcNam* (IN nam : ARRAY OF CHAR);
 995     BEGIN
 996       GPText.Assign(nam,srcNam);
 997     END SetSrcNam;
 998
 999 (* ============================================================ *)
1000 BEGIN
1001   NEW(eBuffer, 8); eBuffer[0] := NIL; eLimit := 7; eTide := 0;
1002   prompt := FALSE;
1003   nowarn := FALSE;
1004   forVisualStudio := FALSE;
1005 END CPascalErrors.
1006 (* ============================================================ *)