MODULE DevCPM;
(**
project = "BlackBox"
organization = "www.oberon.ch"
contributors = "Oberon microsystems"
version = "System/Rsrc/About"
copyright = "System/Rsrc/About"
license = "Docu/BB-License"
references = "ftp://ftp.inf.ethz.ch/pub/software/Oberon/OberonV4/Docu/OP2.Paper.ps"
changes = ""
issues = ""
**)
IMPORT SYSTEM, Kernel, Files, Stores, Models, Views, TextModels, TextMappers, StdLog, DevMarkers;
CONST
ProcSize* = 4; (* PROCEDURE type *)
PointerSize* = 4; (* POINTER type *)
DArrSizeA* = 8; (* dyn array descriptor *)
DArrSizeB* = 4; (* size = A + B * typ.n *)
MaxSet* = 31;
MaxIndex* = 7FFFFFFFH; (* maximal index value for array declaration *)
MinReal32Pat = 0FF7FFFFFH; (* most positive, 32-bit pattern *)
MinReal64PatL = 0FFFFFFFFH; (* mostnegative, lower 32-bit pattern *)
MinReal64PatH = 0FFEFFFFFH; (* mostnegative, higher 32-bit pattern *)
MaxReal32Pat = 07F7FFFFFH; (* most positive, 32-bit pattern *)
MaxReal64PatL = 0FFFFFFFFH; (* most positive, lower 32-bit pattern *)
MaxReal64PatH = 07FEFFFFFH; (* most positive, higher 32-bit pattern *)
InfRealPat = 07F800000H; (* real infinity pattern *)
(* inclusive range of parameter of standard procedure HALT *)
MinHaltNr* = 0;
MaxHaltNr* = 128;
(* inclusive range of register number of procedures SYSTEM.GETREG and SYSTEM.PUTREG *)
MinRegNr* = 0;
MaxRegNr* = 31;
(* maximal value of flag used to mark interface structures *)
MaxSysFlag* = 127; (* shortint *)
CProcFlag* = 1; (* code procedures *)
(* maximal condition value of parameter of SYSTEM.CC *)
MaxCC* = 15;
(* initialization of constant address, must be different from any valid constant address *)
ConstNotAlloc* = -1;
(* whether hidden pointer fields have to be nevertheless exported *)
ExpHdPtrFld* = TRUE;
HdPtrName* = "@ptr";
(* whether hidden untagged pointer fields have to be nevertheless exported *)
ExpHdUtPtrFld* = TRUE;
HdUtPtrName* = "@utptr";
(* whether hidden procedure fields have to be nevertheless exported (may be used for System.Free) *)
ExpHdProcFld* = TRUE;
HdProcName* = "@proc";
(* whether hidden bound procedures have to be nevertheless exported *)
ExpHdTProc* = FALSE;
HdTProcName* = "@tproc";
(* maximal number of exported stuctures: *)
MaxStruct* = 16000; (* must be < MAX(INTEGER) DIV 2 in object model *)
(* maximal number of record extensions: *)
MaxExts* = 15; (* defined by type descriptor layout *)
(* whether field leaf of pointer variable p has to be set to FALSE, when NEW(p) or SYSTEM.NEW(p, n) is used *)
NEWusingAdr* = FALSE;
(* special character (< " ") returned by procedure Get, if end of text reached *)
Eot* = 0X;
(* warnings *)
longreal* = 0; largeint* = 1; realConst* = 2; copy* = 3; lchr* = 4; lentier* = 5; invar* = 6; outvar* = 7;
(* language options *)
interface* = 1;
com* = 2; comAware* = 3;
som* = 4; somAware* = 5;
oberon* = 6;
java* = 7; javaAware* = 8;
noCode* = 9;
allSysVal* = 14;
sysImp* = 15;
trap* = 31;
sys386 = 10; sys68k = 20; (* processor type in options if system imported *)
CONST
SFdir = "Sym";
OFdir = "Code";
SYSdir = "System";
SFtag = 6F4F5346H; (* symbol file tag *)
OFtag = 6F4F4346H; (* object file tag *)
maxErrors = 64;
TYPE
File = POINTER TO RECORD next: File; f: Files.File END;
VAR
LEHost*: BOOLEAN; (* little or big endian host *)
MinReal32*, MaxReal32*, InfReal*,
MinReal64*, MaxReal64*: REAL;
noerr*: BOOLEAN; (* no error found until now *)
curpos*, startpos*, errpos*: INTEGER; (* character, start, and error position in source file *)
searchpos*: INTEGER; (* search position in source file *)
errors*: INTEGER;
breakpc*: INTEGER; (* set by OPV.Init *)
options*: SET; (* language options *)
file*: Files.File; (* used for sym file import *)
codeDir*: ARRAY 16 OF CHAR;
symDir*: ARRAY 16 OF CHAR;
checksum*: INTEGER; (* symbol file checksum *)
lastpos: INTEGER;
realpat: INTEGER;
lrealpat: RECORD H, L: INTEGER END;
fpi, fpj: SHORTINT; fp: ARRAY 4 OF SHORTCHAR;
ObjFName: Files.Name;
in: TextModels.Reader;
oldSymFile, symFile, objFile: Files.File;
inSym: Files.Reader;
outSym, outObj: Files.Writer;
errNo, errPos: ARRAY maxErrors OF INTEGER;
lineReader: TextModels.Reader;
lineNum: INTEGER;
crc32tab: ARRAY 256 OF INTEGER;
PROCEDURE^ err* (n: INTEGER);
PROCEDURE Init* (source: TextModels.Reader; logtext: TextModels.Model);
BEGIN
in := source;
DevMarkers.Unmark(in.Base());
noerr := TRUE; options := {};
curpos := in.Pos(); errpos := curpos; lastpos := curpos - 11; errors := 0;
codeDir := OFdir; symDir := SFdir
END Init;
PROCEDURE Close*;
BEGIN
oldSymFile := NIL; inSym := NIL;
symFile := NIL; outSym := NIL;
objFile := NIL; outObj := NIL;
in := NIL; lineReader := NIL
END Close;
PROCEDURE Get* (VAR ch: SHORTCHAR);
VAR ch1: CHAR;
BEGIN
REPEAT in.ReadChar(ch1); INC(curpos) UNTIL (ch1 < 100X) & (ch1 # TextModels.viewcode);
ch := SHORT(ch1)
END Get;
PROCEDURE GetL* (VAR ch: CHAR);
BEGIN
REPEAT in.ReadChar(ch); INC(curpos) UNTIL ch # TextModels.viewcode;
END GetL;
PROCEDURE LineOf* (pos: INTEGER): INTEGER;
VAR ch: CHAR;
BEGIN
IF lineReader = NIL THEN lineReader := in.Base().NewReader(NIL); lineReader.SetPos(0); lineNum := 0 END;
IF lineReader.Pos() > pos THEN lineReader.SetPos(0); lineNum := 0 END;
WHILE lineReader.Pos() < pos DO
lineReader.ReadChar(ch);
IF ch = 0DX THEN INC(lineNum) END
END;
RETURN lineNum
END LineOf;
PROCEDURE LoWord (r: REAL): INTEGER;
VAR x: INTEGER;
BEGIN
x := SYSTEM.ADR(r);
IF ~LEHost THEN INC(x, 4) END;
SYSTEM.GET(x, x);
RETURN x
END LoWord;
PROCEDURE HiWord (r: REAL): INTEGER;
VAR x: INTEGER;
BEGIN
x := SYSTEM.ADR(r);
IF LEHost THEN INC(x, 4) END;
SYSTEM.GET(x, x);
RETURN x
END HiWord;
PROCEDURE Compound (lo, hi: INTEGER): REAL;
VAR r: REAL;
BEGIN
IF LEHost THEN
SYSTEM.PUT(SYSTEM.ADR(r), lo); SYSTEM.PUT(SYSTEM.ADR(r) + 4, hi)
ELSE
SYSTEM.PUT(SYSTEM.ADR(r) + 4, lo); SYSTEM.PUT(SYSTEM.ADR(r), hi)
END;
RETURN r
END Compound;
(* sysflag control *)
PROCEDURE ValidGuid* (VAR str: ARRAY OF SHORTCHAR): BOOLEAN;
VAR i: SHORTINT; ch: SHORTCHAR;
BEGIN
IF (LEN(str$) # 38) OR (str[0] # "{") & (str[37] # "}") THEN RETURN FALSE END;
i := 1;
WHILE i < 37 DO
ch := str[i];
IF (i = 9) OR (i = 14) OR (i = 19) OR (i = 24) THEN
IF ch # "-" THEN RETURN FALSE END
ELSE
IF (ch < "0") OR (ch > "9") & (CAP(ch) < "A") OR (CAP(ch) > "Z") THEN RETURN FALSE END
END;
INC(i)
END;
RETURN TRUE
END ValidGuid;
PROCEDURE GetProcSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
BEGIN
IF id # "" THEN
IF id = "code" THEN num := 1
ELSIF id = "callback" THEN num := 2
ELSIF id = "nostkchk" THEN num := 4
ELSIF id = "ccall" THEN num := -10
ELSIF id = "guarded" THEN num := 8
ELSIF id = "noframe" THEN num := 16
ELSIF id = "native" THEN num := -33
ELSIF id = "bytecode" THEN num := -35
END
END;
IF (options * {sysImp, sys386, sys68k} # {}) & ((num = 1) OR (num = 2)) THEN INC(flag, num)
ELSIF (sys68k IN options) & (num = 4) THEN INC(flag, num)
ELSIF (options * {sys386, interface} # {}) & (num = -10) & (flag = 0) THEN flag := -10
ELSIF (options * {sys386, com} # {}) & (num = 8) & (flag = 0) THEN flag := 8
ELSIF (options * {sysImp, sys386} # {}) & (num = 16) & (flag = 0) THEN flag := 16
ELSIF ({sysImp, java} - options = {}) & ((num= -33) OR (num = -35)) & (flag = 0) THEN flag := num
ELSE err(225); flag := 0
END
END GetProcSysFlag;
PROCEDURE GetVarParSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
VAR old: SHORTINT;
BEGIN
old := flag; flag := 0;
IF (options * {sys386, sys68k, interface, com} # {}) THEN
IF (num = 1) OR (id = "nil") THEN
IF ~ODD(old) THEN flag := SHORT(old + 1) END
ELSIF ((num = 2) OR (id = "in")) & (oberon IN options) THEN
IF old <= 1 THEN flag := SHORT(old + 2) END
ELSIF ((num = 4) OR (id = "out")) & (oberon IN options) THEN
IF old <= 1 THEN flag := SHORT(old + 4) END
ELSIF ((num = 8) OR (id = "new")) & (options * {com, interface} # {}) THEN
IF old <= 1 THEN flag := SHORT(old + 8) END
ELSIF ((num = 16) OR (id = "iid")) & (com IN options) THEN
IF old <= 1 THEN flag := SHORT(old + 16) END
END
END;
IF flag = 0 THEN err(225) END
END GetVarParSysFlag;
PROCEDURE GetRecordSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
VAR old: SHORTINT;
BEGIN
old := flag; flag := 0;
IF (num = 1) OR (id = "untagged") THEN
IF (options * {sysImp, sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END
ELSIF (num = 3) OR (id = "noalign") THEN
IF (options * {sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 3 END
ELSIF (num = 4) OR (id = "align2") THEN
IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 4 END
ELSIF (num = 5) OR (id = "align4") THEN
IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 5 END
ELSIF (num = 6) OR (id = "align8") THEN
IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 6 END
ELSIF (num = 7) OR (id = "union") THEN
IF (options * {sys386, sys68k, interface, com} # {}) & (old = 0) THEN flag := 7 END
ELSIF (num = 10) OR (id = "interface") OR ValidGuid(id) THEN
IF (com IN options) & (old = 0) THEN flag := 10 END
ELSIF (num = -11) OR (id = "jint") THEN
IF (java IN options) & (old = 0) THEN flag := -11 END
ELSIF (num = -13) OR (id = "jstr") THEN
IF (java IN options) & (old = 0) THEN flag := -13 END
ELSIF (num = 20) OR (id = "som") THEN
IF (som IN options) & (old = 0) THEN flag := 20 END
END;
IF flag = 0 THEN err(225) END
END GetRecordSysFlag;
PROCEDURE GetArraySysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
VAR old: SHORTINT;
BEGIN
old := flag; flag := 0;
IF (num = 1) OR (id = "untagged") THEN
IF (options * {sysImp, sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END
ELSIF (num = -12) OR (id = "jarr") THEN
IF (java IN options) & (old = 0) THEN flag := -12 END
ELSIF (num = -13) OR (id = "jstr") THEN
IF (java IN options) & (old = 0) THEN flag := -13 END
END;
IF flag = 0 THEN err(225) END
END GetArraySysFlag;
PROCEDURE GetPointerSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
VAR old: SHORTINT;
BEGIN
old := flag; flag := 0;
IF (num = 1) OR (id = "untagged") THEN
IF (options * {sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END
ELSIF (num = 2) OR (id = "handle") THEN
IF (sys68k IN options) & (old = 0) THEN flag := 2 END
ELSIF (num = 10) OR (id = "interface") THEN
IF (com IN options) & (old = 0) THEN flag := 10 END
ELSIF (num = 20) OR (id = "som") THEN
IF (som IN options) & (old = 0) THEN flag := 20 END
END;
IF flag = 0 THEN err(225) END
END GetPointerSysFlag;
PROCEDURE GetProcTypSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
BEGIN
IF ((num = -10) OR (id = "ccall")) & (options * {sys386, interface} # {}) THEN flag := -10
ELSE err(225); flag := 0
END
END GetProcTypSysFlag;
PROCEDURE PropagateRecordSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT);
BEGIN
IF (baseFlag = 1) OR (baseFlag >= 3) & (baseFlag <= 7) THEN (* propagate untagged .. union *)
IF flag = 0 THEN flag := baseFlag
ELSIF (flag = 6) & (baseFlag < 6) THEN (* OK *) (* special case for 8 byte aligned records *)
ELSIF flag # baseFlag THEN err(225); flag := 0
END
ELSIF (baseFlag # 10) & (flag = 10) THEN err(225)
END
END PropagateRecordSysFlag;
PROCEDURE PropagateRecPtrSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT);
BEGIN
IF (baseFlag = 1) OR (baseFlag >= 3) & (baseFlag <= 7) THEN (* pointer to untagged .. union is untagged *)
IF flag = 0 THEN flag := 1
ELSIF (flag # 1) & (flag # 2) THEN err(225); flag := 0
END
ELSIF baseFlag = 10 THEN (* pointer to interface is interface *)
IF flag = 0 THEN flag := 10
ELSIF flag # 10 THEN err(225); flag := 0
END
ELSIF baseFlag = -11 THEN (* pointer to java interface is java interface *)
IF flag # 0 THEN err(225) END;
flag := -11
ELSIF baseFlag = -13 THEN (* pointer to java string is java string *)
IF flag # 0 THEN err(225) END;
flag := -13
END
END PropagateRecPtrSysFlag;
PROCEDURE PropagateArrPtrSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT);
BEGIN
IF baseFlag = 1 THEN (* pointer to untagged or guid is untagged *)
IF flag = 0 THEN flag := 1
ELSIF (flag # 1) & (flag # 2) THEN err(225); flag := 0
END
ELSIF baseFlag = -12 THEN (* pointer to java array is java array *)
IF flag # 0 THEN err(225) END;
flag := -12
ELSIF baseFlag = -13 THEN (* pointer to java string is java string *)
IF flag # 0 THEN err(225) END;
flag := -13
END
END PropagateArrPtrSysFlag;
(* utf8 strings *)
PROCEDURE PutUtf8* (VAR str: ARRAY OF SHORTCHAR; val: INTEGER; VAR idx: INTEGER);
BEGIN
ASSERT((val >= 0) & (val < 65536));
IF val < 128 THEN
str[idx] := SHORT(CHR(val)); INC(idx)
ELSIF val < 2048 THEN
str[idx] := SHORT(CHR(val DIV 64 + 192)); INC(idx);
str[idx] := SHORT(CHR(val MOD 64 + 128)); INC(idx)
ELSE
str[idx] := SHORT(CHR(val DIV 4096 + 224)); INC(idx);
str[idx] := SHORT(CHR(val DIV 64 MOD 64 + 128)); INC(idx);
str[idx] := SHORT(CHR(val MOD 64 + 128)); INC(idx)
END
END PutUtf8;
PROCEDURE GetUtf8* (VAR str: ARRAY OF SHORTCHAR; VAR val, idx: INTEGER);
VAR ch: SHORTCHAR;
BEGIN
ch := str[idx]; INC(idx);
IF ch < 80X THEN
val := ORD(ch)
ELSIF ch < 0E0X THEN
val := ORD(ch) - 192;
ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128
ELSE
val := ORD(ch) - 224;
ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128;
ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128
END
END GetUtf8;
(* log output *)
PROCEDURE LogW* (ch: SHORTCHAR);
BEGIN
StdLog.Char(ch)
END LogW;
PROCEDURE LogWStr* (s: ARRAY OF SHORTCHAR);
VAR str: ARRAY 256 OF CHAR;
BEGIN
str := s$; StdLog.String(str)
END LogWStr;
PROCEDURE LogWNum* (i, len: INTEGER);
BEGIN
StdLog.Int(i)
END LogWNum;
PROCEDURE LogWLn*;
BEGIN
StdLog.Ln
END LogWLn;
(*
PROCEDURE LogW* (ch: CHAR);
BEGIN
out.WriteChar(ch);
END LogW;
PROCEDURE LogWStr* (s: ARRAY OF CHAR);
BEGIN
out.WriteString(s);
END LogWStr;
PROCEDURE LogWNum* (i, len: LONGINT);
BEGIN
out.WriteChar(" "); out.WriteInt(i);
END LogWNum;
PROCEDURE LogWLn*;
BEGIN
out.WriteLn;
Views.RestoreDomain(logbuf.Domain())
END LogWLn;
*)
PROCEDURE Mark* (n, pos: INTEGER);
BEGIN
IF (n >= 0) & ~((oberon IN options) & (n >= 181) & (n <= 190)) THEN
noerr := FALSE;
IF pos < 0 THEN pos := 0 END;
IF (pos < lastpos) OR (lastpos + 9 < pos) THEN
lastpos := pos;
IF errors < maxErrors THEN
errNo[errors] := n; errPos[errors] := pos
END;
INC(errors)
END;
IF trap IN options THEN HALT(100) END;
ELSIF (n <= -700) & (errors < maxErrors) THEN
errNo[errors] := -n; errPos[errors] := pos; INC(errors)
END
END Mark;
PROCEDURE err* (n: INTEGER);
BEGIN
Mark(n, errpos)
END err;
PROCEDURE InsertMarks* (text: TextModels.Model);
VAR i, j, x, y, n: INTEGER; script: Stores.Operation;
BEGIN
n := errors;
IF n > maxErrors THEN n := maxErrors END;
(* sort *)
i := 1;
WHILE i < n DO
x := errPos[i]; y := errNo[i]; j := i-1;
WHILE (j >= 0) & (errPos[j] > x) DO errPos[j+1] := errPos[j]; errNo[j+1] := errNo[j]; DEC(j) END;
errPos[j+1] := x; errNo[j+1] := y; INC(i)
END;
(* insert *)
Models.BeginModification(Models.clean, text);
Models.BeginScript(text, "#Dev:InsertMarkers", script);
WHILE n > 0 DO DEC(n);
DevMarkers.Insert(text, errPos[n], DevMarkers.dir.New(errNo[n]))
END;
Models.EndScript(text, script);
Models.EndModification(Models.clean, text);
END InsertMarks;
(* fingerprinting *)
PROCEDURE InitCrcTab;
(* CRC32, high bit first, pre & post inverted *)
CONST poly = {0, 1, 2, 4, 5, 7, 8, 10, 11, 12, 16, 22, 23, 26}; (* CRC32 polynom *)
VAR x, c, i: INTEGER;
BEGIN
x := 0;
WHILE x < 256 DO
c := x * 1000000H; i := 0;
WHILE i < 8 DO
IF c < 0 THEN c := ORD(BITS(c * 2) / poly)
ELSE c := c * 2
END;
INC(i)
END;
crc32tab[ORD(BITS(x) / BITS(255))] := ORD(BITS(c) / BITS(255));
INC(x)
END
END InitCrcTab;
PROCEDURE FPrint* (VAR fp: INTEGER; val: INTEGER);
VAR c: INTEGER;
BEGIN
(*
fp := SYSTEM.ROT(ORD(BITS(fp) / BITS(val)), 1) (* bad collision detection *)
*)
(* CRC32, high bit first, pre & post inverted *)
c := ORD(BITS(fp * 256) / BITS(crc32tab[ORD(BITS(fp DIV 1000000H) / BITS(val DIV 1000000H)) MOD 256]));
c := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val DIV 10000H)) MOD 256]));
c := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val DIV 100H)) MOD 256]));
fp := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val)) MOD 256]));
END FPrint;
PROCEDURE FPrintSet* (VAR fp: INTEGER; set: SET);
BEGIN FPrint(fp, ORD(set))
END FPrintSet;
PROCEDURE FPrintReal* (VAR fp: INTEGER; real: SHORTREAL);
BEGIN FPrint(fp, SYSTEM.VAL(INTEGER, real))
END FPrintReal;
PROCEDURE FPrintLReal* (VAR fp: INTEGER; lr: REAL);
VAR l, h: INTEGER;
BEGIN
FPrint(fp, LoWord(lr)); FPrint(fp, HiWord(lr))
END FPrintLReal;
PROCEDURE ChkSum (VAR fp: INTEGER; val: INTEGER); (* symbolfile checksum *)
BEGIN
(* same as FPrint, 8 bit only *)
fp := ORD(BITS(fp * 256) / BITS(crc32tab[ORD(BITS(fp DIV 1000000H) / BITS(val)) MOD 256]))
END ChkSum;
(* compact format *)
PROCEDURE WriteLInt (w: Files.Writer; i: INTEGER);
BEGIN
ChkSum(checksum, i);
w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256;
ChkSum(checksum, i);
w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256;
ChkSum(checksum, i);
w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256;
ChkSum(checksum, i);
w.WriteByte(SHORT(SHORT(i MOD 256)))
END WriteLInt;
PROCEDURE ReadLInt (r: Files.Reader; VAR i: INTEGER);
VAR b: BYTE; x: INTEGER;
BEGIN
r.ReadByte(b); x := b MOD 256;
ChkSum(checksum, b);
r.ReadByte(b); x := x + 100H * (b MOD 256);
ChkSum(checksum, b);
r.ReadByte(b); x := x + 10000H * (b MOD 256);
ChkSum(checksum, b);
r.ReadByte(b); i := x + 1000000H * b;
ChkSum(checksum, b)
END ReadLInt;
PROCEDURE WriteNum (w: Files.Writer; i: INTEGER);
BEGIN (* old format of Oberon *)
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;
ChkSum(checksum, i MOD 128);
w.WriteByte(SHORT(SHORT(i MOD 128)))
END WriteNum;
PROCEDURE ReadNum (r: Files.Reader; VAR i: INTEGER);
VAR b: BYTE; s, y: INTEGER;
BEGIN
s := 0; y := 0; r.ReadByte(b);
IF ~r.eof THEN ChkSum(checksum, b) END;
WHILE b < 0 DO INC(y, ASH(b + 128, s)); INC(s, 7); r.ReadByte(b); ChkSum(checksum, b) END;
i := ASH((b + 64) MOD 128 - 64, s) + y;
END ReadNum;
PROCEDURE WriteNumSet (w: Files.Writer; x: SET);
BEGIN
WriteNum(w, ORD(x))
END WriteNumSet;
PROCEDURE ReadNumSet (r: Files.Reader; VAR x: SET);
VAR i: INTEGER;
BEGIN
ReadNum(r, i); x := BITS(i)
END ReadNumSet;
PROCEDURE WriteReal (w: Files.Writer; x: SHORTREAL);
BEGIN
WriteLInt(w, SYSTEM.VAL(INTEGER, x))
END WriteReal;
PROCEDURE ReadReal (r: Files.Reader; VAR x: SHORTREAL);
VAR i: INTEGER;
BEGIN
ReadLInt(r, i); x := SYSTEM.VAL(SHORTREAL, i)
END ReadReal;
PROCEDURE WriteLReal (w: Files.Writer; x: REAL);
BEGIN
WriteLInt(w, LoWord(x)); WriteLInt(w, HiWord(x))
END WriteLReal;
PROCEDURE ReadLReal (r: Files.Reader; VAR x: REAL);
VAR h, l: INTEGER;
BEGIN
ReadLInt(r, l); ReadLInt(r, h); x := Compound(l, h)
END ReadLReal;
(* read symbol file *)
PROCEDURE SymRCh* (VAR ch: SHORTCHAR);
VAR b: BYTE;
BEGIN
inSym.ReadByte(b); ch := SHORT(CHR(b));
ChkSum(checksum, b)
END SymRCh;
PROCEDURE SymRInt* (): INTEGER;
VAR k: INTEGER;
BEGIN
ReadNum(inSym, k); RETURN k
END SymRInt;
PROCEDURE SymRSet* (VAR s: SET);
BEGIN
ReadNumSet(inSym, s)
END SymRSet;
PROCEDURE SymRReal* (VAR r: SHORTREAL);
BEGIN
ReadReal(inSym, r)
END SymRReal;
PROCEDURE SymRLReal* (VAR lr: REAL);
BEGIN
ReadLReal(inSym, lr)
END SymRLReal;
PROCEDURE eofSF* (): BOOLEAN;
BEGIN
RETURN inSym.eof
END eofSF;
PROCEDURE OldSym* (VAR modName: ARRAY OF SHORTCHAR; VAR done: BOOLEAN);
VAR tag: INTEGER; loc: Files.Locator; dir, name: Files.Name;
BEGIN
done := FALSE;
IF modName = "@file" THEN
oldSymFile := file
ELSE
name := modName$; Kernel.SplitName(name, dir, name);
Kernel.MakeFileName(name, Kernel.symType);
loc := Files.dir.This(dir); loc := loc.This(symDir);
oldSymFile := Files.dir.Old(loc, name, Files.shared);
IF (oldSymFile = NIL) & (dir = "") THEN
loc := Files.dir.This(SYSdir); loc := loc.This(symDir);
oldSymFile := Files.dir.Old(loc, name, Files.shared)
END
END;
IF oldSymFile # NIL THEN
inSym := oldSymFile.NewReader(inSym);
IF inSym # NIL THEN
ReadLInt(inSym, tag);
IF tag = SFtag THEN done := TRUE ELSE err(151) END
END
END
END OldSym;
PROCEDURE CloseOldSym*;
BEGIN
IF oldSymFile # NIL THEN oldSymFile.Close; oldSymFile := NIL END
END CloseOldSym;
(* write symbol file *)
PROCEDURE SymWCh* (ch: SHORTCHAR);
BEGIN
ChkSum(checksum, ORD(ch));
outSym.WriteByte(SHORT(ORD(ch)))
END SymWCh;
PROCEDURE SymWInt* (i: INTEGER);
BEGIN
WriteNum(outSym, i)
END SymWInt;
PROCEDURE SymWSet* (s: SET);
BEGIN
WriteNumSet(outSym, s)
END SymWSet;
PROCEDURE SymWReal* (VAR r: SHORTREAL);
BEGIN
WriteReal(outSym, r)
END SymWReal;
PROCEDURE SymWLReal* (VAR r: REAL);
BEGIN
WriteLReal(outSym, r)
END SymWLReal;
PROCEDURE SymReset*;
BEGIN
outSym.SetPos(4)
END SymReset;
PROCEDURE NewSym* (VAR modName: ARRAY OF SHORTCHAR);
VAR loc: Files.Locator; dir: Files.Name;
BEGIN
ObjFName := modName$; Kernel.SplitName(ObjFName, dir, ObjFName);
loc := Files.dir.This(dir); loc := loc.This(symDir);
symFile := Files.dir.New(loc, Files.ask);
IF symFile # NIL THEN
outSym := symFile.NewWriter(NIL);
WriteLInt(outSym, SFtag)
ELSE
err(153)
END
END NewSym;
PROCEDURE RegisterNewSym*;
VAR res: INTEGER; name: Files.Name;
BEGIN
IF symFile # NIL THEN
name := ObjFName$;
Kernel.MakeFileName(name, Kernel.symType);
symFile.Register(name, Kernel.symType, Files.ask, res);
symFile := NIL
END
END RegisterNewSym;
PROCEDURE DeleteNewSym*;
BEGIN
IF symFile # NIL THEN symFile.Close; symFile := NIL END
END DeleteNewSym;
(* write object file *)
PROCEDURE ObjW* (ch: SHORTCHAR);
BEGIN
outObj.WriteByte(SHORT(ORD(ch)))
END ObjW;
PROCEDURE ObjWNum* (i: INTEGER);
BEGIN
WriteNum(outObj, i)
END ObjWNum;
PROCEDURE ObjWInt (i: SHORTINT);
BEGIN
outObj.WriteByte(SHORT(SHORT(i MOD 256)));
outObj.WriteByte(SHORT(SHORT(i DIV 256)))
END ObjWInt;
PROCEDURE ObjWLInt* (i: INTEGER);
BEGIN
ObjWInt(SHORT(i MOD 65536));
ObjWInt(SHORT(i DIV 65536))
END ObjWLInt;
PROCEDURE ObjWBytes* (VAR bytes: ARRAY OF SHORTCHAR; n: INTEGER);
TYPE P = POINTER TO ARRAY [untagged] 100000H OF BYTE;
VAR p: P;
BEGIN
p := SYSTEM.VAL(P, SYSTEM.ADR(bytes));
outObj.WriteBytes(p^, 0, n)
END ObjWBytes;
PROCEDURE ObjLen* (): INTEGER;
BEGIN
RETURN outObj.Pos()
END ObjLen;
PROCEDURE ObjSet* (pos: INTEGER);
BEGIN
outObj.SetPos(pos)
END ObjSet;
PROCEDURE NewObj* (VAR modName: ARRAY OF SHORTCHAR);
VAR loc: Files.Locator; dir: Files.Name;
BEGIN
errpos := 0;
ObjFName := modName$; Kernel.SplitName(ObjFName, dir, ObjFName);
loc := Files.dir.This(dir); loc := loc.This(codeDir);
objFile := Files.dir.New(loc, Files.ask);
IF objFile # NIL THEN
outObj := objFile.NewWriter(NIL);
WriteLInt(outObj, OFtag)
ELSE
err(153)
END
END NewObj;
PROCEDURE RegisterObj*;
VAR res: INTEGER; name: Files.Name;
BEGIN
IF objFile # NIL THEN
name := ObjFName$;
Kernel.MakeFileName(name, Kernel.objType);
objFile.Register(name, Kernel.objType, Files.ask, res);
objFile := NIL; outObj := NIL
END
END RegisterObj;
PROCEDURE DeleteObj*;
BEGIN
IF objFile # NIL THEN objFile.Close; objFile := NIL END
END DeleteObj;
PROCEDURE InitHost;
VAR test: SHORTINT; lo: SHORTCHAR;
BEGIN
test := 1; SYSTEM.GET(SYSTEM.ADR(test), lo); LEHost := lo = 1X;
InfReal := SYSTEM.VAL(SHORTREAL, InfRealPat);
MinReal32 := SYSTEM.VAL(SHORTREAL, MinReal32Pat);
MaxReal32 := SYSTEM.VAL(SHORTREAL, MaxReal32Pat);
MinReal64 := Compound(MinReal64PatL, MinReal64PatH);
MaxReal64 := Compound(MaxReal64PatL, MaxReal64PatH)
END InitHost;
BEGIN
InitCrcTab;
InitHost
END DevCPM.