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