<> <> <> <> <> <> <> <> <> <> <> <> <<>> DIRECTORY AMTypes, CedarProcess, Commander, Core, CoreOps, CoreProperties, GList, IO, PrintTV, ProcessProps, RefTab, RefTabExtras, SymTab, Rope, RopeList; CoreOpsImpl: CEDAR PROGRAM IMPORTS CedarProcess, CoreProperties, GList, IO, PrintTV, ProcessProps, RefTab, RefTabExtras, SymTab, Rope, RopeList EXPORTS CoreOps = BEGIN OPEN Core, CoreOps; <> nameProp: PUBLIC ATOM _ CoreProperties.RegisterProperty[$CoreName, CoreProperties.Props[[CoreProperties.propPrint, CoreProperties.PropDontPrint]]]; <> printClassProcProp: ATOM _ CoreProperties.RegisterProperty[$CorePrintClassProc]; SetClassPrintProc: PUBLIC PROC [class: CellClass, proc: PrintClassProc] RETURNS [sameClass: CellClass] = { CoreProperties.PutCellClassProp[on: class, prop: printClassProcProp, value: NEW[PrintClassProc _ proc]]; sameClass _ class; }; <> CreateCellType: PUBLIC PROC [class: CellClass, public: WireSeq, data: REF ANY _ NIL, name: ROPE _ NIL, props: Properties _ NIL] RETURNS [cellType: CellType] = { cellType _ NEW [CellTypeRec _ [class: class, public: public, data: data, properties: props]]; IF name#NIL THEN cellType _ SetCellTypeName[cellType, name]; }; SetCellTypeName: PUBLIC PROC [cellType: CellType, name: ROPE] RETURNS [sameCellType: CellType] = { CoreProperties.PutCellTypeProp[cellType, nameProp, name]; sameCellType _ cellType; }; GetCellTypeName: PUBLIC PROC [cellType: CellType] RETURNS [name: ROPE _ NIL] = { name _ NARROW [CoreProperties.GetCellTypeProp[cellType, nameProp]]; }; InheritCellTypeName: PUBLIC PROC [cellType: CellType] RETURNS [name: ROPE _ NIL] = { DO name _ NARROW [CoreProperties.GetCellTypeProp[cellType, nameProp]]; IF name#NIL OR NOT cellType.class.layersProps THEN EXIT; cellType _ Recast[cellType]; ENDLOOP; }; recastCacheProp: ATOM _ CoreProperties.RegisterProperty[$CoreRecastCache]; Recast: PUBLIC PROC [me: CellType, fillCacheIfEmpty: BOOL _ TRUE] RETURNS [new: CellType] = { new _ NARROW[CoreProperties.GetCellTypeProp[me, recastCacheProp]]; IF new=NIL THEN { IF me.class.recast=NIL THEN ERROR; -- Caller error. No recast proc on this class. Trap it here so that this comment is obvious to a user instead of getting an error window with a control fault in it. new _ me.class.recast[me]; IF new#me AND fillCacheIfEmpty THEN CoreProperties.PutCellTypeProp[me, recastCacheProp, new]; }; }; RecastBindingTable: PUBLIC PROC [cellType: CellType] RETURNS [table: RefTab.Ref] = { table _ NARROW [CoreProperties.GetCellTypeProp[cellType, $CoreRecastBindingTableCache]]; IF table=NIL THEN { recasted: CellType _ Recast[cellType]; IF recasted#cellType THEN { table _ CreateBindingTable[cellType.public, recasted.public]; CoreProperties.PutCellTypeProp[cellType, $CoreRecastBindingTableCache, table]; }; }; }; ToBasic: PUBLIC PROC [cellType: Core.CellType] RETURNS [basic: Core.CellType] = { FOR basic _ cellType, Recast[basic] UNTIL basic.class.recast = NIL DO NULL ENDLOOP; }; PrintCellType: PUBLIC PROC [cellType: CellType, out: STREAM _ NIL, indent: NAT _ 0, level: NAT _ 2] = { classProc: REF PrintClassProc; IF out=NIL THEN out _ NARROW [ProcessProps.GetProp[$CommanderHandle], Commander.Handle].out; IO.PutF[out, "\n\n%g: %g Cell Type", [rope[GetCellTypeName[cellType]]], [rope[cellType.class.name]] ]; IO.PutRope[out, "\nPublic wire:"]; PrintWire[cellType.public, out, indent+1, level]; IF (classProc _ NARROW [CoreProperties.GetProp[from: cellType.class.properties, prop: printClassProcProp]]) # NIL THEN classProc[cellType.data, out, indent, level]; CoreProperties.PrintProperties[props: cellType.properties, out: out, indent: indent, level: level]; }; PrintIndent: PUBLIC PROC [indent: NAT, out: STREAM, cr: BOOL _ TRUE] = { IF cr THEN { IO.PutChar[out, IO.CR]; FOR i: NAT IN [0..indent) DO IO.PutRope[out, " "] ENDLOOP } ELSE IO.PutRope[out, ", "] }; <> CreateWire: PUBLIC PROC [elements: Wires _ NIL, name: ROPE _ NIL, props: Properties _ NIL] RETURNS [wire: Wire] = { size: NAT _ GList.Length[elements]; wire _ CreateWires[size, name, props]; size _ 0; FOR c: Wires _ elements, c.rest UNTIL c=NIL DO wire[size] _ c.first; size _ size + 1; ENDLOOP; }; CreateWires: PUBLIC PROC [size: NAT, name: ROPE _ NIL, props: Properties _ NIL] RETURNS [wire: Wire] = { wire _ NEW [WireRec[size]]; wire.properties _ props; IF name#NIL THEN CoreProperties.PutWireProp[wire, nameProp, name]; }; SubrangeWire: PUBLIC PROC [wire: Wire, start, size: NAT, name: ROPE _ NIL, props: Properties _ NIL] RETURNS [sub: Wire] = { sub _ CreateWires[size, name, props]; FOR i: NAT IN [0 .. size) DO sub[i] _ wire[start+i]; ENDLOOP; }; CopyWire: PUBLIC PROC [wire: Wire] RETURNS [new: Wire] = { new _ IF wire=NIL THEN NIL ELSE CopyWireUsingTable[wire, RefTab.Create[], TRUE]; }; CopyWireUsingTable: PUBLIC PROC [old: Wire, oldToNew: RefTab.Ref, copyName: BOOL _ TRUE] RETURNS [new: Wire] = { new _ NARROW [RefTab.Fetch[oldToNew, old].val]; IF new#NIL THEN RETURN; new _ CreateWires[size: old.size, name: IF copyName THEN GetShortWireName[old] ELSE NIL]; [] _ RefTab.Insert[oldToNew, old, new]; FOR i: NAT IN [0 .. old.size) DO new[i] _ CopyWireUsingTable[old[i], oldToNew, copyName]; ENDLOOP; }; UnionWire: PUBLIC PROC [wire1, wire2: Wire, name: ROPE _ NIL, props: Properties _ NIL] RETURNS [union: Wire] = { union _ CreateWires[size: wire1.size+wire2.size, name: name, props: props]; FOR i: NAT IN [0 .. wire1.size) DO union[i] _ wire1[i] ENDLOOP; FOR i: NAT IN [0 .. wire2.size) DO union[wire1.size+i] _ wire2[i] ENDLOOP; }; <> VisitWire: PUBLIC PROC [wire: Wire, eachWire: EachWireProc] RETURNS [quit: BOOL] = { subWires: BOOL; [subWires, quit] _ eachWire[wire]; IF quit OR NOT subWires THEN RETURN; FOR i: NAT IN [0 .. wire.size) DO IF VisitWire[wire[i], eachWire] THEN RETURN [TRUE]; ENDLOOP; quit _ FALSE; }; VisitWireSeq: PUBLIC PROC [seq: WireSeq, eachWire: EachWireProc] RETURNS [quit: BOOL] = { FOR i: NAT IN [0 .. seq.size) DO IF VisitWire[seq[i], eachWire] THEN RETURN [TRUE]; ENDLOOP; quit _ FALSE; }; VisitRootAtomics: PUBLIC PROC [root: WireSeq, eachWire: PROC [Wire]] = { VisitAtomicWires: PROC [wire: Wire] = { IF wire.size=0 THEN eachWire[wire] ELSE FOR i: NAT IN [0 .. wire.size) DO VisitAtomicWires[wire[i]] ENDLOOP; }; FOR i: NAT IN [0 .. root.size) DO VisitAtomicWires[root[i]] ENDLOOP; }; VisitBinding: PUBLIC PROC [actual, public: Wire, eachWirePair: EachWirePairProc] RETURNS [quit: BOOL] = { subWires: BOOL; IF actual.size#public.size THEN RETURN [TRUE]; -- wires do not conform [subWires, quit] _ eachWirePair[actual, public]; IF quit OR NOT subWires THEN RETURN; FOR i: NAT IN [0 .. actual.size) DO IF VisitBinding[actual[i], public[i], eachWirePair] THEN RETURN [TRUE]; ENDLOOP; quit _ FALSE; }; VisitBindingSeq: PUBLIC PROC [actual, public: WireSeq, eachWirePair: EachWirePairProc] RETURNS [quit: BOOL] = { IF actual.size#public.size THEN RETURN [TRUE]; -- wires do not conform FOR i: NAT IN [0 .. actual.size) DO IF VisitBinding[actual[i], public[i], eachWirePair] THEN RETURN [TRUE]; ENDLOOP; quit _ FALSE; }; CorrespondingActual: PUBLIC PROC [actual, public: WireSeq, subPublic: Wire] RETURNS [subActual: Wire] ~ { <> IF actual.size#public.size THEN RETURN [NIL]; -- non-conform FOR i: NAT IN [0..actual.size) DO subActual _ CorrespondingActualInternal[actual: actual[i], public: public[i], subPublic: subPublic]; IF subActual#NIL THEN RETURN; ENDLOOP; RETURN [NIL]; -- not found anywhere }; CorrespondingActualInternal: PROC [actual, public: Wire, subPublic: Wire] RETURNS [subActual: Wire] ~ { <> IF actual.size#public.size THEN RETURN [NIL]; -- non-conform FOR i: NAT IN [0..actual.size) DO subActual _ CorrespondingActualInternal[actual: actual[i], public: public[i], subPublic: subPublic]; IF subActual#NIL THEN RETURN; ENDLOOP; RETURN [NIL]; -- not found anywhere }; Conform: PUBLIC PROC [actual, public: Wire] RETURNS [BOOL] = { <> IF actual.size#public.size THEN RETURN [FALSE]; -- non conform root FOR i: NAT IN [0..actual.size) DO IF NOT Conform[actual[i], public[i]] THEN RETURN [FALSE]; -- non conform subwire ENDLOOP; RETURN [TRUE]; -- the wires conform }; DAGConform: PROC [actual, public: Wire, p2a: RefTab.Ref] RETURNS [BOOL] ~ { <> found: BOOL; ra: REF ANY; [found, ra] _ RefTab.Fetch[p2a, public]; IF found THEN RETURN [ra=actual]; IF NOT RefTab.Insert[p2a, public, actual] THEN ERROR; -- cannot happen (not found !) IF actual.size#public.size THEN RETURN [FALSE]; -- root failed FOR i: NAT IN [0..actual.size) DO IF NOT DAGConform[actual[i], public[i], p2a] THEN RETURN [FALSE]; -- subwire failed ENDLOOP; RETURN [TRUE]; }; CorrectConform: PUBLIC PROC [actual, public: WireSeq] RETURNS [BOOL] = { <> p2a: RefTab.Ref _ RefTab.Create[]; -- must go public->actual (not reverse !!!) IF actual.size#public.size THEN RETURN [FALSE]; -- non-conform roots FOR i: NAT IN [0..actual.size) DO IF NOT DAGConform[actual[i], public[i], p2a] THEN RETURN [FALSE]; ENDLOOP; RETURN [TRUE]; }; CountBits: PROC [wire: Wire, visitTab: RefTab.Ref] RETURNS [bits: NAT _ 0] = { <> IF RefTab.Fetch[visitTab, wire].found THEN RETURN; -- no new bits here IF NOT RefTab.Insert[visitTab, wire, NIL] THEN ERROR; IF wire.size=0 THEN RETURN [bits: 1]; FOR sub: NAT IN [0..wire.size) DO bits _ bits + CountBits[wire[sub], visitTab]; ENDLOOP; }; WireBits: PUBLIC PROC [wire: Wire] RETURNS [bits: NAT] = { bits _ CountBits[wire, RefTab.Create[]]; }; WireSeqBits: PUBLIC PROC [seq: WireSeq] RETURNS [bits: NAT _ 0] = { visitTab: RefTab.Ref _ RefTab.Create[]; FOR i: NAT IN [0 .. seq.size) DO bits _ bits + CountBits[seq[i], visitTab] ENDLOOP; }; CreateBindingTable: PUBLIC PROC [wire1, wire2: Wire] RETURNS [table: RefTab.Ref] = { AddInTable: EachWirePairProc = {[] _ RefTab.Store[table, actualWire, publicWire]}; table _ RefTab.Create[wire1.size]; [] _ VisitBinding[wire1, wire2, AddInTable]; }; VisitAtomicPairs: PUBLIC PROC [wire1, wire2: Wire, eachPair: PROC [Wire, Wire]] ~ { <> VisitAtomicPairsInternal: PROC [wire1, wire2: Wire] ~ { IF wire1.size#wire2.size THEN ERROR; -- structure mismatch IF wire1.size=0 THEN eachPair[wire1, wire2] ELSE FOR i: NAT IN [0 .. wire1.size) DO VisitAtomicPairsInternal[wire1[i], wire2[i]]; ENDLOOP; }; IF wire1.size#wire2.size THEN ERROR; FOR i: NAT IN [0 .. wire1.size) DO VisitAtomicPairsInternal[wire1[i], wire2[i]] ENDLOOP; }; <> GetShortWireName: PUBLIC PROC [wire: Wire] RETURNS [name: ROPE _ NIL] = { name _ NARROW [CoreProperties.GetWireProp[wire, nameProp]]; }; SetShortWireName: PUBLIC PROC [wire: Wire, name: ROPE] RETURNS [sameWire: Wire] = { CoreProperties.PutWireProp[wire, nameProp, name]; sameWire _ wire; }; GetWireIndex: PUBLIC PROC [wire: Wire, name: ROPE] RETURNS [n: INT _ -1] ~ { FOR i: NAT IN [0..wire.size) DO IF Rope.Equal[name, GetShortWireName[wire[i]]] THEN RETURN [i]; ENDLOOP; }; wireToNamesCacheProp: ATOM _ CoreProperties.RegisterProperty[$CoreWireToNamesCache, CoreProperties.Props[[CoreProperties.propPrint, CoreProperties.PropDontPrint]]]; < list of full names>> nameToWireCacheProp: ATOM _ CoreProperties.RegisterProperty[$CoreNameToWireCache, CoreProperties.Props[[CoreProperties.propPrint, CoreProperties.PropDontPrint]]]; < wire>> FullWireNames: PRIVATE PROC [root: Wire] RETURNS [wireToNames, nameToWire: RefTab.Ref] = { SetName: PUBLIC PROC [wire: Wire, name: ROPE] = { names: LIST OF ROPE _ NARROW [RefTab.Fetch[wireToNames, wire].val]; previousWire: Wire _ NARROW [RefTab.Fetch[nameToWire, name].val]; IF name#NIL AND NOT RopeList.Memb[names, name] THEN { names _ CONS [name, names]; [] _ RefTab.Store[wireToNames, wire, names]; }; IF name#NIL AND ~RefTab.Insert[nameToWire, name, wire] AND previousWire#wire THEN ERROR; -- two different wires have the same name relative to this root FOR i: NAT IN [0 .. wire.size) DO short: ROPE _ GetShortWireName[wire[i]]; SetName[wire[i], SELECT TRUE FROM short=NIL => Index[name, i], name=NIL => short, ENDCASE => Rope.Cat[name, ".", short]]; ENDLOOP; }; wireToNames _ NARROW [CoreProperties.GetWireProp[root, wireToNamesCacheProp]]; nameToWire _ NARROW [CoreProperties.GetWireProp[root, nameToWireCacheProp]]; IF wireToNames#NIL AND nameToWire#NIL THEN RETURN; wireToNames _ RefTab.Create[WireBits[root]]; nameToWire _ RefTab.Create[WireBits[root], RefTabExtras.EqualRope, RefTabExtras.HashRope]; <> SetName[root, GetShortWireName[root]]; CoreProperties.PutWireProp[root, wireToNamesCacheProp, wireToNames]; CoreProperties.PutWireProp[root, nameToWireCacheProp, nameToWire]; }; GetFullWireNames: PUBLIC PROC [root: WireSeq, wire: Wire] RETURNS [names: LIST OF ROPE ] = { names _ NARROW [RefTab.Fetch[FullWireNames[root].wireToNames, wire].val]; }; GetFullWireName: PUBLIC PROC [root: WireSeq, wire: Wire] RETURNS [name: ROPE _ NIL] = { names: LIST OF ROPE _ GetFullWireNames[root, wire]; WHILE names#NIL DO IF name=NIL OR (Rope.Fetch[name]='[ AND Rope.Fetch[names.first]#'[) OR Rope.Length[names.first] { endBracket: INT _ Rope.Find[name, "]"]; IF endBracket=-1 THEN ERROR; -- malformed name components _ CONS [Rope.Substr[name, 1, endBracket-1], components]; name _ Rope.Substr[name, endBracket+1]; }; '. => { endField: INT _ MIN [Rope.Index[name, 1, "."], Rope.Index[name, 1, "["]]; components _ CONS [Rope.Substr[name, 1, endField-1], components]; name _ Rope.Substr[name, endField]; }; ENDCASE => ERROR; -- malformed name ENDLOOP; components _ RopeList.Reverse[components]; }; PrintWire: PUBLIC PROC [wire: Wire, out: STREAM _ NIL, indent: NAT _ 0, level: NAT _ 2] = { name: ROPE _ GetShortWireName[wire]; PrintAWire: PROC [wire: Wire, indent: NAT, level: NAT, name: ROPE, cr, firstWire: BOOL, recur: NAT] = { CedarProcess.CheckAbort[]; PrintIndent[indent, out, cr OR firstWire]; IO.PutRope[out, name]; IF recur=1 AND Rope.Match["[*]", name] THEN out.PutF["(%g^)", IO.int[LOOPHOLE[wire]]]; IF wire.size#0 THEN IO.PutF[out, ", %g elements", IO.int[wire.size]]; CoreProperties.PrintProperties[props: wire.properties, out: out, indent: indent+1, cr: cr, level: level]; IF wire.size#0 AND (level=0 OR AllSimpleAtomics[wire]) THEN IO.PutRope[out, " [...] "] ELSE FOR i: NAT IN [0 .. wire.size) DO subName: ROPE _ GetShortWireName[wire[i]]; IF subName=NIL THEN subName _ Index[NIL, i]; PrintAWire[wire[i], indent+1, level-1, subName, cr AND wire.size<=32, cr AND i=0, recur+1]; ENDLOOP; }; IF out=NIL THEN out _ NARROW[ProcessProps.GetProp[$CommanderHandle], Commander.Handle].out; PrintAWire[wire, indent, level, IF name#NIL THEN name ELSE "", TRUE, TRUE, 0]; }; AllSimpleAtomics: PROC[w: Wire] RETURNS[BOOL] = { FOR ii: NAT IN [0..w.size) DO IF w[ii].size#0 OR HasPrintableProp[w[ii]] THEN RETURN[FALSE]; ENDLOOP; RETURN[TRUE]}; HasPrintableProp: PROC[w: Wire] RETURNS[printable: BOOL _ FALSE] = { Consume: PROC [prop: ATOM, val: REF ANY] = { PP: CoreProperties.PropPrintProc ~ CoreProperties.GetPropPrintProc[prop, val]; IF PP # CoreProperties.PropDontPrint^ THEN {printable _ TRUE; RETURN}; }; IF GetShortWireName[w]#NIL THEN RETURN[TRUE]; CoreProperties.Enumerate[w.properties, Consume]}; FlushNameCaches: PUBLIC PROC [root: WireSeq] = { CoreProperties.PutWireProp[root, wireToNamesCacheProp, NIL]; CoreProperties.PutWireProp[root, nameToWireCacheProp, NIL]; }; <> Reverse: PUBLIC PROC [wires: Wires] RETURNS [revWires: Wires _ NIL] = { revWires _ NARROW [GList.Reverse[wires]]; }; Delete: PUBLIC PROC [wires: Wires, wire: Wire] RETURNS [newWires: Wires _ NIL] = { WHILE wires#NIL DO IF wires.first#wire THEN newWires _ CONS [wires.first, newWires]; wires _ wires.rest; ENDLOOP; }; Member: PUBLIC PROC [wires: Wires, wire: Wire] RETURNS [BOOL] = { RETURN [GList.Member[wire, wires]]; }; ParentWires: PUBLIC PROC [root, candidate: Wire] RETURNS [parents: LIST OF Wire _ NIL] = { FindActual: EachWireProc = { FOR i: NAT IN [0 .. wire.size) DO IF wire[i]=candidate AND NOT Member[parents, wire] THEN parents _ CONS [wire, parents]; ENDLOOP; }; [] _ VisitWire[root, FindActual]; }; RecursiveMember: PUBLIC PROC [wire, candidate: Wire] RETURNS [BOOL] = { IF wire=candidate THEN RETURN [TRUE]; -- found it FOR i: NAT IN [0..wire.size) DO IF RecursiveMember[wire[i], candidate] THEN RETURN [TRUE]; ENDLOOP; RETURN [FALSE]; }; <> brackets: ARRAY [0 .. 32) OF ROPE = [ "[0]", "[1]", "[2]", "[3]", "[4]", "[5]", "[6]", "[7]", "[8]", "[9]", "[10]", "[11]", "[12]", "[13]", "[14]", "[15]", "[16]", "[17]", "[18]", "[19]", "[20]", "[21]", "[22]", "[23]", "[24]", "[25]", "[26]", "[27]", "[28]", "[29]", "[30]", "[31]"]; <> <<>> Index: PUBLIC PROC [rope: ROPE, index: NAT] RETURNS [indexed: ROPE] = { RETURN [IF index<32 THEN Rope.Concat[rope, brackets[index]] -- speed up hack! ELSE Rope.Cat[rope, "[", IO.PutR1[IO.int[index]], "]"] ]; }; FixStupidRef: PUBLIC PROC [ref: REF ANY] RETURNS [rope: ROPE] = { IF ref=NIL THEN RETURN [NIL]; rope _ WITH ref SELECT FROM r: REF TEXT => Rope.FromRefText[r], r: ROPE => r, ENDCASE => ERROR; }; Print: PUBLIC PROC [ref: REF, out: STREAM _ NIL, indent: NAT _ 0, level: NAT _ 2] = { IF out=NIL THEN out _ NARROW [ProcessProps.GetProp[$CommanderHandle], Commander.Handle].out; WITH ref SELECT FROM wire: Wire => PrintWire[wire, out, indent, level]; wires: Wires => WHILE wires#NIL DO PrintWire[wires.first, out, indent, level]; wires _ wires.rest; ENDLOOP; cellType: CellType => PrintCellType[cellType, out, indent, level]; table: SymTab.Ref => { EachItem: SymTab.EachPairAction ~ { <> var: Rope.ROPE = NARROW [key]; tv: AMTypes.TV = NARROW [val]; IO.PutF[out, "%l%g%l : ", IO.rope["b"], IO.rope[var], IO.rope["B"]]; IF tv#NIL THEN PrintTV.Print[tv, out] ELSE IO.PutF[out, "-- Not initialized --"]; IO.PutF[out, "\n"]; }; [] _ SymTab.Pairs[table, EachItem]; }; ENDCASE => IO.PutRope[out, IF ref=NIL THEN "NIL\n" ELSE "*** CoreOps.Print Does not know how to print argument\n"]; }; END.