Trurl-based/Dev0/Mod/CPM.txt

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