-- JaMControl.mesa
-- Written by John Warnock, Feb., 1979.
-- Last changed by Doug Wyatt, February 10, 1981  7:26 PM
-- Last changed by Doug Brotz, June 8, 1981  10:47 PM

DIRECTORY
	JaMControlDefs,
	JaMMasterDefs USING [Frame, Object, StackLink],
	JaMArrayDefs USING [JaMArray],
	JaMAttributesDefs USING [JaMAttributes],
	JaMDictionaryDefs USING [JaMDictionary, DictBegin, DictDefine,
		DictDict, DictGet, DictWhere],
	JaMExecDefs USING [JaMExec, JaMError,
		badbcdfile, badname, commandovrflw, longname, unregistered],
	JaMFnsDefs USING [JaMFns, PopBoolean, PopObject, PopString, PushObject],
	JaMInterruptDefs USING [KillJaMBreak],
	JaMIODefs USING [JaMIO],
	JaMLiteralDefs USING [JaMLiteral, BooleanLit, IntegerLit,
		MakeStringObject, StringLit],
	JaMMathDefs USING [JaMMath],
	JaMScannerDefs USING [JaMScanner],
	JaMStackDefs USING [CleanupStack, JaMStack, Push, Top],
	JaMStartDefs USING [JaMStart],
	JaMStringDefs USING [JaMString],
	JaMTypeChkDefs USING [JaMTypeChk],
	JaMVMDefs USING [JaMVM, AllocateWordsVM, FlushVM, GetWordsVM,
		GetWordVM, PutWordsVM, PutWordVM, RestartVM],
	BcdDefs USING [VersionID],
	BcdOps USING [BcdBase],
	ControlDefs USING [ControlModule, NullControl],
	FrameDefs USING [IsBound, UnlockCode, UnNewConfig],
	FrameOps USING [Start],
	ImageDefs USING [AddCleanupProcedure, AllReasons, BcdTime,
		CleanupItem, CleanupProcedure, StopMesa],
	IODefs USING [LineOverflow],
	LaurelExecDefs USING [MakeMenuCommandCallable],
	LoaderOps USING [BadCode, FileNotFound, InvalidFile, New,
		VersionMismatch],
	MiscDefs USING [CallDebugger],
	Real USING [InitReals],
	SegmentDefs USING [DefaultMDSBase, DeleteFileSegment, FileHandle,
		FileNameError, FileSegmentAddress, FileSegmentHandle, HardUp,
		InsufficientVM, LockFile, MakeSwappedIn, MoveFileSegment,
		NewFile, NewFileSegment, OldFileOnly, Read, ReleaseFile,
		SegmentFault, Unlock, UnlockFile],
	StringDefs USING [AppendString, StringBoundsFault],
	SystemDefs USING [AllocateHeapNode, AllocateSegment, FreeHeapNode,
		FreeSegment, PruneHeap],
	TimeDefs USING [AppendDayTime, PackedTime, UnpackDT];

JaMControl: PROGRAM
IMPORTS JaMArrayDefs, JaMAttributesDefs, JaMDictionaryDefs,
	JaMExecDefs, JaMFnsDefs, JaMInterruptDefs, JaMIODefs, JaMLiteralDefs,
	JaMMathDefs, JaMScannerDefs, JaMStackDefs, JaMStartDefs,
	JaMStringDefs, JaMTypeChkDefs, vm:JaMVMDefs,
	FrameDefs, FrameOps, ImageDefs, IODefs, LaurelExecDefs, LoaderOps, MiscDefs,
	Real, 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.

OldVM: BOOLEAN;
SysDict: Object;

CommandArray: TYPE = JaMControlDefs.CommandArray;
commands: PUBLIC POINTER TO CommandArray_NIL;

MaxCommands: CARDINAL = 512;
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)

-- 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;

RegisterCommand: PUBLIC PROCEDURE[stringname: STRING, procedure: PROCEDURE] =
	BEGIN
	JaMLiteralDefs.StringLit[stringname,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 => { commands[dob.Command]_procedure; RETURN[TRUE] };
		ENDCASE;
	JaMFnsDefs.PushObject[nameob];
	RETURN[FALSE];
	END;

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

RegisterIntCommand: PUBLIC PROCEDURE[procedure: PROCEDURE]
	RETURNS[c: CommandType Object] =
	BEGIN
	IF NOT internalindex < MaxCommands THEN
		{ OPEN JaMExecDefs; ERROR JaMError[commandovrflw,FALSE] };
	internalindex _ internalindex+1;
	commands[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 =
	{ OPEN JaMExecDefs; ERROR JaMError[unregistered,TRUE] };

Quit: PROCEDURE = 
	BEGIN
	IF FrameDefs.IsBound[LaurelExecDefs.MakeMenuCommandCallable] THEN
	BEGIN
		THROUGH [1..2] DO FrameDefs.UnlockCode[Real.InitReals]; ENDLOOP;
		JaMInterruptDefs.KillJaMBreak[];
		vm.FlushVM[];
		UNTIL loadedConfigs = NIL DO UnNewLastConfig[]; ENDLOOP;
		IF commands # NIL THEN SystemDefs.FreeSegment[commands];
		JaMStackDefs.CleanupStack[];
		[] _ SystemDefs.PruneHeap[];
		ERROR QuitError;
		END
	ELSE ImageDefs.StopMesa[];
	END;

QuitError: PUBLIC ERROR = CODE;

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

LoadedConfigRec: TYPE = RECORD
	[next: LoadedConfigRecPtr,
	cm: ControlDefs.ControlModule,
	bcdFile: SegmentDefs.FileHandle];
LoadedConfigRecPtr: TYPE = POINTER TO LoadedConfigRec;

loadedConfigs: LoadedConfigRecPtr _ NIL;

BCDLoader: PROCEDURE [debug: BOOLEAN] =
	BEGIN
		OPEN SegmentDefs;
	s: STRING _ [40];
	extended: BOOLEAN _ FALSE;
	bcdFile: FileHandle _ NIL;
	cm: ControlDefs.ControlModule _ ControlDefs.NullControl;
	bcd: BcdOps.BcdBase;
	bcdseg: FileSegmentHandle;
	oldLoadedConfigs: LoadedConfigRecPtr;

	OurLoad: PROCEDURE RETURNS [worked: BOOLEAN] =
		-- This is derived from AltoLoader.Load and incorporates some bug
		-- fixes and some optimizations.
		BEGIN
		pages: CARDINAL;
		worked _ FALSE;
		bcdseg _ NewFileSegment[bcdFile, 1, 1, Read];
		MakeSwappedIn[bcdseg, DefaultMDSBase, HardUp
			! SegmentFault => GO TO bogus];
		bcd _ FileSegmentAddress[bcdseg];
		IF bcd.versionIdent # BcdDefs.VersionID OR bcd.definitions THEN
			{Unlock[bcdseg]; GO TO bogus}
		ELSE IF (pages _ bcd.nPages) > 1 THEN
			BEGIN
			Unlock[bcdseg];
			MoveFileSegment[bcdseg, 1, pages];
			MakeSwappedIn[bcdseg, DefaultMDSBase, HardUp];
			bcd _ FileSegmentAddress[bcdseg];
			END;
		worked _ TRUE;
		EXITS
		bogus => DeleteFileSegment[bcdseg];
		END;  -- of OurLoad --

	OurUnload: PROCEDURE =
		BEGIN
		Unlock[bcdseg];
		DeleteFileSegment[bcdseg];
		END;  -- of OurUnload --

	BEGIN
	JaMFnsDefs.PopString[s ! IODefs.LineOverflow =>
		{ OPEN JaMExecDefs; ERROR JaMError[longname,TRUE] }];
	bcdFile _ NewFile[s, Read, OldFileOnly
		! FileNameError =>
			BEGIN
			--maybe extension omitted
			IF extended THEN GOTO BadName;
			StringDefs.AppendString[s,".bcd"L];
			extended_TRUE;
			RETRY;
			END];
	LockFile[bcdFile];
	IF ~OurLoad[ ! InsufficientVM => GO TO out] THEN GO TO cantExecute;
	cm _ LoaderOps.New[bcd, TRUE, FALSE
		! LoaderOps.BadCode => GO TO cantExecute;
		LoaderOps.InvalidFile,
		LoaderOps.VersionMismatch => GO TO BadVersion;
		StringDefs.StringBoundsFault,
		LoaderOps.FileNotFound => GO TO out;
		InsufficientVM => {OurUnload[]; GO TO out} ];
	IF cm = ControlDefs.NullControl THEN GO TO cantExecute;
	IF debug THEN
		BEGIN
		message: STRING _ [60];
		StringDefs.AppendString[message,"About to START "];
		StringDefs.AppendString[message,s];
		MiscDefs.CallDebugger[message];
		END;
	FrameOps.Start[cm ! UNWIND => FrameDefs.UnNewConfig[cm.frame]];
	oldLoadedConfigs _ loadedConfigs;
	loadedConfigs _ SystemDefs.AllocateHeapNode[SIZE[LoadedConfigRec]];
	loadedConfigs^ _ LoadedConfigRec[oldLoadedConfigs, cm, bcdFile];
	EXITS
		BadName => {OPEN JaMExecDefs; ERROR JaMError[badname,TRUE]};
		BadVersion => {OPEN JaMExecDefs; ERROR JaMError[badbcdfile, TRUE]};
		cantExecute,
		out => IF bcdFile ~= NIL THEN
		{SegmentDefs.UnlockFile[bcdFile]; SegmentDefs.ReleaseFile[bcdFile]};
	END;
	END;

UnNewLastConfig: PROCEDURE =
	BEGIN
	newLoadedConfigs: LoadedConfigRecPtr;
	IF loadedConfigs = NIL THEN RETURN;
	newLoadedConfigs _ loadedConfigs.next;
	FrameDefs.UnNewConfig[loadedConfigs.cm.frame];
	IF loadedConfigs.bcdFile ~= NIL THEN
		{SegmentDefs.UnlockFile[loadedConfigs.bcdFile];
		SegmentDefs.ReleaseFile[loadedConfigs.bcdFile]};
	SystemDefs.FreeHeapNode[loadedConfigs];
	loadedConfigs _ newLoadedConfigs;
	END;  -- of UnNewLastConfig --


-- 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 =
	INLINE { vm.PutWordVM[commandindexcount,vmaCICount,0] };

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

AllocArrays: PROCEDURE[Alloc: PROCEDURE[CARDINAL] RETURNS[POINTER]] =
	BEGIN
	commands _ Alloc[SIZE[CommandArray[MaxCommands]]];
	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;

	-- Initialize command table
	FOR i: CARDINAL IN [0..MaxCommands)
		DO commands[i]_UnregisteredCommand ENDLOOP;

	-- 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
	-- Each JaM module should contain a STOP in its initialization code.
	-- It should not attempt to use the VM before that point.
	-- After being RESTARTed, it should use RegisterCommand 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;

	-- 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[];
	IF FrameDefs.IsBound[LaurelExecDefs.MakeMenuCommandCallable] THEN
		BEGIN
		LaurelExecDefs.MakeMenuCommandCallable[newMail];
		LaurelExecDefs.MakeMenuCommandCallable[user];
		LaurelExecDefs.MakeMenuCommandCallable[mailFile];
		LaurelExecDefs.MakeMenuCommandCallable[display];
		LaurelExecDefs.MakeMenuCommandCallable[delete];
		LaurelExecDefs.MakeMenuCommandCallable[undelete];
		LaurelExecDefs.MakeMenuCommandCallable[moveTo];
		LaurelExecDefs.MakeMenuCommandCallable[copy];
		END
	ELSE ImageDefs.AddCleanupProcedure[@cleanup];

	-- Record commands and strings in the VM
	RESTART JaMLiteralDefs.JaMLiteral;
	RESTART JaMStackDefs.JaMStack;
	RESTART JaMDictionaryDefs.JaMDictionary;
	RESTART JaMIODefs.JaMIO;
	RESTART JaMAttributesDefs.JaMAttributes;
	RESTART JaMMathDefs.JaMMath;
	RESTART JaMArrayDefs.JaMArray;
	RESTART JaMStringDefs.JaMString;
	RESTART JaMFnsDefs.JaMFns;
	RESTART JaMTypeChkDefs.JaMTypeChk;
	RESTART JaMScannerDefs.JaMScanner;
	RESTART JaMExecDefs.JaMExec;
	RESTART JaMStartDefs.JaMStart;

	-- Commands implemented by JaMControl
	RegisterCommand[".quit"L,Quit];
	RegisterCommand[".loadbcd"L,LoadBCD];
	RegisterCommand[".debugbcd"L,DebugBCD];
	RegisterCommand[".unnew"L,UnNewLastConfig];

	-- 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];
	};

-- 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

DKW  February 10, 1981  2:51 PM
	new form of CommandArray
	ripped out all the fancy installation code
	now RESTARTs all JaM modules after starting VM
(670)
DKB  June 5, 1981  3:02 PM
	Changed Quit to clean up more, raise QuitError if in Laurel.
	AddCleanupProcedure only if not running in Laurel.

DKB  June 8, 1981  11:59 AM
	Turn on Laurel commands if running inside Laurel.

DKB  June 8, 1981  10:47 PM
	Modified BcdLoader.  Added .unnew.