DIRECTORY
Ascii: TYPE USING [Lower],
Atom: TYPE USING [MakeAtom],
BasicTime: TYPE USING [GMT, Now, Period, ToNSTime],
BcdStamps: TYPE USING [Compute],
CompilerOps:
TYPE
USING [
AppendHerald, CompilerVersion, DefaultSwitches, DoTransaction,
LetterSwitches, Start, Stop, StreamId, Transaction],
CS: TYPE USING [PartialName, RopeFromStamp, RootName, ShortName],
FileParms:
TYPE
USING [
ActualId, BindingProc, Name, nullActual, nullSymbolSpace, SymbolSpace],
FileViewerOps: TYPE USING [AttachErrorLog, ShowLog, RemoveErrorLog],
FS:
TYPE
USING [
OpenFile, nullOpenFile,
Delete, Error, ExpandName, GetInfo, Open, StreamOpen, StreamFromOpenFile],
IO:
TYPE
USING [
atom, card, Close, PutChar, PutF, PutRope, rope, STREAM, time],
Process:
TYPE
USING [
Priority, priorityBackground, Abort, CheckForAbort, GetCurrent, GetPriority, SetPriority],
Rope: TYPE USING [Concat, Fetch, Length, ROPE, Text],
SMComp: TYPE USING [],
SMFI: TYPE USING[BcdFileInfo, SrcFileInfo],
SMFIOps: TYPE USING [Available, Fill],
SMLDriver: TYPE USING [LoadMod, LoadedModule],
SMOps: TYPE USING [MS],
SMProj: TYPE USING [Proj, Analyzed, Available, Erase, Fill, Find, Update],
SMTree: TYPE Tree USING [ApplOp, Handle, Link, Name, null],
SMTreeOps:
TYPE TreeOps
USING [
GetExt, GetName, NthSon, NSons, OpName, PutExt, Scan, ScanSons],
SMVal:
TYPE
USING [
Binding, BtoG, GetExtFromParse, OuterBody, ValOf, ValOfNthSon, VisitNodes],
TimeStamp: TYPE USING [Stamp, Null],
TiogaMenuOps: TYPE USING [DefaultMenus],
VersionMapDefaults: TYPE USING [FileNameFromVersion],
ViewerClasses: TYPE USING [Viewer],
ViewerOps: TYPE USING [FindViewer];
CompileAll:
PUBLIC
PROC[ms: SMOps.
MS, t: Tree.Link, replace:
BOOL]
RETURNS[completed: BOOL] ~ {
abort: BOOL;
AcquireCompiler[];
{
ENABLE UNWIND => {ReleaseCompiler[]};
startTime, endTime: BasicTime.GMT;
formals, body: Tree.Link;
[formals, body] ← SMVal.OuterBody[t];
startTime ← BasicTime.Now[];
nSuccessful ← nWarnings ← nErrors ← nUnmatched ← 0;
userAbort ← FALSE; complete ← TRUE;
TraverseTreeForCompile[ms, body, replace ! UNWIND => {[] ← StopBatchCompile[ms]}];
StopBatchCompile[ms];
endTime ← BasicTime.Now[];
IF nSuccessful = 0
AND nErrors = 0
AND nWarnings = 0
THEN
ms.out.PutRope["Nothing was compiled.\n\n"]
ELSE {
ms.out.PutF["%d successful", IO.card[nSuccessful]];
IF nErrors > 0 THEN ms.out.PutF["; %d w/errors", IO.card[nErrors]];
IF nWarnings > 0
THEN
ms.out.PutF["; %d w/warnings", IO.card[nWarnings]];
ms.out.PutF[
"\nTotal time to compile: %d seconds.\n\n", IO.card[startTime.Period[endTime]]];
};
completed ← complete AND (nErrors = 0) AND (nUnmatched = 0);
abort ← userAbort;
};
ReleaseCompiler[];
IF abort THEN TRUSTED {Process.Abort[Process.GetCurrent[]]};
RETURN};
AcquireCompiler:
ENTRY
PROC ~ {
ENABLE UNWIND => {NULL};
WHILE compilerIsLocked DO WAIT compilerWait ENDLOOP;
compilerIsLocked ← TRUE};
ReleaseCompiler:
ENTRY
PROC ~ {
ENABLE UNWIND => {NULL};
compilerIsLocked ← FALSE;
NOTIFY compilerWait};
InProgress: SIGNAL[appl: Tree.Link] RETURNS[BOOL] ~ CODE;
TraverseTreeForCompile:
PROC[ms: SMOps.
MS, root: Tree.Link, replace:
BOOL] ~
INLINE {
ForEachApply:
PROC[node, parent: Tree.Link] ~ {
SELECT TreeOps.OpName[node]
FROM
IN Tree.ApplOp =>
WITH SMVal.ValOfNthSon[node, 1]
SELECT
FROM
source:
SMFI.SrcFileInfo =>
WITH TreeOps.GetExt[node]
SELECT
FROM
proj: SMProj.Proj =>
-- already processed
IF ~proj.Available THEN complete ← FALSE;
ENDCASE =>
[] ← DoCompile[ms, source, node, parent, replace];
ENDCASE => NULL; -- ignore this appl on this pass
ENDCASE;
};
SMVal.VisitNodes[ms.tm, root, ForEachApply ! InProgress => {RESUME[FALSE]}]};
FormalActual:
TYPE ~
RECORD[
SEQUENCE length:
NAT
OF
RECORD[
name: Tree.Name,
object: SMProj.Proj]
];
DoCompile:
PROC[
ms: SMOps.MS, source: SMFI.SrcFileInfo, node, parent: Tree.Link, replace: BOOL] RETURNS[proj: SMProj.Proj] ~ {
oldLoadMod: SMLDriver.LoadMod ~ (
IF TreeOps.OpName[parent]
IN Tree.ApplOp
THEN NARROW[SMVal.GetExtFromParse[parent]]
ELSE NIL);
args: Tree.Link ~ SMVal.ValOfNthSon[node, 2];
proj ← PossibleCompile[ms, source, args, replace, oldLoadMod
! InProgress => {IF appl = node THEN RESUME[TRUE]}];
IF ~userAbort THEN TreeOps.PutExt[node, proj];
IF ~proj.Available THEN complete ← FALSE; -- errors or declined
RETURN};
PossibleCompile:
PROC[
ms: SMOps.MS, source: SMFI.SrcFileInfo, args: Tree.Link,
replace: BOOL, oldLoadMod: SMLDriver.LoadMod]
RETURNS[proj: SMProj.Proj] ~ {
directoryMap: REF FormalActual;
bcdStamp: TimeStamp.Stamp;
switches: CompilerOps.LetterSwitches;
BcdStampFromAppl:
PROC[source:
SMFI.SrcFileInfo, args: Tree.Link]
RETURNS[
bcdVersion: TimeStamp.Stamp, directoryMap: REF FormalActual,
switches: CompilerOps.LetterSwitches] ~ INLINE {
inx: NAT ← 0;
DeclName:
PROC[t: Tree.Link]
RETURNS[Tree.Name] ~
INLINE {
RETURN[TreeOps.GetName[TreeOps.NthSon[t, 1]]]};
SetFormalName: TreeOps.Scan ~ {
SELECT TreeOps.OpName[t]
FROM
$declElem =>
IF inx < directoryMap.length
THEN {
directoryMap[inx].name ← DeclName[t]; inx ← inx + 1};
ENDCASE;
};
d: Tree.Link ~ TreeOps.NthSon[source.type, 1];
g: Tree.Link ~ (IF SMVal.Binding[args] THEN SMVal.BtoG[args] ELSE args);
TRUSTED {switches ← CompilerOps.DefaultSwitches[]; switches['s] ← FALSE};
directoryMap ← (ms.z).NEW[FormalActual[TreeOps.NSons[d]-1]]; -- excludes &options
TreeOps.ScanSons[d, SetFormalName];
IF TreeOps.OpName[g] = $group
THEN {
i: NAT ← 0;
ExtractProjection:
PROC[t: Tree.Link, parent: Tree.Link←Tree.null]
RETURNS[proj: SMProj.Proj ← NIL] ~ {
WITH t
SELECT
FROM
fiBcd:
SMFI.BcdFileInfo => {
-- temporary (inefficient)
proj ← SMProj.Find[fiBcd.stamp];
IF ~proj.Analyzed THEN proj.Fill[fiBcd.fName, ms.wDir, FALSE]};
ENDCASE =>
SELECT TreeOps.OpName[t]
FROM
IN Tree.ApplOp => {
son1: Tree.Link ~ SMVal.ValOfNthSon[t, 1];
WITH son1
SELECT
FROM
fiSrc:
SMFI.SrcFileInfo =>
WITH TreeOps.GetExt[t]
SELECT
FROM
p: SMProj.Proj => proj ← p;
ENDCASE =>
IF
SIGNAL InProgress[t]
THEN {
ms.out.PutF[
"Cannot compile %g because of circular dependency\n",
IO.rope[fiSrc.localName]];
proj ← NIL; complete ← FALSE}
ELSE proj ← DoCompile[ms, fiSrc, t, parent, replace];
ENDCASE => proj ← ExtractProjection[son1, t];
};
$subscript =>
-- assert: ValOf[son[1]] is an appl
proj ← ExtractProjection[SMVal.ValOfNthSon[t, 1]];
ENDCASE;
RETURN};
ActualByPosition: TreeOps.Scan ~ {
v: Tree.Link ~ SMVal.ValOf[t];
WITH v
SELECT
FROM
text: Rope.Text => switches ← InterpolateSwitches[text];
ENDCASE => {directoryMap[i].object ← ExtractProjection[v]; i ← i+1};
};
TreeOps.ScanSons[g, ActualByPosition]}
ELSE
ERROR;
-- residual TYPE CHECK
{compilerVersion: TimeStamp.Stamp;
DirectoryEnumerator:
PROC[forEach:
PROC[TimeStamp.Stamp]] ~ {
FOR i:
NAT
IN [0..directoryMap.length)
DO
proj: SMProj.Proj ~ directoryMap[i].object;
forEach[IF proj = NIL THEN TimeStamp.Null ELSE proj.stamp]
ENDLOOP;
};
TRUSTED {compilerVersion ← CompilerOps.CompilerVersion[]};
bcdVersion ← BcdStamps.Compute[
BasicTime.ToNSTime[LOOPHOLE[source.create]],
switches, compilerVersion, DirectoryEnumerator]
};
};
argsAvailable: BOOL ← TRUE;
tryToReplace: BOOL;
[bcdStamp, directoryMap, switches] ← BcdStampFromAppl[source, args];
first scan existing projection data base
proj ← SMProj.Find[bcdStamp];
IF proj.Available THEN RETURN; -- already found and analyzed
see if on file system
proj.Fill[CS.RootName[source.simpleName], ms.wDir, source.new];
IF proj.Available THEN RETURN; -- correct version on file system
FOR i:
NAT
IN [0..directoryMap.length)
WHILE argsAvailable
DO
IF ~(directoryMap[i].object).Available THEN argsAvailable ← FALSE;
ENDLOOP;
tryToReplace ← replace AND argsAvailable AND Replaceable[oldLoadMod];
IF ~argsAvailable
THEN
ms.out.PutF[
"Cannot compile %g because compilation of an argument failed\n",
IO.rope[source.localName]]
ELSE
IF ~userAbort
THEN {
oldProj: SMProj.Proj ~ (IF tryToReplace THEN oldLoadMod.proj ELSE NIL);
errors, replaceable: BOOL;
CompileMessage[ms, source.localName, switches];
[errors, , replaceable] ← CompileIt[ms, source, directoryMap, switches, proj, oldProj];
IF oldProj ~=
NIL
THEN {
-- tried for replacement
IF replaceable
AND ~errors
THEN
ms.out.PutF[" %g passes compiler's test for replaceability.\n", IO.rope[proj.localName]]
ELSE {
replaceable ← FALSE;
IF ~errors
THEN
ms.out.PutF[" %g is not replaceable (compiler refuses).\n", IO.rope[proj.localName]]
};
};
IF oldLoadMod # NIL THEN oldLoadMod.mustReplace ← replaceable}
ELSE NULL};
Replaceable:
PROC[loadMod: SMLDriver.LoadMod]
RETURNS[
BOOL] ~
INLINE {
RETURN[loadMod # NIL AND loadMod.loadInfo.LoadedModule]};
CompileIt:
PROC[
ms: SMOps.MS,
source: SMFI.SrcFileInfo, args: REF FormalActual,
switches: CompilerOps.LetterSwitches,
proj, oldProj: SMProj.Proj]
RETURNS[errors, warnings, replaceable: BOOL] ~ {
priority: Process.Priority ~ Process.GetPriority[];
t: REF CompilerOps.Transaction ~ (ms.z).NEW[CompilerOps.Transaction];
startTime: BasicTime.GMT;
DirectoryBinding:
PROC[
formalId, formalType: FileParms.Name, defaultLocator: FileParms.Name,
binder: FileParms.BindingProc] ~ {
desiredName: Tree.Name ~ Atom.MakeAtom[formalId];
FOR i:
NAT
IN [0 .. args.length)
DO
IF args[i].name = desiredName
THEN {
bcd: SMProj.Proj ~ args[i].object;
TRUSTED {
binder[
FileParms.ActualId[
version~bcd.stamp,
locator~CS.ShortName[bcd.localName]]
]
};
RETURN}
ENDLOOP;
ms.out.PutF["\nError - '%g' not found in argument list.\n", IO.atom[desiredName]];
TRUSTED {binder[FileParms.nullActual]}};
called after DirectoryBinding except for hidden directory entries
DirectoryAcquire:
PROC[type: FileParms.Name, actual: FileParms.ActualId]
RETURNS[ss: FileParms.SymbolSpace] ~ {
bcd: SMProj.Proj;
FOR i:
NAT
IN [0 .. args.length)
DO
IF args[i].object.stamp = actual.version
THEN
RETURN[[file~args[i].object.file, span~args[i].object.symbolPages]];
ENDLOOP;
not found
bcd ← SMProj.Find[actual.version];
IF ~bcd.Available
THEN {
mapName: Rope.
ROPE ~
VersionMapDefaults.FileNameFromVersion[$Symbols, actual.version].name;
bcd.Fill[IF mapName # NIL THEN mapName ELSE actual.locator, ms.wDir, FALSE]};
IF bcd.Available
THEN {
IF bcd.symbolPages = FileParms.nullSymbolSpace.span
THEN
ms.out.PutF["Can't get symbol space for type %g, file %g\n",
IO.rope[type], IO.rope[actual.locator]];
RETURN[[file~bcd.file, span~bcd.symbolPages]]};
ms.out.PutF["%g OF %g not found on parameter list.\n",
IO.rope[actual.locator], IO.rope[CS.RopeFromStamp[actual.version]]];
RETURN[FileParms.nullSymbolSpace]};
DirectoryRelease: PROC[ss: FileParms.SymbolSpace] ~ {};
DirectoryForget: PROC[actual: FileParms.ActualId] ~ {};
errlogName: Rope.ROPE ~ CS.RootName[source.simpleName].Concat[".errlog"];
errlog: IO.STREAM ← NIL;
GetStream:
PROC[id: CompilerOps.StreamId]
RETURNS[s:
IO.
STREAM] ~ {
SELECT id
FROM
$source => s ← t.sourceStream; -- temporary
$log => {
IF errlog =
NIL
THEN {
errlog ← FS.StreamOpen[fileName~errlogName, accessOptions~$create, wDir~ms.wDir];
TRUSTED {CompilerOps.AppendHerald[errlog]};
errlog.PutF["\nCompilation of %g on %t\n\n",
IO.rope[source.localName], IO.time[timeCompilerStarted]]};
s ← errlog};
ENDCASE => ERROR;
RETURN};
CompilerPass:
PROC[p:
CARDINAL]
RETURNS[goOn:
BOOL] ~ {
Process.CheckForAbort[ ! ABORTED => {userAbort ← TRUE; CONTINUE}];
goOn ← ~userAbort;
ms.msgOut.PutChar['.]};
DeleteBadBcd:
PROC ~ {
proj.Erase[];
IF t.objectName ~= NIL THEN FS.Delete[t.objectName];
t.objectName ← NIL};
CleanUp:
PROC ~ {
sourceFileName: Rope.ROPE ~ FS.ExpandName[source.localName, ms.wDir].fullFName;
IF t.sourceStream ~= NIL THEN t.sourceStream.Close[];
t.sourceStream ← NIL;
IF errlog ~=
NIL
THEN {
errlog.Close[];
FileViewerOps.ShowLog[fileName~sourceFileName, createIconic~TRUE];
following until FileViewerOps is fixed
{viewer: ViewerClasses.Viewer ~ ViewerOps.FindViewer[sourceFileName];
IF viewer ~= NIL AND viewer.iconic THEN TiogaMenuOps.DefaultMenus[viewer]};
FileViewerOps.AttachErrorLog[sourceFileName]}
ELSE {
FileViewerOps.RemoveErrorLog[sourceFileName];
DO
FS.Delete[name~errlogName, wDir~ms.wDir
! FS.Error => IF error.group = $lock OR error.code = $unknownFile THEN EXIT];
ENDLOOP;
};
Process.SetPriority[priority]};
{
ENABLE UNWIND => {DeleteBadBcd[]; CleanUp[]};
errors ← warnings ← TRUE; replaceable ← FALSE;
t.sourceStream ← NIL; t.objectName ← NIL;
make sure the compiler is loaded, etc.
IF ~(compilerStarted OR StartBatchCompile[ms]) THEN RETURN;
source.new ← FALSE;
set up Transaction record contents
IF ~SMFIOps.Available[source]
THEN
SMFIOps.Fill[ms, source, source.localName, source.wDir];
IF ~SMFIOps.Available[source]
OR source.file.GetInfo[].created # source.create
THEN {
ms.out.PutF["Correct version of %g not found on local disk\n", IO.rope[source.localName]];
errors ← TRUE;
RETURN};
Process.SetPriority[Process.priorityBackground];
t.op ← (IF oldProj # NIL THEN $replace ELSE $compile);
t.source ← [
version~[net~0, host~0, time~BasicTime.ToNSTime[LOOPHOLE[source.create]]],
locator~source.localName];
t.sourceStream ←
source.file.StreamFromOpenFile[streamOptions~[closeFSOpenFileOnClose~FALSE]];
TRUSTED {
t.fileParms ← [DirectoryBinding, DirectoryAcquire, DirectoryRelease, DirectoryForget]};
t.switches ← switches;
IF t.op = $replace
THEN
t.pattern ← [version~oldProj.stamp, locator~oldProj.localName]
ELSE t.pattern ← FileParms.nullActual;
t.objectName ← (
IF
CS.PartialName[proj.localName]
THEN (ms.wDir).Concat[proj.localName] ELSE proj.localName);
t.objectFile ← FS.nullOpenFile;
t.debugPass ← CARDINAL.LAST;
TRUSTED {
t.getStream ← GetStream;
t.startPass ← CompilerPass};
PrintStart[ms, t];
startTime ← BasicTime.Now[];
these are here to hide them from the user
t.switches['d] ← t.switches['d] OR ms.debugFlag;
t.switches['g] ← FALSE; -- log is always Compiler.log
actually call the compiler
TRUSTED {CompilerOps.DoTransaction[t]};
PrintStop[ms, t, startTime];
replaceable ← (t.op = $replace AND t.matched);
errors ← (t.nErrors # 0); IF errors THEN nErrors ← nErrors + 1;
warnings ← (t.nWarnings # 0); IF warnings THEN nWarnings ← nWarnings + 1;
IF ~errors AND ~warnings THEN nSuccessful ← nSuccessful + 1;
IF ~errors
THEN {
IF proj.stamp # t.objectVersion THEN ERROR;
should only do this on demand --
t.objectFile ← FS.Open[name~proj.localName, wDir~ms.wDir];
proj.Update[t];
IF t.op =$replace AND ~t.matched THEN nUnmatched ← nUnmatched + 1}
ELSE DeleteBadBcd[];
CleanUp[]
}
};
StartBatchCompile:
PROC[ms: SMOps.
MS]
RETURNS[loadedOk:
BOOL] ~ {
log ← NIL;
IF ~(loadedOk ← LoadCompiler[ms.msgOut]) THEN RETURN;
timeCompilerStarted ← BasicTime.Now[];
log ← FS.StreamOpen[fileName~"Compiler.log", accessOptions~$create, wDir~ms.wDir];
TRUSTED {CompilerOps.AppendHerald[log]};
log.PutF["\n%t\n", IO.time[timeCompilerStarted]];
TRUSTED {CompilerOps.Start[]};
StopBatchCompile:
PROC[ms: SMOps.
MS] ~ {
IF compilerStarted
THEN {
log.PutChar['\n];
IF nSuccessful # 0 THEN log.PutF[" %d successful; ", IO.card[nSuccessful]];
IF nWarnings # 0 THEN log.PutF[" %d w/warnings; ", IO.card[nWarnings]];
IF nErrors # 0 THEN log.PutF[" %d w/errors; ", IO.card[nErrors]];
log.PutF["\nTotal elapsed time %r.\n",
IO.card[timeCompilerStarted.Period[BasicTime.Now[]]]];
log.Close[]; log ← NIL;
TRUSTED {CompilerOps.Stop[]};
compilerStarted ← FALSE;
ms.msgOut.PutRope["End of compilation\n"]};
};
CompileMessage:
PROC[
ms: SMOps.MS, fName: Rope.ROPE, switches: CompilerOps.LetterSwitches] ~ {
PutChar: PROC[c: CHAR] ~ {ms.out.PutChar[c]};
ms.out.PutF["Compile %g", IO.rope[fName]];
GenerateDifferentialSwitches[switches, PutChar];
ms.out.PutRope[" ... \n"]};
GenerateDifferentialSwitches:
PROC[
sw: CompilerOps.LetterSwitches, proc: PROC[CHAR]] ~ {
standardSwitches: CompilerOps.LetterSwitches;
first: BOOL ← TRUE;
TRUSTED {standardSwitches ← CompilerOps.DefaultSwitches[]};
FOR c:
CHAR
IN ['a .. 'z]
DO
sd: BOOL ~ (c # 'p AND standardSwitches[c]);
IF sw[c] ~= sd
THEN {
IF first THEN {first ← FALSE; proc['/]};
IF sd THEN proc['-];
proc[c]};
ENDLOOP;
};
PrintStart:
PROC[ms: SMOps.
MS, t:
REF CompilerOps.Transaction] ~ {
PutChar: PROC[c: CHAR] ~ {ms.msgOut.PutChar[c]; log.PutChar[c]};
ms.msgOut.PutF["Compiling: %g", IO.rope[t.source.locator]];
log.PutF["\nCommand: %g", IO.rope[t.source.locator]];
GenerateDifferentialSwitches[t.switches, PutChar];
log.PutChar['\n]};
PrintStop:
PROC[
ms: SMOps.MS, t: REF CompilerOps.Transaction, startTime: BasicTime.GMT] ~ {
first MsgSW
IF t.nErrors > 0 THEN ms.msgOut.PutF["%d errors", IO.card[t.nErrors]]
ELSE ms.msgOut.PutRope["no errors"];
IF t.nWarnings > 0 THEN ms.msgOut.PutF[", %d warnings", IO.card[t.nWarnings]];
ms.msgOut.PutChar['\n];
now log
log.PutF["%g -- ", IO.rope[t.source.locator]];
IF t.nErrors > 0
THEN {
log.PutF[" aborted, %d errors", IO.card[t.nErrors]];
IF t.nWarnings > 0 THEN log.PutF[", %d warnings", IO.card[t.nWarnings]];
log.PutF[", time: %r.\n\n", IO.card[startTime.Period[BasicTime.Now[]]]]}
ELSE {
log.PutF["source tokens: %d, time: %r",
IO.card[t.sourceTokens],
IO.card[startTime.Period[BasicTime.Now[]]]];
IF t.objectBytes > 0
THEN
log.PutF["\n code bytes: %d, links: %d, global frame words: %d",
IO.card[t.objectBytes], IO.card[t.linkCount], IO.card[t.objectFrameSize]];
IF t.nWarnings > 0
THEN
log.PutF["\n%d warnings", IO.card[t.nWarnings]];
log.PutChar['\n]};
InterpolateSwitches:
PROC[parms: Rope.Text]
RETURNS[switches: CompilerOps.LetterSwitches] ~ {
on: BOOL ← TRUE;
TRUSTED {switches ← CompilerOps.DefaultSwitches[]};
switches['s] ← FALSE; -- the modeller defaults to /-s
IF parms #
NIL
THEN
FOR i:
INT
IN [0 .. parms.Length)
DO
c: CHAR ~ Ascii.Lower[parms.Fetch[i]];
SELECT c
FROM
'-, '~ => on ← ~on;
IN ['a .. 'z] => {switches[c] ← on; on ← TRUE};
ENDCASE;
ENDLOOP;
};