new/Dev/Mod/CPM.txt

   1 MODULE DevCPM;
   2
   3         (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPM.odc *)
   4         (* DO NOT EDIT *)
   5
   6         IMPORT SYSTEM, Kernel, Files, Stores, Models, Views, TextModels, TextMappers, StdLog, DevMarkers;
   7
   8         CONST
   9                 ProcSize* = 4;  (* PROCEDURE type *)
  10                 PointerSize* = 4;       (* POINTER type *)
  11                 DArrSizeA* = 8; (* dyn array descriptor *)
  12                 DArrSizeB* = 4; (* size = A + B * typ.n *)
  13
  14                 MaxSet* = 31;
  15                 MaxIndex* = 7FFFFFFFH;  (* maximal index value for array declaration *)
  16
  17                 MinReal32Pat = 0FF7FFFFFH;      (* most positive, 32-bit pattern *)
  18                 MinReal64PatL = 0FFFFFFFFH;     (* most  negative, lower 32-bit pattern *)
  19                 MinReal64PatH = 0FFEFFFFFH;     (* most  negative, higher 32-bit pattern *)
  20                 MaxReal32Pat = 07F7FFFFFH;      (* most positive, 32-bit pattern *)
  21                 MaxReal64PatL = 0FFFFFFFFH;     (* most positive, lower 32-bit pattern *)
  22                 MaxReal64PatH = 07FEFFFFFH;     (* most positive, higher 32-bit pattern *)
  23                 InfRealPat = 07F800000H;        (* real infinity pattern *)
  24
  25
  26                 (* inclusive range of parameter of standard procedure HALT *)
  27                 MinHaltNr* = 0;
  28                 MaxHaltNr* = 128;
  29
  30                 (* inclusive range of register number of procedures SYSTEM.GETREG and SYSTEM.PUTREG *)
  31                 MinRegNr* = 0;
  32                 MaxRegNr* = 31;
  33
  34                 (* maximal value of flag used to mark interface structures *)
  35                 MaxSysFlag* = 127;      (* shortint *)
  36                 CProcFlag* = 1; (* code procedures *)
  37
  38                 (* maximal condition value of parameter of SYSTEM.CC *)
  39                 MaxCC* = 15;
  40
  41                 (* initialization of constant address, must be different from any valid constant address *)
  42                 ConstNotAlloc* = -1;
  43
  44                 (* whether hidden pointer fields have to be nevertheless exported *)
  45                 ExpHdPtrFld* = TRUE;
  46                 HdPtrName* = "@ptr";
  47
  48                 (* whether hidden untagged pointer fields have to be nevertheless exported *)
  49                 ExpHdUtPtrFld* = TRUE;
  50                 HdUtPtrName* = "@utptr";
  51
  52                 (* whether hidden procedure fields have to be nevertheless exported (may be used for System.Free) *)
  53                 ExpHdProcFld* = TRUE;
  54                 HdProcName* = "@proc";
  55
  56                 (* whether hidden bound procedures have to be nevertheless exported *)
  57                 ExpHdTProc* = FALSE;
  58                 HdTProcName* = "@tproc";
  59
  60                 (* maximal number of exported stuctures: *)
  61                 MaxStruct* = 16000;     (* must be < MAX(INTEGER) DIV 2 in object model *)
  62
  63                 (* maximal number of record extensions: *)
  64                 MaxExts* = 15;  (* defined by type descriptor layout *)
  65
  66                 (* whether field leaf of pointer variable p has to be set to FALSE, when NEW(p) or SYSTEM.NEW(p, n) is used *)
  67                 NEWusingAdr* = FALSE;
  68
  69                 (* special character (< " ") returned by procedure Get, if end of text reached *)
  70                 Eot* = 0X;
  71
  72                 (* warnings *)
  73                 longreal* = 0; largeint* = 1; realConst* = 2; copy* = 3; lchr* = 4; lentier* = 5; invar* = 6; outvar* = 7;
  74
  75                 (* language options *)
  76                 interface* = 1;
  77                 com* = 2; comAware* = 3;
  78                 som* = 4; somAware* = 5;
  79                 oberon* = 6;
  80                 java* = 7; javaAware* = 8;
  81                 noCode* = 9;
  82                 allSysVal* = 14;
  83                 sysImp* = 15;
  84                 trap* = 31;
  85                 sys386 = 10; sys68k = 20;       (* processor type in options if system imported *)
  86
  87         CONST
  88                 SFdir = "Sym";
  89                 OFdir = "Code";
  90                 SYSdir = "System";
  91                 SFtag = 6F4F5346H;      (* symbol file tag *)
  92                 OFtag = 6F4F4346H;      (* object file tag *)
  93                 maxErrors = 64;
  94
  95 TYPE
  96         File = POINTER TO RECORD next: File; f: Files.File END;
  97
  98         VAR
  99                 LEHost*: BOOLEAN;       (* little or big endian host *)
 100                 MinReal32*, MaxReal32*, InfReal*,
 101                 MinReal64*, MaxReal64*: REAL;
 102                 noerr*: BOOLEAN;        (* no error found until now *)
 103                 curpos*, startpos*, errpos*: INTEGER;   (* character, start, and error position in source file *)
 104                 searchpos*: INTEGER;    (* search position in source file *)
 105                 errors*: INTEGER;
 106                 breakpc*: INTEGER;      (* set by OPV.Init *)
 107                 options*: SET;  (* language options *)
 108                 file*: Files.File;      (* used for sym file import *)
 109                 codeDir*: ARRAY 16 OF CHAR;
 110                 symDir*: ARRAY 16 OF CHAR;
 111                 checksum*: INTEGER;     (* symbol file checksum *)
 112
 113                 lastpos: INTEGER;
 114                 realpat: INTEGER;
 115                 lrealpat: RECORD H, L: INTEGER END;
 116                 fpi, fpj: SHORTINT; fp: ARRAY 4 OF SHORTCHAR;
 117                 ObjFName: Files.Name;
 118
 119                 in: TextModels.Reader;
 120                 oldSymFile, symFile, objFile: Files.File;
 121                 inSym: Files.Reader;
 122                 outSym, outObj: Files.Writer;
 123
 124                 errNo, errPos: ARRAY maxErrors OF INTEGER;
 125
 126                 lineReader: TextModels.Reader;
 127                 lineNum: INTEGER;
 128
 129                 crc32tab: ARRAY 256 OF INTEGER;
 130
 131
 132         PROCEDURE^ err* (n: INTEGER);
 133
 134         PROCEDURE Init* (source: TextModels.Reader; logtext: TextModels.Model);
 135         BEGIN
 136                 in := source;
 137                 DevMarkers.Unmark(in.Base());
 138                 noerr := TRUE; options := {};
 139                 curpos := in.Pos(); errpos := curpos; lastpos := curpos - 11; errors := 0;
 140                 codeDir := OFdir; symDir := SFdir
 141         END Init;
 142
 143         PROCEDURE Close*;
 144         BEGIN
 145                 oldSymFile := NIL; inSym := NIL;
 146                 symFile := NIL; outSym := NIL;
 147                 objFile := NIL; outObj := NIL;
 148                 in := NIL; lineReader := NIL
 149         END Close;
 150
 151         PROCEDURE Get* (VAR ch: SHORTCHAR);
 152                 VAR ch1: CHAR;
 153         BEGIN
 154                 REPEAT in.ReadChar(ch1); INC(curpos) UNTIL (ch1 < 100X) & (ch1 # TextModels.viewcode);
 155                 ch := SHORT(ch1)
 156         END Get;
 157
 158         PROCEDURE GetL* (VAR ch: CHAR);
 159         BEGIN
 160                 REPEAT in.ReadChar(ch); INC(curpos) UNTIL ch # TextModels.viewcode;
 161         END GetL;
 162
 163         PROCEDURE LineOf* (pos: INTEGER): INTEGER;
 164                 VAR ch: CHAR;
 165         BEGIN
 166                 IF lineReader = NIL THEN lineReader := in.Base().NewReader(NIL); lineReader.SetPos(0); lineNum := 0 END;
 167                 IF lineReader.Pos() > pos THEN lineReader.SetPos(0); lineNum := 0 END;
 168                 WHILE lineReader.Pos() < pos DO
 169                         lineReader.ReadChar(ch);
 170                         IF ch = 0DX THEN INC(lineNum) END
 171                 END;
 172                 RETURN lineNum
 173         END LineOf;
 174
 175         PROCEDURE LoWord (r: REAL): INTEGER;
 176                 VAR x: INTEGER;
 177         BEGIN
 178                 x := SYSTEM.ADR(r);
 179                 IF ~LEHost THEN INC(x, 4) END;
 180                 SYSTEM.GET(x, x);
 181                 RETURN x
 182         END LoWord;
 183
 184         PROCEDURE HiWord (r: REAL): INTEGER;
 185                 VAR x: INTEGER;
 186         BEGIN
 187                 x := SYSTEM.ADR(r);
 188                 IF LEHost THEN INC(x, 4) END;
 189                 SYSTEM.GET(x, x);
 190                 RETURN x
 191         END HiWord;
 192
 193         PROCEDURE Compound (lo, hi: INTEGER): REAL;
 194                 VAR r: REAL;
 195         BEGIN
 196                 IF LEHost THEN
 197                         SYSTEM.PUT(SYSTEM.ADR(r), lo); SYSTEM.PUT(SYSTEM.ADR(r) + 4, hi)
 198                 ELSE
 199                         SYSTEM.PUT(SYSTEM.ADR(r) + 4, lo); SYSTEM.PUT(SYSTEM.ADR(r), hi)
 200                 END;
 201                 RETURN r
 202         END Compound;
 203
 204
 205         (* sysflag control *)
 206
 207         PROCEDURE ValidGuid* (VAR str: ARRAY OF SHORTCHAR): BOOLEAN;
 208                 VAR i: SHORTINT; ch: SHORTCHAR;
 209         BEGIN
 210                 IF (LEN(str$) # 38) OR (str[0] # "{") & (str[37] # "}") THEN RETURN FALSE END;
 211                 i := 1;
 212                 WHILE i < 37 DO
 213                         ch := str[i];
 214                         IF (i = 9) OR (i = 14) OR (i = 19) OR (i = 24) THEN
 215                                 IF ch # "-" THEN RETURN FALSE END
 216                         ELSE
 217                                 IF (ch < "0") OR (ch > "9") & (CAP(ch) < "A") OR (CAP(ch) > "Z") THEN RETURN FALSE END
 218                         END;
 219                         INC(i)
 220                 END;
 221                 RETURN TRUE
 222         END ValidGuid;
 223
 224         PROCEDURE GetProcSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
 225         BEGIN
 226                 IF id # "" THEN
 227                         IF id = "code" THEN num := 1
 228                         ELSIF id = "callback" THEN num := 2
 229                         ELSIF id = "nostkchk" THEN num := 4
 230                         ELSIF id = "ccall" THEN num := -10
 231                         ELSIF id = "guarded" THEN num := 8
 232                         ELSIF id = "noframe" THEN num := 16
 233                         ELSIF id = "native" THEN num := -33
 234                         ELSIF id = "bytecode" THEN num := -35
 235                         END
 236                 END;
 237                 IF (options * {sysImp, sys386, sys68k} # {}) & ((num = 1) OR (num = 2)) THEN INC(flag, num)
 238                 ELSIF (sys68k IN options) & (num = 4) THEN INC(flag, num)
 239                 ELSIF (options * {sys386, interface} # {}) & (num = -10) & (flag = 0) THEN flag := -10
 240                 ELSIF (options * {sys386, com} # {}) & (num = 8) & (flag = 0) THEN flag := 8
 241                 ELSIF (options * {sysImp, sys386} # {}) & (num = 16) & (flag = 0) THEN flag := 16
 242                 ELSIF ({sysImp, java} - options = {}) & ((num= -33) OR (num = -35)) & (flag = 0) THEN flag := num
 243                 ELSE err(225); flag := 0
 244                 END
 245         END GetProcSysFlag;
 246
 247         PROCEDURE GetVarParSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
 248                 VAR old: SHORTINT;
 249         BEGIN
 250                 old := flag; flag := 0;
 251                 IF (options * {sys386, sys68k, interface, com} # {}) THEN
 252                         IF (num = 1) OR (id = "nil") THEN
 253                                 IF ~ODD(old) THEN flag := SHORT(old + 1) END
 254                         ELSIF ((num = 2) OR (id = "in")) & (oberon IN options) THEN
 255                                 IF old <= 1 THEN flag := SHORT(old + 2) END
 256                         ELSIF ((num = 4) OR (id = "out")) & (oberon IN options) THEN
 257                                 IF old <= 1 THEN flag := SHORT(old + 4) END
 258                         ELSIF ((num = 8) OR (id = "new")) & (options * {com, interface} # {}) THEN
 259                                 IF old <= 1 THEN flag := SHORT(old + 8) END
 260                         ELSIF ((num = 16) OR (id = "iid")) & (com IN options) THEN
 261                                 IF old <= 1 THEN flag := SHORT(old + 16) END
 262                         END
 263                 END;
 264                 IF flag = 0 THEN err(225) END
 265         END GetVarParSysFlag;
 266
 267         PROCEDURE GetRecordSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
 268                 VAR old: SHORTINT;
 269         BEGIN
 270                 old := flag; flag := 0;
 271                 IF (num = 1) OR (id = "untagged") THEN
 272                         IF (options * {sysImp, sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END
 273                 ELSIF (num = 3) OR (id = "noalign") THEN
 274                         IF (options * {sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 3 END
 275                 ELSIF (num = 4) OR (id = "align2") THEN
 276                         IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 4 END
 277                 ELSIF (num = 5) OR (id = "align4") THEN
 278                         IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 5 END
 279                 ELSIF (num = 6) OR (id = "align8") THEN
 280                         IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 6 END
 281                 ELSIF (num = 7) OR (id = "union") THEN
 282                         IF (options * {sys386, sys68k, interface, com} # {}) & (old = 0) THEN flag := 7 END
 283                 ELSIF (num = 10) OR (id = "interface") OR ValidGuid(id) THEN
 284                         IF (com IN options) & (old = 0) THEN flag := 10 END
 285                 ELSIF (num = -11) OR (id = "jint") THEN
 286                         IF (java IN options) & (old = 0) THEN flag := -11 END
 287                 ELSIF (num = -13) OR (id = "jstr") THEN
 288                         IF (java IN options) & (old = 0) THEN flag := -13 END
 289                 ELSIF (num = 20) OR (id = "som") THEN
 290                         IF (som IN options) & (old = 0) THEN flag := 20 END
 291                 END;
 292                 IF flag = 0 THEN err(225) END
 293         END GetRecordSysFlag;
 294
 295         PROCEDURE GetArraySysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
 296                 VAR old: SHORTINT;
 297         BEGIN
 298                 old := flag; flag := 0;
 299                 IF (num = 1) OR (id = "untagged") THEN
 300                         IF (options * {sysImp, sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END
 301                 ELSIF (num = -12) OR (id = "jarr") THEN
 302                         IF (java IN options) & (old = 0) THEN flag := -12 END
 303                 ELSIF (num = -13) OR (id = "jstr") THEN
 304                         IF (java IN options) & (old = 0) THEN flag := -13 END
 305                 END;
 306                 IF flag = 0 THEN err(225) END
 307         END GetArraySysFlag;
 308
 309         PROCEDURE GetPointerSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
 310                 VAR old: SHORTINT;
 311         BEGIN
 312                 old := flag; flag := 0;
 313                 IF (num = 1) OR (id = "untagged") THEN
 314                         IF (options * {sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END
 315                 ELSIF (num = 2) OR (id = "handle") THEN
 316                         IF (sys68k IN options) & (old = 0) THEN flag := 2 END
 317                 ELSIF (num = 10) OR (id = "interface") THEN
 318                         IF (com IN options) & (old = 0) THEN flag := 10 END
 319                 ELSIF (num = 20) OR (id = "som") THEN
 320                         IF (som IN options) & (old = 0) THEN flag := 20 END
 321                 END;
 322                 IF flag = 0 THEN err(225) END
 323         END GetPointerSysFlag;
 324
 325         PROCEDURE GetProcTypSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
 326         BEGIN
 327                 IF ((num = -10) OR (id = "ccall")) & (options * {sys386, interface} # {}) THEN flag := -10
 328                 ELSE err(225); flag := 0
 329                 END
 330         END GetProcTypSysFlag;
 331
 332         PROCEDURE PropagateRecordSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT);
 333         BEGIN
 334                 IF (baseFlag = 1) OR (baseFlag >= 3) & (baseFlag <= 7) THEN     (* propagate untagged .. union *)
 335                         IF flag = 0 THEN flag := baseFlag
 336                         ELSIF (flag = 6) & (baseFlag < 6) THEN (* OK *) (* special case for 8 byte aligned records *)
 337                         ELSIF flag # baseFlag THEN err(225); flag := 0
 338                         END
 339                 ELSIF (baseFlag # 10) & (flag = 10) THEN err(225)
 340                 END
 341         END PropagateRecordSysFlag;
 342
 343         PROCEDURE PropagateRecPtrSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT);
 344         BEGIN
 345                 IF (baseFlag = 1) OR (baseFlag >= 3) & (baseFlag <= 7) THEN     (* pointer to untagged .. union is untagged *)
 346                         IF flag = 0 THEN flag := 1
 347                         ELSIF (flag # 1) & (flag # 2) THEN err(225); flag := 0
 348                         END
 349                 ELSIF baseFlag = 10 THEN        (* pointer to interface is interface *)
 350                         IF flag = 0 THEN flag := 10
 351                         ELSIF flag # 10 THEN err(225); flag := 0
 352                         END
 353                 ELSIF baseFlag = -11 THEN       (* pointer to java interface is java interface *)
 354                         IF flag # 0 THEN err(225) END;
 355                         flag := -11
 356                 ELSIF baseFlag = -13 THEN       (* pointer to java string is java string *)
 357                         IF flag # 0 THEN err(225) END;
 358                         flag := -13
 359                 END
 360         END PropagateRecPtrSysFlag;
 361
 362         PROCEDURE PropagateArrPtrSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT);
 363         BEGIN
 364                 IF baseFlag = 1 THEN    (* pointer to untagged or guid is untagged *)
 365                         IF flag = 0 THEN flag := 1
 366                         ELSIF (flag # 1) & (flag # 2) THEN err(225); flag := 0
 367                         END
 368                 ELSIF baseFlag = -12 THEN       (* pointer to java array is java array *)
 369                         IF flag # 0 THEN err(225) END;
 370                         flag := -12
 371                 ELSIF baseFlag = -13 THEN       (* pointer to java string is java string *)
 372                         IF flag # 0 THEN err(225) END;
 373                         flag := -13
 374                 END
 375         END PropagateArrPtrSysFlag;
 376
 377
 378         (* utf8 strings *)
 379
 380         PROCEDURE PutUtf8* (VAR str: ARRAY OF SHORTCHAR; val: INTEGER; VAR idx: INTEGER);
 381         BEGIN
 382                 ASSERT((val >= 0) & (val < 65536));
 383                 IF val < 128 THEN
 384                         str[idx] := SHORT(CHR(val)); INC(idx)
 385                 ELSIF val < 2048 THEN
 386                         str[idx] := SHORT(CHR(val DIV 64 + 192)); INC(idx);
 387                         str[idx] := SHORT(CHR(val MOD 64 + 128)); INC(idx)
 388                 ELSE
 389                         str[idx] := SHORT(CHR(val DIV 4096 + 224)); INC(idx);
 390                         str[idx] := SHORT(CHR(val DIV 64 MOD 64 + 128)); INC(idx);
 391                         str[idx] := SHORT(CHR(val MOD 64 + 128)); INC(idx)
 392                 END
 393         END PutUtf8;
 394
 395         PROCEDURE GetUtf8* (VAR str: ARRAY OF SHORTCHAR; VAR val, idx: INTEGER);
 396                 VAR ch: SHORTCHAR;
 397         BEGIN
 398                 ch := str[idx]; INC(idx);
 399                 IF ch < 80X THEN
 400                         val := ORD(ch)
 401                 ELSIF ch < 0E0X THEN
 402                         val := ORD(ch) - 192;
 403                         ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128
 404                 ELSE
 405                         val := ORD(ch) - 224;
 406                         ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128;
 407                         ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128
 408                 END
 409         END GetUtf8;
 410
 411
 412         (* log output *)
 413
 414         PROCEDURE LogW* (ch: SHORTCHAR);
 415         BEGIN
 416                 StdLog.Char(ch)
 417         END LogW;
 418
 419         PROCEDURE LogWStr* (s: ARRAY OF SHORTCHAR);
 420                 VAR str: ARRAY 256 OF CHAR;
 421         BEGIN
 422                 str := s$; StdLog.String(str)
 423         END LogWStr;
 424
 425         PROCEDURE LogWNum* (i, len: INTEGER);
 426         BEGIN
 427                 StdLog.Int(i)
 428         END LogWNum;
 429
 430         PROCEDURE LogWLn*;
 431         BEGIN
 432                 StdLog.Ln
 433         END LogWLn;
 434 (*
 435         PROCEDURE LogW* (ch: CHAR);
 436         BEGIN
 437                 out.WriteChar(ch);
 438         END LogW;
 439
 440         PROCEDURE LogWStr* (s: ARRAY OF CHAR);
 441         BEGIN
 442                 out.WriteString(s);
 443         END LogWStr;
 444
 445         PROCEDURE LogWNum* (i, len: LONGINT);
 446         BEGIN
 447                 out.WriteChar(" "); out.WriteInt(i);
 448         END LogWNum;
 449
 450         PROCEDURE LogWLn*;
 451         BEGIN
 452                 out.WriteLn;
 453                 Views.RestoreDomain(logbuf.Domain())
 454         END LogWLn;
 455 *)
 456         PROCEDURE Mark* (n, pos: INTEGER);
 457         BEGIN
 458                 IF (n >= 0) & ~((oberon IN options) & (n >= 181) & (n <= 190)) THEN
 459                         noerr := FALSE;
 460                         IF pos < 0 THEN pos := 0 END;
 461                         IF (pos < lastpos) OR (lastpos + 9 < pos) THEN
 462                                 lastpos := pos;
 463                                 IF errors < maxErrors THEN
 464                                         errNo[errors] := n; errPos[errors] := pos
 465                                 END;
 466                                 INC(errors)
 467                         END;
 468                         IF trap IN options THEN HALT(100) END;
 469                 ELSIF (n <= -700) & (errors < maxErrors) THEN
 470                         errNo[errors] := -n; errPos[errors] := pos; INC(errors)
 471                 END
 472         END Mark;
 473
 474         PROCEDURE err* (n: INTEGER);
 475         BEGIN
 476                 Mark(n, errpos)
 477         END err;
 478
 479         PROCEDURE InsertMarks* (text: TextModels.Model);
 480                 VAR i, j, x, y, n: INTEGER; script: Stores.Operation;
 481         BEGIN
 482                 n := errors;
 483                 IF n > maxErrors THEN n := maxErrors END;
 484                 (* sort *)
 485                 i := 1;
 486                 WHILE i < n DO
 487                         x := errPos[i]; y := errNo[i]; j := i-1;
 488                         WHILE (j >= 0) & (errPos[j] > x) DO errPos[j+1] := errPos[j]; errNo[j+1] := errNo[j]; DEC(j) END;
 489                         errPos[j+1] := x; errNo[j+1] := y; INC(i)
 490                 END;
 491                 (* insert *)
 492                 Models.BeginModification(Models.clean, text);
 493                 Models.BeginScript(text, "#Dev:InsertMarkers", script);
 494                 WHILE n > 0 DO DEC(n);
 495                         DevMarkers.Insert(text, errPos[n], DevMarkers.dir.New(errNo[n]))
 496                 END;
 497                 Models.EndScript(text, script);
 498                 Models.EndModification(Models.clean, text);
 499         END InsertMarks;
 500
 501
 502         (* fingerprinting *)
 503
 504         PROCEDURE InitCrcTab;
 505                 (* CRC32, high bit first, pre & post inverted *)
 506                 CONST poly = {0, 1, 2, 4, 5, 7, 8, 10, 11, 12, 16, 22, 23, 26}; (* CRC32 polynom *)
 507                 VAR x, c, i: INTEGER;
 508         BEGIN
 509                 x := 0;
 510                 WHILE x < 256 DO
 511                         c := x * 1000000H; i := 0;
 512                         WHILE i < 8 DO
 513                                 IF c < 0 THEN c := ORD(BITS(c * 2) / poly)
 514                                 ELSE c := c * 2
 515                                 END;
 516                                 INC(i)
 517                         END;
 518                         crc32tab[ORD(BITS(x) / BITS(255))] := ORD(BITS(c) / BITS(255));
 519                         INC(x)
 520                 END
 521         END InitCrcTab;
 522
 523         PROCEDURE FPrint* (VAR fp: INTEGER; val: INTEGER);
 524                 VAR c: INTEGER;
 525         BEGIN
 526 (*
 527                 fp := SYSTEM.ROT(ORD(BITS(fp) / BITS(val)), 1)  (* bad collision detection *)
 528 *)
 529                 (* CRC32, high bit first, pre & post inverted *)
 530                 c := ORD(BITS(fp * 256) / BITS(crc32tab[ORD(BITS(fp DIV 1000000H) / BITS(val DIV 1000000H)) MOD 256]));
 531                 c := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val DIV 10000H)) MOD 256]));
 532                 c := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val DIV 100H)) MOD 256]));
 533                 fp := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val)) MOD 256]));
 534         END FPrint;
 535
 536         PROCEDURE FPrintSet* (VAR fp: INTEGER; set: SET);
 537         BEGIN FPrint(fp, ORD(set))
 538         END FPrintSet;
 539
 540         PROCEDURE FPrintReal* (VAR fp: INTEGER; real: SHORTREAL);
 541         BEGIN FPrint(fp, SYSTEM.VAL(INTEGER, real))
 542         END FPrintReal;
 543
 544         PROCEDURE FPrintLReal* (VAR fp: INTEGER; lr: REAL);
 545                 VAR l, h: INTEGER;
 546         BEGIN
 547                 FPrint(fp, LoWord(lr)); FPrint(fp, HiWord(lr))
 548         END FPrintLReal;
 549
 550         PROCEDURE ChkSum (VAR fp: INTEGER; val: INTEGER);       (* symbolfile checksum *)
 551         BEGIN
 552                 (* same as FPrint, 8 bit only *)
 553                 fp := ORD(BITS(fp * 256) / BITS(crc32tab[ORD(BITS(fp DIV 1000000H) / BITS(val)) MOD 256]))
 554         END ChkSum;
 555
 556
 557
 558         (* compact format *)
 559
 560         PROCEDURE WriteLInt (w: Files.Writer; i: INTEGER);
 561         BEGIN
 562                 ChkSum(checksum, i);
 563                 w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256;
 564                 ChkSum(checksum, i);
 565                 w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256;
 566                 ChkSum(checksum, i);
 567                 w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256;
 568                 ChkSum(checksum, i);
 569                 w.WriteByte(SHORT(SHORT(i MOD 256)))
 570         END WriteLInt;
 571
 572         PROCEDURE ReadLInt (r: Files.Reader; VAR i: INTEGER);
 573                 VAR b: BYTE; x: INTEGER;
 574         BEGIN
 575                 r.ReadByte(b); x := b MOD 256;
 576                 ChkSum(checksum, b);
 577                 r.ReadByte(b); x := x + 100H * (b MOD 256);
 578                 ChkSum(checksum, b);
 579                 r.ReadByte(b); x := x + 10000H * (b MOD 256);
 580                 ChkSum(checksum, b);
 581                 r.ReadByte(b); i := x + 1000000H * b;
 582                 ChkSum(checksum, b)
 583         END ReadLInt;
 584
 585         PROCEDURE WriteNum (w: Files.Writer; i: INTEGER);
 586         BEGIN   (* old format of Oberon *)
 587                 WHILE (i < -64) OR (i > 63) DO ChkSum(checksum, i MOD 128 - 128); w.WriteByte(SHORT(SHORT(i MOD 128 - 128))); i := i DIV 128 END;
 588                 ChkSum(checksum, i MOD 128);
 589                 w.WriteByte(SHORT(SHORT(i MOD 128)))
 590         END WriteNum;
 591
 592         PROCEDURE ReadNum (r: Files.Reader; VAR i: INTEGER);
 593                 VAR b: BYTE; s, y: INTEGER;
 594         BEGIN
 595                 s := 0; y := 0; r.ReadByte(b);
 596                 IF ~r.eof THEN ChkSum(checksum, b) END;
 597                 WHILE b < 0 DO INC(y, ASH(b + 128, s)); INC(s, 7); r.ReadByte(b); ChkSum(checksum, b) END;
 598                 i := ASH((b + 64) MOD 128 - 64, s) + y;
 599         END ReadNum;
 600
 601         PROCEDURE WriteNumSet (w: Files.Writer; x: SET);
 602         BEGIN
 603                 WriteNum(w, ORD(x))
 604         END WriteNumSet;
 605
 606         PROCEDURE ReadNumSet (r: Files.Reader; VAR x: SET);
 607                 VAR i: INTEGER;
 608         BEGIN
 609                 ReadNum(r, i); x := BITS(i)
 610         END ReadNumSet;
 611
 612         PROCEDURE WriteReal (w: Files.Writer; x: SHORTREAL);
 613         BEGIN
 614                 WriteLInt(w, SYSTEM.VAL(INTEGER, x))
 615         END WriteReal;
 616
 617         PROCEDURE ReadReal (r: Files.Reader; VAR x: SHORTREAL);
 618                 VAR i: INTEGER;
 619         BEGIN
 620                 ReadLInt(r, i); x := SYSTEM.VAL(SHORTREAL, i)
 621         END ReadReal;
 622
 623         PROCEDURE WriteLReal (w: Files.Writer; x: REAL);
 624         BEGIN
 625                 WriteLInt(w, LoWord(x)); WriteLInt(w, HiWord(x))
 626         END WriteLReal;
 627
 628         PROCEDURE ReadLReal (r: Files.Reader; VAR x: REAL);
 629                 VAR h, l: INTEGER;
 630         BEGIN
 631                 ReadLInt(r, l); ReadLInt(r, h); x := Compound(l, h)
 632         END ReadLReal;
 633
 634
 635         (* read symbol file *)
 636
 637         PROCEDURE SymRCh* (VAR ch: SHORTCHAR);
 638                 VAR b: BYTE;
 639         BEGIN
 640                 inSym.ReadByte(b); ch := SHORT(CHR(b));
 641                 ChkSum(checksum, b)
 642         END SymRCh;
 643
 644         PROCEDURE SymRInt* (): INTEGER;
 645                 VAR k: INTEGER;
 646         BEGIN
 647                 ReadNum(inSym, k); RETURN k
 648         END SymRInt;
 649
 650         PROCEDURE SymRSet* (VAR s: SET);
 651         BEGIN
 652                 ReadNumSet(inSym, s)
 653         END SymRSet;
 654
 655         PROCEDURE SymRReal* (VAR r: SHORTREAL);
 656         BEGIN
 657                 ReadReal(inSym, r)
 658         END SymRReal;
 659
 660         PROCEDURE SymRLReal* (VAR lr: REAL);
 661         BEGIN
 662                 ReadLReal(inSym, lr)
 663         END SymRLReal;
 664
 665         PROCEDURE eofSF* (): BOOLEAN;
 666         BEGIN
 667                 RETURN inSym.eof
 668         END eofSF;
 669
 670         PROCEDURE OldSym* (VAR modName: ARRAY OF SHORTCHAR; VAR done: BOOLEAN);
 671                 VAR tag: INTEGER; loc: Files.Locator; dir, name: Files.Name;
 672         BEGIN
 673                 done := FALSE;
 674                 IF modName = "@file" THEN
 675                         oldSymFile := file
 676                 ELSE
 677                         name := modName$; Kernel.SplitName(name, dir, name);
 678                         Kernel.MakeFileName(name, Kernel.symType);
 679                         loc := Files.dir.This(dir); loc := loc.This(symDir);
 680                         oldSymFile := Files.dir.Old(loc, name, Files.shared);
 681                         IF (oldSymFile = NIL) & (dir = "") THEN
 682                                 loc := Files.dir.This(SYSdir); loc := loc.This(symDir);
 683                                 oldSymFile := Files.dir.Old(loc, name, Files.shared)
 684                         END
 685                 END;
 686                 IF oldSymFile # NIL THEN
 687                         inSym := oldSymFile.NewReader(inSym);
 688                         IF inSym # NIL THEN
 689                                 ReadLInt(inSym, tag);
 690                                 IF tag = SFtag THEN done := TRUE ELSE err(151) END
 691                         END
 692                 END
 693         END OldSym;
 694
 695         PROCEDURE CloseOldSym*;
 696         BEGIN
 697                 IF oldSymFile # NIL THEN oldSymFile.Close; oldSymFile := NIL END
 698         END CloseOldSym;
 699
 700
 701         (* write symbol file *)
 702
 703         PROCEDURE SymWCh* (ch: SHORTCHAR);
 704         BEGIN
 705                 ChkSum(checksum, ORD(ch));
 706                 outSym.WriteByte(SHORT(ORD(ch)))
 707         END SymWCh;
 708
 709         PROCEDURE SymWInt* (i: INTEGER);
 710         BEGIN
 711                 WriteNum(outSym, i)
 712         END SymWInt;
 713
 714         PROCEDURE SymWSet* (s: SET);
 715         BEGIN
 716                 WriteNumSet(outSym, s)
 717         END SymWSet;
 718
 719         PROCEDURE SymWReal* (VAR r: SHORTREAL);
 720         BEGIN
 721                 WriteReal(outSym, r)
 722         END SymWReal;
 723
 724         PROCEDURE SymWLReal* (VAR r: REAL);
 725         BEGIN
 726                 WriteLReal(outSym, r)
 727         END SymWLReal;
 728
 729         PROCEDURE SymReset*;
 730         BEGIN
 731                 outSym.SetPos(4)
 732         END SymReset;
 733
 734         PROCEDURE NewSym* (VAR modName: ARRAY OF SHORTCHAR);
 735                 VAR loc: Files.Locator; dir: Files.Name;
 736         BEGIN
 737                 ObjFName := modName$; Kernel.SplitName(ObjFName, dir, ObjFName);
 738                 loc := Files.dir.This(dir); loc := loc.This(symDir);
 739                 symFile := Files.dir.New(loc, Files.ask);
 740                 IF symFile # NIL THEN
 741                         outSym := symFile.NewWriter(NIL);
 742                         WriteLInt(outSym, SFtag)
 743                 ELSE
 744                         err(153)
 745                 END
 746         END NewSym;
 747
 748         PROCEDURE RegisterNewSym*;
 749                 VAR res: INTEGER; name: Files.Name;
 750         BEGIN
 751                 IF symFile # NIL THEN
 752                         name := ObjFName$;
 753                         Kernel.MakeFileName(name, Kernel.symType);
 754                         symFile.Register(name, Kernel.symType, Files.ask, res);
 755                         symFile := NIL
 756                 END
 757         END RegisterNewSym;
 758
 759         PROCEDURE DeleteNewSym*;
 760         BEGIN
 761                 IF symFile # NIL THEN symFile.Close; symFile := NIL END
 762         END DeleteNewSym;
 763
 764
 765         (* write object file *)
 766
 767         PROCEDURE ObjW* (ch: SHORTCHAR);
 768         BEGIN
 769                 outObj.WriteByte(SHORT(ORD(ch)))
 770         END ObjW;
 771
 772         PROCEDURE ObjWNum* (i: INTEGER);
 773         BEGIN
 774                 WriteNum(outObj, i)
 775         END ObjWNum;
 776
 777         PROCEDURE ObjWInt (i: SHORTINT);
 778         BEGIN
 779                 outObj.WriteByte(SHORT(SHORT(i MOD 256)));
 780                 outObj.WriteByte(SHORT(SHORT(i DIV 256)))
 781         END ObjWInt;
 782
 783         PROCEDURE ObjWLInt* (i: INTEGER);
 784         BEGIN
 785                 ObjWInt(SHORT(i MOD 65536));
 786                 ObjWInt(SHORT(i DIV 65536))
 787         END ObjWLInt;
 788
 789         PROCEDURE ObjWBytes* (VAR bytes: ARRAY OF SHORTCHAR; n: INTEGER);
 790                 TYPE P = POINTER TO ARRAY [untagged] 100000H OF BYTE;
 791                 VAR p: P;
 792         BEGIN
 793                 p := SYSTEM.VAL(P, SYSTEM.ADR(bytes));
 794                 outObj.WriteBytes(p^, 0, n)
 795         END ObjWBytes;
 796
 797         PROCEDURE ObjLen* (): INTEGER;
 798         BEGIN
 799                 RETURN outObj.Pos()
 800         END ObjLen;
 801
 802         PROCEDURE ObjSet* (pos: INTEGER);
 803         BEGIN
 804                 outObj.SetPos(pos)
 805         END ObjSet;
 806
 807         PROCEDURE NewObj* (VAR modName: ARRAY OF SHORTCHAR);
 808                 VAR loc: Files.Locator; dir: Files.Name;
 809         BEGIN
 810                 errpos := 0;
 811                 ObjFName := modName$; Kernel.SplitName(ObjFName, dir, ObjFName);
 812                 loc := Files.dir.This(dir); loc := loc.This(codeDir);
 813                 objFile := Files.dir.New(loc, Files.ask);
 814                 IF objFile # NIL THEN
 815                         outObj := objFile.NewWriter(NIL);
 816                         WriteLInt(outObj, OFtag)
 817                 ELSE
 818                         err(153)
 819                 END
 820         END NewObj;
 821
 822         PROCEDURE RegisterObj*;
 823                 VAR res: INTEGER; name: Files.Name;
 824         BEGIN
 825                 IF objFile # NIL THEN
 826                         name := ObjFName$;
 827                         Kernel.MakeFileName(name, Kernel.objType);
 828                         objFile.Register(name, Kernel.objType, Files.ask, res);
 829                         objFile := NIL; outObj := NIL
 830                 END
 831         END RegisterObj;
 832
 833         PROCEDURE DeleteObj*;
 834         BEGIN
 835                 IF objFile # NIL THEN objFile.Close; objFile := NIL END
 836         END DeleteObj;
 837
 838
 839         PROCEDURE InitHost;
 840                 VAR test: SHORTINT; lo: SHORTCHAR;
 841         BEGIN
 842                 test := 1; SYSTEM.GET(SYSTEM.ADR(test), lo); LEHost := lo = 1X;
 843                 InfReal := SYSTEM.VAL(SHORTREAL, InfRealPat);
 844                 MinReal32 := SYSTEM.VAL(SHORTREAL, MinReal32Pat);
 845                 MaxReal32 := SYSTEM.VAL(SHORTREAL, MaxReal32Pat);
 846                 MinReal64 := Compound(MinReal64PatL, MinReal64PatH);
 847                 MaxReal64 := Compound(MaxReal64PatL, MaxReal64PatH)
 848         END InitHost;
 849
 850 BEGIN
 851         InitCrcTab;
 852         InitHost
 853 END DevCPM.