-- CTIntImpl.Mesa, last edit May 19, 1983 7:33 pm
DIRECTORY
Buttons: TYPE USING [Button, ButtonProc],
CompilerOps: TYPE USING [DefaultSwitches, LetterSwitches],
Containers: TYPE USING [ChildXBound, ChildYBound, Container, Create],
CS: TYPE USING [EndsIn, EquivalentRope, SetPFCodes],
CT: TYPE USING[AppendExtension, DetermineCompilation, Global, GlobalRecord,
LoadBcdsAndResolveImports, MI, MIRecord, ModuleList, SetPossiblyBadAndValid,
StartAllControlBcds, UnLoad],
Directory: TYPE USING[Lookup],
File: TYPE USING[Capability],
FileIO: TYPE USING[Open, OpenFailed],
IO: TYPE USING[Close, EndOf, GetChar, Handle, noWhereStream,
Put, PutChar, PutF, PutFR, PutRope, ResetUserAbort,
rope, SetUserAbort, string, time, UserAborted],
Labels: TYPE USING [Create, Label, Set],
List: TYPE USING[DRemove, Reverse],
Loader: TYPE USING[Instantiate, Start],
MBQueue: TYPE USING[Create, CreateMenuEntry, CreateButton, Flush],
Menus: TYPE USING [CreateEntry, CreateMenu, InsertMenuEntry, Menu, MenuProc],
PrincOps: TYPE USING[ControlModule],
Rope: TYPE USING[Cat, Fetch, Find, Flatten, FromChar, Length, Lower, ROPE, Text],
RopeInline: TYPE USING[InlineFlatten],
Rules: TYPE USING [Create, Rule],
Runtime: TYPE USING[IsBound],
Space: TYPE USING[nullHandle],
TypeScript: TYPE USING[TS, Create],
UserProfile: TYPE USING[Boolean, Token],
ViewerClasses: TYPE USING [Viewer],
ViewerEvents: TYPE USING[EventProc, EventRegistration, RegisterEventProc,
UnRegisterEventProc],
ViewerIO: TYPE USING[CreateViewerStreams],
ViewerOps: TYPE USING [AddProp, CreateViewer, EstablishViewerPosition,
FetchProp, PaintViewer, SetMenu, SetOpenHeight],
ViewerTools: TYPE USING [GetContents, MakeNewTextViewer, SetContents, SetSelection];
CTIntImpl: CEDAR PROGRAM
IMPORTS CompilerOps, Containers, CS, CT, Directory, FileIO, IO, Labels,
List, Loader, MBQueue, Menus, Rope, RopeInline,
Rules, Runtime, Space, TypeScript, UserProfile, ViewerEvents, ViewerOps,
ViewerIO, ViewerTools = {
-- MDS usage!
makeDebuggingWindow: BOOL ← FALSE; -- only set once, not monitored
globalList: LIST OF CT.Global; -- not properly monitored
destroyEventRegistration: ViewerEvents.EventRegistration;
-- end of MDS
-- these are commands for the viewers world
entryHeight: CARDINAL = 15;
entryVSpace: CARDINAL = 7;
entryHSpace: CARDINAL = 10;
-- this is called by the Start code and also by the Another button
BuildOuter: PROC RETURNS[g: CT.Global] =
{
ttyTypeScript, msgTypeScript, dTypeScript: TypeScript.TS;
vName: Rope.ROPE ← IO.PutFR["Replacement Tool, started on %t", IO.time[]];
menu: Menus.Menu ← Menus.CreateMenu[lines: 2];
g ← NEW[CT.GlobalRecord ← [fakebcdspace: Space.nullHandle]];
g.container ← Containers.Create[info: [name: vName, iconic: FALSE, scrollable: FALSE]];
ViewerOps.AddProp[g.container, $CTGlobalRef, g];
g.q ← MBQueue.Create[];
-- first row of menu items
Menus.InsertMenuEntry[menu, Menus.CreateEntry["Stop", StopProc, g], 0];
Menus.InsertMenuEntry[menu, MBQueue.CreateMenuEntry[g.q, "UnLoad", UnLoadProc, g], 0];
Menus.InsertMenuEntry[menu, MBQueue.CreateMenuEntry[g.q, "Continue", ContinueProc, g], 0];
Menus.InsertMenuEntry[menu, MBQueue.CreateMenuEntry[g.q, "Begin", BeginProc, g], 0];
Menus.InsertMenuEntry[menu, MBQueue.CreateMenuEntry[g.q, "Another", AnotherProc, g], 0];
-- second row of menu items
Menus.InsertMenuEntry[menu, MBQueue.CreateMenuEntry[g.q, "FlushCache", FlushCacheProc, g], 1];
Menus.InsertMenuEntry[menu, MBQueue.CreateMenuEntry[g.q, "Start", StartProc, g], 1];
Menus.InsertMenuEntry[menu, MBQueue.CreateMenuEntry[g.q, "Load", LoadProc, g], 1];
Menus.InsertMenuEntry[menu, MBQueue.CreateMenuEntry[g.q, "Compile", CompileProc, g], 1];
--
ViewerOps.SetMenu[g.container, menu, FALSE];
[ttyTypeScript, msgTypeScript, dTypeScript] ← BuildUserInput[g];
-- kludge required for multiple rows in menus
ViewerOps.EstablishViewerPosition[g.container, g.container.wx, g.container.wy,
g.container.ww, g.container.wh];
ViewerOps.PaintViewer[g.container, all];
[in: g.ttyin, out: g.ttyout] ← ViewerIO.CreateViewerStreams[viewer: ttyTypeScript, name: NIL];
[out: g.msgout] ← ViewerIO.CreateViewerStreams[viewer: msgTypeScript, name: NIL];
IF makeDebuggingWindow THEN
[out: g.dout] ← ViewerIO.CreateViewerStreams[viewer: dTypeScript, name: NIL]
ELSE
g.dout ← IO.noWhereStream;
CS.SetPFCodes[g.ttyout];
CS.SetPFCodes[g.msgout];
CS.SetPFCodes[g.dout];
IF g.attachEditor THEN AttachSymbiote[g];
globalList ← CONS[g, globalList];
};
BuildUserInput: PROC[g: CT.Global]
RETURNS[ttyTypeScript, msgTypeScript, dTypeScript: TypeScript.TS] =
{
heightSoFar: CARDINAL;
l: ViewerClasses.Viewer;
rule: Rules.Rule;
CreateButton: PROC[bname, lname: Rope.Text, newLine: BOOL, drawRule: BOOL ← FALSE]
RETURNS[button: Buttons.Button, label: Labels.Label] =
{
x: CARDINAL;
IF newLine THEN {
IF l = NIL THEN
heightSoFar ← entryVSpace/2
ELSE
heightSoFar ← heightSoFar + entryVSpace + l.wh;
IF drawRule THEN {
rule ← Rules.Create[info: [parent: g.container, wx: 0, wy: heightSoFar,
ww: 0, wh: 1]];
Containers.ChildXBound[g.container, rule];
heightSoFar ← heightSoFar + entryVSpace;
};
x ← 0;
}
ELSE
x ← l.wx + l.ww + entryHSpace;
l ← button ← MBQueue.CreateButton[q: g.q, info: [name: bname, parent: g.container,
border: FALSE, wx: x, wy: heightSoFar], proc: PushButton, clientData: g];
IF lname ~= NIL THEN
l ← label ← Labels.Create[info: [name: lname, parent: g.container,
wx: button.wx + button.ww + entryHSpace, wy: heightSoFar, border: TRUE]];
};
-- first line
[g.compileButton, ] ← CreateButton["Compile:", NIL, TRUE];
l ← g.compileViewer ← ViewerTools.MakeNewTextViewer[info: [parent: g.container,
wx: l.wx+l.ww+entryHSpace, wy: heightSoFar, ww: 100, wh: entryHeight,
data: NIL, scrollable: FALSE, border: FALSE], paint: FALSE];
Containers.ChildXBound[g.container, g.compileViewer];
heightSoFar ← heightSoFar+--entryVSpace/2+--l.wh;
--
-- second line
[g.confirmButton, g.confirmViewer] ← CreateButton["ConfirmCompiles:", "FALSE", TRUE];
IF g.confirmCompiles THEN Labels.Set[g.confirmViewer, "TRUE"];
[g.attachEditorButton, g.attachEditorLabel] ← CreateButton["AttachEditor:", "FALSE", FALSE];
IF g.attachEditor THEN Labels.Set[g.attachEditorLabel, "TRUE"];
heightSoFar ← heightSoFar+ entryVSpace/2+l.wh;
--
-- first the msg window
-- now the line above the typescript
rule ← Rules.Create[info: [parent: g.container, wx: 0, wy: heightSoFar, ww: 0, wh: 1]];
Containers.ChildXBound[g.container, rule];
heightSoFar ← heightSoFar+entryVSpace/2;
-- now the typescript
msgTypeScript ← TypeScript.Create[info: [parent: g.container,
wx: 0, wy: heightSoFar, ww: 0, wh: 25, border: FALSE]];
Containers.ChildXBound[g.container, msgTypeScript];
heightSoFar ← heightSoFar + entryVSpace + 20;
-- now the line above the typescript
rule ← Rules.Create[info: [parent: g.container, wx: 0, wy: heightSoFar, ww: 0, wh: 1]];
Containers.ChildXBound[g.container, rule];
heightSoFar ← heightSoFar+entryVSpace/2;
-- now the typescript
ttyTypeScript ← TypeScript.Create[info: [parent: g.container,
wx: 0, wy: heightSoFar, ww: 0, wh: 80, border: FALSE]]; -- 800 due to viewers bug
heightSoFar ← heightSoFar + entryVSpace + 80;
Containers.ChildXBound[g.container, ttyTypeScript];
IF makeDebuggingWindow THEN {
-- now the line above the typescript
rule ← Rules.Create[info: [parent: g.container, wx: 0, wy: heightSoFar, ww: 0, wh: 1]];
Containers.ChildXBound[g.container, rule];
heightSoFar ← heightSoFar+entryVSpace/2;
-- now the debugging typescript
dTypeScript ← TypeScript.Create[info: [parent: g.container,
wx: 0, wy: heightSoFar, ww: 0, wh: 800, border: FALSE]]; -- 800 due to viewers bug
Containers.ChildXBound[g.container, dTypeScript];
Containers.ChildYBound[g.container, dTypeScript];
}
ELSE
Containers.ChildYBound[g.container, ttyTypeScript];
ViewerOps.SetOpenHeight[g.container, heightSoFar + 200];
};
PushButton: Buttons.ButtonProc =
{
g: CT.Global ← NARROW[clientData];
SELECT NARROW[parent, ViewerClasses.Viewer] FROM
g.compileButton =>
ViewerTools.SetSelection[g.compileViewer, NIL];
g.confirmButton => {
g.confirmCompiles ← NOT g.confirmCompiles;
Labels.Set[g.confirmViewer, IF g.confirmCompiles THEN "TRUE" ELSE "FALSE"];
};
g.attachEditorButton => {
g.attachEditor ← NOT g.attachEditor;
Labels.Set[g.attachEditorLabel, IF g.attachEditor THEN "TRUE" ELSE "FALSE"];
IF g.attachEditor THEN AttachSymbiote[g] ELSE DetachSymbiote[g, TRUE];
};
ENDCASE => ERROR;
};
AnotherProc: Menus.MenuProc = {
[] ← BuildOuter[]; -- make another compiler tool
};
BeginProc: Menus.MenuProc = {
g: CT.Global ← NARROW[clientData];
{
ENABLE ABORTED, IO.UserAborted => {
g.ttyout.ResetUserAbort[];
g.ttyout.PutF["Begin Aborted\n"];
GOTO out;
};
errors: BOOL;
CT.UnLoad[g, TRUE];
g.moduleList ← NIL;
g.noticeList ← NIL;
errors ← ParseCompileList[g];
IF errors THEN GOTO badComp;
errors ← CT.DetermineCompilation[g, FALSE];
IF errors THEN GOTO badComp;
g.compiledOk ← TRUE;
errors ← CT.LoadBcdsAndResolveImports[g, FALSE];
g.loadedOk ← errors;
IF NOT errors THEN CT.StartAllControlBcds[g];
EXITS
badComp => g.compiledOk ← FALSE;
out => NULL;
}};
ContinueProc: Menus.MenuProc = {
g: CT.Global ← NARROW[clientData];
{
ENABLE ABORTED, IO.UserAborted => {
g.ttyout.ResetUserAbort[];
g.ttyout.PutF["Continue Aborted\n"];
GOTO out;
};
errors: BOOL;
UpdateNewFile[g];
errors ← CT.DetermineCompilation[g, TRUE];
IF NOT errors THEN
errors ← CT.LoadBcdsAndResolveImports[g, TRUE];
EXITS
out => NULL;
}};
CompileProc: Menus.MenuProc = {
g: CT.Global ← NARROW[clientData];
{
ENABLE ABORTED, IO.UserAborted => {
g.ttyout.ResetUserAbort[];
g.ttyout.PutF["Compilation Aborted\n"];
GOTO out;
};
errors: BOOL;
IF g.moduleList = NIL THEN {
errors ← ParseCompileList[g];
IF errors THEN RETURN;
};
errors ← CT.DetermineCompilation[g, g.fakebcdspace ~= Space.nullHandle];
g.compiledOk ← errors;
EXITS
out => NULL;
}};
LoadProc: Menus.MenuProc = {
g: CT.Global ← NARROW[clientData];
{
ENABLE ABORTED, IO.UserAborted => {
g.ttyout.ResetUserAbort[];
g.ttyout.PutF["Load Aborted\n"];
GOTO out;
};
IF g.moduleList = NIL THEN
g.ttyout.PutF["Error - must Compile before Loading.\n"]
ELSE {
errors: BOOL ← CT.LoadBcdsAndResolveImports[g, TRUE];
g.loadedOk ← NOT errors;
};
EXITS
out => NULL;
}};
StartProc: Menus.MenuProc = {
g: CT.Global ← NARROW[clientData];
{
ENABLE ABORTED, IO.UserAborted => {
g.ttyout.ResetUserAbort[];
g.ttyout.PutF["Start Aborted\n"];
GOTO out;
};
IF g.loadedOk THEN
CT.StartAllControlBcds[g]
ELSE
g.ttyout.PutF["Error - cannot load.\n"];
EXITS
out => NULL;
}};
UnLoadProc: Menus.MenuProc = {
g: CT.Global ← NARROW[clientData];
{
ENABLE ABORTED, IO.UserAborted => {
g.ttyout.ResetUserAbort[];
g.ttyout.PutF["UnLoad Aborted\n"];
GOTO out;
};
CT.UnLoad[g, TRUE];
g.moduleList ← NIL;
EXITS
out => NULL;
}};
-- not on the queue
StopProc: Menus.MenuProc = {
g: CT.Global ← NARROW[clientData];
MBQueue.Flush[g.q];
g.ttyout.SetUserAbort[];
};
FlushCacheProc: Menus.MenuProc = {
g: CT.Global ← NARROW[clientData];
g.bcdTabList ← NIL;
};
ParseCompileList: PROC[g: CT.Global] RETURNS[errors: BOOL] = {
errors ← ParseString[g, ViewerTools.GetContents[g.compileViewer]];
IF errors THEN RETURN;
TRUSTED{g.moduleList ← LOOPHOLE[List.Reverse[LOOPHOLE[g.moduleList]]]};
g.msgout.PutChar['\n];
};
-- may call itself recursively
ParseString: PROC[g: CT.Global, string: Rope.ROPE] RETURNS[errors: BOOL] = {
ch: CHAR;
mi: CT.MI;
inx: CARDINAL ← 0;
start: CARDINAL;
slash: INT;
srcName, bcdName, item: Rope.Text;
switches: CompilerOps.LetterSwitches;
controlModule, explicitSortSwitch, exportedInterface: BOOL;
errors ← FALSE;
WHILE inx < string.Length[] DO
WHILE inx < string.Length[] DO
ch ← string.Fetch[inx];
IF ch ~= ' AND ch ~= '\n THEN EXIT;
g.msgout.PutChar[' ];
inx ← inx + 1;
ENDLOOP;
start ← inx;
WHILE inx < string.Length[] DO
ch ← string.Fetch[inx];
IF ch = ' OR ch = '\n THEN EXIT;
inx ← inx + 1;
ENDLOOP;
IF inx = start THEN LOOP;
item ← Rope.Flatten[string, start, inx-start];
IF item.Fetch[0] = '@ THEN {
in: IO.Handle;
fn, r: Rope.ROPE;
fn ← Rope.Flatten[item, 1];
IF Rope.Find[fn, "."] = -1 THEN
fn ← CT.AppendExtension[fn, ".cl"L];
in ← FileIO.Open[fn, read
! FileIO.OpenFailed => {
g.ttyout.PutF["%s: cannot open\n", IO.rope[fn]];
GOTO badFile
}];
WHILE NOT in.EndOf[] DO
r ← r.Cat[Rope.FromChar[in.GetChar[]]];
ENDLOOP;
in.Close[];
-- recursive call
IF ParseString[g, r] THEN GOTO badFile;
LOOP;
};
g.msgout.PutRope[item];
IF item.Fetch[0] = '+ THEN { -- control module
controlModule ← TRUE;
item ← Rope.Flatten[item, 1];
}
ELSE
controlModule ← FALSE;
IF item.Fetch[0] = '= THEN { -- export this interface
exportedInterface ← TRUE;
item ← Rope.Flatten[item, 1];
}
ELSE
exportedInterface ← FALSE;
IF (slash ← Rope.Find[item, "/"]) >= 0 THEN {
sstring: Rope.Text ← Rope.Flatten[item, slash+1];
item ← Rope.Flatten[item, 0, slash];
[switches, explicitSortSwitch] ← InterpolateSwitches[sstring];
}
ELSE TRUSTED {
switches ← CompilerOps.DefaultSwitches[];
explicitSortSwitch ← FALSE;
};
IF NOT CS.EndsIn[item, ".bcd"L] THEN
srcName ← CT.AppendExtension[item, ".Mesa"L]
ELSE
srcName ← NIL;
bcdName ← CT.AppendExtension[item, ".Bcd"L];
mi ← NEW[CT.MIRecord
← [srcFileName: srcName, bcdFileName: bcdName, switches: switches,
explicitSortSwitch: explicitSortSwitch, controlModule: controlModule,
exportedInterface: exportedInterface]];
g.moduleList ← CONS[mi, g.moduleList];
ENDLOOP;
EXITS
badFile => RETURN[TRUE];
};
-- what to do about explicitSortSwitch?
InterpolateSwitches: PROC[parms: Rope.Text] RETURNS[switches: CompilerOps.LetterSwitches,
explicitSortSwitch: BOOL] =
{
i: CARDINAL ← 0;
on: BOOL;
ch: CHAR;
-- set defaults
TRUSTED{switches ← CompilerOps.DefaultSwitches[]};
-- switches['s] ← FALSE; the modeller defaults to /-s
explicitSortSwitch ← FALSE;
IF parms = NIL THEN RETURN;
WHILE i < parms.Length[] DO
on ← TRUE;
IF parms.Fetch[i] = '- THEN {
i ← i + 1;
on ← FALSE;
};
ch ← Rope.Lower[parms.Fetch[i]];
IF ch IN ['a .. 'z] THEN {
switches[ch] ← on;
IF ch = 's THEN explicitSortSwitch ← TRUE;
};
i ← i + 1;
ENDLOOP;
};
LoadCompiler: PROC[out: IO.Handle] RETURNS[success: BOOL] = TRUSTED {
cap: File.Capability;
success ← TRUE;
IF Runtime.IsBound[CompilerOps.DefaultSwitches] THEN RETURN[TRUE]; -- already loaded
out.PutF["Loading Compiler ... "];
{
ENABLE ANY => { out.PutF["failed.\n"]; GOTO out};
cm: PrincOps.ControlModule;
cap ← Directory.Lookup["compiler.bcd"L];
[cm: cm] ← Loader.Instantiate[file: cap, offset: 1, codeLinks: TRUE];
Loader.Start[cm];
out.PutF["done.\n"];
EXITS
out => success ← FALSE;
}};
AttachSymbiote: PROC[g: CT.Global] =
{
IF g.attachEditorRef = NIL THEN
g.attachEditorRef ← ViewerEvents.RegisterEventProc[CallProcedureForNotice, save];
g.msgout.Put[IO.string["Editor set to call this compile tool.\n"L]];
};
DetachSymbiote: PROC[g: CT.Global, print: BOOL] = {
IF g.attachEditorRef ~= NIL THEN
ViewerEvents.UnRegisterEventProc[g.attachEditorRef, save];
g.attachEditorRef ← NIL;
IF print THEN
g.msgout.Put[IO.string["Editor detached from this compile tool.\n"L]];
};
-- this is the procedure called by the editor
-- can't print anything in this procedure
CallProcedureForNotice: ViewerEvents.EventProc =
{
ENABLE ANY => GOTO out;
flat: Rope.Text;
IF viewer.file = NIL THEN RETURN;
flat ← RopeInline.InlineFlatten[viewer.file];
FOR l: LIST OF CT.Global ← globalList, l.rest UNTIL l = NIL DO
l.first.noticeList ← CONS[flat, l.first.noticeList];
ENDLOOP;
EXITS
out => NULL;
};
UpdateNewFile: PROC[g: CT.Global] = {
FOR l: LIST OF Rope.Text ← g.noticeList, l.rest UNTIL l = NIL DO
FOR ml: CT.ModuleList ← g.moduleList, ml.rest UNTIL ml = NIL DO
IF CS.EquivalentRope[l.first, ml.first.srcFileName] THEN {
g.ttyout.PutF["Noticing edited version of %s.\n", IO.rope[l.first]];
ml.first.bcdValid ← FALSE;
CT.SetPossiblyBadAndValid[ml.first];
EXIT;
};
ENDLOOP;
ENDLOOP;
g.noticeList ← NIL;
};
MyDestroy: ViewerEvents.EventProc = {
g: CT.Global;
IF event ~= destroy THEN RETURN;
g ← NARROW[ViewerOps.FetchProp[viewer, $CTGlobalRef]];
IF g ~= NIL THEN DetachSymbiote[g, FALSE];
IF globalList = NIL THEN {
ViewerEvents.UnRegisterEventProc[destroyEventRegistration, destroy];
destroyEventRegistration ← NIL;
RETURN;
};
FOR l: LIST OF CT.Global ← globalList, l.rest UNTIL l = NIL DO
IF l.first.container = viewer THEN TRUSTED {
globalList ← LOOPHOLE[List.DRemove[ref: l.first, list: LOOPHOLE[globalList]]];
RETURN;
};
ENDLOOP;
};
BeginProcFromUser: PROC[g: REF ANY] = {
BeginProc[parent: NIL, clientData: g, mouseButton: red, shift: FALSE, control: FALSE];
};
{
initialCL: Rope.ROPE;
g: CT.Global;
-- start code
makeDebuggingWindow ← UserProfile.Boolean["CompileTool.Wizard", FALSE];-- default is false
destroyEventRegistration ← ViewerEvents.RegisterEventProc[MyDestroy, destroy];
g ← BuildOuter[];
initialCL ← UserProfile.Token["CompileTool.AutoLoad", NIL];
IF initialCL ~= NIL THEN
ViewerTools.SetContents[g.compileViewer, initialCL];
[] ← LoadCompiler[g.ttyout];
IF initialCL ~= NIL THEN -- this simulates the button push
-- MBQueue.QueueClientAction[g.q, BeginProcFromUser, g];
BeginProcFromUser[g]; -- this is the actual call, above code doesn't work
}}.