SiroccoBase1Impl.Mesa
Copyright Ó 1986, 1987 by Xerox Corporation. All rights reserved.
Bhargava, August 9, 1986 2:56:46 pm PDT
Demers, December 29, 1986 9:48:13 pm PST
Bill Jackson (bj) August 25, 1987 6:46:38 pm PDT
DIRECTORY
Convert USING [ CardFromRope, IntFromRope ],
FS USING [ StreamOpen ],
IO USING [ card, int, rope, BreakProc, CharClass, Close, GetTokenRope, PutF, PutFR, STREAM ],
PriorityQueue USING [ Create, SortPred ],
Rope USING [ ROPE, Cat, Concat, Equal, IsEmpty, Length, Substr ],
RopeList USING [ Cons, Map ],
SiroccoBaseDef USING [ MkCType, SendError ],
SiroccoCGDef USING [ Generic, ItemKind, ValueKind ],
SymTab USING [ Copy, Create, EachPairAction, Fetch, GetSize, Insert, Key, Pairs, Ref ],
SiroccoPrivate USING [ AbstractValue, AbstractValueObject, AquireState, CComponent, CComponentBody, CONTEXT, ContextRep, CType, CTypeBody, Handle, InterfaceItem, ITEM, NodeRep, PQItem, RIB, SCOPE, ScopeRep, TABLES, TablesBody, TypeGraph, TypeGraphNode ];
SiroccoBase1Impl: CEDAR PROGRAM
IMPORTS Convert, FS, IO, PriorityQueue, Rope, RopeList, SymTab, SiroccoBaseDef, SiroccoPrivate
EXPORTS SiroccoBaseDef, SiroccoPrivate ~ {
OPEN SiroccoBaseDef, SiroccoCGDef, SiroccoPrivate;
ROPE: TYPE ~ Rope.ROPE;
PQFirst: PUBLIC PriorityQueue.SortPred ~ {
one: REF PQItem ~ NARROW[x];
two: REF PQItem ~ NARROW[y];
RETURN[( one.position < two.position )];
};
Scopes, Ribs & Contexts
UpdateItem: PUBLIC PROC [ left: TypeGraph, name: ROPE, node: TypeGraphNode,
value: AbstractValue ] RETURNS [ new: TypeGraph ] ~ {
item: ITEM ~ ItemFromContext[left.context, name];
itemtype: REF NodeRep ~ NARROW[item.type];
itemvalue: REF AbstractValueObject ~ NARROW[item.value];
SELECT TRUE FROM
item.type = NIL => { ERROR };
item.value = NIL => { ERROR };
itemtype.specifics # NIL => { ERROR };
itemvalue.specifics # NIL => { ERROR };
ENDCASE => { NULL };
itemtype.specifics ← node;
itemvalue.specifics ← value;
new ← left;
};
Context
CreateContext: PUBLIC PROC [rib: RIB, scope: SCOPE, name: ROPE, pgm: CARD,
version: CARD] RETURNS [context: CONTEXT] ~ {
scope.id ← name;
scope.pgm ← pgm;
scope.version ← version;
context ← NEW [ContextRep ←
[ rib: rib, scope: scope ]];
};
ItemFromContext: PUBLIC PROC [context: CONTEXT, name: ROPE]
RETURNS [item: ITEM] ~ {
item ← ItemFromScope[context.scope, name];
};
Scope
EmptyScope: PUBLIC PROC [] RETURNS [new: SCOPE] ~ {
id: ROPE ~ "<program>";
pgm: CARD ~ 0;
version: CARD ~ 0;
items: SymTab.Ref ~ SymTab.Create[];
tables: TABLES ~ NIL;
new ← NEW [ScopeRep ←
[ id: id, pgm: pgm, version: version, items: items, tables: tables ]];
};
ItemConcat: PUBLIC PROC [old: SCOPE, item: ITEM] RETURNS [new: SCOPE] ~ {
IF ( NOT SymTab.Insert[old.items, item.name, item] ) THEN ERROR;
new ← old;
};
ItemFromScope: PUBLIC PROC [scope: SCOPE, name: ROPE] RETURNS [item: ITEM] ~ {
WITH SymTab.Fetch[scope.items, name].val SELECT FROM
i: ITEM => item ← i;
ENDCASE => ERROR;
};
Ribs
EmptyRIB: PUBLIC PROC [] RETURNS [new: RIB] ~ {
new ← SymTab.Create[];
};
ScopeConcat: PUBLIC PROC [old: RIB, scope: SCOPE] RETURNS [new: RIB] ~ {
IF ( NOT SymTab.Insert[old, scope.id, scope] ) THEN ERROR;
new ← old;
};
ScopeFromRIB: PUBLIC PROC [rib: RIB, name: ROPE] RETURNS [scope: SCOPE] ~ {
scope ← NIL;
};
Interface/Item procedures
ImportItem: PUBLIC PROC [t: TABLES, interface, item: SymTab.Key]
RETURNS [entry: InterfaceItem] ~ {
entry ← ItemFromInterface[InterfaceFromName[t, interface], item];
};
TypeNameForItem: PUBLIC PROC [entry: InterfaceItem]
RETURNS [type: ROPE] ~ {
type ← entry.type;
};
ConstantForItem: PUBLIC PROC [entry: InterfaceItem]
RETURNS [constant: ROPE] ~ {
constant ← entry.constant;
};
ValueFromName: PUBLIC PROC [constant: ROPE]
RETURNS [value: CARD] ~ {
value ← Convert.CardFromRope[constant];
};
"Fetch" procedures
FetchFromTypeTable: PUBLIC PROC [t1: TABLES, key: ROPE] RETURNS [value: CType] ~ {
value ← CTypeFromName[t1, key]; -- just change the name in the ThreeC4 code!
};
CTypeFromName: PROC [tables: TABLES, type: ROPE]
RETURNS [ctype: CType] ~ {
WITH SymTab.Fetch[tables.typeTable, type].val SELECT FROM
ct: CType => ctype ← ct;
ENDCASE => ERROR;
};
ItemFromInterface: PROC [x: SymTab.Ref, name: SymTab.Key]
RETURNS [item: InterfaceItem] ~ {
WITH SymTab.Fetch[x, name].val SELECT FROM
entry: REF InterfaceItem => item ← entry^;
ENDCASE => [] ← SendError["Undeclared Remote Identifier"];
};
InterfaceFromName: PROC [t: TABLES, name: SymTab.Key]
RETURNS [s: SymTab.Ref] ~ {
WITH SymTab.Fetch[t.globalTable, name].val SELECT FROM
symtab: SymTab.Ref => s ← symtab;
ENDCASE => ERROR;
};
"Check" procedures
Array: PUBLIC PROC [constantType: ROPE, tables: TABLES] RETURNS [yes: BOOLEAN] ~ {
ctype: CType ~ CTypeFromName[tables, constantType];
yes ← ( ctype.class = array );
};
CheckCanonicalType: PUBLIC PROC [r1, r2: ROPE] RETURNS [same: BOOLEAN] ~ {
IF ( NOT (same ← Rope.Equal[r1, r2]) )
THEN [] ← SendError[Rope.Cat["Type Mismatch Expected ", r2, " found ", r1]];
};
CheckResultsForSourceAndSink: PUBLIC PROC [results: CComponent]
RETURNS [ok: BOOLEAN] ~ {
ok ← TRUE;
FOR tail: CComponent ← results, tail.sibling WHILE ( tail # NIL ) DO
IF ( ( Rope.Equal[tail.type, "SOURCE"] ) OR ( Rope.Equal[tail.type, "SINK"] ) ) THEN {
[] ← SendError["Result Has Source or Sink"];
ok ← FALSE;
EXIT;
};
ENDLOOP;
};
xxxx
ClassToRope: PROC [class: Generic] RETURNS [rope: ROPE] ~ {
SELECT class FROM
array => rope ← "ARRAY";
bool => rope ← "BOOLEAN";
card16 => rope ← "CARDINAL";
card32 => rope ← "LONGCARDINAL";
choice => rope ← "CHOICE";
enum => rope ← "ENUMERATION";
error => rope ← "ERROR";
int16 => rope ← "INTEGER";
int32 => rope ← "LONGINTEGER";
proc => rope ← "PROCEDURE";
record => rope ← "RECORD";
seq => rope ← "SEQUENCE";
sink => rope ← "SINK";
source => rope ← "SOURCE";
string => rope ← "STRING";
unspec => rope ← "UNSPECIFIED";
ENDCASE => ERROR;
};
RopeToClass: PROC [rope: ROPE] RETURNS [class: Generic] ~ {
SELECT TRUE FROM
Rope.Equal[rope, "ARRAY"] => class ← array;
Rope.Equal[rope, "BOOLEAN"] => class ← bool;
Rope.Equal[rope, "CARDINAL"] => class ← card16;
Rope.Equal[rope, "CHOICE"] => class ← choice;
Rope.Equal[rope, "ENUMERATION"] => class ← enum;
Rope.Equal[rope, "ERROR"] => class ← error;
Rope.Equal[rope, "INTEGER"] => class ← int16;
Rope.Equal[rope, "LONGCARDINAL"] => class ← card32;
Rope.Equal[rope, "LONGINTEGER"] => class ← int32;
Rope.Equal[rope, "PROCEDURE"] => class ← proc;
Rope.Equal[rope, "RECORD"]=> class ← record;
Rope.Equal[rope, "SEQUENCE"] => class ← seq;
Rope.Equal[rope, "SINK"] => class ← sink;
Rope.Equal[rope, "SOURCE"] => class ← source;
Rope.Equal[rope, "STRING"] => class ← string;
Rope.Equal[rope, "UNSPECIFIED"] => class ← unspec;
ENDCASE => ERROR;
};
MkPrimitiveCType: PUBLIC PROC [g: Generic] RETURNS [ctype: CType, name: ROPE] ~ {
name ← ClassToRope[g];
ctype ← NEW[CTypeBody ← [bound: 0, children: NIL, class: g]];
};
CompareTypes: PUBLIC PROC [first: CType, second: CType, tables: TABLES]
RETURNS [INT ← 1] ~ {
Mismatch: PROC ~ {
[] ← SendError["Type Mismatch"];
};
CompareCComponents: PROC [first: CComponent, second: CComponent] ~ {
SELECT TRUE FROM
( ( first = NIL ) AND ( second = NIL ) ) => RETURN;
( first = NIL ) => Mismatch[];
( second = NIL ) => Mismatch[];
( NOT Rope.Equal[first.name, second.name] ) => Mismatch[];
( first.val # second.val ) => Mismatch[];
( NOT Rope.Equal[first.type, second.type] ) => {
one: CType ~ CTypeFromName[tables, first.type];
two: CType ~ CTypeFromName[tables, second.type];
[] ← CompareTypes[one, two, tables];
};
ENDCASE => NULL;
CompareCComponents[first.sibling, second.sibling];
};
Check on status of unspecified
SELECT first.class FROM
enum, record, choice => { NULL }; -- Comparison of names already done
bool, card16, card32, int16, int32, string, unspec => {
IF ( first.class # second.class ) THEN Mismatch[];
};
array, seq => {
IF ( first.class = second.class ) AND ( first.bound = second.bound )
THEN {
CompareCComponents[first.children, second.children];
IF ( GetLengthOfCComponentList[first.children, first.bound] # 0 ) THEN ERROR;
}
};
proc, error => {
IF ( second.class # card16 )
THEN {
IF ( first.class # second.class ) OR ( first.bound # second.bound )
THEN Mismatch[]
ELSE CompareCComponents[first.children, second.children];
};
};
ENDCASE => { Mismatch[] };
};
TypeOfSequence: PUBLIC PROC [sequenceName: ROPE, tables: TABLES]
RETURNS [typeOf: ROPE] ~ {
ctype: CType ~ CTypeFromName[tables, sequenceName];
typeOf ← ctype.children.type;
};
GetTypeOfComponent: PUBLIC PROC [id: ROPE, name: ROPE, tables: TABLES]
RETURNS [typeOf: ROPE] ~ {
ctype: CType ~ CTypeFromName[tables, name];
FOR tail: CComponent ← ctype.children, tail.sibling WHILE ( tail # NIL ) DO
IF ( Rope.Equal[tail.name, id] ) THEN { typeOf ← tail.type; RETURN };
ENDLOOP;
ERROR;
};
GetCType: PUBLIC PROC [id: ROPE, list: CComponent, tables: TABLES]
RETURNS [type: CType, name: ROPE] ~ {
FOR tail: CComponent ← list, tail.sibling WHILE ( tail # NIL ) DO
IF ( Rope.Equal[id, tail.name] ) THEN {
RETURN[CTypeFromName[tables, tail.name], tail.type];
}
ENDLOOP;
[] ← SendError["Type Mismatch"];
};
GetTypeOfElement: PUBLIC PROC [name: ROPE, tables: TABLES]
RETURNS [typeOf: ROPE] ~ {
ctype: CType ~ CTypeFromName[tables, name];
list: CComponent ~ ctype.children;
IF ( list = NIL ) THEN ERROR;
typeOf ← list.type;
};
GetLengthOfCComponentList: PUBLIC PROC [list: CComponent, initial: INT]
RETURNS [final: INT] ~ {
FOR tail: CComponent ← list, tail.sibling WHILE ( tail # NIL ) DO
initial ← initial.PRED;
ENDLOOP;
final ← (0 - initial);
IF ( final >= 0 )
THEN {
final ← (0 - initial);
RETURN;
}
ELSE [] ← SendError["Type Mismatch"]; -- Incorrect Length
};
SeeIfArrOrSeq: PUBLIC PROC [first: CType, size: CARD, tables: TABLES]
RETURNS [type: CType, name: ROPE] ~ {
SELECT TRUE FROM
( first.class = array ) => {
IF ( first.bound # size )
THEN [] ← SendError["Wrong number of elements in array constant"];
};
( first.class = seq ) => {
IF ( size > first.bound )
THEN [] ← SendError["Too many elements in sequence constant"];
};
ENDCASE => [] ← SendError["Type Mismatch"];
type ← CTypeFromName[tables, first.children.type];
name ← first.children.type;
};
xxxx
Merge: PROC [t1, t2: SymTab.Ref] RETURNS [new: SymTab.Ref] ~ {
EachPair: SymTab.EachPairAction ~ {
IF ( NOT SymTab.Insert[new, key, val] ) THEN ERROR;
};
big, small: SymTab.Ref;
IF ( SymTab.GetSize[t1] > SymTab.GetSize[t2] )
THEN { big ← t1; small ← t2 }
ELSE { big ← t2; small ← t1 };
new ← SymTab.Copy[big];
IF ( SymTab.Pairs[small, EachPair] ) THEN ERROR;
};
DiskToTable: PUBLIC PROC [id: ROPE, pgm, version: CARD] RETURNS [scope: SCOPE] ~ {
ProgramFile: PROC RETURNS [name: ROPE] ~ {
name ← IO.PutFR["%gP%gV%g",
IO.rope[id],
IO.card[pgm],
IO.card[version]
];
};
info: REF InterfaceItem;
keyRope: ROPE;
sibling: CComponent;
fname: ROPE ~ Rope.Concat[ProgramFile[], ".Tables"];
sourceStream: IO.STREAM ← FS.StreamOpen[fname];
successful: BOOLEAN;
table: SymTab.Ref ← SymTab.Create[];
token: ROPE;
type: CType;
NextToken: PROC RETURNS [text: ROPE] ~ {
charsSkipped: INT;
[text, charsSkipped] ← IO.GetTokenRope[sourceStream, Control];
};
Control: IO.BreakProc ~ {
SELECT char FROM
'\r, '| => RETURN[sepr];
ENDCASE => RETURN[other];
};
Normalize: PROC [arg: ROPE] RETURNS [res: ROPE] ~ {
length: INT ~ Rope.Length[arg];
res ← IF (length > 1)
THEN Rope.Substr[arg, 0, length.PRED]
ELSE "";
};
TokenToInt: PROC [arg: ROPE] RETURNS [res: INT] ~ {
length: INT ~ Rope.Length[arg];
res ← IF (length > 1)
THEN Convert.IntFromRope[Rope.Substr[arg, 0, length.PRED]]
ELSE 0;
};
scope ← NEW [ScopeRep ← [id, pgm, version, NIL, CreateTables[]]];
[] ← SymTab.Insert[scope.tables.directory, id, ProgramFile[]];
token ← NextToken[]; -- Skip Heading
keyRope ← token ← NextToken[]; -- Get First Key
WHILE ( NOT Rope.Equal[keyRope, "TypeTables"] ) DO -- While Local Table is not exhausted
info ← NEW[InterfaceItem];
info.type ← token ← NextToken[];
info.constant ← Normalize[token ← NextToken[]];
token ← NextToken[]; -- Throw away Function Header
token ← NextToken[];
WHILE ( NOT Rope.Equal[token, "~~~~~"] ) DO
info.functions ← RopeList.Cons[info.functions, token];
token ← NextToken[];
ENDLOOP;
info.value ← NIL;
successful ← SymTab.Insert[table, keyRope, info];
keyRope ← token ← NextToken[];
ENDLOOP;
[] ← SymTab.Insert[scope.tables.globalTable, id, table]; -- Local Tables over
token ← NextToken[]; -- Skip Type Heading
keyRope ← token ← NextToken[]; -- Get First Type Name
WHILE ( NOT Rope.Equal[keyRope, "."] ) DO -- Process Type Table
type ← NEW[CTypeBody]; -- Allocate CType
type.class ← RopeToClass[token ← NextToken[]]; -- Get Class
type.bound ← Convert.CardFromRope[token ← NextToken[]]; -- Get bound
token ← NextToken[];
IF ( NOT Rope.Equal[token, "TYPE"] ) THEN { -- Are there any children
sibling ← NEW[CComponentBody];
type.children ← sibling --First Child
};
WHILE ( NOT Rope.Equal[token, "TYPE"] ) DO
sibling.name ← Normalize[token];
sibling.val ← TokenToInt[token ← NextToken[]];
sibling.type ← Normalize[token ← NextToken[]];
token ← NextToken[];
IF ( NOT Rope.Equal[token, "TYPE"] ) THEN {
sibling.sibling ← NEW[CComponentBody]; --Rest Of the Children
sibling ← sibling.sibling;
}
ENDLOOP;
[] ← SymTab.Insert[scope.tables.typeTable, keyRope, type]; -- Enter Type
keyRope ← token ← NextToken[]; -- Get Next Type Name
ENDLOOP;
token ← NextToken[]; --Skip Header
keyRope ← token ← NextToken[];
WHILE ( NOT Rope.Equal[keyRope, "."] ) DO
token ← NextToken[];
[] ← SymTab.Insert[scope.tables.functionTable, keyRope, token];
keyRope ← token ← NextToken[];
ENDLOOP;
};
TableMerge: PUBLIC PROC [t1, t2: TABLES] RETURNS [new: TABLES] ~ {
new ← t1;
new.unresolvedConstantTable ← Merge[t1.unresolvedConstantTable, t2.unresolvedConstantTable];
new.unresolvedTypeTable ← Merge[t1.unresolvedTypeTable, t2.unresolvedTypeTable];
};
Junk
Collapse: PUBLIC PROC ~ {
failure: BOOLEAN;
outStream: IO.STREAM;
tables: TABLES;
h: SiroccoPrivate.Handle;
AddUsedTypes: SymTab.EachPairAction ~ {
usedTable: SymTab.Ref ~ tables.condensedTypeTable;
TraverseCtype: PUBLIC PROC [type: CType] ~ {
FOR list: CComponent ← type.children, list.sibling WHILE (list # NIL) DO
IF ( NOT Rope.IsEmpty[list.type] ) THEN {
ctype: CType ~ CTypeFromName[tables, list.type];
IF ( SymTab.Insert[usedTable, list.type, ctype] ) THEN TraverseCtype[ctype];
};
ENDLOOP;
};
entry: REF InterfaceItem ~ NARROW[val];
ctype: CType ~ CTypeFromName[tables, entry.type];
IF ( NOT SymTab.Insert[usedTable, entry.type, ctype] ) THEN RETURN[FALSE];
TraverseCtype[ctype];
};
WriteOutLocalTableEntry: SymTab.EachPairAction ~ {
keyRope: ROPE ← NARROW[key];
entry: REF InterfaceItem ← NARROW[val];
FuctionsToDisk: PROC[name: ROPE] ~ {
IO.PutF[outStream, "%g|",
IO.rope[name]
];
};
IO.PutF[outStream, "|%g|%g|%g |\nFunctions|",
IO.rope[keyRope],
IO.rope[entry.type],
IO.rope[entry.constant]
];
RopeList.Map[entry.functions, FuctionsToDisk];
IO.PutF[outStream, "~~~~~\n"]
};
WriteOutTypeTableEntry: SymTab.EachPairAction ~ {
type: CType ← NARROW[val];
keyRope: ROPE ← NARROW[key];
list: CComponent ← type.children;
IO.PutF[outStream, "TYPE|%g|%g|%g|\n",
IO.rope[keyRope],
IO.rope[ClassToRope[type.class]],
IO.card[type.bound]
];
WHILE ( list # NIL ) DO
IO.PutF[outStream, "%g |%g |%g |\n",
IO.rope[list.name],
IO.int[list.val],
IO.rope[list.type]
];
list ← list.sibling;
ENDLOOP;
};
WriteOutFunctionTableEntry: SymTab.EachPairAction ~ {
IO.PutF[outStream, "%g|%g\n",
IO.rope[NARROW[key]],
IO.rope[NARROW[val]]
]
};
h ← SIGNAL SiroccoPrivate.AquireState;
tables ← h.allTheTables;
failure ← SymTab.Pairs[tables.localTable, AddUsedTypes];
outStream ← FS.StreamOpen[Rope.Concat[h.programKey,"Tables"], $create];
IO.PutF[outStream, "LocalTables\n"];
failure ← SymTab.Pairs[tables.localTable, WriteOutLocalTableEntry];
IO.PutF[outStream, "\nTypeTables\n"];
failure ← SymTab.Pairs[tables.condensedTypeTable, WriteOutTypeTableEntry];
IO.PutF[outStream, "\nTYPE|.\n"];
IO.PutF[outStream, "\nFunctions\n"];
failure ← SymTab.Pairs[tables.functionTable, WriteOutFunctionTableEntry];
IO.PutF[outStream, "\n.\n"];
IO.Close[outStream];
};
CreateTables: PUBLIC PROC RETURNS [t: TABLES] ~ {
h: SiroccoPrivate.Handle ~ SIGNAL SiroccoPrivate.AquireState;
InsertValue: PROC [key: ROPE, type: Generic] RETURNS [ok: BOOLEAN] ~ {
ok ← SymTab.Insert[h.allTheTables.typeTable, key, MkCType[type, 0, NIL]]
};
h.allTheTables ← NEW [TablesBody];
h.allTheTables.condensedFunctionTable ← SymTab.Create[]; XXXX
h.allTheTables.condensedTypeTable ← SymTab.Create[];
h.allTheTables.directory ← SymTab.Create[];
h.allTheTables.errors ← SymTab.Create[];
h.allTheTables.functionTable ← SymTab.Create[];
h.allTheTables.globalTable ← SymTab.Create[];
h.allTheTables.index ← PriorityQueue.Create[PQFirst]; -- just plain vanilla, please!
h.allTheTables.localTable ← SymTab.Create[];
h.allTheTables.procedures ← SymTab.Create[];
h.allTheTables.typeTable ← SymTab.Create[];
h.allTheTables.unresolvedConstantTable ← SymTab.Create[];
h.allTheTables.unresolvedTypeTable ← SymTab.Create[];
h.allTheTables.workTable ← SymTab.Create[];
Put Predefined Values: integer, boolean, etc. into the table
IF ( NOT InsertValue["BOOLEAN", bool] ) THEN ERROR;
IF ( NOT InsertValue["CARDINAL", card16] ) THEN ERROR;
IF ( NOT InsertValue["LONGCARDINAL", card32] ) THEN ERROR;
IF ( NOT InsertValue["INTEGER", int16] ) THEN ERROR;
IF ( NOT InsertValue["LONGINTEGER", int32] ) THEN ERROR;
IF ( NOT InsertValue["STRING", string] ) THEN ERROR;
IF ( NOT InsertValue["SOURCE", source] ) THEN ERROR;
IF ( NOT InsertValue["SINK", sink] ) THEN ERROR;
IF ( NOT InsertValue["UNSPECIFIED", unspec] ) THEN ERROR;
RETURN[h.allTheTables];
};
}.