-- JaMControl.mesa
-- Written by John Warnock, Feb., 1979.
-- Last changed by Doug Wyatt, January 12, 1981  5:42 PM

DIRECTORY
	JaMControlDefs,
	JaMMasterDefs USING [
		CommandArray, CommandIndex, Frame, MaxCommands, Object, StackLink],
	JaMArrayDefs USING [JaMArray],
	JaMAttributesDefs USING [JaMAttributes],
	JaMDictionaryDefs USING [JaMDictionary,
		DictBegin, DictDefine, DictDict, DictGet, DictWhere],
	JaMExecDefs USING [JaMExec,
		JaMError],
	JaMFnsDefs USING [JaMFns,
		PopBoolean, PopObject, PopString, PushObject],
	JaMIODefs USING [JaMIO],
	JaMLiteralDefs USING [JaMLiteral,
		BooleanLit, IntegerLit, MakeStringObject, StringLit],
	JaMMathDefs USING [JaMMath],
	JaMScannerDefs USING [JaMScanner],
	JaMStackDefs USING [JaMStack, Push, Top],
	JaMStartDefs USING [JaMStart],
	JaMStringDefs USING [JaMString],
	JaMTypeChkDefs USING [JaMTypeChk],
	JaMVMDefs USING [JaMVM,
		AllocateWordsVM, FlushVM, GetWordsVM, GetWordVM,
		PutWordsVM, PutWordVM, RestartVM],
	FrameDefs USING [IsBound, LoadConfig],
	ImageDefs USING [AddCleanupProcedure, AllReasons, BcdTime,
		CleanupItem, CleanupProcedure, StopMesa],
	IODefs USING [LineOverflow],
	LoaderOps USING [InvalidFile, VersionMismatch],
	MiscDefs USING [CallDebugger],
	SegmentDefs USING [FileNameError],
	StringDefs USING [AppendString, EqualString],
	SystemDefs USING [AllocateHeapString, AllocateSegment],
	TimeDefs USING [AppendDayTime, PackedTime, UnpackDT];

JaMControl: PROGRAM
IMPORTS JaMArrayDefs,JaMAttributesDefs,JaMDictionaryDefs,JaMExecDefs,
	JaMFnsDefs,JaMIODefs,JaMLiteralDefs,JaMMathDefs,JaMScannerDefs,
	JaMStackDefs,JaMStartDefs,JaMStringDefs,JaMTypeChkDefs,vm:JaMVMDefs,
	FrameDefs,ImageDefs,IODefs,LoaderOps,MiscDefs,
	SegmentDefs,StringDefs,SystemDefs,TimeDefs
EXPORTS JaMControlDefs  =
BEGIN OPEN JaMLiteralDefs,JaMMasterDefs;

-- This is the main control program for JaM. This program STARTs JaM's
-- modules, registers several critical commands, and then transfers
-- execution control to JaMStart.

LongFileName: StringType Object;  --must be initialized after starting VM
BadFileName: StringType Object;
BadFile: StringType Object;
BadCommand: StringType Object;
CommandOvrFlw: StringType Object;

OldVM: BOOLEAN;
SysDict: Object;

commandarray: PUBLIC POINTER TO CommandArray_NIL;

GetCommandArray: PUBLIC PROCEDURE RETURNS[POINTER TO CommandArray] =
	BEGIN RETURN[commandarray] END;

internalmax: CARDINAL = 16;
maxcommands: CARDINAL = MaxCommands - internalmax;
commandindexcount: CARDINAL_0;
internalindex: CARDINAL_maxcommands;

-- Commands known to the current VM and image are
--  [0..commandindexcount)
-- internal Commands known to the current image are
--  [maxcommands..internalindex)

maxcommandpairs: CARDINAL = maxcommands;
CommandPair: TYPE = RECORD[string: STRING, proc: PROCEDURE];
CommandPairTable: TYPE = ARRAY[0..maxcommandpairs) OF CommandPair;
commandpaircount: CARDINAL_0;
commandpairs: POINTER TO CommandPairTable _ NIL;

maxstringobs: CARDINAL = 50;
StringObIndex: TYPE = [0..maxstringobs);
StringObArray: TYPE = ARRAY StringObIndex OF StringType Object;
StringArray: TYPE = ARRAY StringObIndex OF STRING;
stringobcount: CARDINAL_0;
stringobs: POINTER TO StringObArray _ NIL;
strings: POINTER TO StringArray _ NIL;

maxstringpairs: CARDINAL = 100;
StringPair: TYPE = RECORD[index: StringObIndex,
	ob: POINTER TO StringType Object];
StringPairTable: TYPE = ARRAY[0..maxstringpairs) OF StringPair;
stringpaircount: CARDINAL_0;
stringpairs: POINTER TO StringPairTable _ NIL;

-- the initial frame stack. (note: 1 entry).
FrameStack: TYPE = ARRAY FrameStkPtr OF Frame;
nframes: CARDINAL=1;
FrameStkPtr: TYPE = [0..nframes);
nlinks: CARDINAL=SIZE[Frame]*nframes;
StackLinkArray: TYPE = ARRAY[0..nlinks) OF StackLink;
framestack: POINTER TO FrameStack_NIL;
stacklinks: POINTER TO StackLinkArray_NIL;
frameplace: FrameStkPtr_0;
frame: Frame;

GetCurrentFrame: PUBLIC PROCEDURE RETURNS[frm:Frame] =
	BEGIN RETURN[frame] END;

CopyString: PROCEDURE[string: STRING] RETURNS[STRING] =
	BEGIN
	s: STRING_SystemDefs.AllocateHeapString[string.length];
	StringDefs.AppendString[s,string];
	RETURN[s];
	END;

NotifyOverflow: SIGNAL=CODE;

NotifyCommand: PUBLIC PROCEDURE
	[stringname: STRING, procedure: PROCEDURE] =
	BEGIN
	IF commandpaircount ~< maxcommandpairs THEN
		BEGIN SIGNAL NotifyOverflow; RETURN END;
	commandpairs[commandpaircount]_[CopyString[stringname],procedure];
	commandpaircount_commandpaircount+1;
	END;

AddStringOb: PROCEDURE[s: STRING] RETURNS[StringObIndex] =
	BEGIN
	i: CARDINAL;
	FOR i IN[0..stringobcount)
		DO IF StringDefs.EqualString[strings[i],s] THEN RETURN[i] ENDLOOP;
	IF stringobcount ~< maxstringobs THEN
		BEGIN SIGNAL NotifyOverflow; RETURN[0] END;
	strings[i_stringobcount]_CopyString[s];
	stringobcount_stringobcount+1;
	RETURN[i];
	END;

NotifyStringObject: PUBLIC PROCEDURE
	[sob: POINTER TO StringType Object, stringvalue: STRING] =
	BEGIN
	IF stringpaircount ~< maxstringpairs THEN
		BEGIN SIGNAL NotifyOverflow; RETURN END;
	stringpairs[stringpaircount]_[AddStringOb[stringvalue],sob];
	stringpaircount_stringpaircount+1;
	END;

RegisterCommand: PROCEDURE[name: STRING, procedure: PROCEDURE] =
	BEGIN
	JaMLiteralDefs.StringLit[name,frame.opstk];
	IF OldVM AND RegisterOldCommand[procedure] THEN RETURN;
	RegisterNewCommand[procedure];
	END;
	
LookupObject: PROCEDURE[key,ob: POINTER TO Object] RETURNS[BOOLEAN] =
	BEGIN
	JaMFnsDefs.PushObject[key^];
	JaMDictionaryDefs.DictWhere[];
	IF NOT JaMFnsDefs.PopBoolean[] THEN RETURN[FALSE];
	JaMFnsDefs.PushObject[key^];
	JaMDictionaryDefs.DictGet[];
	ob^_JaMFnsDefs.PopObject[];
	RETURN[TRUE];
	END;

RegisterOldCommand: PROCEDURE[procedure: PROCEDURE]
	RETURNS[BOOLEAN] =
	BEGIN
	nameob,ob: Object;
	nameob_JaMFnsDefs.PopObject[];
	IF LookupObject[@nameob,@ob] THEN WITH dob:ob SELECT FROM
		CommandType =>
			BEGIN commandarray[dob.Command]_procedure; RETURN[TRUE] END;
		ENDCASE;
	JaMFnsDefs.PushObject[nameob];
	RETURN[FALSE];
	END;

RegisterNewCommand: PROCEDURE[procedure: PROCEDURE] =
	BEGIN
	command: Object;
	IF commandindexcount ~< maxcommands THEN
		ERROR JaMExecDefs.JaMError[CommandOvrFlw,FALSE];
	command_[nolit,CommandType[Command:commandindexcount]];
	commandarray[commandindexcount]_procedure;
	commandindexcount _ commandindexcount+1;
	UpdateCICount; -- update VM's version of commandindexcount
	JaMFnsDefs.PushObject[command];
	JaMDictionaryDefs.DictDefine[];
	END;

RegisterExtCommand: PUBLIC PROCEDURE
	[stringname: STRING, procedure: PROCEDURE] =
	BEGIN
	RegisterCommand[stringname,procedure];
	NotifyCommand[stringname,procedure];
	END;

RegisterIntCommand: PUBLIC PROCEDURE[procedure: PROCEDURE]
	RETURNS[c: CommandType Object] =
	BEGIN
	IF NOT internalindex < MaxCommands THEN
		ERROR JaMExecDefs.JaMError[CommandOvrFlw,FALSE];
	internalindex _ internalindex+1;
	commandarray[internalindex]_procedure;
	RETURN[[nolit,CommandType[Command:internalindex]]];
	END;

RegisterString: PROCEDURE[stringname: STRING, stringval: STRING] =
	BEGIN
	frame: Frame_GetCurrentFrame[];
	JaMLiteralDefs.StringLit[stringname,frame.opstk];
	JaMStackDefs.Push[JaMLiteralDefs.MakeStringObject[stringval],frame.opstk];
	JaMDictionaryDefs.DictDefine[];
	END;

RegisterBoolean: PROCEDURE[obname: STRING, b: BOOLEAN] =
	BEGIN
	frame: Frame_GetCurrentFrame[];
	JaMLiteralDefs.StringLit[obname,frame.opstk];
	JaMLiteralDefs.BooleanLit[b,frame.opstk];
	JaMDictionaryDefs.DictDefine[];
	END;

RegisterObject: PROCEDURE[obname: STRING, ob: Object] =
	BEGIN
	frame: Frame_GetCurrentFrame[];
	JaMLiteralDefs.StringLit[obname,frame.opstk];
	JaMStackDefs.Push[ob,frame.opstk];
	JaMDictionaryDefs.DictDefine[];
	END;

UnregisteredCommand: PROCEDURE =
	BEGIN
	ERROR JaMExecDefs.JaMError[BadCommand,TRUE];
	END;

Quit: PROCEDURE = BEGIN ImageDefs.StopMesa[] END;

LoadBCD: PROCEDURE = { BCDLoader[debug: FALSE] };
-- Expects opstk: (bcdFileName)
-- Loads and STARTS the configuration in bcdFileName

DebugBCD: PROCEDURE = { BCDLoader[debug: TRUE] };
-- Expects opstk: (bcdFileName)
-- Like LoadBCD, but invokes the debugger before STARTing

BCDLoader: PROCEDURE[debug: BOOLEAN] =
	BEGIN
	s: STRING _ [40];
	extended: BOOLEAN _ FALSE;
	prog: PROGRAM;
	JaMFnsDefs.PopString[s ! IODefs.LineOverflow =>
		ERROR JaMExecDefs.JaMError[LongFileName,TRUE]];
	prog_FrameDefs.LoadConfig[s !
		SegmentDefs.FileNameError =>
			BEGIN
			--maybe extension omitted
			IF extended THEN GOTO BadName;
			StringDefs.AppendString[s,".bcd"]; extended_TRUE;
			RETRY;
			END;
		LoaderOps.InvalidFile,
		LoaderOps.VersionMismatch => GO TO BadVersion];
	IF debug THEN
		BEGIN
		message: STRING _ [60];
		StringDefs.AppendString[message,"About to START "];
		StringDefs.AppendString[message,s];
		MiscDefs.CallDebugger[message];
		END;
	IF FrameDefs.IsBound[prog] THEN START prog;
	EXITS
		BadName => ERROR JaMExecDefs.JaMError[BadFileName,TRUE];
		BadVersion => ERROR JaMExecDefs.JaMError[BadFile,TRUE];
	END;

-- hard-wired VM addresses of commandindexcount and SysDict
vmaCICount: LONG POINTER = LOOPHOLE[LONG[0]];
vmaSysDict: LONG POINTER = LOOPHOLE[LONG[1]];

StartVM: PROCEDURE =
	BEGIN OPEN vm;
	-- fire up the VM
	OldVM _ RestartVM["JaM.VM",1000,20];
	IF OldVM THEN
		BEGIN
		commandindexcount_GetWordVM[vmaCICount,0];
		GetWordsVM[vmaSysDict,@SysDict,SIZE[Object]];
		JaMStackDefs.Push[SysDict,frame.dictstk];
		END
	ELSE
		BEGIN
		-- Build the System Dictionary (note: only 256 entries).
		vma: LONG POINTER;
		IF (vma _ AllocateWordsVM[1])#vmaCICount THEN ERROR;
		IF (vma _ AllocateWordsVM[SIZE[Object]])#vmaSysDict THEN ERROR;
		JaMLiteralDefs.IntegerLit[256,frame.opstk];
		JaMDictionaryDefs.DictDict[];
		JaMDictionaryDefs.DictBegin[];
		SysDict_JaMStackDefs.Top[frame.dictstk];
		PutWordsVM[vmaSysDict,@SysDict,SIZE[Object]];
		commandindexcount_0; UpdateCICount;
		END;
	END;

UpdateCICount: PROCEDURE =
	BEGIN
	vm.PutWordVM[commandindexcount,vmaCICount,0];
	END;

--installType: CARDINAL=4476; // some "random" number
--
--InstallCommandsAndStrings: PROCEDURE =
--	BEGIN
--	ob: Object;
--	vma,vmaddress: LONG POINTER;
--	clength,slength: CARDINAL;
--	clength_commandindexcount*SIZE[PROCEDURE];
--	slength_stringobcount*SIZE[StringType Object];
--	vmaddress_vm.AllocateWordsVM[1+clength+slength];
--	vm.PutWordVM[commandindexcount,vmaddress,0];
--	vma_vmaddress+1;
--	vm.PutWordsVM[vma,commandarray,clength];
--	vma_vma+clength;
--	vm.PutWordsVM[vma,stringobs,slength];
--	ob_[lit,UserType[Type: installType, Address: vmaddress]];
--	JaMFnsDefs.PushObject[imagekey];
--	JaMFnsDefs.PushObject[ob];
--	JaMDictionaryDefs.DictDefine[];
--	END;

--RestoreCommandsAndStrings: PROCEDURE RETURNS[restored: BOOLEAN] =
--	BEGIN
--	RETURN[FALSE];
--	ob: Object;
--	vma,vmaddress: LONG POINTER;
--	ccount,clength,slength: CARDINAL;
--	IF NOT LookupObject[@imagekey,@ob] THEN RETURN[FALSE];
--	WITH dob:ob SELECT FROM
--		UserType =>
--			BEGIN
--			IF dob.Type#installType THEN RETURN[FALSE];
--			vmaddress_dob.Address;
--			END;
--		ENDCASE => RETURN[FALSE];
--	ccount_vm.GetWordVM[vmaddress,0];
--	clength_ccount*SIZE[PROCEDURE];
--	slength_stringobcount*SIZE[StringType Object];
--	vma_vmaddress+1;
--	vm.GetWordsVM[vma,commandarray,clength];
--	vma_vma+clength;
--	vm.GetWordsVM[vma,stringobs,slength];
--	RETURN[TRUE];
--	END;

ReRegister: PROCEDURE =
	BEGIN
	i: CARDINAL;
	-- Initialize commandarray
	FOR i IN [0..maxcommands)
		DO commandarray[i]_UnregisteredCommand ENDLOOP;

	-- Register commands and strings if necessary
--	IF NOT RestoreCommandsAndStrings[] THEN
		BEGIN
		-- Register commands
		FOR i IN[0..commandpaircount)
			DO OPEN cp:commandpairs[i];
			RegisterCommand[cp.string,cp.proc];
			ENDLOOP;
		-- Register string objects
		FOR i IN[0..stringobcount)
			DO
			stringobs[i]_JaMLiteralDefs.MakeStringObject[strings[i]];
			ENDLOOP;
	--	InstallCommandsAndStrings;
		END;

	-- copy string objects
	FOR i IN[0..stringpaircount)
		DO OPEN sp:stringpairs[i];
		sp.ob^_stringobs[sp.index];
		ENDLOOP;
	END;

imagekey: Object;
version: STRING _ [40];

AllocArrays: PROCEDURE[Alloc: PROCEDURE[CARDINAL] RETURNS[POINTER]] =
	BEGIN
	commandarray _ Alloc[SIZE[CommandArray]];
	commandpairs _ Alloc[SIZE[CommandPairTable]];
	stringobs _ Alloc[SIZE[StringObArray]];
	strings _ Alloc[SIZE[StringArray]];
	stringpairs _ Alloc[SIZE[StringPairTable]];
	framestack _ Alloc[SIZE[FrameStack]];
	stacklinks _ Alloc[SIZE[StackLinkArray]];
	END;

InitControl: PROCEDURE = {
	i: CARDINAL;
	versiontime: TimeDefs.PackedTime;

	-- Allocate arrays
	BEGIN
	words: CARDINAL_0;
	p: POINTER_NIL;
	Count: PROCEDURE[size: CARDINAL] RETURNS[POINTER] =
		BEGIN words_words+size; RETURN[NIL] END;
	Alloc: PROCEDURE[size: CARDINAL] RETURNS[POINTER] =
		BEGIN q: POINTER_p; p_p+size; RETURN[q] END;
	AllocArrays[Count]; -- count words required
	p_SystemDefs.AllocateSegment[words]; -- get a large enough block
	AllocArrays[Alloc]; -- now allocate out of the block
	END;

	FOR i IN [0..maxcommandpairs)
		DO commandpairs[i]_[NIL,UnregisteredCommand] ENDLOOP;
	commandpaircount_0;
	FOR i IN [0..maxstringobs)
		DO stringobs[i]_[nolit,StringType[0,0,NIL]]; strings[i]_NIL ENDLOOP;
	stringobcount_0;
	FOR i IN [0..maxstringpairs)
		DO stringpairs[i]_[0,NIL] ENDLOOP;
	stringpaircount_0;

	-- Initialize frame stack
	FOR i IN [0..nlinks) DO stacklinks[i] _ NIL ENDLOOP;
	FOR i IN FrameStkPtr DO
		framestack[i] _
			[@stacklinks[SIZE[Frame]*i],
			 @stacklinks[SIZE[Frame]*i+1],
			 @stacklinks[SIZE[Frame]*i+2]]
		ENDLOOP;
	frameplace_0;
	frame _ framestack[frameplace];

	-- Start everybody else
	-- The START code for a JaM module should not attempt to use the VM.
	-- Each module should use NotifyCommand and NotifyStringObject
	-- to notify JaMControl of commands and strings to be installed
	-- when the VM is ready.
	-- Each module is expected to register its own intrinsics.

	START JaMLiteralDefs.JaMLiteral;
	START JaMStackDefs.JaMStack;
	START JaMDictionaryDefs.JaMDictionary;
	START JaMIODefs.JaMIO;
	START JaMAttributesDefs.JaMAttributes;
	START JaMMathDefs.JaMMath;
	START JaMArrayDefs.JaMArray;
	START JaMStringDefs.JaMString;
	START JaMFnsDefs.JaMFns;
	START JaMTypeChkDefs.JaMTypeChk;
	START JaMScannerDefs.JaMScanner;
	START JaMExecDefs.JaMExec;
	START JaMStartDefs.JaMStart;
	StartControl; -- me too

	-- JaMVM should not have been invoked up to now.
	START vm.JaMVM;

	-- Initialize timestamp and version
	versiontime_ImageDefs.BcdTime[];
	imagekey_[nolit,LongIntegerType[LOOPHOLE[versiontime]]];
	StringDefs.AppendString[version, "(JaM of "L];
	TimeDefs.AppendDayTime[version,TimeDefs.UnpackDT[versiontime]];
	StringDefs.AppendString[version, "
) .print"L];
	};

RunControl: PROC = {
	-- start up the VM
	StartVM[];
	ImageDefs.AddCleanupProcedure[@cleanup];

	-- Record commands and strings in the VM
	ReRegister;

	-- A name for the system dictionary
	RegisterObject[".sysdict"L,SysDict];
	-- An error handler for undefined keys
	RegisterString[".undefkey"L," (Undefined key - .undefkey: ).print
			(                    ) .cvis .print"L];
	--Booleans
	RegisterBoolean[".true"L,TRUE];
	RegisterBoolean[".false"L,FALSE];

	RegisterString[".prompt"L,"(*) .print"L];
	RegisterString[".version"L,version];
	IF ~OldVM THEN RegisterString[".start"L,".version"L];
	};

StartControl: PROCEDURE =
	BEGIN
	NotifyStringObject[@LongFileName, ".longname"L];
	NotifyStringObject[@BadFileName, ".badname"L];
	NotifyStringObject[@BadFile, ".badbcdfile"L];
	NotifyStringObject[@BadCommand, ".unregistered"L];
	NotifyStringObject[@CommandOvrFlw, ".commandovrflw"L];

	-- Commands implemented by JaMControl
	NotifyCommand[".quit"L,Quit];
	NotifyCommand[".loadbcd"L,LoadBCD];
	NotifyCommand[".debugbcd"L,DebugBCD];
	END;

-- Initialization
cleanup: ImageDefs.CleanupItem _ [link: NIL,
	mask: ImageDefs.AllReasons, proc: CleanupJaMControl];

CleanupJaMControl: ImageDefs.CleanupProcedure =
	BEGIN
	SELECT why FROM
		Finish,Abort => vm.FlushVM[];
		ENDCASE;
	END;

InitControl[];
STOP;
RunControl[];

END.

DKW  January 17, 1980  4:02 AM
	added .herald

DKW  March 25, 1980  1:01 PM
	changed .herald to .version
	added .start initialization

DKW  March 26, 1980  11:10 PM
	changed LoadBCD: defaulting omitted ".bcd" now works

DKW  March 28, 1980  4:34 PM
	Added the .makeimage command. Substantially changed initialization code
	to make this possible: added AddStartProc, and a CleanupProcedure to redo
	necessary initialization when an image is restarted. JaMControl is now the
	control module for JaM; it takes care of STARTing all other JaM modules,
	then invokes JaMStart.

DKW  March 29, 1980  1:16 AM
	removed GetCommandArray; see JaMControlDefs.CallCommand

DKW  May 9, 1980  4:18 PM
	changed MakeImage to MakeUnMergedImage

DKW  May 31, 1980  1:03 AM
	updated for Mesa 6

DKW  July 14, 1980  11:08 PM
	changed RunConfig to LoadConfig;START

DKW  July 25, 1980  1:52 PM
	no longer makes JaM.image

DKW  December 15, 1980  11:45 AM
	disabled InstallCommandsAndStrings stuff

DKW  January 9, 1981  3:51 PM
	introduced STOP between InitControl and RunControl
	JaMRun now takes care of starting Reals and calling JaMStartDefs.RunJaM

DKW  January 12, 1981  5:41 PM
	BCDLoader doesn't try to START a config with no control module
(600)\2262b15B86b1B148b1B1327b15B272b13B627b18B1578b18B157b18B