Oberon/V2/OCT
< Oberon
MODULE OCT; (*NW 28.5.87 / 5.3.91*)
IMPORT Files, OCS;
CONST maxImps = 24; SFtag = 0FAX; firstStr = 16;
maxStr = 80; maxUDP = 16; maxMod = 24; maxParLev = 6;
PtrSize = 4; ProcSize = 4; NotYetExp = 0;
(*object modes*)
Var = 1; Ind = 3; Con = 8; Fld = 12; Typ = 13;
XProc = 15; SProc = 16; CProc = 17; Mod = 19; Head = 20;
(*structure forms*)
Undef = 0; Byte = 1; Bool = 2; Char = 3; SInt = 4; Int = 5; LInt = 6;
Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12;
Pointer = 13; ProcTyp = 14; Array = 15; DynArr = 16; Record = 17;
TYPE
Object* = POINTER TO ObjDesc;
Struct* = POINTER TO StrDesc;
ObjDesc* = RECORD
dsc*, next*: Object;
typ*: Struct;
a0*, a1*: LONGINT;
a2*: INTEGER;
mode*: SHORTINT;
marked*: BOOLEAN;
name*: ARRAY 32 OF CHAR;
END ;
StrDesc* = RECORD
form*, n*, mno*, ref*: INTEGER;
size*, adr*: LONGINT;
BaseTyp*: Struct;
link*, strobj*: Object
END ;
Item* = RECORD
mode*, lev*: INTEGER;
a0*, a1*, a2*: LONGINT;
typ*: Struct;
obj*: Object
END ;
VAR topScope*: Object;
undftyp*, bytetyp*, booltyp*, chartyp*, sinttyp*, inttyp*, linttyp*,
realtyp*, lrltyp*, settyp*, stringtyp*, niltyp*, notyp*: Struct;
nofGmod*: INTEGER; (*nof imports*)
GlbMod*: ARRAY maxImps OF Object;
universe, syslink: Object;
strno, udpinx: INTEGER; (*for export*)
nofExp: SHORTINT;
SR: Files.Rider;
undPtr: ARRAY maxUDP OF Struct;
PROCEDURE Init*;
BEGIN topScope := universe; strno := 0; udpinx := 0; nofGmod := 0
END Init;
PROCEDURE Close*;
VAR i: INTEGER;
BEGIN Files.Set(SR, NIL, 0); i := 0;
WHILE i < maxImps DO GlbMod[i] := NIL; INC(i) END
END Close;
PROCEDURE FindImport*(mod: Object; VAR res: Object);
VAR obj: Object;
BEGIN obj := mod.dsc;
WHILE (obj # NIL) & (obj.name # OCS.name) DO obj := obj.next END ;
IF (obj # NIL) & (obj.mode = Typ) & ~obj.marked THEN obj := NIL END ;
res := obj
END FindImport;
PROCEDURE Find*(VAR res: Object; VAR level: INTEGER);
VAR obj, head: Object;
BEGIN head := topScope;
LOOP obj := head.next;
WHILE (obj # NIL) & (obj.name # OCS.name) DO obj := obj.next END ;
IF obj # NIL THEN level := SHORT(head.a0); EXIT END ;
head := head.dsc;
IF head = NIL THEN level := 0; EXIT END
END ;
res := obj
END Find;
PROCEDURE FindField*(typ: Struct; VAR res: Object);
VAR obj: Object;
BEGIN (*typ.form = Record*)
LOOP obj := typ.link;
WHILE (obj # NIL) & (obj.name # OCS.name) DO obj := obj.next END ;
IF obj # NIL THEN EXIT END ;
typ := typ.BaseTyp;
IF typ = NIL THEN EXIT END
END ;
res := obj
END FindField;
PROCEDURE Insert*(VAR name: ARRAY OF CHAR; VAR res: Object);
VAR obj, new: Object;
BEGIN obj := topScope;
WHILE (obj.next # NIL) & (obj.next.name # name) DO obj := obj.next END ;
IF obj.next = NIL THEN NEW(new);
new.dsc := NIL; new.next := NIL; COPY(name, new.name); obj.next := new; res := new
ELSE res := obj.next;
IF obj.next.mode # Undef THEN OCS.Mark(1) END
END
END Insert;
PROCEDURE OpenScope*(level: INTEGER);
VAR head: Object;
BEGIN NEW(head);
head.mode := Head; head.a0 := level; head.typ := NIL;
head.dsc := topScope; head.next := NIL; topScope := head
END OpenScope;
PROCEDURE CloseScope*;
BEGIN topScope := topScope.dsc
END CloseScope;
(*---------------------- import ------------------------*)
PROCEDURE ReadInt(VAR i: INTEGER);
BEGIN Files.ReadBytes(SR, i, 2)
END ReadInt;
PROCEDURE ReadXInt(VAR k: LONGINT);
VAR i: INTEGER;
BEGIN Files.ReadBytes(SR, i, 2); k := i
END ReadXInt;
PROCEDURE ReadLInt(VAR k: LONGINT);
BEGIN Files.ReadBytes(SR, k, 4)
END ReadLInt;
PROCEDURE ReadId(VAR id: ARRAY OF CHAR);
VAR i: INTEGER; ch: CHAR;
BEGIN i := 0;
REPEAT Files.Read(SR, ch); id[i] := ch; INC(i)
UNTIL ch = 0X
END ReadId;
PROCEDURE Import*(VAR name, self, FileName: ARRAY OF CHAR);
VAR i, j, m, s, class: INTEGER; k: LONGINT;
nofLmod, strno, parlev, fldlev: INTEGER;
obj, ob0: Object;
typ: Struct;
ch, ch1, ch2: CHAR;
si: SHORTINT;
xval: REAL; yval: LONGREAL;
SymFile: Files.File;
modname: ARRAY 32 OF CHAR;
LocMod: ARRAY maxMod OF Object;
struct: ARRAY maxStr OF Struct;
lastpar, lastfld: ARRAY maxParLev OF Object;
PROCEDURE reversedList(p: Object): Object;
VAR q, r: Object;
BEGIN q := NIL;
WHILE p # NIL DO
r := p.next; p.next := q; q := p; p := r
END ;
RETURN q
END reversedList;
BEGIN nofLmod := 0; strno := firstStr;
parlev := -1; fldlev := -1;
IF FileName = "SYSTEM.Sym" THEN
Insert(name, obj); obj.mode := Mod; obj.dsc := syslink;
obj.a0 := 0; obj.typ := notyp
ELSE SymFile := Files.Old(FileName);
IF SymFile # NIL THEN
Files.Set(SR, SymFile, 0); Files.Read(SR, ch);
IF ch = SFtag THEN
struct[Undef] := undftyp; struct[Byte] := bytetyp;
struct[Bool] := booltyp; struct[Char] := chartyp;
struct[SInt] := sinttyp; struct[Int] := inttyp;
struct[LInt] := linttyp; struct[Real] := realtyp;
struct[LReal] := lrltyp; struct[Set] := settyp;
struct[String] := stringtyp; struct[NilTyp] := niltyp; struct[NoTyp] := notyp;
LOOP (*read next item from symbol file*)
Files.Read(SR, ch); class := ORD(ch);
IF SR.eof THEN EXIT END ;
CASE class OF
0: OCS.Mark(151)
| 1..7: (*object*) NEW(obj); m := 0;
Files.Read(SR, ch); s := ORD(ch); obj.typ := struct[s];
CASE class OF
1: obj.mode := Con;
CASE obj.typ.form OF
2,4: Files.Read(SR, si); obj.a0 := si
| 1,3: Files.Read(SR, ch); obj.a0 := ORD(ch)
| 5: ReadXInt(obj.a0)
| 6,7,9: ReadLInt(obj.a0)
| 8: ReadLInt(obj.a0); ReadLInt(obj.a1)
| 10: ReadId(obj.name); OCS.Mark(151)
| 11: (*NIL*)
END
|2,3: obj.mode := Typ; Files.Read(SR, ch); m := ORD(ch);
IF obj.typ.strobj = NIL THEN obj.typ.strobj := obj END;
obj.marked := class = 2
|4: obj.mode := Var; ReadLInt(obj.a0)
|5,6,7: IF class # 7 THEN obj.mode := XProc; Files.Read(SR, ch)
ELSE obj.mode := CProc;
Files.Read(SR, ch); Files.Read(SR, ch); Files.Read(SR, ch)
END ;
obj.a0 := ORD(ch); obj.a1 := 0; (*link adr*)
obj.dsc := reversedList(lastpar[parlev]); DEC(parlev)
END ;
ReadId(obj.name); ob0 := LocMod[m];
WHILE (ob0.next # NIL)&(ob0.next.name # obj.name) DO
ob0 := ob0.next
END ;
IF ob0.next = NIL THEN ob0.next := obj; obj.next := NIL (*insert object*)
ELSIF obj.mode = Typ THEN struct[s] := ob0.next.typ
END
| 8..12: (*structure*)
NEW(typ); typ.strobj := NIL; typ.ref := 0;
Files.Read(SR, ch); typ.BaseTyp := struct[ORD(ch)];
Files.Read(SR, ch); typ.mno := SHORT(LocMod[ORD(ch)].a0);
CASE class OF
8: typ.form := Pointer; typ.size := PtrSize; typ.n := 0
| 9: typ.form := ProcTyp; typ.size := ProcSize;
typ.link := reversedList(lastpar[parlev]); DEC(parlev)
| 10: typ.form := Array; ReadLInt(typ.size);
ReadXInt(typ.adr); ReadLInt(k); typ.n := SHORT(k)
| 11: typ.form := DynArr; ReadLInt(typ.size); ReadXInt(typ.adr)
| 12: typ.form := Record; ReadLInt(typ.size); typ.n := 0;
typ.link := reversedList(lastfld[fldlev]); DEC(fldlev);
IF typ.BaseTyp = notyp THEN typ.BaseTyp := NIL; typ.n := 0
ELSE typ.n := typ.BaseTyp.n + 1
END ;
ReadXInt(typ.adr) (*of descriptor*)
END ;
struct[strno] := typ; INC(strno)
| 13: (*parameter list start*)
IF parlev < maxParLev-1 THEN INC(parlev); lastpar[parlev] := NIL
ELSE OCS.Mark(229)
END
| 14, 15: (*parameter*)
NEW(obj);
IF class = 14 THEN obj.mode := Var ELSE obj.mode := Ind END ;
Files.Read(SR, ch); obj.typ := struct[ORD(ch)];
ReadXInt(obj.a0); ReadId(obj.name);
obj.dsc := NIL; obj.next := lastpar[parlev]; lastpar[parlev] := obj
| 16: (*start field list*)
IF fldlev < maxParLev-1 THEN INC(fldlev); lastfld[fldlev] := NIL
ELSE OCS.Mark(229)
END
| 17: (*field*)
NEW(obj); obj.mode := Fld; Files.Read(SR, ch);
obj.typ := struct[ORD(ch)]; ReadLInt(obj.a0);
ReadId(obj.name); obj.marked := TRUE;
obj.dsc := NIL; obj.next := lastfld[fldlev]; lastfld[fldlev] := obj
| 18: (*hidden pointer field*)
NEW(obj); obj.mode := Fld; ReadLInt(obj.a0);
obj.name := ""; obj.typ := notyp; obj.marked := FALSE;
obj.dsc := NIL; obj.next := lastfld[fldlev]; lastfld[fldlev] := obj
| 19: (*hidden procedure field*)
ReadLInt(k)
| 20: (*fixup pointer typ*)
Files.Read(SR, ch); typ := struct[ORD(ch)];
Files.Read(SR, ch1);
IF typ.BaseTyp = undftyp THEN typ.BaseTyp := struct[ORD(ch1)] END
| 21, 23, 24: OCS.Mark(151); EXIT
| 22: (*module anchor*)
ReadLInt(k); ReadId(modname);
IF modname = self THEN OCS.Mark(49) END;
i := 0;
WHILE (i < nofGmod) & (modname # GlbMod[i].name) DO INC(i) END ;
IF i < nofGmod THEN (*module already present*)
IF k # GlbMod[i].a1 THEN OCS.Mark(150) END ;
obj := GlbMod[i]
ELSE NEW(obj);
IF nofGmod < maxImps THEN GlbMod[nofGmod] := obj; INC(nofGmod)
ELSE OCS.Mark(227)
END ;
obj.mode := NotYetExp; COPY(modname, obj.name);
obj.a1 := k; obj.a0 := nofGmod; obj.next := NIL
END ;
IF nofLmod < maxMod THEN LocMod[nofLmod] := obj; INC(nofLmod)
ELSE OCS.Mark(227)
END
END
END (*LOOP*) ;
Insert(name, obj);
obj.mode := Mod; obj.dsc := LocMod[0].next;
obj.a0 := LocMod[0].a0; obj.typ := notyp
ELSE OCS.Mark(151)
END
ELSE OCS.Mark(152) (*sym file not found*)
END
END
END Import;
(*---------------------- export ------------------------*)
PROCEDURE WriteByte(i: INTEGER);
BEGIN Files.Write(SR, CHR(i))
END WriteByte;
PROCEDURE WriteInt(i: LONGINT);
BEGIN Files.WriteBytes(SR, i, 2)
END WriteInt;
PROCEDURE WriteLInt(k: LONGINT);
BEGIN Files.WriteBytes(SR, k, 4)
END WriteLInt;
PROCEDURE WriteId(VAR name: ARRAY OF CHAR);
VAR ch: CHAR; i: INTEGER;
BEGIN i := 0;
REPEAT ch := name[i]; Files.Write(SR, ch); INC(i)
UNTIL ch = 0X
END WriteId;
PROCEDURE^ OutStr(typ: Struct);
PROCEDURE OutPars(par: Object);
BEGIN WriteByte(13);
WHILE (par # NIL) & (par.mode <= Ind) & (par.a0 > 0) DO
OutStr(par.typ);
IF par.mode = Var THEN WriteByte(14) ELSE WriteByte(15) END ;
WriteByte(par.typ.ref); WriteInt(par.a0); WriteId(par.name); par := par.next
END
END OutPars;
PROCEDURE OutFlds(fld: Object; adr: LONGINT; visible: BOOLEAN);
BEGIN
IF visible THEN WriteByte(16) END ;
WHILE fld # NIL DO
IF fld.marked & visible THEN
OutStr(fld.typ); WriteByte(17); WriteByte(fld.typ.ref);
WriteLInt(fld.a0); WriteId(fld.name)
ELSIF fld.typ.form = Record THEN OutFlds(fld.typ.link, fld.a0 + adr, FALSE)
ELSIF (fld.typ.form = Pointer) OR (fld.name = "") THEN
WriteByte(18); WriteLInt(fld.a0 + adr)
END ;
fld := fld.next
END
END OutFlds;
PROCEDURE OutStr(typ: Struct);
VAR m, em, r: INTEGER; btyp: Struct; mod: Object;
BEGIN
IF typ.ref = 0 THEN
m := typ.mno; btyp := typ.BaseTyp;
IF m > 0 THEN mod := GlbMod[m-1]; em := mod.mode;
IF em = NotYetExp THEN
GlbMod[m-1].mode := nofExp; m := nofExp; INC(nofExp);
WriteByte(22); WriteLInt(mod.a1); WriteId(mod.name)
ELSE m := em
END
END;
CASE typ.form OF
Undef .. NoTyp:
| Pointer: WriteByte(8);
IF btyp.ref > 0 THEN WriteByte(btyp.ref)
ELSE WriteByte(Undef);
IF udpinx < maxUDP THEN undPtr[udpinx] := typ; INC(udpinx)
ELSE OCS.Mark(224)
END
END ;
WriteByte(m)
| ProcTyp: OutStr(btyp); OutPars(typ.link);
WriteByte(9); WriteByte(btyp.ref); WriteByte(m)
| Array: OutStr(btyp);
WriteByte(10); WriteByte(btyp.ref); WriteByte(m);
WriteLInt(typ.size); WriteInt(typ.adr); WriteLInt(typ.n)
| DynArr: OutStr(btyp);
WriteByte(11); WriteByte(btyp.ref); WriteByte(m);
WriteLInt(typ.size); WriteInt(typ.adr)
| Record:
IF btyp = NIL THEN r := NoTyp
ELSE OutStr(btyp); r := btyp.ref
END ;
OutFlds(typ.link, 0, TRUE); WriteByte(12); WriteByte(r); WriteByte(m);
WriteLInt(typ.size); WriteInt(typ.adr)
END ;
IF typ.strobj # NIL THEN
IF typ.strobj.marked THEN WriteByte(2) ELSE WriteByte(3) END;
WriteByte(strno); WriteByte(m); WriteId(typ.strobj.name)
END ;
typ.ref := strno; INC(strno);
IF strno > maxStr THEN OCS.Mark(228) END
END
END OutStr;
PROCEDURE OutObjs;
VAR obj: Object;
f: INTEGER; xval: REAL; yval: LONGREAL;
BEGIN obj := topScope.next;
WHILE obj # NIL DO
IF obj.marked THEN
IF obj.mode = Con THEN
WriteByte(1); f := obj.typ.form; WriteByte(f);
CASE f OF
Undef:
| Byte, Bool, Char, SInt: WriteByte(SHORT(obj.a0))
| Int: WriteInt(SHORT(obj.a0))
| LInt, Real, Set: WriteLInt(obj.a0)
| LReal: WriteLInt(obj.a0); WriteLInt(obj.a1)
| String: WriteByte(0); OCS.Mark(221)
| NilTyp:
END;
WriteId(obj.name)
ELSIF obj.mode = Typ THEN
OutStr(obj.typ);
IF (obj.typ.strobj # obj) & (obj.typ.strobj # NIL) THEN
WriteByte(2); WriteByte(obj.typ.ref); WriteByte(0); WriteId(obj.name)
END
ELSIF obj.mode = Var THEN
OutStr(obj.typ); WriteByte(4);
WriteByte(obj.typ.ref); WriteLInt(obj.a0); WriteId(obj.name)
ELSIF obj.mode = XProc THEN
OutStr(obj.typ); OutPars(obj.dsc); WriteByte(5);
WriteByte(obj.typ.ref); WriteByte(SHORT(obj.a0)); WriteId(obj.name)
ELSIF obj.mode = CProc THEN
OutStr(obj.typ); OutPars(obj.dsc); WriteByte(7);
WriteByte(obj.typ.ref); WriteByte(2); WriteByte(226);
WriteByte(SHORT(obj.a0)); WriteId(obj.name)
END
END ;
obj := obj.next
END
END OutObjs;
PROCEDURE Export*(VAR name, FileName: ARRAY OF CHAR;
VAR newSF: BOOLEAN; VAR key: LONGINT);
VAR i: INTEGER;
ch0, ch1: CHAR;
oldkey: LONGINT;
typ: Struct;
oldFile, newFile: Files.File;
oldSR: Files.Rider;
BEGIN newFile := Files.New(FileName);
IF newFile # NIL THEN
Files.Set(SR, newFile, 0); Files.Write(SR, SFtag); strno := firstStr;
WriteByte(22); WriteLInt(key); WriteId(name); nofExp := 1;
OutObjs; i := 0;
WHILE i < udpinx DO
typ := undPtr[i]; OutStr(typ.BaseTyp); undPtr[i] := NIL; INC(i);
WriteByte(20); (*fixup*)
WriteByte(typ.ref); WriteByte(typ.BaseTyp.ref)
END ;
IF ~OCS.scanerr THEN
oldFile := Files.Old(FileName);
IF oldFile # NIL THEN (*compare*)
Files.Set(oldSR, oldFile, 2); Files.ReadBytes(oldSR, oldkey, 4);
Files.Set(SR, newFile, 6);
REPEAT Files.Read(oldSR, ch0); Files.Read(SR, ch1)
UNTIL (ch0 # ch1) OR SR.eof;
IF oldSR.eof & SR.eof THEN (*equal*) newSF := FALSE; key := oldkey
ELSIF newSF THEN Files.Register(newFile)
ELSE OCS.Mark(155)
END
ELSE Files.Register(newFile); newSF := TRUE
END
ELSE newSF := FALSE
END
ELSE OCS.Mark(153)
END
END Export;
(*------------------------ initialization ------------------------*)
PROCEDURE InitStruct(VAR typ: Struct; f: INTEGER);
BEGIN NEW(typ); typ.form := f; typ.ref := f; typ.size := 1
END InitStruct;
PROCEDURE EnterConst(name: ARRAY OF CHAR; value: INTEGER);
VAR obj: Object;
BEGIN Insert(name, obj); obj.mode := Con; obj.typ := booltyp; obj.a0 := value
END EnterConst;
PROCEDURE EnterTyp(name: ARRAY OF CHAR; form,
size: INTEGER; VAR res: Struct);
VAR obj: Object; typ: Struct;
BEGIN Insert(name, obj);
NEW(typ); obj.mode := Typ; obj.typ := typ; obj.marked := TRUE;
typ.form := form; typ.strobj := obj; typ.size := size;
typ.mno := 0; typ.ref := form; res := typ
END EnterTyp;
PROCEDURE EnterProc(name: ARRAY OF CHAR; num: INTEGER);
VAR obj: Object;
BEGIN Insert(name, obj); obj.mode := SProc; obj.typ := notyp; obj.a0 := num
END EnterProc;
BEGIN topScope := NIL; InitStruct(undftyp, Undef); InitStruct(notyp, NoTyp);
InitStruct(stringtyp, String); InitStruct(niltyp, NilTyp); OpenScope(0);
(*initialization of module SYSTEM*)
EnterProc("LSH", 22); EnterProc("ROT", 23); EnterProc("ADR", 9);EnterProc("OVFL",15);
EnterProc("GET", 24); EnterProc("PUT", 25); EnterProc("BIT", 26); EnterProc("VAL", 27);
EnterProc("NEW", 28); EnterProc("MOVE",30); EnterProc("CC", 2);
EnterTyp("BYTE", Byte, 1, bytetyp);
syslink := topScope.next; universe := topScope; topScope.next := NIL;
EnterTyp("CHAR", Char, 1, chartyp); EnterTyp("SET", Set, 4, settyp);
EnterTyp("REAL", Real, 4, realtyp); EnterTyp("INTEGER", Int, 2, inttyp);
EnterTyp("LONGINT", LInt, 4, linttyp); EnterTyp("LONGREAL", LReal, 8, lrltyp);
EnterTyp("SHORTINT", SInt, 1, sinttyp); EnterTyp("BOOLEAN", Bool, 1, booltyp);
EnterProc("INC", 16); EnterProc("DEC", 17); EnterConst("FALSE", 0);
EnterConst("TRUE", 1); EnterProc("HALT", 0); EnterProc("NEW", 1);
EnterProc("ABS", 3); EnterProc("CAP", 4); EnterProc("ORD", 5);
EnterProc("ENTIER", 6); EnterProc("SIZE", 7); EnterProc("ODD", 8);
EnterProc("MIN", 10); EnterProc("MAX", 11); EnterProc("CHR", 12);
EnterProc("SHORT", 13); EnterProc("LONG", 14); EnterProc("INCL", 18);
EnterProc("EXCL", 19); EnterProc("LEN", 20); EnterProc("ASH", 21);
EnterProc("COPY", 29)
END OCT.