-- SMIntImpl.mesa
-- last edit by Schmidt, May 27, 1983 7:12 pm
-- last edit by Satterthwaite, August 12, 1983 9:54 am
DIRECTORY
Buttons: TYPE USING [Button, ButtonProc],
Containers: TYPE USING [ChildXBound, ChildYBound, Container, Create],
CS: TYPE USING [CardFromRope, EndsIn, RopeFromCard, SetPFCodes],
Directory: TYPE USING [DeleteFile, Error, Rename],
FileIO: TYPE USING [Open, OpenFailed],
IO: TYPE USING [
card, Close, PutF, PutFR, ResetUserAbort, RIS, rope, SetUserAbort,
STREAM, time, UserAborted],
Labels: TYPE USING [Create, Label, Set, SetDisplayStyle],
List: TYPE USING [DRemove],
MBQueue: TYPE USING [Create, CreateMenuEntry, CreateButton, Flush, Queue],
Menus: TYPE USING [CreateEntry, CreateMenu, InsertMenuEntry, Menu, MenuProc],
Rope: TYPE USING [Cat, Equal, Flatten, IsEmpty, ROPE, Text],
Rules: TYPE USING [Create, Rule],
SMBcd: TYPE USING[WriteModelBcd],
SMComp: TYPE USING [CompileAll, LoadCompiler],
SMDF: TYPE USING [WriteDFFile],
SMEval: TYPE USING [Eval, UnitToRope],
SMFI: TYPE USING [SrcFileInfo],
SMFIOps: TYPE USING [Ambiguous, --Flush,-- NewestSource],
SMLDriver: TYPE USING [LoadAndBind, Loaded, StartAll, Started, Unload],
SMOps: TYPE USING [MS, NewModel],
SMUtil: TYPE USING [ParseStream, PrettyPrint, PrintTree],
SMTree: TYPE Tree USING [Handle, Link, null],
SMTreeOps: TYPE --TreeOps-- USING [
Initialize, Finalize, NthSon, OpName, PutExt, PutNthSon, Scan, ScanSons],
TypeScript: TYPE USING [TS, Create],
ViewerClasses: TYPE USING [Viewer],
ViewerEvents: TYPE USING [
EventProc, EventRegistration, RegisterEventProc, UnRegisterEventProc],
ViewerIO: TYPE USING [CreateViewerStreams],
ViewerOps: TYPE USING [
AddProp, EstablishViewerPosition, FetchProp, PaintViewer, SetMenu, SetOpenHeight],
ViewerTools: TYPE USING [
GetContents, GetSelectionContents, MakeNewTextViewer, SetSelection];
SMIntImpl: CEDAR PROGRAM
IMPORTS
Containers, CS, Directory, FileIO, MBQueue, IO, Labels, List, Menus, Rope, Rules,
SMBcd, SMComp, SMDF, SMEval, SMFIOps, SMLDriver, SMOps, SMUtil,
SMTreeOps, TypeScript, ViewerEvents, ViewerOps, ViewerIO, ViewerTools ~ {
OPEN Tree~~SMTree, TreeOps~~SMTreeOps;
-- modeller state
ModelState: TYPE~{ -- ordered
idle, unparsed, parsed, evaluated, compiled, loaded, run};
-- global data
Global: TYPE ~ REF GlobalRecord;
GlobalRecord: TYPE ~ RECORD[
-- viewers data
container: Containers.Container←NIL,
ttyin: IO.STREAM←NIL,
ttyout: IO.STREAM←NIL,
msgout: IO.STREAM←NIL,
-- fields
startModellingFileNameButton: Buttons.Button←NIL,
startModellingFileNameViewer: ViewerClasses.Viewer←NIL,
confirmButton: Buttons.Button←NIL,
confirmViewer: ViewerClasses.Viewer←NIL,
attachEditorButton: Buttons.Button←NIL,
attachEditorLabel: ViewerClasses.Viewer←NIL,
-- modelling state
state: ModelState←$idle,
stateLabel: Labels.Label←NIL,
-- other objects
q: MBQueue.Queue←NIL,
noticeList: LIST OF Rope.Text←NIL, -- files that have been noticed
confirmCompiles: REF BOOL,
attachEditor: BOOL←TRUE,
attachEditorRef: REF ANY←NIL,
model: SMOps.MS←NIL,
modelFileName: Rope.Text←NIL,
modelUpdated: BOOL←FALSE,
debugLevel: NAT←NAT.LAST -- >= 1: parse tree, >= 2: value tree, >= 3: pp value
];
-- MDS usage
globalList: LIST OF Global ← NIL; -- not properly monitored
destroyEventRegistration: ViewerEvents.EventRegistration;
-- end of MDS usage
-- these are commands for the viewers world
entryHeight: CARDINAL ~ 15;
entryVSpace: CARDINAL ~ 7;
entryHSpace: CARDINAL ~ 10;
Create: PROC RETURNS[g: Global] ~ {
ttyTypeScript, msgTypeScript: TypeScript.TS;
vName: Rope.ROPE ~ IO.PutFR["Cedar Modeller, started on %t", IO.time[]];
menu: Menus.Menu ~ Menus.CreateMenu[lines~3];
MenuItem: PROC[name: Rope.ROPE, proc: Menus.MenuProc, line: NAT] ~ {
menu.InsertMenuEntry[(g.q).CreateMenuEntry[name, proc, g], line]};
g ← NEW[GlobalRecord ← [
confirmCompiles~NEW[BOOL←FALSE],
container~Containers.Create[info~[name~vName, iconic~FALSE, scrollable~FALSE]],
q~MBQueue.Create[]]];
ViewerOps.AddProp[g.container, $SMGlobalRef, g];
-- first row of menu items
MenuItem["StopModel", StopModel, 0];
MenuItem["Continue", Continue, 0];
MenuItem["Begin", Begin, 0];
MenuItem["NoticeAll", NoticeAll, 0];
MenuItem["StartModel", StartModel, 0];
-- second row of menu items
MenuItem["NewModeller", NewModeller, 1];
MenuItem["Bind", Bind, 1];
MenuItem["MakeDFFile", MakeDFFile, 1];
MenuItem["MakeModelBcd", MakeModelBcd, 1];
-- third row of menu items
MenuItem["Debug", Debug, 2];
menu.InsertMenuEntry[Menus.CreateEntry["Abort", Abort, g], 2];
MenuItem["Unload", Unload, 2];
MenuItem["Start", Start, 2];
MenuItem["Load", Load, 2];
MenuItem["Compile", Compile, 2];
MenuItem["Check", Check, 2];
--
ViewerOps.SetMenu[g.container, menu, FALSE];
[ttyTypeScript, msgTypeScript] ← 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];
g.msgout ← ViewerIO.CreateViewerStreams[viewer~msgTypeScript, name~NIL].out;
CS.SetPFCodes[g.ttyout]; CS.SetPFCodes[g.msgout];
IF g.attachEditor THEN AttachSymbiote[g];
globalList ← CONS[g, globalList]};
BuildUserInput: PROC[g: Global] RETURNS[ttyTypeScript, msgTypeScript: TypeScript.TS] ~ {
heightSoFar: CARDINAL ← 0;
l: ViewerClasses.Viewer ← NIL;
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 {
heightSoFar ← heightSoFar + entryVSpace/2;
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.startModellingFileNameButton, ] ← CreateButton["ModelName:", NIL, TRUE];
l ← g.startModellingFileNameViewer ← 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.startModellingFileNameViewer];
heightSoFar ← heightSoFar + l.wh + entryVSpace/2;
-- second line
heightSoFar ← heightSoFar + entryVSpace/2;
l ← Labels.Create[info~[
name~"State: ", parent~g.container, wx~0, wy~heightSoFar, border~FALSE]];
l ← g.stateLabel ← Labels.Create[info~[
name~"wwwwww",
parent~g.container, wx~l.wx+l.ww+entryHSpace, wy~heightSoFar, border~FALSE]];
SetState[g, $idle];
heightSoFar ← heightSoFar + l.wh + entryVSpace/2;
-- third 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]];
heightSoFar ← heightSoFar + entryVSpace + 80;
Containers.ChildXBound[g.container, ttyTypeScript];
Containers.ChildYBound[g.container, ttyTypeScript];
ViewerOps.SetOpenHeight[g.container, heightSoFar + 200]};
SetState: PROC[g: Global, state: ModelState] ~ {
Labels.SetDisplayStyle[g.stateLabel, $BlackOnWhite];
Labels.Set[g. stateLabel, SELECT state FROM
$idle => "idle",
$unparsed => "unparsed",
$parsed => "parsed",
$evaluated => "checked",
$compiled => "compiled",
$loaded => "loaded",
$run => "started",
ENDCASE => "ERROR"];
g.state ← state};
PushButton: Buttons.ButtonProc ~ {
g: Global ~ NARROW[clientData];
SELECT NARROW[parent, ViewerClasses.Viewer] FROM
g.startModellingFileNameButton =>
ViewerTools.SetSelection[g.startModellingFileNameViewer, NIL];
g.confirmButton => {
g.confirmCompiles↑ ← ~g.confirmCompiles↑;
Labels.Set[g.confirmViewer, IF g.confirmCompiles↑ THEN "TRUE" ELSE "FALSE"]};
g.attachEditorButton => {
g.attachEditor ← ~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;
};
-- BUTTON PROCS
-- not on the queue
Abort: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
MBQueue.Flush[g.q];
g.ttyin.SetUserAbort[]};
Begin: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
{
ENABLE ABORTED, IO.UserAborted => {GOTO out};
InternalUnload[g, TRUE];
IF g.state = $idle THEN InternalStartModel[g, TRUE]; -- auto StartModel
ClearExtensions[g.model.tree];
InternalCheck[g];
InternalCompile[g, FALSE];
InternalLoad[g, FALSE];
InternalStart[g];
EXITS
out => {g.ttyin.ResetUserAbort[]; g.ttyout.PutF["Begin aborted\n"]};
};
SetState[g, g.state]};
Bind: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
g.ttyout.PutF["Bind not implemented yet.\n"];
g.ttyout.PutF["-------------\n"]};
Check: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
{
ENABLE ABORTED, IO.UserAborted => {GOTO out};
IF g.state = $idle THEN InternalStartModel[g, TRUE];
InternalCheck[g];
EXITS
out => {g.ttyin.ResetUserAbort[]; g.ttyout.PutF["Check aborted\n"]};
};
SetState[g, g.state]};
Compile: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
{
ENABLE ABORTED, IO.UserAborted => {GOTO out};
IF g.state = $idle THEN InternalStartModel[g, TRUE];
InternalCheck[g];
InternalCompile[g, FALSE];
EXITS
out => {g.ttyin.ResetUserAbort[]; g.ttyout.PutF["Compilation aborted\n"]};
};
SetState[g, g.state]};
Continue: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
{
ENABLE ABORTED, IO.UserAborted => {GOTO out};
IF g.state = $idle THEN InternalStartModel[g, TRUE]; -- auto StartModel
InternalCheck[g];
InternalCompile[g, TRUE];
InternalLoad[g, TRUE];
InternalStart[g];
EXITS
out => {g.ttyin.ResetUserAbort[]; g.ttyout.PutF["Continue aborted\n"]};
};
SetState[g, g.state]};
Debug: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
g.ttyout.PutF["-------------\n"];
IF g.state = $idle THEN {
ENABLE ABORTED, IO.UserAborted => {GOTO out};
g.model ← SMOps.NewModel[g.ttyin, g.ttyout, g.ttyout];
(g.model.tm).Initialize;
g.model.tree ← SMUtil.ParseStream[g.model, IO.RIS[ViewerTools.GetSelectionContents[]]];
IF g.model.tree # Tree.null THEN {
IF g.debugLevel <= 1 THEN SMUtil.PrintTree[g.model, g.model.tree];
SMUtil.PrettyPrint[g.model.out, g.model.tree, g.model.comments]};
IF g.model.tree # Tree.null THEN {
g.model.val ← SMEval.Eval[g.model, g.model.tree, NIL];
g.model.out.PutF["\n\n"];
SMUtil.PrintTree[g.model, g.model.val];
SMUtil.PrettyPrint[g.model.out, g.model.val, NIL];
g.model.val ← NIL};
g.model ← NIL;
EXITS
out => {g.ttyin.ResetUserAbort[]; g.ttyout.PutF["Debug aborted\n"]};
};
g.ttyout.PutF["-------------\n"]};
Load: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
{
ENABLE ABORTED, IO.UserAborted => {GOTO out};
InternalLoad[g, FALSE];
EXITS
out => {g.ttyin.ResetUserAbort[]; g.ttyout.PutF["Load aborted\n"]};
};
SetState[g, g.state]};
MakeDFFile: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
{
ENABLE ABORTED, IO.UserAborted => {GOTO out};
IF g.state >= $evaluated THEN {
InternalTemporary[g];
SMDF.WriteDFFile[g.model, g.model.val, g.modelFileName, g.modelFileName]};
EXITS
out => {g.ttyin.ResetUserAbort[]; g.ttyout.PutF["MakeDFFile aborted\n"]};
};
};
MakeModelBcd: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
{
ENABLE ABORTED, IO.UserAborted => {GOTO out};
IF g.state >= $evaluated THEN {
InternalTemporary[g];
SMBcd.WriteModelBcd[g.model, g.model.val, g.modelFileName, g.modelFileName]};
EXITS
out => {g.ttyin.ResetUserAbort[]; g.ttyout.PutF["MakeModelBcd aborted\n"]};
};
};
NewModeller: Menus.MenuProc ~ {
[] ← Create[]};
NoticeAll: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
{
ENABLE ABORTED, IO.UserAborted => {GOTO out};
InternalNoticeAll[g];
EXITS
out => {g.ttyin.ResetUserAbort[]; g.ttyout.PutF["NoticeAll aborted\n"]};
};
};
StartModel: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
{
ENABLE ABORTED, IO.UserAborted => {GOTO out};
InternalStartModel[g];
EXITS
out => {g.ttyin.ResetUserAbort[]; g.ttyout.PutF["StartModelling aborted\n"]};
};
SetState[g, g.state]};
Start: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
{
ENABLE ABORTED, IO.UserAborted => {GOTO out};
InternalStart[g];
EXITS
out => {g.ttyin.ResetUserAbort[]; g.ttyout.PutF["Start aborted\n"]};
};
SetState[g, g.state]};
StopModel: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
{
ENABLE ABORTED, IO.UserAborted => {GOTO out};
InternalStopModel[g];
EXITS
out => {g.ttyin.ResetUserAbort[]; g.ttyout.PutF["StopModelling aborted\n"]};
};
SetState[g, $idle]};
Unload: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
{
ENABLE ABORTED, IO.UserAborted => {GOTO out};
InternalUnload[g, TRUE];
EXITS
out => {g.ttyin.ResetUserAbort[]; g.ttyout.PutF["Unload aborted\n"]};
};
SetState[g, g.state]};
-- SUPPORT ROUTINES
AttachSymbiote: PROC[g: Global] ~ {
IF g.attachEditorRef = NIL THEN
g.attachEditorRef ← ViewerEvents.RegisterEventProc[SaveEvent, $save];
g.msgout.PutF["Editor set to call this modeller.\n"]};
DetachSymbiote: PROC[g: Global, print: BOOL] ~ {
IF g.attachEditorRef ~= NIL THEN
ViewerEvents.UnRegisterEventProc[g.attachEditorRef, $save];
g.attachEditorRef ← NIL;
IF print THEN g.msgout.PutF["Editor detached from this modeller.\n"]};
-- this is the procedure called by the editor
-- can't print anything in this procedure
SaveEvent: ViewerEvents.EventProc ~ {
ENABLE ANY => {GOTO out};
IF viewer.file # NIL THEN {
flat: Rope.Text ~ viewer.file.Flatten[];
IF CS.EndsIn[flat, ".mesa"] THEN -- only source now
FOR l: LIST OF Global ← globalList, l.rest UNTIL l = NIL DO
l.first.noticeList ← CONS[flat, l.first.noticeList];
ENDLOOP;
}
EXITS
out => NULL;
};
DestroyEvent: ViewerEvents.EventProc ~ {
IF event = $destroy THEN {
g: Global ~ NARROW[ViewerOps.FetchProp[viewer, $SMGlobalRef]];
IF g ~= NIL THEN DetachSymbiote[g, FALSE];
IF globalList = NIL THEN {
ViewerEvents.UnRegisterEventProc[destroyEventRegistration, $destroy];
destroyEventRegistration ← NIL;
RETURN};
FOR l: LIST OF 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;
};
};
InternalStartModel: PROC[g: Global, autoNotice: BOOL←FALSE] ~ {
modelFileName: Rope.Text;
input: IO.STREAM ← NIL;
IF g.state ~= $idle THEN InternalStopModel[g];
-- now set the contents
modelFileName ← ViewerTools.GetContents[g.startModellingFileNameViewer].Flatten[];
IF modelFileName.IsEmpty THEN {
g.ttyout.PutF["Error - no model source input file\n"];
GOTO failed};
IF ~CS.EndsIn[modelFileName, ".model"]
THEN modelFileName ← modelFileName.Cat[".model"].Flatten[];
input ← FileIO.Open[modelFileName
! FileIO.OpenFailed => {
g.ttyout.PutF["Error - file %s could not be opened\n", IO.rope[modelFileName]];
GOTO failed}];
g.model ← SMOps.NewModel[g.ttyin, g.ttyout, g.msgout];
(g.model.tm).Initialize;
g.modelFileName ← modelFileName;
g.modelUpdated ← FALSE; SetState[g, $unparsed];
Labels.SetDisplayStyle[g.stateLabel, $BlackOnGrey];
g.model.tree ← SMUtil.ParseStream[m~g.model, source~input];
Labels.SetDisplayStyle[g.stateLabel, $BlackOnWhite];
IF g.model.tree # Tree.null THEN {
SetState[g, $parsed];
IF autoNotice THEN InternalNoticeAll[g];
IF g.debugLevel <= 1 THEN {
SMUtil.PrintTree[g.model, g.model.tree];
SMUtil.PrettyPrint[g.model.out, g.model.tree, g.model.comments]};
};
EXITS
failed => NULL
}; -- file remains open
InternalNoticeAll: PROC[g: Global] ~ {
nChanged: CARDINAL ← 0;
LookForSource: TreeOps.Scan ~ {
WITH t SELECT FROM
node: Tree.Handle =>
IF TreeOps.OpName[node] = $unitId THEN {
fileName: Rope.Text ~ LocalName[node];
IF CS.EndsIn[fileName, ".mesa"] AND NoticeSource[g, node, fileName, FALSE] THEN
nChanged ← nChanged + 1
ELSE IF CS.EndsIn[fileName, ".model"]
AND NoticeSource[g, node, fileName, FALSE] THEN {
nChanged ← nChanged + 1;
TreeOps.PutExt[node, Tree.null]} -- force reparsing of embedded model
}
ELSE TreeOps.ScanSons[node, LookForSource];
ENDCASE => NULL;
};
IF g.state >= $parsed THEN {
LookForSource[g.model.tree]; g.noticeList ← NIL};
g.ttyout.PutF["%d files noticed.\n\n", IO.card[nChanged]];
IF nChanged > 0 THEN {
g.modelUpdated ← TRUE;
SetState[g, MIN[g.state, $parsed]]; g.model.val ← NIL}; -- force reevaluation
};
InternalCheck: PROC[g: Global] ~ {
[] ← RecordNoticedFiles[g];
IF g.state = $parsed THEN { -- must (re)evaluate
g.model.errors ← FALSE; -- set by evaluation errors
Labels.SetDisplayStyle[g.stateLabel, $BlackOnGrey];
g.model.val ← SMEval.Eval[g.model, g.model.tree, NIL];
Labels.SetDisplayStyle[g.stateLabel, $BlackOnWhite];
IF g.debugLevel <= 2 THEN {
SMUtil.PrintTree[g.model, g.model.val]; (g.model.out).PutF["\n"]};
IF g.debugLevel <= 3 THEN SMUtil.PrettyPrint[g.model.out, g.model.val, NIL];
IF ~g.model.errors THEN SetState[g, $evaluated]};
};
InternalCompile: PROC[g: Global, replacement: BOOL] ~ {
IF g.state = $evaluated THEN {
InternalTemporary[g];
Labels.SetDisplayStyle[g.stateLabel, $BlackOnGrey];
IF SMComp.CompileAll[g.model, g.model.val, g.confirmCompiles, replacement].complete THEN
SetState[g, $compiled];
Labels.SetDisplayStyle[g.stateLabel, $BlackOnWhite]};
};
InternalLoad: PROC[g: Global, replacement: BOOL] ~ {
IF g.state = $compiled THEN {
Labels.SetDisplayStyle[g.stateLabel, $BlackOnGrey];
IF ~(g.model.ls).LoadAndBind[g.model.val, replacement].errors THEN SetState[g, $loaded];
Labels.SetDisplayStyle[g.stateLabel, $BlackOnWhite]};
};
InternalStart: PROC[g: Global] ~ {
IF g.state = $loaded THEN {
Labels.SetDisplayStyle[g.stateLabel, $BlackOnGrey];
IF ~(g.model.ls).Started THEN (g.model.ls).StartAll[g.model.val];
Labels.SetDisplayStyle[g.stateLabel, $BlackOnWhite];
SetState[g, $run]};
};
InternalTemporary: PROC[g: Global] ~ {
IF g.modelUpdated THEN TRUSTED {
sh: IO.STREAM;
oldName: Rope.Text ~ g.modelFileName.Cat["$"].Flatten[];
g.ttyout.PutF["Old model on %s, ", IO.rope[oldName]];
Directory.DeleteFile[fileName: LOOPHOLE[oldName]
! Directory.Error => {CONTINUE}];
Directory.Rename[
oldName~LOOPHOLE[g.modelFileName], newName~LOOPHOLE[oldName]];
sh ← FileIO.Open[g.modelFileName, $overwrite];
SMUtil.PrettyPrint[sh, g.model.tree, g.model.comments];
sh.Close[];
g.ttyout.PutF["new model on %s\n\n", IO.rope[g.modelFileName]];
g.modelUpdated ← FALSE};
};
InternalStopModel: PROC[g: Global] ~ {
IF g.state # $idle THEN {
InternalTemporary[g];
InternalUnload[g, FALSE];
(g.model.tm).Finalize;
g.model.val ← NIL; g.model ← NIL};
--SMFIOps.Flush[]; SMProj.Flush[];--
SetState[g, $idle]};
InternalUnload: PROC[g: Global, unloadBcd: BOOL] ~ {
IF g.model # NIL AND (g.model.ls).Loaded THEN {
Labels.SetDisplayStyle[g.stateLabel, $BlackOnGrey];
(g.model.ls).Unload[g.model.val, unloadBcd];
Labels.SetDisplayStyle[g.stateLabel, $BlackOnWhite];
SetState[g, MIN[g.state, $compiled]]};
};
-- only does this for the parse tree
ClearExtensions: PROC[parseTree: Tree.Link] ~ {
ANode: TreeOps.Scan ~ TRUSTED {
WITH t SELECT FROM
node: Tree.Handle => {
IF TreeOps.OpName[node] ~= $none THEN TreeOps.PutExt[node, NIL];
TreeOps.ScanSons[node, ANode]};
ENDCASE => NULL
};
ANode[parseTree]};
LocalName: PROC [uid: Tree.Link] RETURNS[Rope.Text] ~ {
RETURN [SMEval.UnitToRope[TreeOps.NthSon[uid, 3]].Flatten[]]};
NoticeSource: PROC[g: Global, unitId: Tree.Link, fileName: Rope.Text, new: BOOL]
RETURNS[changed: BOOL] ~ {
fiSrc: SMFI.SrcFileInfo ~ SMFIOps.NewestSource[fileName];
version: Rope.Text ~ NARROW[TreeOps.NthSon[unitId, 4]];
create: LONG CARDINAL ~
(IF SMFIOps.Ambiguous[version] THEN 0 ELSE CS.CardFromRope[version]);
changed ← (fiSrc.create # 0 AND fiSrc.create # create);
IF changed THEN {
g.ttyout.PutF["Notice %s\n", IO.rope[fileName]];
IF new THEN fiSrc.new ← TRUE;
TreeOps.PutNthSon[unitId, 4, CS.RopeFromCard[fiSrc.create].Flatten[]]};
RETURN};
RecordNoticedFiles: PROC[g: Global] RETURNS[noticedFile: BOOL ← FALSE] ~ {
LookForSource: TreeOps.Scan ~ {
WITH t SELECT FROM
node: Tree.Handle =>
IF TreeOps.OpName[node] = $unitId THEN {
fileName: Rope.Text ~ LocalName[node];
FOR l: LIST OF Rope.Text ← g.noticeList, l.rest UNTIL l = NIL DO
IF fileName.Equal[l.first, FALSE]
AND NoticeSource[g, node, fileName, TRUE] THEN {
noticedFile ← TRUE; EXIT} -- new file
ENDLOOP;
}
ELSE TreeOps.ScanSons[node, LookForSource];
ENDCASE => NULL;
};
IF g.noticeList # NIL AND g.state >= $parsed THEN {
LookForSource[g.model.tree]; g.noticeList ← NIL};
IF noticedFile THEN {
g.modelUpdated ← TRUE;
SetState[g, MIN[g.state, $parsed]]; g.model.val ← NIL}; -- force reevaluation
};
{
g: Global;
destroyEventRegistration ← ViewerEvents.RegisterEventProc[DestroyEvent, $destroy];
g ← Create[];
[] ← SMComp.LoadCompiler[g.msgout];
};
}.