-- MDUtilImpl.Mesa
-- last edit by Schmidt, May 4, 1982 1:04 pm
-- last edit by Satterthwaite, January 31, 1983 9:29 am
-- Pilot 6.0/ Mesa 7.0
-- MDUtilImpl for the system modeller, defined in MDUtil
-- can't use the Dir stuff since it may not be around (e.g. Designmodel)

DIRECTORY
  Ascii: TYPE USING [CR],
  CWF: TYPE USING [FWF0, FWF1, FWF2, FWF3, FWFC, SetCode, SetWriteProcedure, SWF1, SWF3, 
  	WF0, WF1, WF2, WF4, WFC, WFCR],
  Dir: TYPE USING [DepSeq, FileInfo],
  Directory: TYPE USING [Error, GetProperty, Handle, Lookup, PropertyType, PutProperty],
  ExecOps: TYPE USING [Bind, Command, Outcome],
  Feedback: TYPE USING [BeginItemProc, CreateProc, DestroyProc, FinishItemProc, 
  	Handle, NoteProgressProc, Outcome, Procs],
  File: TYPE USING [Capability],
  FileStream: TYPE USING [EndOf],
  IO: TYPE USING[GetChar, Handle, Put, PutChar,
  		SetEcho, Signal, string],
  LongString: TYPE USING [AppendString, EqualString, EquivalentString],
  MDModel: TYPE USING [APPLSymbol, GetFileInfo, HasAStringName, 
  	LETSymbol, LISTSymbol, LocForType, LOCSymbol, LookForInstBcd, MODELSymbol, NarrowToAPPL, 
	NarrowToLET, NarrowToLIST, NarrowToLOC, NarrowToMODEL, NarrowToSTRING, 
	NarrowToTYPE, Sym, Symbol, SymbolSeq, TraverseList, TraverseTree, TYPESymbol],
  MDUtil: TYPE USING [],
  Rope: TYPE USING[Fetch, Length, Lower, ROPE, Text],
  Runtime: TYPE USING [IsBound, RunConfig],
  Stream: TYPE USING [Delete, GetChar, Handle, PutChar],
  Subr: TYPE USING [AbortMyself, Any, CopyString, EndsIn, FreeString, NewStream,
    Read, strcpy],
  TemporarySpecialExecOps: TYPE USING [BindUsingFeedback],
  TimeStamp: TYPE USING [Stamp],
  TypeScript: TYPE USING[ResetUserAbort, TS, UserAbort];

-- this monitor is for the AcquireMsgLock, ReleaseMsgLock lock

MDUtilImpl: MONITOR  
IMPORTS CWF, Directory, ExecOps, FileStream, IO, LongString, 
	MDModel, Rope, Runtime, Stream, Subr, TemporarySpecialExecOps, TypeScript
EXPORTS MDUtil = {

-- declarations used throughout this module
TooManySymbols: ERROR = CODE;

-- MDS Usage!!
msgLock: CONDITION;
msgLocked: BOOL _ FALSE;
--
controlloc: MDModel.LOCSymbol _ NIL;	-- the location (e.g. @) of "CONTROL"
ss: MDModel.SymbolSeq _ NIL;
curlen: CARDINAL; 	-- the current output column on the terminal
globalTypeScript: TypeScript.TS _ NIL;
officialwindow: IO.Handle _ NIL;
globalmsgout: IO.Handle _ NIL;
-- Binder-specific feedback stuff
binderState: {normal, warnings, errors};
-- for hidden imports
MakeBinary, MakeSource: PROC[LONG STRING] RETURNS[Dir.DepSeq] _ NIL;
savespmodel: MDModel.MODELSymbol _ NIL;
-- endof MDS usage !!!

THRESHOLD: CARDINAL = 60;
INDENTSIZE: CARDINAL = 6;
MAXLINES: CARDINAL = 60;

AcquireMsgLock: PUBLIC ENTRY PROC =
	{
	ENABLE UNWIND => NULL;
	WHILE msgLocked DO
		WAIT msgLock;
		ENDLOOP;
	msgLocked _ TRUE;
	};

ReleaseMsgLock: PUBLIC ENTRY PROC =
	{
	ENABLE UNWIND => NULL;
	msgLocked _ FALSE;
	NOTIFY msgLock;
	};
	
AnyR: PUBLIC PROC[str: Rope.ROPE, ch: CHAR] RETURNS[BOOL] = {
len: CARDINAL _ str.Length[];
FOR i: CARDINAL IN [0..len) DO
	IF str.Fetch[i] = ch THEN RETURN[TRUE];
	ENDLOOP;
RETURN[FALSE];
};

IOConfirm: PUBLIC PROC[dch: CHAR, in, out: IO.Handle] RETURNS[CHAR] =
	{
	ch: CHAR;
	old: IO.Handle;
	DO {
		ENABLE IO.Signal => TRUSTED {IF ec = Rubout THEN LOOP};
		out.Put[IO.string["? "L]];
		old _ IO.SetEcho[in, NIL];
		ch _ in.GetChar[ ! UNWIND => [] _ IO.SetEcho[in, old]];
		[] _ IO.SetEcho[in, old];
		IF ch = '\n THEN ch _ dch;
		ch _ Rope.Lower[ch];
		RETURN[ch];
		};
		ENDLOOP;
	};

-- if outsh = NIL then print on IOStream
PrintNewModelStream: PUBLIC PROC[symbolseq: MDModel.SymbolSeq, 
	sproot: MDModel.Symbol, outsh: Stream.Handle, title: Rope.Text,
	dontdefault: BOOL, typeScript: TypeScript.TS, ttyout: IO.Handle] = {
wp: PROC[CHAR];
nlines: CARDINAL _ 0;
NoMore: SIGNAL = CODE;
	
	Incr: PROC[ch: CHAR] = {
	IF ch = Ascii.CR THEN {
		curlen _ 0;
		nlines _ nlines + 1;
		}
	ELSE curlen _ curlen + 1;
	IF outsh = NIL THEN ttyout.PutChar[ch]
	ELSE Stream.PutChar[outsh, ch];
	};

ss _ symbolseq;
SetAllPrint[FALSE, symbolseq];
curlen _ 0;
wp _ CWF.SetWriteProcedure[Incr];
IF sproot.stype = typeLOC THEN {
	sploc: MDModel.LOCSymbol;
	spm: MDModel.MODELSymbol;
	sploc _ MDModel.NarrowToLOC[sproot];
	spm _ sploc.nestedmodel;
	IF spm ~= NIL AND sploc.host ~= NIL THEN 
		CWF.WF4["--[%s]<%s>%s.%s\n"L, sploc.host, sploc.path,
			sploc.tail, sploc.sext];
	-- avoid printing the LOC
	sproot _ spm;
	};
IF sproot.stype = typeMODEL THEN {
	spm: MDModel.MODELSymbol;
	spm _ MDModel.NarrowToMODEL[sproot];
	CWF.WF2["-- %s, %lt\n"L, spm.modelfilename, @spm.modelcreate];
	};
IF title ~= NIL THEN CWF.WF1["-- %s\n"L, LOOPHOLE[title]];
PrintNewModel[sproot, ";\n"L, NIL, 0, TRUE, dontdefault, typeScript
	! NoMore => CONTINUE];
CWF.WF0["\n"L];	
[] _ CWF.SetWriteProcedure[wp];
};

-- indent = 0 means no indenting
-- indent > 0 means levels of indenting
PrintNewModel: PROC[p: MDModel.Symbol, sep: STRING, parent: MDModel.Symbol,
	indent: CARDINAL, definitional, dontdefault: BOOL, typeScript: TypeScript.TS] = {
fprint: BOOL;
s: LONG STRING;

	ProcPrintModel: PROC[sp: MDModel.Symbol] = {
	IF fprint THEN CWF.WF0[sep];
	IF curlen >= THRESHOLD THEN {
		CWF.WFCR[];
		FOR i: CARDINAL IN [0.. indent*INDENTSIZE) DO
			CWF.WFC[' ];
			ENDLOOP;
		};
	-- this puts () around PLUS and THEN arguments
	IF Subr.Any[sep, 'U] OR Subr.Any[sep, 'N] THEN
		CWF.WFC['(];
	PrintNewModel[sp,sep,p, indent, definitional, dontdefault, typeScript];
	IF Subr.Any[sep, 'U] OR Subr.Any[sep, 'N] THEN
		CWF.WFC[')];
	fprint _ TRUE;
	};

IF p = NIL THEN {
	CWF.WF0["{p is NIL}"L];
	RETURN;
	};
IF NOT dontdefault AND NOT p.print THEN {
	IF definitional THEN {
		-- this default may only be used in a place that allows
		-- definitions
		IF ConsiderColonAbbr[p, indent, typeScript] THEN RETURN;
		IF ConsiderStarId[p, indent] THEN RETURN;
		};
	};
s _ NIL;
IF p.qualified THEN PrintQualified[p, ss]
ELSE IF p.stype IN MDModel.HasAStringName THEN {
	s _ MDModel.Sym[p];
	IF s ~= NIL THEN CWF.WF1["%s"L, s]
	ELSE IF p.stype = typeSTRING THEN 
		CWF.WF1["""%s"""L, MDModel.NarrowToSTRING[p].strval]
	ELSE CWF.WF0[">NULLSTR<"L];
	};
IF (NOT p.print AND definitional) OR p.stype NOT IN MDModel.HasAStringName THEN {
	p.print _ TRUE;		-- this avoids recursive print loops
	WITH pt: p SELECT FROM
	typeTYPE => {
		IF ss = NIL THEN ERROR;
		IF p = ss.controlv THEN RETURN; 	-- CONTROL 
		CWF.WF1[": %s"L, IF pt.frameptr THEN "FRAMEPTRTYPE"L ELSE "TYPE"L]; 
		IF NOT LongString.EquivalentString[pt.typeName, pt.typesym] THEN 
			CWF.WF1[" %s"L, pt.typeName];
		IF pt.typeval ~= NIL THEN {
			CWF.WF0["~"L];  --CWF.WF0[" == "L]; 
			PrintNewModel[pt.typeval,sep,p, indent,
				TRUE, dontdefault, typeScript];
			};
		};
	typeLOC => {
		IF TypeScript.UserAbort[typeScript]THEN SIGNAL Subr.AbortMyself;
		PrintLoc[MDModel.NarrowToLOC[p], dontdefault, indent, parent, typeScript];
		};
	typePROC => {
		CWF.WF0[": PROC ["L];
		IF pt.procparm ~= NIL THEN
			PrintNewModel[pt.procparm,",\n\t"L,p, indent,
				TRUE, dontdefault, typeScript];
		CWF.WF0["]\nRETURNS ["L];
		IF pt.procret ~= NIL THEN 
			PrintNewModel[pt.procret,", "L,p, indent,
				FALSE, dontdefault, typeScript];
		CWF.WF0["] [\n"L];
		IF pt.procval ~= NIL THEN 
			PrintNewModel[pt.procval,";\n"L,p, indent,
				TRUE, dontdefault, typeScript];
		CWF.WF0["\n]\n"L];
		};
	typeSTRING => 	{	
		CWF.WF1["""%s"""L,pt.strval];
		};
	typeAPPL => {
		CWF.WF0[": "L];
		-- CWF.WF0["{"L];
		IF pt.appltype.stype = typeLIST THEN {
			CWF.WF0["[\n"L];
			PrintNewModel[pt.appltype,",\n"L,p,  
				indent+1, TRUE, dontdefault, typeScript];
			CWF.WF0["\n\t]"L];
			}
		ELSE PrintNewModel[pt.appltype,sep,p, 
			indent, FALSE, dontdefault, typeScript];
		-- CWF.WFC['}];
		IF pt.applval ~= NIL THEN {
			CWF.WF0["~"L]; -- CWF.WF0[" == "L];
			PrintNewModel[pt.applval,sep,p, indent+1,
				FALSE, dontdefault, typeScript];
			};
		};
	typeLIST => {
		oldsep: STRING _ sep;
		fprint _ FALSE;
		sep _ 	IF pt.listtype = plus THEN " PLUS "L
			ELSE IF pt.listtype = then THEN " THEN "L
			ELSE sep;
		-- IF pt.rest = NIL THEN CWF.WF0[">ONELIST<"L];
		MDModel.TraverseList[MDModel.NarrowToLIST[p],ProcPrintModel];
		sep _ oldsep;
		};
	typeOPEN => {
		CWF.WF0[ "OPEN "L];
		PrintNewModel[pt.open,", "L,IF parent~=NIL THEN parent ELSE p,
			indent, TRUE, dontdefault, typeScript];
		};
	typeLET => {
		CWF.WF0[ "LET ["L];
		PrintNewModel[pt.letgrp,", "L,
			IF parent ~= NIL THEN parent ELSE p, indent,
				TRUE, dontdefault, typeScript];
		CWF.WF0[ "]"L];
		IF pt.letval ~= NIL THEN {
			CWF.WF0[" ~ "L];  -- CWF.WF0[" == "L];
			PrintNewModel[pt.letval,sep,
				IF parent ~= NIL THEN parent ELSE p, 
				indent, TRUE, dontdefault, typeScript];
			};
		};
	typeMODEL => {
		PrintNewModel[pt.model, sep, IF parent ~= NIL THEN parent ELSE p,
			indent, TRUE, dontdefault, typeScript];
		};
	ENDCASE => ERROR;	-- bad select PrintNewModel
	}
ELSE IF p.stype = typeLET THEN CWF.WF0["{Unknown LET}"L];
-- ELSE IF s = NIL THEN Runtime.CallDebugger["s is NIL and p.print = FALSE"L];
};

-- must search all over for the a of a.b we use
PrintQualified: PROC[target: MDModel.Symbol, symbolseq: MDModel.SymbolSeq] = {
parent: MDModel.Symbol;
found: BOOL _ FALSE;

	ProcAnal: PROC[spa: MDModel.Symbol, spmodel: MDModel.MODELSymbol] 
		RETURNS[proceed: BOOL _ TRUE] = {
	sptype: MDModel.LISTSymbol;
	spappl: MDModel.APPLSymbol;
	IF found THEN RETURN[FALSE];
	IF spa.stype ~= typeAPPL THEN RETURN;
	spappl _ MDModel.NarrowToAPPL[spa];
	IF spappl.appltype = NIL OR spappl.appltype.stype ~= typeLIST THEN RETURN;
	sptype _ MDModel.NarrowToLIST[spappl.appltype];
	MDModel.TraverseList[sptype, ProcList];
	IF found THEN {
		parent _ spappl;
		RETURN[FALSE];
		};
	};

	ProcList: PROC[sp: MDModel.Symbol] = {
	IF target = sp THEN found _ TRUE;
	};

IF NOT target.qualified THEN RETURN;
MDModel.TraverseTree[symbolseq.toploc, symbolseq, ProcAnal, TRUE];
IF found THEN
	CWF.WF2["%s.%s"L, MDModel.Sym[parent], MDModel.Sym[target]]
ELSE CWF.WF1["%s"L, MDModel.Sym[target]];
};

PrintLoc: PROC[p: MDModel.LOCSymbol, dontdefault: BOOL, indent: CARDINAL,
	parent: MDModel.Symbol, typeScript: TypeScript.TS] = {
CWF.WF0["@"L];
IF p.host ~= NIL THEN CWF.WF1["[%s]"L,p.host];
IF p.path ~= NIL THEN CWF.WF1["<%s>"L,p.path];
IF p.tail ~= NIL THEN CWF.WF1["%s"L,p.tail];
IF p.sext ~= NIL
AND (dontdefault OR NOT LongString.EquivalentString[p.sext, "mesa"L]) THEN {
	CWF.WFC['.];
	IF p.prinpart ~= 0 THEN { 
		FOR i: CARDINAL IN [0 .. p.prinpart) DO
			CWF.WFC[p.sext[i]];
			ENDLOOP;
		CWF.WFC['*];
		FOR i: CARDINAL IN [p.prinpart .. p.sext.length) DO
			CWF.WFC[p.sext[i]];
			ENDLOOP;
		}
	ELSE CWF.WF1["%s"L,p.sext];
	};
IF p.createtime > 0 THEN CWF.WF1["!%lu"L,@p.createtime];
-- NO! ELSE IF p.bcdvers > 0 THEN CWF.WF1["!%lu"L,@p.bcdvers];
IF p.parmlist ~= NIL THEN {
	CWF.WF0["["L];
	IF NOT p.parmsdefaultable OR dontdefault THEN
		PrintNewModel[p.parmlist,", "L,p, indent+1,
			FALSE, dontdefault, typeScript];
	CWF.WF0["]"L];
	};
-- for the case where there is an OPEN @loc
IF p.nestedmodel ~= NIL AND parent.stype = typeOPEN THEN {
	-- prints it SILENTLY to set the p.print bit
	wp: PROC[CHAR];
	NullPrint: PROC[ch: CHAR] = {};
	wp _ CWF.SetWriteProcedure[NullPrint];
	PrintNewModel[p.nestedmodel,", "L,p, indent+1, TRUE, dontdefault, typeScript];
	[] _ CWF.SetWriteProcedure[wp];
	};
p.print _ FALSE;
};

-- makes defaults like ":@id"  equivalent to "id: TYPE = @id.mesa"
-- and ":@idImpl" equivalent to "idImpl: id = @idimpl.mesa"
ConsiderColonAbbr: PROC[sp: MDModel.Symbol, indent: CARDINAL,
	typeScript: TypeScript.TS] RETURNS[success: BOOL] = {
sploc: MDModel.LOCSymbol;
WITH spt: sp SELECT FROM
typeTYPE => {
	IF spt.typeval = NIL OR spt.typeval.stype ~= typeLOC THEN RETURN[FALSE];
	sploc _ MDModel.NarrowToLOC[spt.typeval];
	IF sploc.tail = NIL 
	OR NOT LongString.EquivalentString[sploc.sext, "mesa"L]
		THEN RETURN[FALSE];
	IF NOT LongString.EqualString[spt.typesym, sploc.tail] THEN RETURN[FALSE];
	};
typeAPPL => {
	stemp: STRING _ [30];
	IF spt.applval = NIL OR spt.applval.stype ~= typeLOC THEN RETURN[FALSE];
	sploc _ MDModel.NarrowToLOC[spt.applval];
	IF sploc.tail = NIL 
	OR NOT LongString.EquivalentString[sploc.sext, "mesa"L]
		THEN RETURN[FALSE];
	IF NOT LongString.EqualString[spt.applsym, sploc.tail] THEN RETURN[FALSE];
	Subr.strcpy[stemp, spt.applsym];
	IF NOT Subr.EndsIn[stemp, "impl"L] THEN RETURN[FALSE];
	stemp.length _ stemp.length - 4;
	IF NOT LongString.EqualString[stemp, MDModel.Sym[spt.appltype]] THEN
		RETURN[FALSE];
	};	
ENDCASE => RETURN[FALSE];
CWF.WF0[":"L];
sp.print _ TRUE;
PrintLoc[sploc, FALSE, indent, sp, typeScript];
RETURN[TRUE];
};

-- makes defaults like "*: id"
-- equivalent to "idImpl: id"
ConsiderStarId: PROC[sp: MDModel.Symbol, indent: CARDINAL] RETURNS[BOOL] = {
spappl: MDModel.APPLSymbol;
sptype: MDModel.Symbol;
stemp: STRING _ [30];
IF sp.stype ~= typeAPPL THEN RETURN[FALSE];
spappl _ MDModel.NarrowToAPPL[sp];
IF spappl.applval ~= NIL THEN RETURN[FALSE]; -- language does not allow this
sptype _ spappl.appltype;
IF sptype = NIL OR (sptype.stype NOT IN MDModel.HasAStringName) THEN
	RETURN[FALSE];
CWF.SWF1[stemp, "%sImpl"L, MDModel.Sym[sptype]];
IF NOT LongString.EquivalentString[stemp, MDModel.Sym[sp]] THEN RETURN[FALSE];
CWF.WF1["**: %s"L, MDModel.Sym[sptype]];
sp.print _ TRUE;
RETURN[TRUE];
};


-- procedures to generate config's

-- if outsh = NIL then print on IOStream
-- fileparameters may be NIL
MakeConfig: PUBLIC PROC[spmodel: MDModel.MODELSymbol, 
	symbolseq: MDModel.SymbolSeq, outsh: Stream.Handle, 
	createtime: LONG CARDINAL, ttyout: IO.Handle, fileparameters: LONG STRING] = {
spappl: MDModel.APPLSymbol;

	ConfigSh: PROC[ch: CHAR] = {
	IF outsh = NIL THEN ttyout.PutChar[ch]
	ELSE Stream.PutChar[outsh, ch];
	};

savespmodel _ spmodel;
SetAllPrint[FALSE, symbolseq];
-- this gives MakeConfig the widest latitude in deciding
-- what to name things
FOR i: CARDINAL IN [0 .. symbolseq.size) DO
	IF symbolseq[i].stype = typeAPPL THEN {
		spappl _ MDModel.NarrowToAPPL[@symbolseq[i]];
		IF spappl.configname ~= NIL THEN {
			Subr.FreeString[spappl.configname];
			spappl.configname _ NIL;
			};
		};
	ENDLOOP;
IF createtime ~= 0 THEN {
	str: STRING _ [100];
	CWF.SWF1[str, "--%lu\n"L, @createtime];
	IF outsh = NIL THEN ttyout.Put[IO.string[str]]
	ELSE FOR i: CARDINAL IN [0 .. str.length) DO
		Stream.PutChar[outsh, str[i]];
		ENDLOOP;
	};
[] _ PrintConfig[spmodel.model,";\n"L, ConfigSh, symbolseq, fileparameters];
};

-- returns TRUE if it printed anything, FALSE otherwise
PrintConfig: PROC[p: MDModel.Symbol, sep: STRING, ConfigSh: PROC[CHAR],
	symbolseq: MDModel.SymbolSeq, fileparameters: LONG STRING] 
	RETURNS[BOOL] = {
fprint: BOOL _ FALSE;
isanimport: BOOL _ FALSE;

	ProcPrintConfig: PROC[sp: MDModel.Symbol] = {
	IF fprint THEN CWF.FWF0[ConfigSh,sep];
	fprint _ PrintConfig[sp,sep, ConfigSh, symbolseq, fileparameters];
	};

	HandleArgsProc: PROC[sp: MDModel.Symbol] = {
	spappl: MDModel.APPLSymbol;
	IF sp = NIL OR sp.stype ~= typeAPPL THEN RETURN;
	spappl _ MDModel.NarrowToAPPL[sp];
	IF fprint THEN CWF.FWF0[ConfigSh,-- ", "L-- sep];
	spappl.configname _ PickInterfaceName[spappl, symbolseq, isanimport];
	CWF.FWF1[ConfigSh,"%s"L, spappl.configname];
	fprint _ TRUE;
	};

IF p = NIL THEN {
	CWF.FWF0[ConfigSh,"{p is NIL}"L];
	RETURN[FALSE];
	};
IF p.stype = typeLOC OR p.stype = typeTYPE THEN RETURN[FALSE];
IF NOT p.print THEN WITH pt: p SELECT FROM
typePROC => {
	CWF.FWF1[ConfigSh,"%s: CONFIGURATION "L,pt.procsym];
	sep _ ", "L;
	isanimport _ TRUE;
        IF pt.procparm ~= NIL THEN {
		CWF.FWF0[ConfigSh,"\n     IMPORTS "L];
		fprint _ FALSE;
		MDModel.TraverseList[pt.procparm,HandleArgsProc];
		};
	isanimport _ FALSE;
	IF pt.procret ~= NIL THEN {
		CWF.FWF0[ConfigSh,"\n     EXPORTS "L];
		fprint _ FALSE;
		MDModel.TraverseList[pt.procret,HandleArgsProc];
		};
	PrintControl[ConfigSh, symbolseq, p];
	IF pt.procval ~= NIL THEN {
		CWF.FWF0[ConfigSh," = {\n"L];
		[] _ PrintConfig[pt.procval,";\n"L, ConfigSh, symbolseq, fileparameters];
		CWF.FWF0[ConfigSh,"\n}.\n"L];
		};
	p.print _ TRUE;
	fprint _ TRUE;
	};
typeSTRING => CWF.FWF1[ConfigSh,"%s"L,pt.strval];
typeAPPL => {
	IF FramePointerSpecialCase[p, ConfigSh, symbolseq,
		 fileparameters, HandleArgsProc, HandleVal] THEN RETURN[TRUE];
	pt.configname _ PickInterfaceName[MDModel.NarrowToAPPL[p], symbolseq, FALSE];
	IF pt.appltype ~= symbolseq.controlv THEN {
		CWF.FWF1[ConfigSh,"%s _ "L,pt.configname];
		fprint _ TRUE;
		};
	IF pt.applval ~= NIL THEN { 
		IF pt.applval.stype = typeLIST 
		AND MDModel.NarrowToLIST[pt.applval].listtype ~= normal THEN {
			lp: MDModel.LISTSymbol _ MDModel.NarrowToLIST[pt.applval];
			oldsep: STRING _ sep;
			fprint _ FALSE;
			sep _ 	IF lp.listtype = plus THEN " PLUS "L
				ELSE IF lp.listtype=then THEN " THEN "L
				ELSE sep;
			MDModel.TraverseList[lp,HandleArgsProc];
			sep _ oldsep;
			}
		ELSE IF pt.applval.stype = typeLOC THEN
			fprint _ HandleVal[MDModel.NarrowToLOC[pt.applval], 
				ConfigSh, symbolseq, fileparameters]
		ELSE fprint _ FALSE;
		};
	p.print _ TRUE;
	};
typeLIST => {
	oldsep: STRING _ sep;
	fprint _ FALSE;
	sep _ 	IF pt.listtype = plus THEN " PLUS "L
		ELSE IF pt.listtype = then THEN " THEN "L
		ELSE sep;
	MDModel.TraverseList[MDModel.NarrowToLIST[p],
		IF pt.listtype = normal THEN ProcPrintConfig ELSE HandleArgsProc];
	sep _ oldsep;
	};
typeLET => {
	sep _ ", "L;
	fprint _ FALSE;
	IF FramePointerSpecialCase[p, ConfigSh, symbolseq,
		 fileparameters, HandleArgsProc, HandleVal] THEN RETURN[TRUE];
	CWF.FWF0[ConfigSh, "["L];
	MDModel.TraverseList[pt.letgrp, HandleArgsProc];
	CWF.FWF0[ConfigSh,"] _ "L];
	IF pt.letval ~= NIL AND pt.letval.stype = typeLOC THEN
		fprint _ HandleVal[MDModel.NarrowToLOC[pt.letval], ConfigSh, 
			symbolseq, fileparameters];
	};
typeTYPE, typeLOC, typeOPEN, typeMODEL => NULL;
ENDCASE => ERROR;	-- bad select PrintConfig
RETURN[fprint];
};

PickInterfaceName: PROC[spappl: MDModel.APPLSymbol, symbolseq: MDModel.SymbolSeq,
	 isanimport: BOOL] RETURNS[configname: LONG STRING] = {
fi: Dir.FileInfo;
sptype: MDModel.TYPESymbol;
IF spappl.appltype = symbolseq.controlv THEN RETURN[NIL];
IF spappl.configname ~= NIL THEN RETURN[spappl.configname];
sptype _ MDModel.NarrowToTYPE[spappl.appltype];
IF sptype.frameptr THEN {
	sploc: MDModel.LOCSymbol;
	sploc _ MDModel.LocForType[sptype];
	IF sploc ~= NIL THEN {
		fi _ MDModel.GetFileInfo[sploc];
		IF fi.moduleName ~= NIL THEN 
			RETURN[Subr.CopyString[fi.moduleName]];
		};
	RETURN[Subr.CopyString["FRAMEPTR"L]];
	};
-- given that its not a POINTER TO FRAME,
-- for the special case where the record can't be named
-- the same as the module it implements;
-- because the Binder can't handle XImpl _ XImpl[Y];
IF spappl.applval ~= NIL AND spappl.applval.stype = typeLOC 
AND LongString.EquivalentString[spappl.applsym, 
	MDModel.NarrowToLOC[spappl.applval].tail] THEN {
	configname _ Subr.CopyString[MDModel.Sym[spappl.appltype]];
	RETURN[configname];
	};
-- nor can it handle [XImpl, ZImpl] _ XImpl[Y]
IF spappl.applval = NIL THEN {
	splet: MDModel.LETSymbol;
	-- splet _ LetParentOf[spappl, symbolseq];
	splet _ spappl.letparent;
	IF splet ~= NIL AND splet.letval ~= NIL 
	AND splet.letval.stype = typeLOC
	AND LongString.EquivalentString[spappl.applsym, 
		MDModel.NarrowToLOC[splet.letval].tail] THEN {
		configname _ Subr.CopyString[MDModel.Sym[spappl.appltype]];
		RETURN[configname];
		};
	};
-- for imports and exports to the config where the names are crucial
IF isanimport THEN 
	configname _ Subr.CopyString[MDModel.Sym[spappl.appltype]]
ELSE 
	configname _ Subr.CopyString[spappl.applsym];
};

FramePointerSpecialCase: PROC[sp: MDModel.Symbol, 
	ConfigSh: PROC[CHAR], symbolseq: MDModel.SymbolSeq,
	fileparameters: LONG STRING,
	handleArgsProc: PROC[MDModel.Symbol],
	handleVal: PROC[MDModel.LOCSymbol, PROC[CHAR],
		MDModel.SymbolSeq, LONG STRING] 
		RETURNS[BOOL]] 
	RETURNS[isaspecialcase: BOOL] = {
spappl: MDModel.APPLSymbol;
sptype: MDModel.TYPESymbol;
isaspecialcase _ FALSE;
IF sp.stype = typeAPPL THEN {
	spappl _ MDModel.NarrowToAPPL[sp];
	sptype _ MDModel.NarrowToTYPE[spappl.appltype];
	IF sptype.frameptr THEN {
		sploc: MDModel.LOCSymbol;
		fi: Dir.FileInfo;
		sploc _ MDModel.NarrowToLOC[sptype.typeval];
		fi _ MDModel.GetFileInfo[sploc];
		CWF.FWF1[ConfigSh, "%s"L, IF fi.moduleName ~= NIL THEN 
			fi.moduleName ELSE sploc.tail];
		isaspecialcase _ TRUE;
		};
	}
ELSE IF sp.stype = typeLET THEN {
	numleft: CARDINAL;
	framet: MDModel.TYPESymbol;
	splet: MDModel.LETSymbol;
	splet _ MDModel.NarrowToLET[sp];
	[isaspecialcase, framet, numleft] _ FramePtrLet[splet];
	IF isaspecialcase THEN {
		CWF.WF1["%s is a special case.\n"L, framet.typesym];
		IF numleft > 0 THEN  {
			splist: MDModel.LISTSymbol;
			splist _ splet.letgrp;
			CWF.FWF0[ConfigSh, "["L];
			WHILE splist ~= NIL DO
				IF splist.first ~= framet
				AND MDModel.NarrowToAPPL[splist.first].appltype
				 ~= framet THEN
					handleArgsProc[splist.first];
				splist _ splist.rest;
				ENDLOOP;
			CWF.FWF0[ConfigSh, "] _ "L];
			};
		[] _ HandleVal[MDModel.NarrowToLOC[splet.letval], ConfigSh, 
			symbolseq, fileparameters];
		};
	};
};

FramePtrLet: PROC[splet: MDModel.LETSymbol] 
	RETURNS[isaspecialcase: BOOL, framet: MDModel.TYPESymbol, 
	numleft: CARDINAL] = {
splist: MDModel.LISTSymbol;
isaspecialcase _ FALSE;
numleft _ 0;
framet _ NIL;
splist _ splet.letgrp;
WHILE splist ~= NIL DO
	IF splist.first.stype = typeTYPE
	AND MDModel.NarrowToTYPE[splist.first].frameptr THEN {
		framet _ MDModel.NarrowToTYPE[splist.first];
		EXIT;
		};
	splist _ splist.rest;
	ENDLOOP;
IF splist = NIL THEN RETURN;
splist _ splet.letgrp;
WHILE splist ~= NIL DO
	IF splist.first.stype = typeAPPL
	AND MDModel.NarrowToAPPL[splist.first].appltype = framet THEN EXIT;
	splist _ splist.rest;
	ENDLOOP;
IF splist = NIL THEN RETURN;
isaspecialcase _ TRUE;
splist _ splet.letgrp;
WHILE splist ~= NIL DO
	numleft _ numleft + 1;
	splist _ splist.rest;
	ENDLOOP;
numleft _ numleft - 2;
};

-- returns TRUE if something was printed
HandleVal: PROC[sploc: MDModel.LOCSymbol, ConfigSh: PROC[CHAR],
	symbolseq: MDModel.SymbolSeq, fileparameters: LONG STRING] 
	RETURNS[fprint: BOOL] = {
s: LONG STRING;
fi: Dir.FileInfo;

	HandleArgsProc: PROC[sp: MDModel.Symbol] = {
	spappl: MDModel.APPLSymbol;
	IF sp = NIL OR sp.stype ~= typeAPPL THEN RETURN;
	spappl _ MDModel.NarrowToAPPL[sp];
	IF fprint THEN CWF.FWF0[ConfigSh,", "L];
	spappl.configname _ PickInterfaceName[spappl, symbolseq, FALSE];
	CWF.FWF1[ConfigSh,"%s"L,spappl.configname];
	fprint _ TRUE;
	};

	HandleHiddenImports: PROC = {
	depseqbcd, depseqsrc: Dir.DepSeq;
	bcdname: STRING _ [100];
	sourcename: STRING _ [100];
	lastsrc, start: CARDINAL;
	IF MakeSource = NIL THEN RETURN;
	IF NOT LongString.EquivalentString[sploc.sext, "Mesa"L] THEN RETURN;
	CWF.SWF1[bcdname, "%s.BCD"L, sploc.tail];
	CWF.SWF1[sourcename, "%s.Mesa"L, sploc.tail];
	depseqsrc _ MakeSource[sourcename];
	IF depseqsrc = NIL THEN RETURN;
	depseqbcd _ MakeBinary[bcdname];
	IF depseqbcd = NIL THEN RETURN;
	FOR j: CARDINAL DECREASING IN [0 .. depseqsrc.size) DO
		IF depseqsrc[j].relation = imports THEN {
			lastsrc _ j;
			EXIT;
			};
		REPEAT 
		FINISHED => RETURN;
		ENDLOOP;
	FOR i: CARDINAL IN [0 .. depseqbcd.size) DO
		IF depseqbcd[i].relation = imports 
		AND LongString.EquivalentString[depseqsrc[lastsrc].moduleName,
		depseqbcd[i].moduleName] THEN {
			start _ i;
			EXIT;
			};
		REPEAT
		FINISHED => RETURN;
		ENDLOOP;
	FOR i: CARDINAL IN [start+1 .. depseqbcd.size) DO
		IF depseqbcd[i].relation = imports THEN {
			spappl: MDModel.APPLSymbol;
			[spappl] _ MDModel.LookForInstBcd[depseqbcd[i].bcdFileName,
				depseqbcd[i].bcdVers, symbolseq, savespmodel, NIL];
			IF spappl ~= NIL THEN HandleArgsProc[spappl];
			};
		ENDLOOP;
	};
	
fprint _ FALSE;
fi _ MDModel.GetFileInfo[sploc];
s _ IF fi.moduleName ~= NIL THEN fi.moduleName ELSE sploc.tail;
CWF.FWF1[ConfigSh, "%s["L, s];
IF fi.bcdFileName ~= NIL AND fileparameters ~= NIL THEN {
	stemp: STRING _ [100];
	CWF.SWF3[stemp, "%s%s: %s"L, IF fileparameters.length = 0 THEN ""L ELSE ", "L,
		s, fi.bcdFileName];
	LongString.AppendString[fileparameters, stemp];
	};
MDModel.TraverseList[sploc.parmlist,HandleArgsProc];
HandleHiddenImports[];
CWF.FWF0[ConfigSh,"]"L];
fprint _ TRUE;
};

-- has the side effect of setting controlloc
PrintControl: PROC[ConfigSh: PROC[CHAR], symbolseq: MDModel.SymbolSeq,
	sproot: MDModel.Symbol] = {
once: BOOL _ FALSE;

	ProcAnal: PROC[spa: MDModel.Symbol, spmodel: MDModel.MODELSymbol] 
		RETURNS[proceed: BOOL _ TRUE] = {
	spappl: MDModel.APPLSymbol;
	-- this avoids searching into the nested models
	IF spa.stype = typePROC AND controlloc ~= NIL THEN RETURN[FALSE];
	IF spa.stype ~= typeAPPL THEN RETURN;
	spappl _ MDModel.NarrowToAPPL[spa];
	IF spappl.applsym ~= NIL 
	AND spappl.appltype = symbolseq.controlv THEN {
		s: LONG STRING;
		fi: Dir.FileInfo;
		IF spappl.applval.stype ~= typeLOC THEN 
			CWF.WF0["Control error\n"L];
		controlloc _ MDModel.NarrowToLOC[spappl.applval];
		fi _ MDModel.GetFileInfo[controlloc];
		s _ IF fi.moduleName ~= NIL THEN fi.moduleName
			ELSE controlloc.tail;
		IF NOT once THEN CWF.FWF1[ConfigSh,"\n     CONTROL %s"L,s]
		ELSE CWF.FWF1[ConfigSh,", %s"L,s];
		once _ TRUE;
		};
	RETURN[TRUE];
	};
	
controlloc _ NIL;
MDModel.TraverseTree[sproot, symbolseq, ProcAnal, TRUE];
IF NOT once THEN CWF.WF0["Warning - no CONTROL module\n"L]
ELSE CWF.FWF0[ConfigSh, "\n"L];
};

SetAllPrint: PROC[f: BOOL, symbolseq: MDModel.SymbolSeq] = {
FOR i: CARDINAL IN [0..symbolseq.size) DO
	symbolseq[i].print _ f;
	ENDLOOP;
};

  -- from [Igor]<PreCascade>Utilities>CascadeExec.Mesa
  -- Compiler-specific feedback stuff
 
 
MSGTTYProc: PROC[ch: CHAR] = {
globalmsgout.PutChar[ch];
};

  StartBinding: Feedback.CreateProc = {
        binderState _ normal;
        CWF.WF1["\n%s"L, herald];
	RETURN[NIL]
	};
  DoneBinding: Feedback.DestroyProc = {
	IF trailer # NIL THEN CWF.WF1["%s"L, trailer];
	CWF.WFCR[];
	};
  NewBinderSource: Feedback.BeginItemProc = {
        CWF.FWF1[MSGTTYProc, "\n%s"L, item]};
  NextBinderPass: Feedback.NoteProgressProc = {
        SELECT state FROM
          98 --warning-- => {
	    IF binderState = normal THEN 
	      {CWF.FWF0[MSGTTYProc, " warnings "L];  binderState _ warnings}};
          99 --error-- => {
	    IF binderState = normal OR binderState = warnings THEN
	      {CWF.FWF0[MSGTTYProc, " errors "L];  binderState _ errors}};	
          ENDCASE => CWF.FWFC[MSGTTYProc, '.]};
  EndOfBinderSource: Feedback.FinishItemProc = {
        CWF.FWFC[MSGTTYProc, ' ];
        IF trailer # NIL THEN CWF.FWF1[MSGTTYProc, "%s"L, trailer]
	};
	  
	
RunBinder: PUBLIC PROC[cmd: STRING, typeScript: TypeScript.TS,
	ttyin, ttyout, msgout: IO.Handle, confirm: REF BOOL]
	RETURNS[outcome: ExecOps.Outcome] = {
binderFeedback: Feedback.Procs _ [create: StartBinding, destroy: DoneBinding, 
	beginItem: NewBinderSource, noteProgress: NextBinderPass, 
	finishItem: EndOfBinderSource];
cmd1: LONG STRING;
command: ExecOps.Command;   -- PACKED ARRAY [0..900) OF CHAR;
dontconfirm: BOOL _ IF confirm = NIL THEN FALSE ELSE NOT (confirm^);
globalmsgout _ msgout;
outcome _ aborted;
-- FOR i: CARDINAL IN [0 .. cmd.length) DO
	-- command[i] _ cmd[i];
	-- ENDLOOP;
CWF.WF1["Bind %s ... "L, cmd];
cmd[cmd.length] _ Ascii.CR;
cmd.length _ cmd.length + 1;
-- argghh!!!
cmd1 _ cmd;
command _ LOOPHOLE[cmd1+2];
IF dontconfirm OR IOConfirm['y, ttyin, ttyout] = 'y THEN {
	CWF.WF0["Yes.\n"L];
	IF LoadBinder[] THEN {
		CWF.WF0["Binding ... "L];
		AcquireMsgLock[];
		outcome _ TemporarySpecialExecOps.BindUsingFeedback[
			command, @binderFeedback
			! UNWIND => ReleaseMsgLock[]];
		ReleaseMsgLock[];
		PrintOutcome[outcome];
		IF outcome ~= ok AND outcome ~= aborted THEN {
			logsh: Stream.Handle;
			logsh _ Subr.NewStream["Binder.Log"L, Subr.Read];
			WHILE NOT FileStream.EndOf[logsh] DO
				IF TypeScript.UserAbort[typeScript]THEN {
					CWF.WF0["\nAborted.\n"L];
					EXIT;
					};
				ttyout.PutChar[Stream.GetChar[logsh]];
				ENDLOOP;
			TypeScript.ResetUserAbort[typeScript];
			Stream.Delete[logsh];
			};
		};
	}
ELSE CWF.WF0["No.\n"L];
globalmsgout _ NIL;
};

LoadBinder: PROC RETURNS[success: BOOL] = {
cap: File.Capability;
success _ TRUE;
IF Runtime.IsBound[ExecOps.Bind] THEN RETURN[TRUE];  -- already loaded
CWF.WF0["Loading ... "L];
{
ENABLE ANY => { CWF.WF0["failed.\n"L]; GOTO out};
cap _ Directory.Lookup["binder.bcd"L];
Runtime.RunConfig[file: cap, offset: 1, codeLinks: TRUE];
CWF.WF0["done.\n"L];
EXITS
out => success _ FALSE;
}};

PrintOutcome: PROC[o: ExecOps.Outcome] = {
CWF.WF0[SELECT o FROM
ok => "ok"L, 
warnings => "warnings"L, 
errors => "errors"L, 
errorsAndWarnings => "errorsAndWarnings"L, 
aborted => "aborted"L,
ENDCASE => ERROR];
CWF.WFCR[]
};

ModelCreateProperty: Directory.PropertyType = LOOPHOLE[217B];

SetModelCreateProperty: PUBLIC PROC[configcap: File.Capability,
	create: LONG CARDINAL] = {
Directory.PutProperty[configcap, ModelCreateProperty, 
	DESCRIPTOR[@create, SIZE[LONG CARDINAL]], TRUE];
};

-- returns 0 if there is no such property
GetModelCreateProperty: PUBLIC PROC[configcap: File.Capability] 
	RETURNS[create: LONG CARDINAL] = {
arr: ARRAY[0 .. 1) OF LONG CARDINAL;	-- to get around a bug
Directory.GetProperty[configcap, ModelCreateProperty,
	DESCRIPTOR[BASE[arr], SIZE[LONG CARDINAL]]
	! Directory.Error => IF type = invalidProperty THEN GOTO leave];
create _ arr[0];
EXITS
leave => create _ 0;
};

SupportInit: PUBLIC PROC[symbolseq: MDModel.SymbolSeq, typeScript: TypeScript.TS, 
	ttyout: IO.Handle] = {
ss _ symbolseq;
officialwindow _ ttyout;
globalTypeScript _ typeScript;
CWF.SetCode['v, CWFVRoutine];
CWF.SetCode['z, CWFZRoutine];
};

CWFVRoutine: PROC[uns: LONG POINTER, form: LONG STRING, wp: PROC[CHAR]] = {
p: LONG POINTER TO TimeStamp.Stamp _ uns;
net: CARDINAL _ p.net;
host: CARDINAL _ p.host;
IF p.time = 0 THEN 
	CWF.FWF2[wp, "(%u#%u#,Null)"L, @net, @host]
ELSE 	CWF.FWF3[wp, "(%u#%u#,%lt)"L, @net, @host, @p.time];
};

CWFZRoutine: PROC[uns: LONG POINTER, form: LONG STRING, wp: PROC[CHAR]] = {
sp: MDModel.Symbol _ uns;
IF ss = NIL THEN ERROR;
IF officialwindow = NIL THEN ERROR;
PrintNewModelStream[ss,sp, NIL, NIL, FALSE, globalTypeScript, officialwindow];
};

}.