Oberon/V2/OCT

From Wikibooks, open books for an open world
Jump to navigation Jump to search
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.