Oberon/V2/Modules

MODULE Modules; (*NW 16.2.86 / 7.4.91*)
	IMPORT SYSTEM, Kernel, FileDir, Files;

	CONST ModNameLen* = 20; ObjMark = 0F8X;

	TYPE Module* = POINTER TO ModDesc;
	Command* = PROCEDURE;
		ModuleName* = ARRAY ModNameLen OF CHAR;

		ModDesc* = RECORD SB*, LB*, PB*, BB*, CB*, RB*, IB*, size*, key*: LONGINT;
				name*: ModuleName;
				refcnt*: LONGINT;
				link*: Module
			END ;

	VAR res*: INTEGER;
		importing*, imported*: ModuleName;
		loop: Command;
		
	PROCEDURE ReadName(VAR R: Files.Rider; VAR s: ARRAY OF CHAR; n: INTEGER);
		VAR ch: CHAR; i: INTEGER;
	BEGIN i := 0;
		REPEAT Files.Read(R, ch); s[i] := ch; INC(i)
		UNTIL ch = 0X;
		WHILE i < n DO Files.Read(R, ch); s[i] := 0X; INC(i) END
	END ReadName;

	PROCEDURE OpenFile(VAR F: Files.File; VAR name: ARRAY OF CHAR);
		VAR i: INTEGER; ch: CHAR;
			Fname: ARRAY 32 OF CHAR;
	BEGIN i := 0; ch := name[0]; (*make file name*)
		WHILE ch > 0X DO Fname[i] := ch; INC(i); ch := name[i] END ;
		Fname[i] := "."; Fname[i+1] := "O"; Fname[i+2] := "b"; Fname[i+3] := "j"; Fname[i+4] := 0X;
		F := Files.Old(Fname)
	END OpenFile;

	PROCEDURE PD(mod: Module; pc: LONGINT): LONGINT;
	BEGIN (*procedure descriptor*)
		RETURN ASH(pc, 16) + SYSTEM.VAL(LONGINT, mod)
	END PD;

	PROCEDURE ThisMod*(name: ARRAY OF CHAR): Module;
		(*search module in list; if not found, load module*)

		VAR
			mod, impmod, md: Module;
			ch: CHAR; mno, pno: SHORTINT;
			i, j: INTEGER;
			nofentries, nofimps, nofptrs, comsize, noflinks, constsize, codesize: INTEGER;
			varsize, size, key, impkey, k, p, q, pos1, pos2: LONGINT;
			init: Command;
			F: Files.File; R: Files.Rider;
			modname, impname: ModuleName;
			Fname: ARRAY FileDir.FnLength OF CHAR;
			import: ARRAY 16 OF Module;

		PROCEDURE err(n: INTEGER);
		BEGIN
			IF res = 0 THEN res := n; COPY(name, imported) END
		END err;
		
	BEGIN res := 0; mod := SYSTEM.VAL(Module, Kernel.ModList);
		LOOP
			IF name = mod.name THEN EXIT END ;
			mod := mod.link;
			IF mod = NIL THEN EXIT END
		END ;
		IF mod = NIL THEN (*load*)
			OpenFile(F, name);
			IF F # NIL THEN
				Files.Set(R, F, 0); Files.Read(R, ch); (*header*)
				IF ch # ObjMark THEN err(2); RETURN NIL END ;
				Files.Read(R, ch);
				IF ch # "6" THEN err(2); RETURN NIL END ;
				Files.ReadBytes(R, k, 4); (*skip*)
				Files.ReadBytes(R, nofentries, 2); Files.ReadBytes(R, comsize, 2);
				Files.ReadBytes(R, nofptrs, 2); Files.ReadBytes(R, nofimps, 2);
				Files.ReadBytes(R, noflinks, 2); Files.ReadBytes(R, varsize, 4);
				Files.ReadBytes(R, constsize, 2); Files.ReadBytes(R, codesize, 2);
				Files.ReadBytes(R, key, 4); ReadName(R, modname, ModNameLen);
				i := (nofentries + nofptrs)*2 + comsize;
				pos1 := Files.Pos(R); Files.Set(R, F, pos1 + i + 3);
				INC(i, nofimps*2); k := (i MOD 4) + i;
				(*imports*) Files.Read(R, ch);
				IF ch # 85X THEN err(4); RETURN NIL END ;
				res := 0; i := 0;
				WHILE (i < nofimps) & (res = 0) DO
					Files.ReadBytes(R, impkey, 4); ReadName(R, impname, 0); Files.Read(R, ch);
					impmod := ThisMod(impname);
					IF res = 0 THEN
						IF impmod.key = impkey THEN import[i] := impmod; INC(i); INC(impmod.refcnt)
						ELSE res := 3; imported := impname; importing := modname
						END
					END
				END ;
				IF res # 0 THEN
					WHILE i > 0 DO DEC(i); DEC(import[i].refcnt) END ;
					RETURN NIL
				END ;

				pos2 := Files.Pos(R);
				size := k + noflinks*4 + constsize + codesize + varsize;
				Kernel.AllocBlock(q, p, size); mod := SYSTEM.VAL(Module, q);
				mod.size := size;
				mod.BB := p;
				mod.CB := nofentries*2 + p;
				mod.RB := comsize + mod.CB;
				mod.IB := nofptrs*2 + mod.RB;
				mod.LB := k + p;
				mod.SB := (noflinks*4 + varsize) + mod.LB;
				mod.PB := constsize + mod.SB;
				mod.refcnt := 0;
				mod.key := key;
				mod.name := modname;
				
				(*entries*) q := mod.CB; Files.Set(R, F, pos1); Files.Read(R, ch);
				IF ch # 82X THEN err(4); RETURN NIL END ;
				WHILE p < q DO Files.Read(R, ch); SYSTEM.PUT(p, ch); INC(p) END ;

				(*commands*) q := mod.RB; Files.Read(R, ch);
				IF ch # 83X THEN err(4); RETURN NIL END ;
				WHILE p < q DO Files.Read(R, ch); SYSTEM.PUT(p, ch); INC(p) END ;

				(*pointer references*) q := mod.IB; Files.Read(R, ch);
				IF ch # 84X THEN err(4); RETURN NIL END ;
				WHILE p < q DO Files.Read(R, ch); SYSTEM.PUT(p, ch); INC(p) END ;
				i := 0;
				WHILE i < nofimps DO SYSTEM.PUT(p, import[i]); INC(p, 2); INC(i) END ;

				(*links*) Files.Set(R, F, pos2+1); p := mod.LB; q := noflinks*4 + p;
				WHILE p < q DO
					Files.Read(R, pno); Files.Read(R, mno);
					IF mno > 0 THEN md := import[mno-1] ELSE md := mod END ;
					IF pno = -1 THEN SYSTEM.PUT(p, md.SB) (*data segment entry*)
					ELSE SYSTEM.GET(pno*2 + md.BB, i);
						SYSTEM.PUT(p, PD(md, i)) (*procedure entry*)
					END ;
					INC(p, 4)
				END ;

				(*variables*) q := mod.SB;
				WHILE p < q DO SYSTEM.PUT(p, 0); INC(p) END ;

				(*constants*) q := mod.PB; Files.Read(R, ch);
				IF ch # 87X THEN err(4); RETURN NIL END ;
				WHILE p < q DO Files.Read(R, ch); SYSTEM.PUT(p, ch); INC(p) END ;

				(*code*) q := p + codesize; Files.Read(R, ch);
				IF ch # 88X THEN err(4); RETURN NIL END ;
				WHILE p < q DO Files.Read(R, ch); SYSTEM.PUT(p, ch); INC(p) END ;

				(*type descriptors*) Files.Read(R, ch);
				IF ch # 89X THEN err(4); RETURN NIL END ;
				LOOP Files.ReadBytes(R, i, 2);
					IF R.eof OR (i MOD 100H = 8AH) THEN EXIT END ;
					Files.ReadBytes(R, j, 2); (*adr*)
					SYSTEM.NEW(md, i);
					p := SYSTEM.VAL(LONGINT, md); q := p + i;
					REPEAT Files.Read(R, ch); SYSTEM.PUT(p, ch); INC(p) UNTIL p = q;
					SYSTEM.PUT(mod.SB + j, md)
				END ;

				init := SYSTEM.VAL(Command, mod); init;
			ELSE COPY(name, imported); err(1)
			END
		END ;
		RETURN mod
	END ThisMod;

	PROCEDURE ThisCommand*(mod: Module; name: ARRAY OF CHAR): Command;
		VAR i: INTEGER; ch: CHAR;
			comadr: LONGINT; com: Command;
	BEGIN com := NIL;
		IF mod # NIL THEN
			comadr := mod.CB; res := 5;
			LOOP SYSTEM.GET(comadr, ch); INC(comadr);
				IF ch = 0X THEN (*not found*) EXIT END ;
				i := 0;
				LOOP
					IF ch # name[i] THEN EXIT END ;
					INC(i);
					IF ch = 0X THEN res := 0; EXIT END ;
					SYSTEM.GET(comadr, ch); INC(comadr)
				END ;
				IF res = 0 THEN (*match*)
					SYSTEM.GET(comadr, i); com := SYSTEM.VAL(Command, PD(mod, i)); EXIT
				ELSE
					WHILE ch > 0X DO SYSTEM.GET(comadr, ch); INC(comadr) END ;
					INC(comadr, 2)
				END
			END
		END ;
		RETURN com
	END ThisCommand;

	PROCEDURE unload(mod: Module; all: BOOLEAN);
		VAR p: LONGINT; k: INTEGER;
		imp: Module;
	BEGIN p := mod.IB;
		WHILE p < mod.LB DO (*scan imports*)
			SYSTEM.GET(p, k); imp := SYSTEM.VAL(Module, LONG(k));
			IF imp # NIL THEN
				DEC(imp.refcnt);
				IF all & (imp.refcnt = 0) THEN unload(imp, all) END
			END ;
			INC(p, 2)
		END ;
		Kernel.FreeBlock(SYSTEM.VAL(LONGINT, mod))
	END unload;

	PROCEDURE Free*(name: ARRAY OF CHAR; all: BOOLEAN);
		VAR mod: Module;
	BEGIN mod := SYSTEM.VAL(Module, Kernel.ModList);
		LOOP
			IF mod = NIL THEN res := 1; EXIT END ;
			IF name = mod.name THEN
				IF mod.refcnt = 0 THEN unload(mod, all); res := 0 ELSE res := 2 END ;
				EXIT
			END ;
			mod := mod.link
		END
	END Free;

BEGIN
	IF Kernel.err = 0 THEN loop := ThisCommand(ThisMod("Oberon"), "Loop") END ;
	loop
END Modules.