-- DesignModelImpl.mesa
-- last edit by Schmidt, January 6, 1983 2:27 pm
-- last edit by Satterthwaite, February 1, 1983 10:12 am

-- construct Models from Bcds
-- Usage:
--   DesignModel [/d] [/h host] [/p path] [/m modelfile] [/w] file1.bcd ... filen.bcd
--	
--	that is, list the bcd's that are part one after the other.
--	The Bcd's are Implementor modules
--
--	/d turn on debugging switch
-- 	/h host	set host name for files,   e.g. "Ivy"
--	/m modelfile	set filename for output model (default = "NewModel.Model")
--	/p path	set path name for files,   e.g. "Schmidt>Model"
--	/w	use defaults in generated model
--

DIRECTORY
  CWF: TYPE USING [SetWriteProcedure, SWF1, SWF3, SWF4, WF0, WF1, WF2, WF3],
  DesModSup: TYPE USING [EnterType, EnterInstAndLoc, FixupExterior,
  		MoveTypesToFront, NeedModuleName, ProcessForStandardOpen,
  		ReorganizeInOrder, SortListOfSymbols],
  DFSubr: TYPE USING [AllocateDFSeq, DF, DFSeq, FreeDFSeq, LookupDF, NextDF, StripLongName],
  Dir: TYPE USING [FileInfo],
  Directory: TYPE USING [Error, GetProps, Handle, ignore, Lookup],
  File: TYPE USING [Capability],
  IO: TYPE USING[Handle, PutChar],
  LongString: TYPE USING [EquivalentString],
  MDModel: TYPE USING [AddToEndOfList, AllocateSymbolSeq, APPLSymbol, CkType, 
  	FreeStringsOf, FreeSymbolSeq, GenerateUniqueName, GetFileInfo, 
	LETSymbol, LISTSymbol, ListType, LOCSymbol, MergeIntoList, 
	MODELSymbol, NarrowToAPPL, NarrowToLET, NarrowToLIST, NarrowToLOC, 
	NarrowToPROC, NarrowToTYPE, NewSymAPPL, NewSymLET, 
	NewSymLOC, NewSymMODEL, NewSymSTRING, NewSymTYPE, 
	PROCSymbol, RemoveFromList, StartMDSupport, StopMDSupport, 
	STRINGSymbol, Sym, Symbol, SymbolSeq, 
	TraverseList, TraverseTree, traversetreecalled, TYPESymbol],
  MDUtil: TYPE USING [AnyR, MakeConfig, PrintNewModelStream, SupportInit],
  ProcBcds: TYPE USING [GetModuleName, Innards, InnardsObject, InstallAddressesBcd, 
  	PrintDepends, ProcDep, ProcMod, ReadInSegmentsBcd, UnstallBcd],
  Rope: TYPE USING[Cat, Fetch, Text],
  RopeInline: TYPE USING[InlineFlatten],
  Space: TYPE USING [Handle, nullHandle],
  Stream: TYPE USING [Delete, Handle],
  String: TYPE USING [AppendString],
  Subr: TYPE USING [AbortMyself, Any, CopyString, debugflg, EndsIn, 
  	errorflg, GetCreateDate, GetRemoteFilenameProp, NewStream, 
	numberofleaders, PackedTime, PrintGreeting, strcpy, SubrInit, SubrStop, Write],
  Time: TYPE USING [Current],
  TimeStamp: TYPE USING[Stamp],
  UECP: TYPE USING[Argv, Parse],
  UserExec: TYPE USING[CommandProc, ExecHandle, GetStreams, RegisterCommand, UserAbort];

DesignModelImpl: PROGRAM
IMPORTS CWF, DesModSup, DFSubr, Directory, IO, LongString,
	MDModel, MDUtil, ProcBcds, RopeInline, Space, Stream, String, Subr,
	Time, UECP, UserExec = {

maxfiles: CARDINAL = 500;		-- the maximum number of files

maxsym: CARDINAL = 5000;		-- the number of symbols

-- MDS USAGE !!!
output: IO.Handle;
-- end of MDS

PutProc: PROC[ch: CHAR] = {
output.PutChar[ch];
};

Main: UserExec.CommandProc  = TRUSTED {
commandline: Rope.Text;
out: IO.Handle;
symbolseq: MDModel.SymbolSeq _ NIL;
sh: Stream.Handle;
dfseq: DFSubr.DFSeq _ NIL;
changes: BOOL;
dontdefault: BOOL _ TRUE;
host: STRING _ [30];
path: STRING _ [100];
time: Subr.PackedTime;
spm: MDModel.PROCSymbol;
modelfile: STRING _ [100];
configfile: STRING _ [100];
procname: STRING _ [100];
n: CARDINAL;
nimpls, parm: CARDINAL;
token: Rope.Text;
argv: UECP.Argv _ UECP.Parse[event.commandLine];

	Cleanup: PROC = {
	MDModel.StopMDSupport[];
	MDModel.FreeSymbolSeq[@symbolseq];
	DFSubr.FreeDFSeq[@dfseq];
	Subr.SubrStop[];
	};

{
	ENABLE {
	Subr.AbortMyself => {
		CWF.WF0["\nDesignModel Aborted.\n"L];
		GOTO leave;
		};
	UNWIND => Cleanup[];
	};

output _ exec.GetStreams[].out;
Subr.SubrInit[256];
Subr.errorflg _ Subr.debugflg _ FALSE;
time _ Time.Current[];
Subr.PrintGreeting["DesignModel"L];

symbolseq _ MDModel.AllocateSymbolSeq[maxsym];
symbolseq.controlv _ MDModel.NewSymTYPE[symbolseq];
symbolseq.controlv.typesym _ Subr.CopyString["CONTROL"L];
symbolseq.controlv.typeName _ Subr.CopyString["CONTROL"L];
symbolseq.toploc _ MDModel.NewSymLOC[symbolseq];
symbolseq.toploc.nestedmodel _ MDModel.NewSymMODEL[symbolseq];
MDUtil.SupportInit[symbolseq, NARROW[exec.viewer], exec.GetStreams[].out];
MDModel.StartMDSupport[];
MDModel.traversetreecalled _ 0;
Subr.numberofleaders _ 0;

dfseq _ DFSubr.AllocateDFSeq[maxEntries: maxfiles, zoneType: shared];

Subr.strcpy[modelfile, "NewModel.Model"L];
parm _ 1;
WHILE parm < argv.argc DO
	token _ RopeInline.InlineFlatten[argv[parm]];
	IF token.Fetch[0] = '/ OR token.Fetch[0] = '- THEN { 
		SELECT token.Fetch[1] FROM
		'd => Subr.debugflg _ TRUE;
		'h => {
			token _ RopeInline.InlineFlatten[argv[parm]];
			parm _ parm + 1;
			Subr.strcpy[host, LOOPHOLE[token]];
			};
		'm => {
			token _ RopeInline.InlineFlatten[argv[parm]];
			parm _ parm + 1;
			Subr.strcpy[modelfile, LOOPHOLE[token]];
			};
		'p => {
			token _ RopeInline.InlineFlatten[argv[parm]];
			parm _ parm + 1;
			Subr.strcpy[path, LOOPHOLE[token]];
			};
		'w => dontdefault _ FALSE;
		ENDCASE => CWF.WF1["Unknown option '%s'\n"L, LOOPHOLE[token]];
		}
	ELSE {
		df: DFSubr.DF;
		IF NOT MDUtil.AnyR[token, '.] THEN 
			token _ RopeInline.InlineFlatten[Rope.Cat[token, ".Bcd"]];
		df _ DFSubr.NextDF[dfseq];
		IF df = NIL THEN ERROR;
		df.shortname _ Subr.CopyString[LOOPHOLE[token], dfseq.dfzone];
		};
	parm _ parm + 1;
	ENDLOOP;
IF dfseq.size = 0 THEN {
	CWF.WF0["Error - no arguments given to DesignModel.\n"L];
	SIGNAL Subr.AbortMyself;
	};
IF NOT Subr.Any[modelfile, '.] THEN String.AppendString[modelfile, ".Model"L];
symbolseq.toploc.nestedmodel.modelfilename _ Subr.CopyString[modelfile];
nimpls _ dfseq.size;
changes _ TRUE;
WHILE changes DO
	changes _ FALSE;
	FOR i: CARDINAL IN [0.. dfseq.size) DO
		IF NOT dfseq[i].eval THEN {
			AddBcd[@dfseq[i], symbolseq, dfseq,
				host, path, (i < nimpls), exec];
			changes _ TRUE;
			dfseq[i].eval _ TRUE;
			};
		ENDLOOP;
	ENDLOOP;
-- at this point symbolseq.toploc.nestedmodel.model
-- is a list of all the Types and APPLs and LEts
-- this takes the TYPEs and LETs, puts a Model: in front of
-- them, and puts TYPEs and APPLs in parameter list
Subr.strcpy[configfile, modelfile];
configfile.length _ configfile.length - 6;
CWF.SWF1[procname, "MODEL%s"L, configfile];
CWF.WF0["Fix up exterior.\n"L];
DesModSup.FixupExterior[symbolseq, procname];

-- symbolseq.toploc.nestedmodel.model is a list of one element, which is a PROC
-- now reorganize the PROC body in sorted order
CWF.WF0["Reorganize procval in order.  "L];
spm _ MDModel.NarrowToPROC[symbolseq.toploc.nestedmodel.model.first];
spm.procval _ DesModSup.ReorganizeInOrder[symbolseq, MDModel.NarrowToLIST[spm.procval], exec];
-- now move all the PLUS's and THEN's to the bottom (for the Binder)
spm.procval _ MoveAllPlus[MDModel.NarrowToLIST[spm.procval], symbolseq];

-- now reorganize the PROC parameter list in topological order
CWF.WF0["Sort parameters in order.  "L];
[spm.procparm, n] _ DesModSup.SortListOfSymbols[symbolseq, spm.procparm];
CWF.WF1["(%u symbols sorted.)\n"L, @n];

CWF.WF0["Figure out exports.  "L];
spm.procret _ FigureOutExports[symbolseq];
[spm.procret, n] _ DesModSup.SortListOfSymbols[symbolseq, spm.procret];
CWF.WF1["(%u symbols sorted.)\n"L, @n];

-- now move the types in the parameter list to before the Model: PROC
CWF.WF0["Moving types to front.\n"L];
DesModSup.MoveTypesToFront[symbolseq];

-- at this point symbolseq.toploc.nestedmodel.model is a LIST of many types, ended by
-- a single PROC; now reorganize those TYPES
CWF.WF0["Reorganizing those types in order.  "L];
symbolseq.toploc.nestedmodel.model _ 
	DesModSup.ReorganizeInOrder[symbolseq, 
		symbolseq.toploc.nestedmodel.model, exec];

CWF.WF0["Process for standard open.\n"L];
-- now run through the list and strip off standard Mesa TYPES, 
-- supplying an @OPEN instead
DesModSup.ProcessForStandardOpen[symbolseq];


-- MDModel.ValidateModel[symbolseq];

-- print out the model
commandline _ RopeInline.InlineFlatten[Rope.Cat["DesignModel ", event.commandLine]];
out _ exec.GetStreams[].out;
CWF.WF1["The new model is in the file '%s'\n\n"L, modelfile];
MDUtil.PrintNewModelStream[symbolseq, symbolseq.toploc.nestedmodel,
	NIL, commandline, dontdefault, NARROW[exec.viewer], out];
sh _ Subr.NewStream[modelfile, Subr.Write];
MDUtil.PrintNewModelStream[symbolseq, symbolseq.toploc.nestedmodel,
		sh, commandline, dontdefault, NARROW[exec.viewer], out];
Stream.Delete[sh];
modelfile.length _ modelfile.length - 5;
CWF.SWF1[configfile, "MODEL%sConfig"L, modelfile];
CWF.WF1["\n\n\nThe New Config File Is '%s'\n\n"L, configfile];
-- prints on the terminal
MDUtil.MakeConfig[symbolseq.toploc.nestedmodel, symbolseq, NIL, 0, out, NIL];
sh _ Subr.NewStream[configfile, Subr.Write];
MDUtil.MakeConfig[symbolseq.toploc.nestedmodel, symbolseq, sh, 0, out, NIL];
Stream.Delete[sh];
EXITS
leave => NULL;
};
CWF.WF3["\nSymbolseq.size %u, leaders: %u, traversetrees: %u.\n"L, 
	@symbolseq.size, @Subr.numberofleaders, @MDModel.traversetreecalled];
time _ Time.Current[] - time;
CWF.WF1["Total elapsed time for DesignModel %lr.\n"L,@time];
Cleanup[];
};


-- take dftop.shortname, add it to the model in symbolseq
-- if usersaysimpl, then the user put this one on the command line
AddBcd: PROC[dftop: DFSubr.DF, symbolseq: MDModel.SymbolSeq, 
	dfseq: DFSubr.DFSeq, defhost, defpath: STRING, usersaysimpl: BOOL,
	exec: UserExec.ExecHandle] = {
spimpl: MDModel.Symbol;	-- is either TYPE or LET
spimplloc: MDModel.LOCSymbol;
mainprog: STRING _ [100];
innardsobject: ProcBcds.InnardsObject _ [bcdheaderspace: Space.nullHandle];
tail: STRING _ [100];
sext: STRING _ [20];

	procMod: ProcBcds.ProcMod = {
	fi: Dir.FileInfo;
	sptype: MDModel.TYPESymbol;
	isc: BOOL _ TRUE;
	uns _ NIL;
	Subr.strcpy[mainprog, smodulename];
	IF sourcefile.length > 0 THEN {
		IF Subr.EndsIn[sourcefile, ".mesa"L] THEN {
			sourcefile.length _ sourcefile.length - 5;
			isc _ FALSE;
			}
		ELSE IF Subr.EndsIn[sourcefile, ".config"L] THEN {
			sourcefile.length _ sourcefile.length - 7;
			isc _ TRUE;
			}
		ELSE ERROR;
		-- in general prefer the capitalization of the modulename
		-- so we can default to a shorter form (:@)
		Subr.strcpy[tail, IF LongString.EquivalentString[sourcefile, 
			smodulename] THEN smodulename ELSE sourcefile];
		Subr.strcpy[sext, IF isc THEN "config"L ELSE "mesa"L];
		}
	ELSE {
		-- for modules which have no source recorded
		-- in them, e.g. TableCompiled
		Subr.strcpy[tail, smodulename];
		Subr.strcpy[sext, "bcd"L];
		};
	IF isdefns THEN {
		bcdfn: STRING _ [100];
		CWF.SWF1[bcdfn, "%s.Bcd"L, tail];
		sptype _ DesModSup.EnterType[bcdfn, smodulename, bcdvers,
			symbolseq, symbolseq.toploc.nestedmodel];
		spimplloc _ MDModel.NarrowToLOC[sptype.typeval];
		-- this resets everything
		MDModel.FreeStringsOf[spimplloc];
		spimplloc.host _ spimplloc.path _ spimplloc.tail _ 
			spimplloc.sext _ NIL;
		}
	ELSE IF NOT usersaysimpl THEN {
		-- must be a pointer to frame
		bcdfn: STRING _ [100];
		CWF.WF1["%s is used as a pointer to frame.\n"L, smodulename];
		CWF.SWF1[bcdfn, "%s.Bcd"L, tail];
		sptype _ DesModSup.EnterType[bcdfn, smodulename, bcdvers,
			symbolseq, symbolseq.toploc.nestedmodel];
		sptype.frameptr _ TRUE;
		-- this way the instance will become a parameter
		spimpl _ sptype;
		RETURN;
		}
	ELSE spimplloc _ MDModel.NewSymLOC[symbolseq];
	-- look at remote name property
	spimplloc.createtime _ sourcevers.time;
	FigureOutRemoteName[spimplloc, sourcefile];
	IF spimplloc.host = NIL AND defhost.length > 0 THEN
		spimplloc.host _ Subr.CopyString[defhost];
	IF spimplloc.path = NIL AND defpath.length > 0 THEN
		spimplloc.path _ Subr.CopyString[defpath];
	spimplloc.tail _ Subr.CopyString[tail];
	spimplloc.sext _ Subr.CopyString[sext];
	-- designmodel can only generate parameters that are defaultable
	spimplloc.parmsdefaultable _ TRUE;
	fi _ MDModel.GetFileInfo[spimplloc];
	fi.bcdVers _ bcdvers;
	fi.moduleName _ Subr.CopyString[smodulename];
	IF isdefns THEN {
		spimpl _ sptype;
		}
	ELSE {
		-- switches don't matter for defs files or config files
		spswitch: MDModel.Symbol;
		splet: MDModel.LETSymbol;
		IF NOT isc THEN {
			spswitch _ SwitchesToSymbol[altoCode, boundsChecks, cedarSwitch, crossJump, 
				linksInCode, nilChecks, sortByUsage, symbolseq];
			spimplloc.parmlist _ MDModel.AddToEndOfList[
				spimplloc.parmlist, spswitch, normal, symbolseq];
			};
		splet _ MDModel.NewSymLET[symbolseq];
		splet.letgrp _ NIL;
		splet.letval _ spimplloc;
		spimpl _ splet;
		IF dftop.isdefns THEN {
			-- oops this is a module that 
			-- is being used for a FRAMEPTR
			CWF.WF1["%s is used as a pointer to frame.\n"L, sourcefile];
			};
		};
	};

	-- spimpl, spimplloc are external
	-- spimpl is either type TYPE or LET
	procDep: ProcBcds.ProcDep = {
	moduleName: STRING _ [100];
	df: DFSubr.DF;
	IF relcode = otherdepends OR relcode = canignore 
	OR relcode = symbolsfile OR relcode = sourcefile THEN RETURN;
	-- if filename is length 0 then ignore
	-- may be result of table-compiled stuff
	IF filename.length = 0 THEN RETURN;
	-- add to DF table, for next iteration
	df _ DFSubr.LookupDF[dfseq, filename];
	IF df = NIL THEN {
		df _ DFSubr.NextDF[dfseq];
		df.shortname _ Subr.CopyString[filename, dfseq.dfzone];
		};
	IF spimpl.stype ~= typeTYPE THEN MDModel.CkType[spimpl, typeLET];
	MDModel.CkType[spimplloc, typeLOC];
	IF relcode = defstype THEN {  
		spaddtype: MDModel.TYPESymbol _ NIL;
		IF smodulename ~= NIL THEN Subr.strcpy[moduleName, smodulename];
		-- added to the end of the model
		spaddtype _ DesModSup.EnterType[filename, moduleName, 
			bcdvers, symbolseq, symbolseq.toploc.nestedmodel
			! DesModSup.NeedModuleName => IF SetModuleName[filename, moduleName] THEN RETRY];
		IF spaddtype ~= NIL THEN
			spimplloc.parmlist _ MDModel.AddToEndOfList[spimplloc.parmlist, 
				spaddtype, normal, symbolseq];
		df.isdefns _ TRUE;
		}
	ELSE {
		-- added to the end of the model at this point
		spi: MDModel.APPLSymbol;
	 	IF spimpl.stype ~= typeLET THEN {
			-- CWF.WF2["Warning: %s is a pointer to frame but has an export '%s'.\n"L,
			-- MDModel.Sym[spimpl], spi.applsym];
			-- ignore this import or export from a FRAMEPTRTYPE
			RETURN;
			};
		IF smodulename ~= NIL THEN Subr.strcpy[moduleName, smodulename];
		spi _ DesModSup.EnterInstAndLoc[filename, moduleName,
			bcdvers, symbolseq, symbolseq.toploc.nestedmodel, NIL 
			! DesModSup.NeedModuleName => IF SetModuleName[filename, moduleName] THEN RETRY];
		IF relcode = imports THEN
			spimplloc.parmlist _ 
				MDModel.AddToEndOfList[spimplloc.parmlist,
				spi, normal, symbolseq]
		ELSE IF relcode = exports THEN {
			splet: MDModel.LETSymbol _ MDModel.NarrowToLET[spimpl];
			IF spi.applval ~= NIL THEN {
				CWF.WF1["Warning: %s is defined by itself and also in a LET stmt.\n"L,
					spi.applsym];
				FixupAPPLtoLET[spi, splet, symbolseq];
				}
			ELSE IF spi.letparent ~= NIL 
				AND spi.letparent.letval ~= NIL THEN {
				CWF.WF1["Warning: %s is defined in two LET stmts.\n"L,
					spi.applsym];
				FixupLETtoLET[spi, splet, symbolseq];
				}
			ELSE {
				spi.letparent _ splet;
				splet.letgrp _ MDModel.AddToEndOfList[splet.letgrp,
					spi, normal, symbolseq];
				};
			}
		ELSE ERROR;
		};
	};

{
splet: MDModel.LETSymbol;
sploc: MDModel.LOCSymbol;
success: BOOL;
IF UserExec.UserAbort[exec] THEN SIGNAL Subr.AbortMyself[];
innardsobject.cap _ Directory.Lookup[fileName: dftop.shortname, 
	permissions: Directory.ignore ! Directory.Error => GOTO err];
[] _ Directory.GetProps[innardsobject.cap, mainprog
	! Directory.Error => {
		Subr.strcpy[mainprog, dftop.shortname];
		CONTINUE;
		}
	];
CWF.WF1["Analyzing %s.\n"L, mainprog];
ProcBcds.ReadInSegmentsBcd[@innardsobject];
ProcBcds.InstallAddressesBcd[@innardsobject];
IF usersaysimpl AND SpecialCase[mainprog, symbolseq, @innardsobject] THEN RETURN;
[success] _ ProcBcds.PrintDepends[@innardsobject, procMod, procDep, 
	FALSE, FALSE, TRUE, mainprog];	-- less is true
ProcBcds.UnstallBcd[@innardsobject];
IF NOT success THEN {
	CWF.WF1["Error - couldn't analyze %s correctly.\n"L, mainprog];
	Subr.errorflg _ TRUE;
	};
-- at this point spimpl is either a TYPE or a LET
-- the type has already been added to the model
IF spimpl.stype = typeTYPE THEN {
	sptype: MDModel.TYPESymbol;
	sptype _ MDModel.NarrowToTYPE[spimpl];
	sploc _ MDModel.NarrowToLOC[sptype.typeval];
	-- doesnt work
	-- [sploc.parmlist] _ SortListOfSymbols[symbolseq, sploc.parmlist];
	RETURN;
	};
splet _ MDModel.NarrowToLET[spimpl];
MDModel.CkType[splet, typeLET];
IF splet.letgrp = NIL THEN {
	-- must be a CONTROL module since it exports nothing
	spappl: MDModel.APPLSymbol;
	spappl _ MDModel.NewSymAPPL[symbolseq];
	spappl.applsym _ Subr.CopyString[mainprog];
	spappl.appltype _ symbolseq.controlv;
	spappl.applval _ NIL;
	splet.letgrp _ MDModel.AddToEndOfList[splet.letgrp, 
		spappl, normal, symbolseq];
	spappl.letparent _ splet;
	};
-- reorganize the parameter list into topological order
sploc _ MDModel.NarrowToLOC[splet.letval];
-- doesnt work
-- [sploc.parmlist] _ SortListOfSymbols[symbolseq, sploc.parmlist];
-- reorganize exports
-- doesnt work
-- [splet.letgrp] _ SortListOfSymbols[symbolseq, splet.letgrp];
spimpl _ SmashLETToAPPL[splet, symbolseq];
-- spimpl may now be an APPL
-- now add spimpl to symbolseq.toploc.nestedmodel.model if not already there
IF NOT usersaysimpl THEN 
	-- remove definition of an impl so it becomes a parameter
	[newlist: symbolseq.toploc.nestedmodel.model] _ 
		MDModel.RemoveFromList[spimpl, symbolseq.toploc.nestedmodel.model]
ELSE LookForMod[symbolseq, spimpl];
EXITS
err => 	CWF.WF2["Analyzing %s.  File %s is not on local disk.\n"L, 
		dftop.shortname, dftop.shortname];
};
};


SetModuleName: PROC[fileName, moduleName: STRING] RETURNS[success: BOOL] = {
innardsobject: ProcBcds.InnardsObject _ [bcdheaderspace: Space.nullHandle];
-- must go and read in bcd to get modulename
success _ FALSE;
innardsobject.cap _ Directory.Lookup[fileName: fileName, 
	permissions: Directory.ignore ! Directory.Error => GOTO out];
ProcBcds.ReadInSegmentsBcd[@innardsobject];
ProcBcds.InstallAddressesBcd[@innardsobject];
IF NOT ProcBcds.GetModuleName[@innardsobject, moduleName] THEN {
	ProcBcds.UnstallBcd[@innardsobject];
	GOTO out;
	};
ProcBcds.UnstallBcd[@innardsobject];
success _ TRUE;
EXITS
out => CWF.WF1["Error - can't get modulename for %s.\n"L, fileName];
};

-- will fixup spappl so that splet may also export it
-- note the PLUS node must follow the splet
FixupAPPLtoLET: PROC[spappl: MDModel.APPLSymbol, splet: MDModel.LETSymbol, 
	symbolseq: MDModel.SymbolSeq] = {
spelem: MDModel.APPLSymbol;

IF spappl.applval.stype ~= typeLIST THEN {
	-- if spappl is not already a PLUS list
	newsp: MDModel.APPLSymbol;
	newsp _ MDModel.NewSymAPPL[symbolseq];
	newsp^ _ spappl^;
	newsp.applsym _ MDModel.GenerateUniqueName[spappl];
	newsp.letparent _ NIL;
	spappl.applval _ MDModel.AddToEndOfList[NIL, newsp, plus, symbolseq];
	symbolseq.toploc.nestedmodel.model _ 
		MDModel.AddToEndOfList[symbolseq.toploc.nestedmodel.model,
			newsp, normal, symbolseq];
	};
spappl.letparent _ NIL;
spelem _ MDModel.NewSymAPPL[symbolseq];
spelem.applsym _ MDModel.GenerateUniqueName[spappl];
spelem.appltype _ spappl.appltype;
spelem.applval _ NIL;
spelem.letparent _ splet;
splet.letgrp _ MDModel.AddToEndOfList[splet.letgrp, spelem, normal, symbolseq];
spappl.applval _ MDModel.AddToEndOfList[
	MDModel.NarrowToLIST[spappl.applval], spelem, plus, symbolseq];
};

-- will fixup spappl so that splet may also export it
FixupLETtoLET: PROC[spappl: MDModel.APPLSymbol, spletnew: MDModel.LETSymbol, 
	symbolseq: MDModel.SymbolSeq] = {
spletold: MDModel.LETSymbol;
newsp: MDModel.APPLSymbol;

spletold _ spappl.letparent;
[newlist: spletold.letgrp] _ MDModel.RemoveFromList[spappl, spletold.letgrp];
newsp _ MDModel.NewSymAPPL[symbolseq];
newsp.letparent _ spletold;
newsp.applsym _ MDModel.GenerateUniqueName[spappl];
newsp.applval _ NIL;
newsp.appltype _ spappl.appltype;
spletold.letgrp _ MDModel.AddToEndOfList[spletold.letgrp, newsp, normal, symbolseq];
spappl.applval _ MDModel.AddToEndOfList[NIL, newsp, plus, symbolseq];
spappl.letparent _ NIL;

newsp _ MDModel.NewSymAPPL[symbolseq];
newsp.letparent _ spletnew;
newsp.applsym _ MDModel.GenerateUniqueName[spappl];
newsp.applval _ NIL;
newsp.appltype _ spappl.appltype;
spletnew.letgrp _ MDModel.AddToEndOfList[spletnew.letgrp, newsp, normal, symbolseq];
spappl.applval _ MDModel.AddToEndOfList[
	MDModel.NarrowToLIST[spappl.applval], newsp, plus, symbolseq];
symbolseq.toploc.nestedmodel.model _ 
	MDModel.AddToEndOfList[symbolseq.toploc.nestedmodel.model,
		spappl, normal, symbolseq];
};

-- manually set spimpl's LET to APPL if necessary
-- on return spimpl may be type APPL!!!
SmashLETToAPPL: PROC[splet: MDModel.LETSymbol, symbolseq: MDModel.SymbolSeq]
	RETURNS[spimpl: MDModel.Symbol] = {
spl: MDModel.LISTSymbol;
spimpl _ splet;
spl _ splet.letgrp;
MDModel.CkType[spl, typeLIST];
IF spl.rest = NIL THEN {
	spa: MDModel.APPLSymbol;
	spa _ MDModel.NarrowToAPPL[spl.first];
	IF spa.letparent ~= splet THEN ERROR;
	spa.letparent _ NIL;
	spa.applval _ splet.letval;
	spa.letparent _ NIL;
	spimpl _ spa;
	}
ELSE RemoveTheElements[symbolseq, spl];	-- remove extra appls from the master list
};

LookForMod: PROC[symbolseq: MDModel.SymbolSeq, spimpl1: MDModel.Symbol] = {
spimpltype: MDModel.TYPESymbol;
spimpl: MDModel.APPLSymbol;
done: BOOL _ FALSE;

	-- this is only called if spimpl has been filled in
	Anal: PROC[sp1: MDModel.Symbol] = {
	IF done THEN RETURN;
	WITH sp: sp1 SELECT FROM
	typeAPPL => {
		spt: MDModel.TYPESymbol;
		sploc: MDModel.LOCSymbol;
		listtype: MDModel.ListType;
		IF NOT LongString.EquivalentString[sp.applsym, spimpl.applsym] THEN 
			RETURN;
		spt _ MDModel.NarrowToTYPE[sp.appltype];
		IF spt.typeval = NIL THEN RETURN; 
		sploc _ MDModel.NarrowToLOC[spt.typeval];
		IF NOT LongString.EquivalentString[spimpltype.typesym,spt.typesym] THEN 
			RETURN;
		IF spimpltype.typeval ~= NIL THEN {
			IF MDModel.NarrowToLOC[spimpltype.typeval].createtime 
				~= sploc.createtime THEN RETURN;
			};
		IF sp.applval ~= NIL AND sp.applval ~= spimpl.applval THEN { 
			listtype _ IF sp.applval.stype = typeLIST THEN
				MDModel.NarrowToLIST[sp.applval].listtype ELSE plus;
 			-- modify it
			sp.applval _ MDModel.MergeIntoList[sp.applval,
				spimpl.applval, symbolseq, listtype];
			}
		ELSE sp.applval _ spimpl.applval;
		done _ TRUE;
		};
	typeLET => {
		splist: MDModel.LISTSymbol;
		splist _ sp.letgrp;
		WHILE splist ~= NIL DO
			IF LongString.EquivalentString[MDModel.Sym[splist.first],
				spimpl.applsym] THEN
				CWF.WF1["Warning - %s conflicts with a LET.\n"L, 
					spimpl.applsym];
			splist _ splist.rest;
			ENDLOOP;
		};
	ENDCASE => NULL;
	};

IF spimpl1.stype = typeAPPL THEN {
	spimpl _ MDModel.NarrowToAPPL[spimpl1];
	spimpltype _ MDModel.NarrowToTYPE[spimpl.appltype];
	MDModel.TraverseList[symbolseq.toploc.nestedmodel.model, Anal];
	};
IF NOT done THEN 
	symbolseq.toploc.nestedmodel.model _ 
		MDModel.AddToEndOfList[symbolseq.toploc.nestedmodel.model,
			 spimpl1, normal, symbolseq];
};

MAXAPPL: CARDINAL = 200;

FigureOutExports: PROC[symbolseq: MDModel.SymbolSeq] 
	RETURNS[procret: MDModel.LISTSymbol] = {
appls: ARRAY[0 .. MAXAPPL) OF MDModel.APPLSymbol;
nappls: CARDINAL _ 0;

	GetAllAppls: PROC[sp: MDModel.Symbol, spmodel: MDModel.MODELSymbol]
		 RETURNS[proceed: BOOL _ TRUE]  = {
	spappl: MDModel.APPLSymbol;
	IF sp.stype ~= typeAPPL THEN RETURN;
	spappl _ MDModel.NarrowToAPPL[sp];
	IF spappl.appltype = symbolseq.controlv THEN RETURN;
	FOR i: CARDINAL IN [0 .. nappls) DO
		IF spappl = appls[i] THEN RETURN;
		ENDLOOP;
	IF nappls < LENGTH[appls] THEN {
		appls[nappls] _ spappl;
		nappls _ nappls + 1;
		}
	ELSE CWF.WF0["Too many appls in the model.\n"L];
	};

	RunDownList: PROC[sp: MDModel.Symbol] = {
	IF sp.stype ~= typeAPPL THEN RETURN;
	FOR i: CARDINAL IN [0 .. nappls) DO
		IF sp = appls[i] THEN {
			appls[i] _ NIL;
			RETURN;
			};
		ENDLOOP;
	};
	
	LookForLOC: PROC[sp: MDModel.Symbol, spmodel: MDModel.MODELSymbol]
		 RETURNS[proceed: BOOL _ TRUE]  = {
	WITH spt: sp SELECT FROM 
	typeLOC => MDModel.TraverseList[spt.parmlist, RunDownList];
	typePROC => MDModel.TraverseList[spt.procparm, RunDownList];
	ENDCASE => NULL;
	};
	
-- first, collect all the APPLS
MDModel.TraverseTree[symbolseq.toploc, symbolseq, GetAllAppls];

-- now we look through and eliminate those in the list
-- that are on parameter lists
procret _ NIL;
MDModel.TraverseTree[symbolseq.toploc, symbolseq, LookForLOC];

-- the remains in the list are exports(?)
FOR i: CARDINAL IN [0 .. nappls) DO
	IF appls[i] ~= NIL THEN 
		procret _ MDModel.AddToEndOfList[procret, appls[i], 
			normal, symbolseq];
	ENDLOOP;
};
	

-- the altoCode switch is permanently FALSE
SwitchesToSymbol: PROC[altoCode, boundsChecks, cedarSwitch, crossJump, 
	linksInCode, nilChecks, sortByUsage: BOOL, symbolseq: MDModel.SymbolSeq] 
	RETURNS[sp: MDModel.STRINGSymbol] = {
stemp1: STRING _ [20];
stemp2: STRING _ [20];
CWF.SWF3[stemp1, "%sb%sc%sj"L, 
	IF boundsChecks THEN ""L ELSE "-"L,
	IF cedarSwitch THEN ""L ELSE "-"L,
	IF crossJump THEN ""L ELSE "-"L];
CWF.SWF4[stemp2, "%s%sl%sn%ss"L, stemp1,
	IF linksInCode THEN ""L ELSE "-"L,
	IF nilChecks THEN ""L ELSE "-"L,
	IF sortByUsage THEN ""L ELSE "-"L];
sp _ MDModel.NewSymSTRING[symbolseq];
sp.strval _ Subr.CopyString[stemp2];
};

-- this puts all the PLUS's at the end of the model
MoveAllPlus: PROC[oldlist: MDModel.LISTSymbol, symbolseq: MDModel.SymbolSeq] 
	RETURNS[newlist: MDModel.LISTSymbol]= {
first, second, splist: MDModel.LISTSymbol _ NIL;
splist _ oldlist;
WHILE splist ~= NIL DO
	{
	IF splist.first.stype = typeAPPL THEN {
		spappl: MDModel.APPLSymbol;
		spappl _ MDModel.NarrowToAPPL[splist.first];
		IF spappl.applval ~= NIL 
		AND spappl.applval.stype = typeLIST THEN {
			second _ MDModel.AddToEndOfList[second, splist.first, 
				normal, symbolseq];
			GOTO loop;
			};
		};
	first _ MDModel.AddToEndOfList[first, splist.first, 
		normal, symbolseq];
	GOTO loop;
	EXITS
	loop => splist _ splist.rest;
	};
	ENDLOOP;
newlist _ first;
IF second ~= NIL THEN
	newlist _ MDModel.NarrowToLIST[MDModel.MergeIntoList[first, second, 
		symbolseq, normal]];
};

RemoveTheElements: PROC[symbolseq: MDModel.SymbolSeq, 
	splist: MDModel.LISTSymbol] = {
WHILE splist ~= NIL DO
	MDModel.CkType[splist, typeLIST];
	[newlist: symbolseq.toploc.nestedmodel.model] _
		 MDModel.RemoveFromList[splist.first, 
		 	symbolseq.toploc.nestedmodel.model];
	splist _ splist.rest;
	ENDLOOP;
};

SpecialCase: PROC[sfn: LONG STRING, symbolseq: MDModel.SymbolSeq,
	innards: ProcBcds.Innards] RETURNS[isaspecialcase: BOOL] = {
sptype: MDModel.TYPESymbol;
spappl: MDModel.APPLSymbol;
sploclet: MDModel.LOCSymbol;
splet: MDModel.LETSymbol;

	procMod: ProcBcds.ProcMod = {
	fi: Dir.FileInfo _ MDModel.GetFileInfo[sploclet];
	fi.bcdVers _ bcdvers;
	fi.moduleName _ Subr.CopyString[smodulename];
	uns _ NIL;
	};
	
	procDep: ProcBcds.ProcDep = {
	};
	
IF NOT LongString.EquivalentString[sfn, "ModelParseData.Bcd"L] THEN 
	RETURN[FALSE];
sploclet _ MDModel.NewSymLOC[symbolseq];
sploclet.tail _ Subr.CopyString["ModelParseData"L];
sploclet.sext _ Subr.CopyString["Bcd"L];
[] _ ProcBcds.PrintDepends[innards, procMod, procDep, FALSE, FALSE, TRUE, sfn];	-- less is TRUE
ProcBcds.UnstallBcd[innards];
sptype _ MDModel.NewSymTYPE[symbolseq];
sptype.typesym _ Subr.CopyString["ModelParseData"L];
sptype.typeName _ Subr.CopyString["ModelParseData"L];
sptype.typeval _ NIL;
sptype.frameptr _ TRUE;
spappl _ MDModel.NewSymAPPL[symbolseq];
spappl.applsym _ Subr.CopyString["ModelParseDataImpl"L];
spappl.appltype _ sptype;
spappl.applval _ NIL;
splet _ MDModel.NewSymLET[symbolseq];
splet.letgrp _ MDModel.AddToEndOfList[NIL, sptype, normal, symbolseq];
splet.letgrp _ MDModel.AddToEndOfList[splet.letgrp, spappl, normal, symbolseq];
splet.letval _ sploclet;
spappl.letparent _ splet;
sptype.letparent _ splet;
symbolseq.toploc.nestedmodel.model _ 
	MDModel.AddToEndOfList[symbolseq.toploc.nestedmodel.model,
		splet, normal, symbolseq];
RETURN[TRUE];
};

-- this will involve a directoy lookup and sourcefile check!
FigureOutRemoteName: PROC[sploc: MDModel.LOCSymbol, sourcefile: STRING] = {
cap: File.Capability;
create: LONG CARDINAL;
fullname: STRING _ [125];
host: STRING _ [100];
directory: STRING _ [100];
cap _ Directory.Lookup[fileName: sourcefile, permissions: Directory.ignore
	! Directory.Error => GOTO out];
[create: create] _ Subr.GetCreateDate[cap];
IF create ~= sploc.createtime THEN GOTO out;
-- they are equal, now get remote property
Subr.GetRemoteFilenameProp[cap, fullname];
IF fullname.length = 0 THEN GOTO out;
[] _ DFSubr.StripLongName[fullname, host, directory, NIL];
IF host.length > 0 THEN sploc.host _ Subr.CopyString[host];
IF directory.length > 0 THEN sploc.path _ Subr.CopyString[directory];
EXITS
out => NULL;
};

-- main program
Init: PROC = {
-- set up WF stuff
[] _ CWF.SetWriteProcedure[PutProc];
UserExec.RegisterCommand["DesignModel.~", Main];
-- the main program exits at this point
-- SimpleExec will call Main when the user invokes it
};

Init[];
}.


-- NO LONGER NEEDED
-- move sptype from the procval field to the procparm field
-- assumes symbolseq.toploc.nestedmodel.model is a list of one element, which is a PROC
SpliceType: PROC[symbolseq: MDModel.SymbolSeq, sptype: MDModel.TYPESymbol] = {
spm: MDModel.PROCSymbol;
spl: MDModel.LISTSymbol;
splast: MDModel.Symbol;
spm _ MDModel.NarrowToPROC[symbolseq.toploc.nestedmodel.model.first];
spl _ MDModel.NarrowToLIST[spm.procval];
splast _ symbolseq.toploc.nestedmodel.model.first;
WHILE spl ~= NIL DO
	MDModel.CkType[spl, typeLIST];
	IF spl.first = sptype THEN {
		MDModel.AddToEndOfList[@spm.procparm, sptype, normal,
			symbolseq];
		WITH splast1: splast SELECT FROM
		typePROC => splast1.procval _ spl.rest;
		typeLIST => splast1.rest _ spl.rest;
		ENDCASE => ERROR;
		}
	ELSE splast _ spl;
	spl _ spl.rest;
	ENDLOOP;
};

-- take the module described by spimpl and look for it in symbolseq
-- if not already there, add it, if there, stick in spimpl's value
OldLookForMod: PROC[symbolseq: MDModel.SymbolSeq, spimpl1: MDModel.Symbol] = {
spimpltype: MDModel.TYPESymbol;
spimpl: MDModel.APPLSymbol;
done: BOOL _ FALSE;

	-- this is only called if spimpl has been filled in
	RunDownList: PROC[sp1: MDModel.Symbol, spmodel: MDModel.MODELSymbol]
		RETURNS[proceed: BOOL _ TRUE] = {
	IF done THEN RETURN[FALSE];
	WITH sp: sp1 SELECT FROM
	typeAPPL => {
		spt: MDModel.TYPESymbol;
		sploc: MDModel.LOCSymbol;
		listtype: MDModel.ListType;
		IF NOT LongString.EquivalentString[sp.applsym, spimpl.applsym] THEN 
			RETURN;
		spt _ MDModel.NarrowToTYPE[sp.appltype];
		IF spt.typeval = NIL THEN RETURN; 
		sploc _ MDModel.NarrowToLOC[spt.typeval];
		IF NOT LongString.EquivalentString[spimpltype.typesym,spt.typesym] THEN 
			RETURN;
		IF spimpltype.typeval ~= NIL THEN {
			IF MDModel.NarrowToLOC[spimpltype.typeval].createtime 
				~= sploc.createtime THEN RETURN;
			};
		IF sp.applval ~= NIL AND sp.applval ~= spimpl.applval THEN { 
			listtype _ IF sp.applval.stype = typeLIST THEN
				MDModel.NarrowToLIST[sp.applval].listtype ELSE plus;
 			-- modify it
			sp.applval _ MDModel.MergeIntoList[sp.applval,
				spimpl.applval, symbolseq, listtype];
			}
		ELSE sp.applval _ spimpl.applval;
		-- this records the new place for the value
		spimpl _ MDModel.NarrowToAPPL[sp1];
		done _ TRUE;
		};
	typeLET => {
		splist: MDModel.LISTSymbol;
		splist _ sp.letgrp;
		WHILE splist ~= NIL DO
			IF LongString.EquivalentString[MDModel.Sym[splist.first],
				spimpl.applsym] THEN
				CWF.WF1["Warning - %s conflicts with a LET.\n"L, 
					spimpl.applsym];
			splist _ splist.rest;
			ENDLOOP;
		};
	ENDCASE => NULL;
	};

IF spimpl1.stype = typeAPPL THEN {
	spimpl _ MDModel.NarrowToAPPL[spimpl1];
	spimpltype _ MDModel.NarrowToTYPE[spimpl.appltype];
	MDModel.TraverseTree[symbolseq.toploc.nestedmodel.model, symbolseq, RunDownList];
	IF done AND spimpl.letparent = NIL 
	AND NOT MDModel.IsOnList[spimpl, symbolseq.toploc.nestedmodel.model] THEN
		done _ FALSE;
	};
IF NOT done THEN 
	symbolseq.toploc.nestedmodel.model _ 
		MDModel.AddToEndOfList[symbolseq.toploc.nestedmodel.model,
			 spimpl1, normal, symbolseq];
};

	-- symbolseq is passed in
	ConvertLetToAppl: PROC[sp1: MDModel.Symbol] = {
	splist: MDModel.LISTSymbol;
	splet: MDModel.LETSymbol;
	nlist: CARDINAL _ 0;
	IF sp1.stype ~= typeLET THEN RETURN;
	splet _ MDModel.NarrowToLET[sp1];
 	splist _ splet.letgrp;
	WHILE splist ~= NIL DO
		MDModel.CkType[splist, typeLIST];
		nlist _ nlist + 1;
		IF nlist > 100 THEN ERROR;		-- cycling
	 	splist _ splist.rest
		ENDLOOP;
	IF nlist = 1 THEN {	-- only one thing in LET
		spt: MDModel.Symbol;
		spl: MDModel.LISTSymbol;
		spsave: MDModel.APPLSymbol;
		spt _ splet.letval;
		spl _ splet.letgrp;
		MDModel.CkType[spl, typeLIST];
		spsave _ MDModel.NarrowToAPPL[spl.first];
		IF spsave.letparent = splet THEN
			spsave.letparent _ NIL;
		-- smash on top, this changes the type of splet
		SmashOnTopOf[spsave, splet];
		-- should not free strings of spsave 
		-- they are also in splet^
		spsave.applsym _ NIL;
		-- splet is now of type APPL
		MDModel.NarrowToAPPL[splet].applval _ spt;
		MDModel.ReplaceBy[spsave, splet, symbolseq];
		-- this will detect erroneous references to this
		MDModel.ZeroOut[spsave];
		MDModel.ZeroOut[spl];
		}
	ELSE 	-- remove from the master list, 
		-- as they are defined in the LET[]
		RemoveTheElements[symbolseq, splet.letgrp];
	};

SmashOnTopOf: PROC[sp, ontopof: MDModel.Symbol] = {
ontopof^ _ sp^;
};

	-- not called!
	SeeIfUndefined: PROC[sp: MDModel.Symbol, spmodel: MDModel.MODELSymbol]
		RETURNS[proceed: BOOL _ TRUE] = {
	IF sp.stype ~= typeAPPL THEN RETURN;
	spa _ MDModel.NarrowToAPPL[sp];
	-- looking for an impl that has no value and is
	-- not exported by a LET
	IF spa.applval = NIL AND spa.letparent = NIL THEN {
		sptype: MDModel.TYPESymbol;
		sploc: MDModel.LOCSymbol;
		sptemp: MDModel.LISTSymbol;
		stemp: STRING _ [100];
		-- SpliceType[symbolseq, spa.appltype];
		spm.procparm _ MDModel.AddToEndOfList[spm.procparm, 
			spa.appltype, normal, symbolseq];
		sptemp _ MDModel.NarrowToLIST[spm.procval];
		[newlist: spm.procval] _ 
			MDModel.RemoveFromList[spa.appltype, sptemp];
		-- now add the IMPL
		spm.procparm _ MDModel.AddToEndOfList[spm.procparm, 
			spa, normal, symbolseq];
		sptype _ MDModel.NarrowToTYPE[spa.appltype];
		sploc _ MDModel.NarrowToLOC[sptype.typeval];
		CWF.SWF2[stemp, "%s.%s"L, sploc.tail, sploc.sext];
		IF NOT Subr.IsASystemFile[stemp] THEN 
			CWF.WF1["Warning - %s is a parameter but is not a Mesa System file.\n"L, 
				stemp];
		};
	};