-- MDCompImpl.mesa
-- last edit by Schmidt, April 21, 1982 2:55 pm
-- last edit by Satterthwaite, January 31, 1983 10:52 am
-- Pilot 6.0/ Mesa 7.0
-- procedures to determine compilation, etc. for the system modeller
DIRECTORY
CompilerOps: TYPE USING [LetterSwitches],
CWF: TYPE USING [FWF1, FWF2, SWF1, SWF2, SWF3, WF0, WF1, WF2, WF3, WF4, WFCR],
Dir: TYPE USING [DepSeq, FileInfo, NewVersion],
Directory: TYPE USING [Error, Handle, ignore, Lookup, Rename],
ExecOps: TYPE USING [Outcome],
File: TYPE USING [Capability],
IO: TYPE USING [Handle],
LowLoader: TYPE USING [ReplaceResult],
LongString: TYPE USING [AppendChar, AppendString, EquivalentString],
MDComp: TYPE USING [],
MDDB: TYPE USING [GetBcdDepSeq],
MDMain: TYPE USING [DebugWP],
MDModel: TYPE USING [
AddToEndOfList, APPLSymbol, CkType, EraseCacheEntry,
FoldInParms, GenerateUniqueName, GetBcdCreate, GetFileInfo, GetSrcCreate,
LETSymbol, LISTSymbol, LocForType, LOCSymbol, MODELSymbol,
NarrowToLIST, NarrowToPROC, NewSymAPPL, OPENSymbol, PROCSymbol,
SpliceBefore, STRINGSymbol, Symbol, SymbolSeq, TraverseList, TYPESymbol],
MDUtil: TYPE USING [MakeConfig, RunBinder, SetModelCreateProperty],
RComp: TYPE USING [Compile, StopBatchCompile],
RTOS: TYPE USING [CheckForModuleReplacement],
Runtime: TYPE USING [IsBound],
Stream: TYPE USING [Delete, Handle],
String: TYPE USING [AppendString],
Subr: TYPE USING [
AbortMyself, CheckForModify, CopyString, debugflg, EndsIn,
NewStream, strcpy, TTYProcs, Write],
TimeStamp: TYPE USING [Null],
TypeScript: TYPE USING[TS, UserAbort];
MDCompImpl: PROGRAM
IMPORTS
CWF, Dir, Directory, LongString, MDDB, MDMain, MDModel, MDUtil,
RComp, RTOS, Runtime, Stream, String, Subr, TypeScript
EXPORTS MDComp = {
RTCallable: BOOL = TRUE;
-- no MDS Usage!!!
OutCome: TYPE = {
compNotNecc, compDeclined, compFailed,
compSuccNotRepl, compSuccRepl, compSucc};
-- this may call a procedure to look at bcd header
DetermineRecomp: PUBLIC PROC[
sproot: MDModel.Symbol, symbolseq: MDModel.SymbolSeq,
officialwindow: Subr.TTYProcs, uniquename, tryreplacement: BOOL,
confirm: REF BOOL, typeScript: TypeScript.TS, ttyin, ttyout, msgout: IO.Handle]
RETURNS[wascompiled, didfail: BOOL] = {
m, dontProceed: BOOL ← FALSE;
numberOfErrors, numberOfWarnings, numberSuccessful: CARDINAL;
RecompRecur: PROC[
sp: MDModel.Symbol, mustcomp, failed: BOOL,
spparent: MDModel.Symbol, spmodel: MDModel.MODELSymbol]
RETURNS[BOOL, BOOL] = {
mustcomp1, mustcomp2, mustcomp3, f1, f2, f3: BOOL;
IF sp = NIL THEN RETURN[mustcomp, failed];
IF sp.visited THEN RETURN[sp.changed OR mustcomp, sp.failed OR failed];
sp.visited ← TRUE;
WITH sp SELECT FROM
spt: MDModel.TYPESymbol => {
[mustcomp1, f1] ← RecompRecur[spt.typeval, FALSE, FALSE, sp, spmodel];
[mustcomp2, f2] ← RecompRecur[spt.letparent, FALSE, FALSE, sp, spmodel];
failed ← f1 OR f2;
mustcomp ← mustcomp1 OR mustcomp2};
spt: MDModel.PROCSymbol => {
[mustcomp1, f1] ← RecompRecur[spt.procparm, FALSE, FALSE, sp, spmodel];
[mustcomp2, f2] ← RecompRecur[spt.procret, FALSE, FALSE, sp, spmodel];
[mustcomp3, f3] ← RecompRecur[spt.procval, FALSE, FALSE, sp, spmodel];
mustcomp ← mustcomp1 OR mustcomp2 OR mustcomp3;
failed ← f1 OR f2 OR f3};
spt: MDModel.APPLSymbol => {
[mustcomp1, f1] ← RecompRecur[spt.appltype, FALSE, FALSE, sp, spmodel];
[mustcomp, f2] ← RecompRecur[spt.applval, mustcomp1, FALSE, sp, spmodel];
failed ← f1 OR f2};
spt: MDModel.LISTSymbol => {
ignoreappls: BOOL = (spparent.stype = typeLOC);
flist, mlist: BOOL ← FALSE;
RunDownList: PROC[spinner: MDModel.Symbol] = {
m1, f1: BOOL;
-- special case for parameter that is an instance;
-- an instance may change but the Importer need not change
-- this is only set to true if the parent is a LOC
-- forthermore, we want to avoid analyzing the value of an APPL
-- but since the LOC is parameterized by TYPES, it is ok to skip them now
-- (problem arose with FRAMEPTRTYPEs)
IF ignoreappls AND ISTYPE[spinner, MDModel.APPLSymbol] THEN m1 ← f1 ← FALSE
ELSE [m1, f1] ← RecompRecur[spinner, FALSE, FALSE, sp, spmodel];
mlist ← mlist OR m1;
flist ← flist OR f1};
MDModel.TraverseList[spt, RunDownList];
mustcomp ← mlist;
failed ← flist};
spt: MDModel.LETSymbol => {
[mustcomp1, f1] ← RecompRecur[spt.letgrp, FALSE, FALSE, sp, spmodel];
[mustcomp, f2] ← RecompRecur[spt.letval, mustcomp1, FALSE, sp, spmodel];
failed ← f1 OR f2};
spt: MDModel.LOCSymbol => {
o: OutCome;
[mustcomp1, f1] ← RecompRecur[spt.parmlist, FALSE, FALSE, sp, spmodel];
[mustcomp2, f2] ← RecompRecur[spt.nestedmodel, FALSE, FALSE, sp, spmodel];
failed ← failed OR f1 OR f2;
mustcomp ← mustcomp OR mustcomp1 OR mustcomp2;
IF TypeScript.UserAbort[typeScript] THEN SIGNAL Subr.AbortMyself;
o ← GenerateBcd[spt,
mustcomp, uniquename, tryreplacement, failed, confirm,
symbolseq, officialwindow, spmodel, typeScript, ttyin, ttyout, msgout];
SELECT o FROM
$compNotNecc => {mustcomp ← FALSE; failed ← FALSE};
$compDeclined => {failed ← FALSE; dontProceed ← TRUE};
$compFailed => {mustcomp ← TRUE; failed ← TRUE; dontProceed ← TRUE};
$compSuccNotRepl => {mustcomp ← TRUE; failed ← FALSE; dontProceed ← TRUE};
$compSuccRepl => {mustcomp ← TRUE; failed ← FALSE};
$compSucc => {mustcomp ← TRUE; failed ← FALSE};
ENDCASE => ERROR;
-- dontProceed means do not do anything after trying to compile --};
spt: MDModel.MODELSymbol => {
IF Subr.debugflg THEN CWF.WF1["About to analyze %s.\n"L, spt.modelfilename];
[mustcomp, failed] ← RecompRecur[spt.model, mustcomp, FALSE, sp, spt]};
spt: MDModel.OPENSymbol => NULL;
spt: MDModel.STRINGSymbol => NULL;
ENDCASE => ERROR; -- Unknown stype
sp.changed ← mustcomp;
sp.failed ← failed;
RETURN[mustcomp, failed]};
-- print is used temporarily here to mean compilation failed ,???
IF symbolseq.traversalInProgress THEN ERROR;
symbolseq.traversalInProgress ← TRUE;
FOR i: CARDINAL IN [0.. symbolseq.size) DO
symbolseq[i].failed ← symbolseq[i].visited ← symbolseq[i].changed ← FALSE;
ENDLOOP;
[m, didfail] ← RecompRecur[sproot, FALSE, FALSE, NIL, NIL
! UNWIND => {
symbolseq.traversalInProgress ← FALSE; [] ← RComp.StopBatchCompile[]}
];
sproot.changed ← m;
[numberSuccessful, numberOfWarnings, numberOfErrors] ← RComp.StopBatchCompile[];
IF numberSuccessful = 0 AND numberOfErrors = 0 AND numberOfWarnings = 0 THEN
CWF.WF0["Nothing was compiled.\n"L]
ELSE {
CWF.WF1["%u successful; "L, @numberSuccessful];
IF numberOfErrors > 0 THEN CWF.WF1["%u w/errors; "L, @numberOfErrors];
IF numberOfWarnings > 0 THEN CWF.WF1["%u w/warnings; "L, @numberOfWarnings];
CWF.WFCR[]};
CWF.WFCR[];
symbolseq.traversalInProgress ← FALSE;
RETURN[m, (numberOfErrors > 0) OR dontProceed]};
oType: TYPE = {mesa, config, model};
-- sploc will be of type typeLOC
-- this procedure may look at the bcd header
GenerateBcd: PROC[
sploc: MDModel.LOCSymbol,
mustcomp, uniquename, tryreplacement, failed: BOOL, confirm: REF BOOL,
symbolseq: MDModel.SymbolSeq, officialwindow: Subr.TTYProcs,
spmodel: MDModel.MODELSymbol,
typeScript: TypeScript.TS, ttyin, ttyout, msgout: IO.Handle]
RETURNS [outc: OutCome] = {
need: BOOL;
ot: oType;
fi: Dir.FileInfo;
MDModel.CkType[sploc, typeLOC];
fi ← MDModel.GetFileInfo[sploc];
IF fi.isBcd THEN {
IF fi.bcdPresent THEN SetVersAndModulename[sploc];
RETURN[$compNotNecc]};
IF Subr.debugflg AND ~fi.srcPresent THEN
CWF.WF1["Check - Cannot find %s.\n"L, fi.srcFileName];
IF sploc.sext = NIL OR LongString.EquivalentString[sploc.sext, "mesa"L] THEN
ot ← $mesa
ELSE IF LongString.EquivalentString[sploc.sext, "config"L] THEN ot ← $config
ELSE IF LongString.EquivalentString[sploc.sext, "model"L] THEN ot ← $model
ELSE ERROR;
IF ot=$model THEN RETURN[$compNotNecc];
--
IF failed THEN {
-- the bcdVers has not been set!
CWF.WF1["Don't bother with %s since something failed before it.\n"L, fi.srcFileName];
RETURN[$compFailed]};
SetVersAndModulename[sploc]; -- this analyzes the bcd to get the bcd version stamp
IF fi.srcPresent
AND sploc.createtime > 0 AND MDModel.GetSrcCreate[fi] ~= sploc.createtime THEN {
CWF.WF3["You want %s of %lt but the disk has %lt.\n"L,
fi.srcFileName, @sploc.createtime, @fi.srcCreate];
RETURN[$compNotNecc]};
-- we used to skip checking the bcd to see if it needs to be compiled
-- if a paramter had changed, but recompiling a defs file may not changed the
-- functional time stamp so we always check now
need ← BcdNoGood[sploc];
IF need THEN {
errors, warnings, replaceable: BOOL ← FALSE;
declined: BOOL ← FALSE;
-- oldBcdCap: File.Capability ← fi.bcdCap;
IF ~fi.srcPresent THEN {
CWF.WF1["Error - Cannot compile/bind %s.\n"L, fi.srcFileName];
RETURN[$compFailed]};
SELECT ot FROM
$mesa => {
IF CheckParametersOnDisk[sploc] THEN RETURN[$compFailed];
-- always tries for replacement
IF -- tryreplacement AND -- fi.loadInfoSeq ~= NIL
AND fi.loadInfoSeq.size = 1 THEN {
-- should do something about checking
-- both for local frames and copied and shared
replaceResult: LowLoader.ReplaceResult;
oldname: STRING ← [100];
GenUniqueBcdName[oldname, sploc];
replaceResult ← SELECT TRUE FROM
LongString.EquivalentString[oldname, fi.bcdFileName] => $cantCopyOldBcd,
RTCallable AND Runtime.IsBound[RTOS.CheckForModuleReplacement]
AND ~RTOS.CheckForModuleReplacement[fi.loadInfoSeq[0].frame] =>
$checkForMRFailed,
ENDCASE => $ok;
IF replaceResult ~= $ok THEN {
CWF.WF2["%s cannot be replaced because %s.\n"L, fi.bcdFileName,
SELECT replaceResult FROM
$cantCopyOldBcd => "can't copy old bcd"L,
$checkForMRFailed => "RT check for module replacement failed"L,
ENDCASE => ERROR];
declined ← TRUE;
GOTO skip};
-- make sure depseq is ready for old bcd
[] ← MDDB.GetBcdDepSeq[fi, 0];
Directory.Rename[newName: oldname, oldName: fi.bcdFileName];
CWF.WF2["Old version of %s renamed to %s.*N"L, fi.bcdFileName, oldname];
[errors, warnings, replaceable, declined] ← RComp.Compile[
symbolseq, sploc, TRUE, oldname,
spmodel, confirm, typeScript, ttyin, ttyout, msgout];
IF ~replaceable THEN replaceResult ← $compilerSaysNo;
IF replaceable AND ~errors AND ~declined THEN {
CWF.WF1["%s passes compiler's test for replaceability.\n"L, fi.bcdFileName];
fi.loadInfoSeq.mustreplace ← TRUE}
ELSE {
fi.loadInfoSeq.mustreplace ← FALSE;
IF declined OR errors THEN {
-- new version has to be deleted
Directory.Rename[newName: fi.bcdFileName, oldName: oldname];
CWF.WF1["Old, loaded version of %s has been left on disk.\n"L, fi.bcdFileName]}
ELSE CWF.WF3[
"%s is not replaceable%s, new version has been left on disk, \n\told loaded version is called %s.\n"L,
fi.bcdFileName,
IF replaceResult = $compilerSaysNo
THEN " (Compiler refuses)"L ELSE ""L, oldname]};
EXITS
skip => NULL;
}
ELSE -- not currently called -- {
[errors, warnings, , declined] ← RComp.Compile[
symbolseq, sploc, FALSE, NIL,
spmodel, confirm, typeScript, ttyin, ttyout, msgout]}};
$config => {
outcome: ExecOps.Outcome;
cmd: STRING ← [1500];
objectfile: STRING ← [100];
FormatBinderCmd[cmd, objectfile, fi.srcFileName, uniquename, NIL];
outcome ← MDUtil.RunBinder[cmd, typeScript, ttyin, ttyout, msgout, confirm];
SELECT outcome FROM
$ok, $aborted => NULL;
$warnings => warnings ← TRUE;
$errors => errors ← TRUE;
$errorsAndWarnings => warnings ← errors ← TRUE;
ENDCASE => ERROR}
ENDCASE => ERROR;
-- leave undisturbed if declined
IF ~declined THEN {
IF errors THEN {
-- there were errors, remove any capabilities for it
MDModel.EraseCacheEntry[fi: fi, src: FALSE];
CWF.FWF1[MDMain.DebugWP, "Erasing fi entry for %s.\n"L, fi.bcdFileName]}
ELSE {
-- record new version and update cache
fdepseq: Dir.DepSeq;
[] ← Dir.NewVersion[fi: fi, src: FALSE];
fdepseq ← MDDB.GetBcdDepSeq[fi, 0]; -- this will use the DB cache
IF fdepseq = NIL THEN ERROR;
fi.bcdVers ← fdepseq.bcdVers;
CWF.FWF1[MDMain.DebugWP, "Resetting fi entry for %s.\n"L, fi.bcdFileName]}};
RETURN[SELECT TRUE FROM
declined => $compDeclined,
errors => $compFailed,
replaceable AND fi.loadInfoSeq ~= NIL => $compSuccRepl,
~replaceable AND fi.loadInfoSeq ~= NIL => $compSuccNotRepl,
ENDCASE => $compSucc]};
RETURN[$compNotNecc]};
SetVersAndModulename: PUBLIC PROC[sploc: MDModel.LOCSymbol] = {
fi: Dir.FileInfo = MDModel.GetFileInfo[sploc];
IF fi.bcdPresent THEN {
fdepseq: Dir.DepSeq = MDDB.GetBcdDepSeq[fi, 0];
IF fdepseq ~= NIL THEN {
IF fdepseq.moduleName ~= NIL AND fi.moduleName = NIL THEN
fi.moduleName ← Subr.CopyString[fdepseq.moduleName];
IF fi.bcdVers = TimeStamp.Null
OR fi.bcdVers.time ~= sploc.createtime
OR sploc.createtime = MDModel.GetBcdCreate[fi] THEN {
IF Subr.debugflg AND fi.bcdVers ~= fdepseq.bcdVers THEN
CWF.WF2["%s bcdVers set to %v.\n"L, fi.bcdFileName, @fdepseq.bcdVers];
fi.bcdVers ← fdepseq.bcdVers}}};
};
CheckParametersOnDisk: PROC[sploctop: MDModel.LOCSymbol]
RETURNS [willfail: BOOL ← FALSE] = {
FOR splist: MDModel.LISTSymbol ← sploctop.parmlist, splist.rest WHILE splist ~= NIL DO
WITH splist.first SELECT FROM
sptype: MDModel.TYPESymbol => {
sploc: MDModel.LOCSymbol = MDModel.LocForType[sptype];
fi: Dir.FileInfo;
IF sploc = NIL THEN RETURN;
fi ← MDModel.GetFileInfo[sploc];
IF fi.bcdVers = TimeStamp.Null THEN {
IF Subr.debugflg THEN
CWF.WF1["Warning- no version stamp for %s.\n"L, fi.bcdFileName]}
ELSE IF ~fi.bcdPresent THEN {
CWF.WF2["Error - to compile %s.Mesa you need %s on the local disk.\n"L,
sploctop.tail, fi.bcdFileName];
RETURN[TRUE]}};
ENDCASE => NULL;
ENDLOOP};
GenUniqueBcdName: PROC[newname: LONG STRING, sploc: MDModel.LOCSymbol] = {
inx: CARDINAL ← 1;
fi: Dir.FileInfo = MDModel.GetFileInfo[sploc];
Subr.strcpy[newname, fi.bcdFileName];
IF ~fi.bcdPresent THEN RETURN;
DO
CWF.SWF2[newname, "%s.%u.Bcd$"L, sploc.tail, @inx];
[] ← Directory.Lookup[fileName: newname, permissions: Directory.ignore
! Directory.Error => {GOTO out}];
inx ← inx + 1;
ENDLOOP;
EXITS
out => NULL;
};
-- verify the Bcd is ok
BcdNoGood: PROC[splocsrc: MDModel.LOCSymbol] RETURNS[terrible: BOOL] = {
bcddepseq: Dir.DepSeq;
fi: Dir.FileInfo;
wantsw: CompilerOps.LetterSwitches;
explicitSortSwitch: BOOL ← FALSE;
-- this only checks the time part of the version stamp
-- in case the sploc.bcdVers came from the model and
-- the bcd is not on the local disk
-- you only need to check the number and types of TYPES (defs files)
-- to verify the parameters (also, should check parms)
ProcParm: PROC[sp: MDModel.Symbol] = {
WITH sp SELECT FROM
spt: MDModel.STRINGSymbol =>
[wantsw, explicitSortSwitch] ← MDModel.FoldInParms[spt.strval];
sptype: MDModel.TYPESymbol => {
sploc: MDModel.LOCSymbol;
fiInner: Dir.FileInfo;
IF terrible THEN RETURN;
sploc ← MDModel.LocForType[sptype];
IF sploc = NIL THEN RETURN;
fiInner ← MDModel.GetFileInfo[sploc];
IF fiInner.bcdVers = TimeStamp.Null THEN {
CWF.FWF1[MDMain.DebugWP, "Bcdvers for %s is 0.\n"L, fiInner.bcdFileName];
RETURN};
IF ~fiInner.bcdPresent AND ~fiInner.srcPresent THEN {
CWF.FWF2[MDMain.DebugWP,
"Neither src nor bcd present for %s, needed by %s.\n"L,
fiInner.bcdFileName, fi.bcdFileName];
RETURN};
IF fiInner.moduleName = NIL THEN ERROR;
-- since the bcddepseq[i].modulename may be NIL, we must match
-- on bcdfilename and bcdvers rather than sptype.typeName
FOR i: CARDINAL IN [0.. bcddepseq.size) DO
IF bcddepseq[i].relation ~= directory THEN LOOP;
IF LongString.EquivalentString[fiInner.bcdFileName, bcddepseq[i].bcdFileName] THEN {
IF bcddepseq[i].bcdVers.time ~= fiInner.bcdVers.time THEN {
CWF.WF2["\nMust recompile %s since it depends on %s.\n"L,
fi.bcdFileName, fiInner.bcdFileName];
CWF.WF4[" %s is now dated %v\n\tbut %s was compiled with %v.\n"L,
fiInner.bcdFileName, @fiInner.bcdVers,
fi.bcdFileName, @bcddepseq[i].bcdVers];
terrible ← TRUE};
RETURN};
ENDLOOP;
terrible ← TRUE;
CWF.WF4[
" \nMust recompile %s since it was compiled with type %s, which is %s of %v in the model\n"L,
fi.bcdFileName, sptype.typeName, fiInner.bcdFileName, @fiInner.bcdVers];
CWF.WF1[" but %s does not use it.\n"L, fi.bcdFileName]};
ENDCASE => NULL};
[wantsw] ← MDModel.FoldInParms[NIL]; -- get default switches
wantsw['s] ← FALSE; -- default for modeller is /-s
MDModel.CkType[splocsrc, typeLOC];
fi ← MDModel.GetFileInfo[splocsrc];
IF ~fi.bcdPresent THEN {
CWF.WF2[
"Must compile %s since there is no %s on the disk.\n"L, fi.srcFileName, fi.bcdFileName];
RETURN[TRUE]};
IF ~fi.srcPresent THEN RETURN[FALSE]; -- can't recompile anyway
-- don't ever free this depseq
bcddepseq ← MDDB.GetBcdDepSeq[fi, 0];
IF bcddepseq = NIL THEN RETURN[TRUE]; -- not in Bcd format, must recompile
terrible ← FALSE;
-- do the file names agree?
IF ~LongString.EquivalentString[fi.srcFileName, bcddepseq.srcFileName] THEN {
CWF.WF3["Must recompile %s since the source for %s on the disk is %s,\n"L,
fi.bcdFileName, fi.bcdFileName, bcddepseq.srcFileName];
CWF.WF1[" so it cannot be used as a .Bcd for %s.\n"L,
fi.srcFileName];
terrible ← TRUE}
-- do the create dates agree?
ELSE IF MDModel.GetSrcCreate[fi] ~= bcddepseq.srcCreate THEN {
CWF.WF3["Must recompile %s since it was compiled with %s of %lt,\n"L,
fi.bcdFileName, fi.srcFileName, @bcddepseq.srcCreate];
CWF.WF2[" but %s is now dated %lt.\n"L, fi.srcFileName, @fi.srcCreate];
terrible ← TRUE}
-- do the parameters agree in type?
ELSE MDModel.TraverseList[splocsrc.parmlist, ProcParm];
-- check parameter switches, these must agree (only for implementors)
-- /b (bounds checks)
-- /c (cedar fork)
-- /j (cross jump)
-- /l (links in code, new interpretation)
-- /n (nil check)
-- /s (sort by usage), only check if the user explicitly specified switches
IF ~terrible AND ~bcddepseq.isdefns AND
(wantsw['b] ~= bcddepseq.switches['b]
OR wantsw['c] ~= bcddepseq.switches['c]
OR wantsw['j] ~= bcddepseq.switches['j]
OR wantsw['l] ~= bcddepseq.switches['l]
OR wantsw['n] ~= bcddepseq.switches['n]
OR (wantsw['s] ~= bcddepseq.switches['s] AND explicitSortSwitch))
THEN {
s1: STRING ← [20];
s2: STRING ← [20];
AppendBcdSwitches[s1, wantsw];
AppendBcdSwitches[s2, bcddepseq.switches];
CWF.WF2[
"Must compile %s since the model specifies compiler options %s,\n"L, fi.srcFileName, s1];
CWF.WF2["but %s was compiled with %s.\n"L, fi.bcdFileName, s2];
terrible ← TRUE};
-- if the file is ok, then make sure the loc has recorded in it
-- the bcd time stamp; if the file is not ok, then give a bogus date
-- can't do this because this module may be replaced, and we need the bcdVers
-- fi.bcdVers ← IF terrible THEN [net: 0, host: 0, time: 1] ELSE depseq.bcdVers;
fi.bcdVers ← bcddepseq.bcdVers;
IF Subr.debugflg AND ~terrible THEN CWF.WF1["%s is ok.\n"L, fi.bcdFileName];
RETURN[terrible]};
-- only does this for
-- /b (bounds checks)
-- /c (cedar fork)
-- /j (cross jump)
-- /l (links in code, new interpretation)
-- /n (nil check)
AppendBcdSwitches: PROC[to: LONG STRING, switches: CompilerOps.LetterSwitches] = {
arr: ARRAY [0..5] OF CHAR = ['b, 'c, 'j, 'l, 'n, 's];
to.length ← 0;
LongString.AppendChar[to, '/];
FOR i: CARDINAL IN [0..arr.LENGTH) DO
c: CHAR = arr[i];
IF ~switches[c] THEN LongString.AppendChar[to, '-];
LongString.AppendChar[to, c];
ENDLOOP};
-- stores the binder command in "cmd"
-- the objectfile name in "objectfile"
FormatBinderCmd: PROC[
cmd, objectfile, sourcefile: LONG STRING, uniquename: BOOL,
fileparameters: LONG STRING] = {
try: STRING ← [100];
Subr.strcpy[objectfile, sourcefile];
IF Subr.EndsIn[objectfile, ".config"L] THEN objectfile.length ← objectfile.length - 7;
CWF.SWF1[try, "%s.bcd"L, objectfile];
IF uniquename THEN {
num: CARDINAL ← 1;
[] ← Directory.Lookup[fileName: try, permissions: Directory.ignore
! Directory.Error => {GOTO ok}];
DO
CWF.SWF2[try, "%s%u.bcd"L, objectfile, @num];
[] ← Directory.Lookup[fileName: try, permissions: Directory.ignore
! Directory.Error => {EXIT}];
num ← num + 1;
ENDLOOP;
-- try is the name we will give it
EXITS
ok => NULL;
};
Subr.strcpy[objectfile, try];
CWF.SWF3[cmd, "[bcd: %s] ← %s[%s]/e"L, objectfile, sourcefile,
IF fileparameters = NIL THEN ""L ELSE fileparameters]};
-- take PLUS nodes and convert them to format acceptible to the modeller loader
HandlePlus: PUBLIC PROC[symbolseq: MDModel.SymbolSeq] = {
start: MDModel.PROCSymbol;
splist : MDModel.LISTSymbol ← symbolseq.toploc.nestedmodel.model;
WHILE splist ~= NIL AND ~ISTYPE[splist.first, MDModel.PROCSymbol] DO
splist ← splist.rest;
IF splist = NIL THEN RETURN;
MDModel.CkType[splist, typeLIST];
ENDLOOP;
start ← MDModel.NarrowToPROC[splist.first];
splist ← MDModel.NarrowToLIST[start.procval];
WHILE splist ~= NIL DO
MDModel.CkType[splist, typeLIST];
WITH splist.first SELECT FROM
spa: MDModel.APPLSymbol =>
WITH spa.applval SELECT FROM
spp: MDModel.LISTSymbol =>
IF spp.listtype = $plus AND ISTYPE[spp.first, MDModel.LOCSymbol] THEN {
spnewlist: MDModel.LISTSymbol ← NIL;
WHILE spp ~= NIL DO
spnew: MDModel.APPLSymbol = MDModel.NewSymAPPL[symbolseq];
MDModel.CkType[spp, typeLIST];
spnew.applsym ← MDModel.GenerateUniqueName[spa];
spnew.applval ← spp.first;
spnew.appltype ← spa.appltype;
spnew.recursive ← spa.recursive;
start.procval ← MDModel.SpliceBefore[symbolseq,
spnew, splist, MDModel.NarrowToLIST[start.procval]];
spnewlist ← MDModel.AddToEndOfList[spnewlist, spnew, $plus, symbolseq];
spp ← spp.rest;
ENDLOOP;
-- now replace list val by new one
-- this discards the old list
-- FreeListHeaders[spa.applval];
spa.applval ← spnewlist};
ENDCASE => NULL;
ENDCASE => NULL;
splist ← splist.rest;
ENDLOOP};
-- add the UID (create date) for the model to the config
NewBind: PUBLIC PROC[
sproot: MDModel.MODELSymbol, symbolseq: MDModel.SymbolSeq,
needsconfig, uniquename: BOOL, confirm: REF BOOL, modelfile: LONG STRING,
modelcreate: LONG CARDINAL, officialwindow: Subr.TTYProcs,
typeScript: TypeScript.TS, ttyin, ttyout, msgout: IO.Handle]
RETURNS[successful: BOOL ← FALSE] = {
fileparameters: STRING ← [2000];
cmd: STRING ← [2000];
sourcefile: STRING ← [100];
objectfile: STRING ← [100];
outcome: ExecOps.Outcome;
IF ~Subr.EndsIn[modelfile, ".model"L] THEN ERROR;
Subr.strcpy[sourcefile, "MODEL"L];
LongString.AppendString[sourcefile, modelfile];
sourcefile.length ← sourcefile.length - 5;
String.AppendString[sourcefile, "config"L];
IF needsconfig THEN {
sh: Stream.Handle;
CWF.WF1["\nThe New Config File Is %s.\n"L, sourcefile];
-- this changes the model to allow for
-- Binder limitations; don't save this version
HandlePlus[symbolseq];
IF Subr.debugflg THEN MDUtil.MakeConfig[sproot, symbolseq, NIL, 0, ttyout, NIL];
IF Subr.CheckForModify[sourcefile, officialwindow] THEN {
cap: File.Capability;
sh ← Subr.NewStream[sourcefile, Subr.Write];
MDUtil.MakeConfig[sproot, symbolseq, sh, modelcreate, ttyout, fileparameters];
Stream.Delete[sh];
cap ← Directory.Lookup[fileName: sourcefile, permissions: Directory.ignore];
MDUtil.SetModelCreateProperty[cap, modelcreate]}};
FormatBinderCmd[cmd, objectfile, sourcefile, uniquename,
IF fileparameters.length = 0 THEN NIL ELSE fileparameters];
outcome ← MDUtil.RunBinder[cmd, typeScript, ttyin, ttyout, msgout, confirm];
IF outcome = $ok OR outcome = $warnings THEN {
cap: File.Capability;
successful ← TRUE;
cap ← Directory.Lookup[fileName: sourcefile, permissions: Directory.ignore];
MDUtil.SetModelCreateProperty[cap, modelcreate];
-- call with the top-level bcd name
-- strip off ".Bcd", it's not needed
objectfile.length ← objectfile.length - 4};
CWF.WFCR[];
RETURN};
}.
TimeToStamp: PROC [time: TimeStamp.Stamp] RETURNS [Stamp] = INLINE {
RETURN [LOOPHOLE[time]]};
-- new version stamp operations
StampSize: NAT = 3;
Stamp: TYPE = RECORD [word: ARRAY [0..StampSize) OF CARDINAL];
AddStamps: PROC [s1, s2: Stamp] RETURNS [sum: Stamp] = {
carry: [0..1] ← 0;
i: NAT;
FOR i DECREASING IN [0..StampSize) DO
t: Inline.LongNumber ← [lc[LONG[s1.word[i]] + LONG[s2.word[i]] + LONG[carry]]];
sum.word[i] ← t.lowbits; carry ← t.highbits;
ENDLOOP;
FOR i DECREASING IN [0..StampSize) WHILE carry # 0 DO
t: Inline.LongNumber ← [lc[LONG[sum.word[i]] + LONG[carry]]];
sum.word[i] ← t.lowbits; carry ← t.highbits;
ENDLOOP};
RotateStamp: PROC [s: Stamp] RETURNS [Stamp] = INLINE {RETURN [AddStamps[s, s]]};
MergeStamps: PUBLIC PROC [sum, item: Stamp] RETURNS [Stamp] = {
RETURN [AddStamps[RotateStamp[sum], item]]};
QuickCheck: PROC[diskbcd, disksrc: Dir.Disk, sploctop: MDModel.LOCSymbol]
RETURNS[bcdisok: BOOL] = {
switches: PACKED ARRAY CHAR ['a..'z] OF BOOL;
compilerVersion: TimeStamp.Stamp = CompilerOps.CompilerVersion[]; -- current Cedar release
trystamp: Stamp;
actualstamp: TimeStamp.Stamp;
depseq: Dir.DepSeq;
willfail: BOOL ← FALSE;
t: TimeStamp.Stamp;
GetSwitches: PROC[sp: MDModel.Symbol] = {
spstr: MDModel.STRINGSymbol;
IF sp.stype ~= typeSTRING THEN RETURN;
spstr ← MDModel.NarrowToSTRING[sp];
switches ← MDModel.FoldInParms[spstr.strval];
};
GetTYPES: PROC[sp: MDModel.Symbol] = {
sptype: MDModel.TYPESymbol;
sploc: MDModel.LOCSymbol;
IF sp.stype ~= typeTYPE THEN RETURN;
sptype ← MDModel.NarrowToTYPE[sp];
sploc ← MDModel.LocForType[sptype];
IF sploc = NIL THEN RETURN;
IF sploc.bcdVers = TimeStamp.Null AND Subr.debugflg THEN
CWF.WF1["Warning- no version stamp for %s.Bcd.\n"L, sploc.tail];
IF sploc.bcdVers.net = 0 AND sploc.bcdVers.host = 0 THEN {
willfail ← TRUE; -- this means a bcdVers is from a bcd not on the disk
IF Subr.debugflg THEN
CWF.WF3["QuickCheck will fail for %s because of %s (time = %lt).\n"L,
sploctop.tail, sploc.tail, @sploc.bcdVers.time];
RETURN;
};
trystamp ← MergeStamps[trystamp, TimeToStamp[sploc.bcdVers -- mdb[c.module].stamp -- ]];
};
-- figure out what stamp should be if the model were correct
trystamp ← TimeToStamp[[net: 0, host: 0, time: disksrc.create]];
-- encode switches, compiler version
-- set defaults
switches ← MDModel.FoldInParms[NIL];
MDModel.TraverseList[sploctop.parmlist, GetSwitches];
switches['g] ← FALSE;
switches['p] ← FALSE;
trystamp ← MergeStamps[trystamp, TimeToStamp[[0, 0, LOOPHOLE[switches]]]];
trystamp ← MergeStamps[trystamp, TimeToStamp[compilerVersion]];
MDModel.TraverseList[sploctop.parmlist, GetTYPES];
IF willfail THEN RETURN[FALSE];
-- now look in the bcd to get the actual stamp
IF sploctop.bcdVers ~= TimeStamp.Null AND sploctop.bcdVers.net ~= 0 THEN
actualstamp ← sploctop.bcdVers -- use this if bonafide
ELSE IF (depseq ← diskbcd.depseq) ~= NIL
OR (depseq ← DBStash.Lookup[diskbcd.create]) ~= NIL THEN
actualstamp ← depseq.bcdtime
ELSE {
bcd: BcdOps.BcdBase;
space: Space.Handle ← Space.Create[size: 1, parent: Space.virtualMemory];
Space.Map[space, [diskbcd.cap, 1]];
MDModel.numberofbcdsmapped ← MDModel.numberofbcdsmapped + 1;
bcd ← Space.LongPointer[space];
actualstamp ← bcd.version; -- this is the bcd version stamp
IF sploctop.bcdVers = TimeStamp.Null
OR sploctop.bcdVers.time ~= sploctop.createtime
OR sploctop.createtime = diskbcd.create THEN
sploctop.bcdVers ← actualstamp;
Space.Delete[space];
};
IF trystamp = TimeToStamp[actualstamp] THEN {
IF Subr.debugflg THEN
CWF.WF1["Quick check succeeded for %s.Bcd.\n"L, sploctop.tail];
RETURN[TRUE];
}
ELSE IF actualstamp.time ~= diskbcd.create THEN { -- only give msg for Cedar
t ← LOOPHOLE[trystamp];
IF Subr.debugflg THEN
CWF.WF3["Quick check failed for %s.Bcd: %lu ~= %lu.\n"L, sploctop.tail,
@t.time, @actualstamp.time];
};
RETURN[FALSE];
};