[ivy]<Satterthwaite>SML>SMIntImpl.mesa!10

SMIntImpl.mesa
Copyright © 1985 by Xerox Corporation. All rights reserved.
last edit by Satterthwaite, May 29, 1986 12:00:08 pm PDT
DIRECTORY
BasicTime: TYPE USING [GMT, nullGMT],
Buttons: TYPE USING [Button, ButtonProc],
Commander: TYPE USING [CommandProc, Register],
Containers: TYPE USING [ChildXBound, ChildYBound, Container, Create],
CS: TYPE USING [EndsIn, GMTFromRope, Init, RootName, RopeFromGMT, ShortName],
FS: TYPE USING [
OpenFile, nullOpenFile,
Create, Error, FileInfo, GetInfo, GetName, Open, StreamFromOpenFile],
IO: TYPE USING [card, Close, PutChar, PutF, PutFR, PutRope, RIS, rope, STREAM, time],
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],
Process: TYPE USING [Abort, CheckForAbort, GetCurrent],
ProcessProps: TYPE USING [GetProp],
Rope: TYPE USING [Concat, Equal, Find, Flatten, IsEmpty, Length, ROPE, Substr, Text],
Rules: TYPE USING [Create, Rule],
SMBcd: TYPE USING [WriteModelBcd],
SMComp: TYPE USING [CompileAll, LoadCompiler],
SMDF: TYPE USING [WriteDFFile],
SMEval: TYPE USING [Equiv, Eval],
SMFI: TYPE USING [SrcFileInfo],
SMFIOps: TYPE USING [
Ambiguous, EvaluateUnitId, Reset, NewestBcd, NewestSource, UnitToRope],
SMLDriver: TYPE USING [Bind, LoadAndBind, Loaded, StartAll, Started, Unload],
SMOps: TYPE USING [MS, NewModel, PatchList],
SMProj: TYPE USING [Proj, Reset],
SMUtil: TYPE USING [ParseStream, PrettyPrint, PrintTree],
SMTree: TYPE Tree USING [Ext, Handle, Link, null],
SMTreeOps: TYPE TreeOps USING [
GetExt, Initialize, Finalize, Map, NthSon, OpName, PutExt, PutNthSon,
Scan, ScanSons, UpdateLeaves],
TiogaMenuOps: TYPE USING [Open],
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 [
EnableUserEdits, GetContents, GetSelectionContents, InhibitUserEdits, MakeNewTextViewer,
SetContents, SetSelection];
SMIntImpl: CEDAR PROGRAM
IMPORTS
Commander, Containers, CS, FS, MBQueue, IO, Labels, List, Menus,
Process, ProcessProps, Rope, Rules,
SMBcd, SMComp, SMDF, SMEval, SMFIOps, SMLDriver, SMOps, SMProj, SMUtil, SMTreeOps,
TiogaMenuOps, TypeScript, ViewerEvents, ViewerOps, ViewerIO, ViewerTools ~ {
OPEN Tree~~SMTree, TreeOps~~SMTreeOps;
modeller state
ModelState: TYPE~{-- ordered
idle, unparsed, parsed, checked, 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,
viewers fields
modelFileNameButton: Buttons.Button←NIL,
modelFileNameViewer: ViewerClasses.Viewer←NIL,
wDirNameButton: Buttons.Button←NIL,
wDirNameViewer: ViewerClasses.Viewer←NIL,
attachEditorButton: Buttons.Button←NIL,
attachEditorLabel: Labels.Label←NIL,
modelling state
state: ModelState←$idle,
stateLabel: Labels.Label←NIL,
replaceable: BOOL←FALSE,
other objects
process: UNSAFE PROCESS←NIL,-- current menu process (NIL if none)
q: MBQueue.Queue←MBQueue.Create[],
noticeList: LIST OF Rope.Text←NIL,-- files that have been noticed
attachEditor: BOOL←TRUE,
attachEditorRef: REF ANY←NIL,
model: SMOps.MS←NIL,-- non-NIL iff state # $idle
modelFileName: Rope.ROPE←NIL,
modelFileVersion: BasicTime.GMT�sicTime.nullGMT,
wDir: Rope.ROPE←NIL,
modelUpdated: BOOL←FALSE,
modelSuperseded: 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: NAT ~ 15;
entryVSpace: NAT ~ 7;
entryHSpace: NAT ~ 10;
Create: PROC[wDir: Rope.ROPE] RETURNS[g: Global] ~ {
ttyTypeScript, msgTypeScript: TypeScript.TS;
vName: Rope.ROPE ~ IO.PutFR["Cedar Modeller 6.1a, started on %t", IO.time[]];
menu: Menus.Menu ~ Menus.CreateMenu[lines~3];
QMenuItem: PROC[name: Rope.ROPE, proc: Menus.MenuProc, line: NAT] ~ {
menu.InsertMenuEntry[(g.q).CreateMenuEntry[name, proc, g], line]};
MenuItem: PROC[name: Rope.ROPE, proc: Menus.MenuProc, line: NAT] ~ {
menu.InsertMenuEntry[Menus.CreateEntry[name, proc, g], line]};
g ← NEW[GlobalRecord ← [
container~Containers.Create[
info~[name~vName, iconic~FALSE, scrollable~FALSE, column~$right]]]
];
ViewerOps.AddProp[g.container, $SMGlobalRef, g];
first row of menu items
QMenuItem["Debug", Debug, 0];
QMenuItem["StopModel", StopModel, 0];
QMenuItem["Continue", Continue, 0];
QMenuItem["Begin", Begin, 0];
QMenuItem["NoticeAll", NoticeAll, 0];
QMenuItem["StartModel", StartModel, 0];
second row of menu items
MenuItem["NewModeller", NewModeller, 1];
QMenuItem["Bind", Bind, 1];
QMenuItem["MakeDFFile", MakeDFFile, 1];
QMenuItem["MakeModelBcd", MakeModelBcd, 1];
third row of menu items
MenuItem["Abort", Abort, 2];
QMenuItem["Unload", Unload, 2];
QMenuItem["Start", Start, 2];
QMenuItem["Load", Load, 2];
QMenuItem["Compile", Compile, 2];
QMenuItem["Check", Check, 2];
MenuItem["Open", Open, 2];
ViewerOps.SetMenu[g.container, menu, FALSE];
[ttyTypeScript, msgTypeScript] ← BuildUserInput[g, wDir];
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;
IF g.attachEditor THEN AttachSymbiote[g];
globalList ← CONS[g, globalList]};
BuildUserInput: PROC[g: Global, wDir: Rope.ROPE]
RETURNS[ttyTypeScript, msgTypeScript: TypeScript.TS] ~ {
heightSoFar: CARDINAL ← 0;
l: ViewerClasses.Viewer ← NIL;
rule: Rules.Rule;
CreateButton: PROC[bName, lName: Rope.ROPE, 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 ← (g.q).CreateButton[
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~FALSE]];
};
first line
[g.modelFileNameButton, ] ← CreateButton["ModelName:", NIL, TRUE];
l ← g.modelFileNameViewer ← 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.modelFileNameViewer];
heightSoFar ← heightSoFar + l.wh + entryVSpace/2;
second line
[g.wDirNameButton, ] ← CreateButton["Working Directory:", NIL, TRUE];
l ← g.wDirNameViewer ← 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.wDirNameViewer];
ViewerTools.SetContents[g.wDirNameViewer, wDir];
heightSoFar ← heightSoFar + l.wh + entryVSpace/2;
third 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];
[g.attachEditorButton, g.attachEditorLabel] ← CreateButton["AttachEditor:", "FALSE", FALSE];
IF g.attachEditor THEN Labels.Set[g.attachEditorLabel, "TRUE"];
heightSoFar ← heightSoFar + l.wh + entryVSpace/2;
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",
$checked => "checked",
$compiled => "compiled",
$loaded => "loaded",
$run => "started",
ENDCASE => "ERROR"];
g.state ← state};
PushButton: Buttons.ButtonProc ~ {
g: Global ~ NARROW[clientData];
SELECT NARROW[parent, Buttons.Button] FROM
g.modelFileNameButton =>
ViewerTools.SetSelection[g.modelFileNameViewer, NIL];
g.wDirNameButton =>
ViewerTools.SetSelection[g.wDirNameViewer, NIL];
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;
};
MENU PROCS
Abort: Menus.MenuProc ~ TRUSTED {
not on the queue
g: Global ~ NARROW[clientData];
(g.q).Flush[];
IF g.process # NIL THEN Process.Abort[g.process]};-- not properly monitored
Begin: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
g.process ← Process.GetCurrent[];
{
ENABLE ABORTED => {GOTO out};
InternalUnload[g, TRUE];
IF g.state = $idle OR g.modelSuperseded THEN InternalStartModel[g];
InternalParse[g, TRUE];
IF g.state >= $parsed THEN ClearExtensions[g.model.tree];
InternalCheck[g];
InternalCompile[g, FALSE];
InternalLoad[g, FALSE];
InternalStart[g];
g.process ← NIL;
EXITS
out => {g.ttyout.PutRope["Begin aborted\n"]};
};
SetState[g, g.state]};
Bind: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
g.process ← Process.GetCurrent[];
{
ENABLE ABORTED => {GOTO out};
IF g.state = $idle OR g.modelSuperseded THEN InternalStartModel[g];
InternalParse[g, TRUE];
InternalCheck[g];
InternalCompile[g, g.replaceable];
InternalBind[g];
g.process ← NIL;
EXITS
out => {g.ttyout.PutRope["Bind aborted\n"]};
};
SetState[g, g.state]};
Check: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
g.process ← Process.GetCurrent[];
{
ENABLE ABORTED => {GOTO out};
IF g.state = $idle OR g.modelSuperseded THEN InternalStartModel[g];
InternalParse[g, TRUE];
InternalCheck[g];
g.process ← NIL;
EXITS
out => {g.ttyout.PutRope["Check aborted\n"]};
};
SetState[g, g.state]};
Compile: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
g.process ← Process.GetCurrent[];
{
ENABLE ABORTED => {GOTO out};
IF g.state = $idle OR g.modelSuperseded THEN InternalStartModel[g];
InternalParse[g, TRUE];
InternalCheck[g];
InternalCompile[g, FALSE];
g.process ← NIL;
EXITS
out => {g.ttyout.PutRope["Compile aborted\n"]};
};
SetState[g, g.state]};
Continue: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
g.process ← Process.GetCurrent[];
{
ENABLE ABORTED => {GOTO out};
IF g.state = $idle OR g.modelSuperseded THEN InternalStartModel[g];
InternalParse[g, TRUE];
InternalCheck[g];
InternalCompile[g, g.replaceable];
InternalLoad[g, g.replaceable];
InternalStart[g];
g.process ← NIL;
EXITS
out => {g.ttyout.PutRope["Continue aborted\n"]};
};
SetState[g, g.state]};
Debug: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
g.ttyout.PutRope["---------------\n"];
IF g.state = $idle THEN {
ENABLE ABORTED => {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.PutRope["\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.ttyout.PutRope["Debug aborted\n"]};
};
g.ttyout.PutRope["---------------\n"]};
Load: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
g.process ← Process.GetCurrent[];
{
ENABLE ABORTED => {GOTO out};
InternalLoad[g, FALSE];
g.process ← NIL;
EXITS
out => {g.ttyout.PutRope["Load aborted\n"]};
};
SetState[g, g.state]};
MakeDFFile: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
g.process ← Process.GetCurrent[];
{
ENABLE ABORTED => {GOTO out};
IF g.state >= $checked THEN {
InternalTemporary[g];
SMDF.WriteDFFile[g.model, g.model.val, g.modelFileName]};
g.process ← NIL;
EXITS
out => {g.ttyout.PutRope["MakeDFFile aborted\n"]};
};
};
MakeModelBcd: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
g.process ← Process.GetCurrent[];
{
ENABLE ABORTED => {GOTO out};
IF g.state >= $checked THEN {
InternalTemporary[g];
SMBcd.WriteModelBcd[g.model, g.model.val, g.modelFileName]};
g.process ← NIL;
EXITS
out => {g.ttyout.PutRope["MakeModelBcd aborted\n"]};
};
};
NewModeller: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
[] ← Create[ViewerTools.GetContents[g.wDirNameViewer]]};
NoticeAll: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
g.process ← Process.GetCurrent[];
{
ENABLE ABORTED => {GOTO out};
InternalNoticeAll[g];
g.process ← NIL;
EXITS
out => {g.ttyout.PutRope["NoticeAll aborted\n"]};
};
};
Open: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
g.process ← Process.GetCurrent[];
{
ENABLE ABORTED => {GOTO out};
OpenViewer[g];
g.process ← NIL;
EXITS
out => {g.ttyout.PutRope["Open aborted\n"]};
};
};
StartModel: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
g.process ← Process.GetCurrent[];
{
ENABLE ABORTED => {GOTO out};
InternalStartModel[g];
InternalParse[g];
g.process ← NIL;
EXITS
out => {g.ttyout.PutRope["StartModelling aborted\n"]};
};
SetState[g, g.state]};
Start: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
g.process ← Process.GetCurrent[];
{
ENABLE ABORTED => {GOTO out};
InternalStart[g];
g.process ← NIL;
EXITS
out => {g.ttyout.PutRope["Start aborted\n"]};
};
SetState[g, g.state]};
StopModel: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
g.process ← Process.GetCurrent[];
{
ENABLE ABORTED => {GOTO out};
InternalStopModel[g];
g.process ← NIL;
EXITS
out => {g.ttyout.PutRope["StopModelling aborted\n"]};
};
SetState[g, $idle]};
Unload: Menus.MenuProc ~ {
g: Global ~ NARROW[clientData];
g.process ← Process.GetCurrent[];
{
ENABLE ABORTED => {GOTO out};
InternalUnload[g, TRUE];
g.process ← NIL;
EXITS
out => {g.ttyout.PutRope["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.PutRope["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.PutRope["Editor detached from this modeller.\n"]};
SaveEvent: ViewerEvents.EventProc ~ {
this is the procedure called by the editor
can't print anything in this procedure
ENABLE ANY => {GOTO out};
IF viewer.file # NIL THEN {
tag: Rope.ROPE ~ CS.ShortName[viewer.file];
IF CS.EndsIn[tag, ".mesa"] THEN -- only source now
FOR l: LIST OF Global ← globalList, l.rest UNTIL l = NIL DO
l.first.noticeList ← CONS[tag.Flatten[], l.first.noticeList];
ENDLOOP
ELSE IF CS.EndsIn[tag, ".model"] THEN
FOR l: LIST OF Global ← globalList, l.rest UNTIL l = NIL DO
IF tag.Equal[l.first.modelFileName, FALSE] THEN l.first.modelSuperseded ← TRUE;
ENDLOOP
};
EXITS
out => NULL;
};
DestroyEvent: ViewerEvents.EventProc ~ {
IF event = $destroy AND globalList # NIL THEN {
g: Global ~ NARROW[ViewerOps.FetchProp[viewer, $SMGlobalRef]];
IF g ~= NIL THEN {
DetachSymbiote[g, FALSE];
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]]];
EXIT};
ENDLOOP;
IF globalList = NIL THEN {
SMFIOps.Reset[]; SMProj.Reset[];
ViewerEvents.UnRegisterEventProc[destroyEventRegistration, $destroy];
destroyEventRegistration ← NIL}
};
};
};
OpenViewer: PROC[g: Global] ~ {
selection: Rope.ROPE ~ ViewerTools.GetSelectionContents[];
index: INT ~ selection.Find[s2~"!"];
name, version: Rope.ROPE;
create: BasicTime.GMT;
{
fName: Rope.ROPE;
IF index = -1 THEN {name ← selection; version ← NIL}
ELSE {
name ← selection.Substr[0, index];
version ← selection.Substr[index+1, selection.Length-index-1]};
IF name.Find[s2~"."] = -1 THEN name ← name.Concat[".model"];
IF SMFIOps.Ambiguous[version] THEN create ← BasicTime.nullGMT
ELSE {
create ← CS.GMTFromRope[version
! UNWIND => NULL;
ANY => {GOTO badSyntax}];
};
fName ← FS.FileInfo[name~name, wantedCreatedTime~create,
wDir~(IF g.model # NIL
THEN g.model.wDir
ELSE ViewerTools.GetContents[g.wDirNameViewer])
! FS.Error => {
IF error.code = $illegalName THEN GOTO badSyntax
ELSE GOTO noFile}].fullFName;
IF SMFIOps.Ambiguous[version] THEN fName ← fName.Substr[0, fName.Find[s2~"!"]];
[] ← TiogaMenuOps.Open[fName];
EXITS
badSyntax => g.ttyout.PutRope["Error - selection is an ill-formed file name\n"];
noFile => g.ttyout.PutF["Error - file %g could not be opened\n", IO.rope[name]];
}
};
InternalStartModel: PROC[g: Global] ~ {
modelFileName: Rope.ROPE;
wDir: Rope.ROPE;
IF g.state ~= $idle THEN InternalStopModel[g];
now set the contents
wDir ← ViewerTools.GetContents[g.wDirNameViewer];
modelFileName ← ViewerTools.GetContents[g.modelFileNameViewer];
IF modelFileName.IsEmpty THEN {
g.ttyout.PutRope["Error - no model source input file\n"];
GOTO failed};
IF ~CS.EndsIn[modelFileName, ".model"] THEN
modelFileName ← modelFileName.Concat[".model"];
g.model ← SMOps.NewModel[g.ttyin, g.ttyout, g.msgout];
(g.model.tm).Initialize;
g.modelFileName ← modelFileName;
g.model.wDir ← wDir;
g.modelUpdated ← g.modelSuperseded ← FALSE;
SetState[g, $unparsed];
ViewerTools.InhibitUserEdits[g.modelFileNameViewer];
ViewerTools.InhibitUserEdits[g.wDirNameViewer];
EXITS
failed => NULL;
};-- file remains open
InternalParse: PROC[g: Global, autoNotice: BOOL←FALSE] ~ {
IF g.state = $unparsed THEN {-- must (re)parse
file: FS.OpenFile ← FS.nullOpenFile;
input: IO.STREAM ← NIL;
file ← FS.Open[name~g.modelFileName, wDir~g.model.wDir
! FS.Error => {
g.ttyout.PutF["Error - file %g could not be opened\n", IO.rope[g.modelFileName]];
GOTO failed}];
input ← file.StreamFromOpenFile[];
g.modelFileVersion ← file.GetInfo[].created;
Labels.SetDisplayStyle[g.stateLabel, $BlackOnGrey];
g.model.tree ← SMUtil.ParseStream[m~g.model, source~input];
input.Close[];
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;
};
Process.CheckForAbort[]};
InternalNoticeAll: PROC[g: Global] ~ {
nChanged: NAT ← 0;
LookForSource: TreeOps.Scan ~ {
WITH t SELECT FROM
node: Tree.Handle =>
IF TreeOps.OpName[node] = $unitId THEN {
tag: Rope.Text ~ ShortName[node];
SELECT TRUE FROM
CS.EndsIn[tag, ".mesa"] =>
IF NoticeSource[g, node, FALSE] THEN nChanged ← nChanged + 1;
CS.EndsIn[tag, ".model"] =>
IF NoticeSource[g, node, FALSE] THEN {
nChanged ← nChanged + 1;
TreeOps.PutExt[node, Tree.null]};-- force reparsing of embedded model
CS.EndsIn[tag, ".bcd"] =>
IF NoticeBcd[g, node] THEN nChanged ← nChanged + 1;
CS.EndsIn[tag, ".modelBcd"] =>
IF NoticeBcd[g, node] THEN {
nChanged ← nChanged + 1;
TreeOps.PutExt[node, Tree.null]};-- force reparsing of embedded model
ENDCASE => NULL;
}
ELSE TreeOps.ScanSons[node, LookForSource];
ENDCASE => NULL;
Process.CheckForAbort[]};
g.ttyout.PutChar['\n];
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).PutRope["\n"]};
IF g.debugLevel <= 3 THEN SMUtil.PrettyPrint[g.model.out, g.model.val, NIL];
IF ~g.model.errors THEN SetState[g, $checked]};
Process.CheckForAbort[]};
InternalCompile: PROC[g: Global, replacement: BOOL] ~ {
IF g.state = $checked THEN {
InternalTemporary[g];
Labels.SetDisplayStyle[g.stateLabel, $BlackOnGrey];
IF ~replacement THEN g.replaceable ← FALSE;
IF SMComp.CompileAll[g.model, g.model.val, replacement].completed THEN
SetState[g, $compiled];
Labels.SetDisplayStyle[g.stateLabel, $BlackOnWhite]};
Process.CheckForAbort[]};
InternalBind: PROC[g: Global] ~ {
IF g.state >= $compiled THEN {
ms: SMOps.MS ~ g.model;
Labels.SetDisplayStyle[g.stateLabel, $BlackOnGrey];
[] ← SMLDriver.Bind[
CS.RootName[g.modelFileName], g.modelFileVersion, ms.val, ms.z, ms.tm, ms.out, ms.wDir];
Labels.SetDisplayStyle[g.stateLabel, $BlackOnWhite]};
Process.CheckForAbort[]};
InternalLoad: PROC[g: Global, replacement: BOOL] ~ {
IF g.state = $compiled THEN {
Labels.SetDisplayStyle[g.stateLabel, $BlackOnGrey];
IF ~(g.model.ls).LoadAndBind[g.model.val, g.model.wDir, replacement].errors THEN {
SetState[g, $loaded]; g.replaceable ← TRUE};
Labels.SetDisplayStyle[g.stateLabel, $BlackOnWhite]};
Process.CheckForAbort[]};
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]};
Process.CheckForAbort[]};
InternalTemporary: PROC[g: Global] ~ {
FoldPatches[g.model];
IF g.modelUpdated THEN {
IF ~g.modelSuperseded THEN {
file: FS.OpenFile ~ FS.Create[name~g.modelFileName, keep~2, wDir~g.model.wDir];
s: IO.STREAM ← file.StreamFromOpenFile[accessRights~$write];
g.modelFileVersion ← file.GetInfo[].created;
SMUtil.PrettyPrint[s, g.model.tree, g.model.comments];
g.ttyout.PutF["new model on %g\n\n", IO.rope[file.GetName[].fullFName]];
s.Close;
g.modelUpdated ← FALSE}
ELSE g.ttyout.PutF["Warning: model was manually edited, new model not written\n\n"]}
};
InternalStopModel: PROC[g: Global] ~ {
IF g.state # $idle THEN {
InternalTemporary[g];
InternalUnload[g, FALSE];
(g.model.tm).Finalize;
g.replaceable ← g.modelSuperseded ← FALSE;
g.model.val ← NIL; g.model ← NIL};
SMFIOps.Reset[]; SMProj.Reset[];--
ViewerTools.EnableUserEdits[g.modelFileNameViewer];
ViewerTools.EnableUserEdits[g.wDirNameViewer];
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];
g.replaceable ← FALSE;
SetState[g, MIN[g.state, $compiled]]};
Process.CheckForAbort[]};
ClearExtensions: PROC[parseTree: Tree.Link] ~ {
only does this for the parse tree
ANode: TreeOps.Scan ~ {
WITH t SELECT FROM
node: Tree.Handle => {
SELECT TreeOps.OpName[node] FROM
$none, $unitId => NULL;
ENDCASE => TreeOps.PutExt[node, Tree.null];
TreeOps.ScanSons[node, ANode]};
ENDCASE => NULL
};
ANode[parseTree]};
ShortName: PROC[unitId: Tree.Link] RETURNS[Rope.Text] ~ {
RETURN [NARROW[TreeOps.NthSon[unitId, 3]]]};
NoticeFile: PROC[g: Global, unitId: Tree.Link, create: BasicTime.GMT]
RETURNS[changed: BOOL] ~ {
version: Rope.Text ~ NARROW[TreeOps.NthSon[unitId, 4]];
oldCreate: BasicTime.GMT ~ (IF SMFIOps.Ambiguous[version]
THEN BasicTime.nullGMT ELSE CS.GMTFromRope[version]);
changed ← (create # BasicTime.nullGMT AND create # oldCreate);
IF changed THEN {
g.ttyout.PutF["Notice %g\n", IO.rope[ShortName[unitId]]];
TreeOps.PutNthSon[unitId, 4, CS.RopeFromGMT[create].Flatten[]]};
RETURN};
NoticeSource: PROC[g: Global, unitId: Tree.Link, new: BOOL] RETURNS[changed: BOOL] ~ {
fName: Rope.ROPE ~ SMFIOps.UnitToRope[unitId];
fiSrc: SMFI.SrcFileInfo ~ SMFIOps.NewestSource[fName, g.model.wDir];
changed ← NoticeFile[g, unitId, fiSrc.create];
IF changed THEN {
TreeOps.PutExt[unitId, fiSrc];
IF new THEN fiSrc.new ← TRUE};
RETURN};
NoticeBcd: PROC[g: Global, unitId: Tree.Link] RETURNS[changed: BOOL] ~ {
fName: Rope.ROPE ~ SMFIOps.UnitToRope[unitId];
RETURN[NoticeFile[g, unitId, SMFIOps.NewestBcd[fName, g.model.wDir].create]]};
SameTag: PROC[unitId: Tree.Link, tag: Rope.Text] RETURNS[BOOL] ~ {
RETURN[
tag.Equal[ShortName[unitId], FALSE] AND
TreeOps.NthSon[unitId, 1] = Tree.null AND TreeOps.NthSon[unitId, 2] = Tree.null]
};
RecordNoticedFiles: PROC[g: Global] RETURNS[noticedFile: BOOL←FALSE] ~ {
maxState: ModelState ← MIN[g.state, $checked];
ms: SMOps.MS ~ g.model;
SameTyped: PROC[oldFile: Tree.Ext, newUnitId: Tree.Link] RETURNS[BOOL] ~ {
IF oldFile = NIL OR maxState < $checked THEN RETURN[FALSE]
ELSE {
oldFi: SMFI.SrcFileInfo ~ NARROW[oldFile];
newFi: SMFI.SrcFileInfo;
[] ← SMFIOps.EvaluateUnitId[ms, newUnitId];
newFi ← NARROW[TreeOps.GetExt[newUnitId]];
RETURN[SMEval.Equiv[ms, oldFi.type, newFi.type]]}
};
LookForSource: TreeOps.Scan ~ {
WITH t SELECT FROM
node: Tree.Handle =>
IF TreeOps.OpName[node] = $unitId THEN
FOR l: LIST OF Rope.Text ← g.noticeList, l.rest UNTIL l = NIL DO
IF SameTag[node, l.first] THEN {
oldExt: Tree.Ext ~ TreeOps.GetExt[node];
IF NoticeSource[g, node, TRUE] THEN {
IF SameTyped[oldExt, node] THEN
ms.patches ← (ms.z).CONS[[old: oldExt, new: TreeOps.GetExt[node]], ms.patches]
ELSE maxState ← $parsed;
noticedFile ← TRUE};
EXIT}-- can ignore multiple entries
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, maxState]];
IF g.state < $checked THEN {-- force reevaluation
g.model.val ← Tree.null; g.model.patches ← NIL};
}
};
FoldPatches: PROC[ms: SMOps.MS] ~ {
IF ms.patches # NIL THEN {
PatchNode: TreeOps.Map ~ {
WITH t SELECT FROM
node: Tree.Handle => {
v ← TreeOps.UpdateLeaves[ms.tm, node, PatchNode];
WITH TreeOps.GetExt[v] SELECT FROM
proj: SMProj.Proj => TreeOps.PutExt[v, Tree.null];
ENDCASE;
};
srcFi: SMFI.SrcFileInfo => {
FOR p: SMOps.PatchList ← ms.patches, p.rest UNTIL p = NIL DO
IF p.first.old = t THEN {v ← p.first.new; EXIT};
REPEAT
FINISHED => v ← t
ENDLOOP
};
ENDCASE => v ← t;
RETURN};
ms.val ← PatchNode[ms.tm, ms.val]; ms.patches ← NIL}
};
SML: Commander.CommandProc ~ {
g: Global;
g ← Create[NARROW[ProcessProps.GetProp[$WorkingDirectory]]];
[] ← SMComp.LoadCompiler[g.msgout]};
module initialization
CS.Init[];
destroyEventRegistration ← ViewerEvents.RegisterEventProc[DestroyEvent, $destroy];
Commander.Register["SML", SML, "Cedar System Modeller"];
}.