
    <<CoreOpsImpl.mesa>>
        <<Copyright © 1985 by Xerox Corporation.  All rights reserved.>>
        <<Barth, January 30, 1986 9:38:27 am PST>>
        <<Spreitzer, April 8, 1986 4:34:16 pm PST>>
        <<Bertrand Serlet May 29, 1986 7:37:33 pm PDT>>
        <<Louis Monier May 1, 1986 4:44:41 pm PDT>>
        <<Pradeep Sindhu February 24, 1986 6:48:20 pm PST>>
        <<>>
    DIRECTORY CedarProcess, Commander, Core, CoreOps, CoreProperties, HashTable, IO, ProcessProps, Rope, RopeList;

    CoreOpsImpl: CEDAR PROGRAM
        IMPORTS CedarProcess, CoreProperties, HashTable, IO, ProcessProps, Rope, RopeList
        EXPORTS CoreOps = 
        BEGIN OPEN Core, CoreOps;
<<Property>>
    nameProp: PUBLIC ATOM _ CoreProperties.RegisterProperty[$CoreName, CoreProperties.Props[[CoreProperties.propCopy, 
    CoreProperties.PropDoCopy], [CoreProperties.propPrint, CoreProperties.PropDontPrint]]];
<<Cell Classes>>
    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;
        };

<<Cell Types>>
    CreateCellType: PUBLIC PROC [class: CellClass, public: Wire, 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]];
        };

    recastCacheProp: ATOM _ CoreProperties.RegisterProperty[$CoreRecastCache];
    Recast: PUBLIC RecastProc = {
        value: REF _ CoreProperties.GetCellTypeProp[me, recastCacheProp];
        IF value#NIL THEN RETURN [NARROW[value]];
        new _ me.class.recast[me];
        CoreProperties.PutCellTypeProp[me, recastCacheProp, new];
        };

    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, ", "]
        };
<<Wire Creation>>
    CreateWire: PUBLIC PROC [elements: Wires _ NIL, name: ROPE _ NIL, props: Properties _ NIL] RETURNS [wire: Wire] = {
        size: NAT _ 0;
        FOR c: Wires _ elements, c.rest UNTIL c=NIL DO
            size _ size + 1;
            ENDLOOP;
        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] = {

        Copy: PROC [wire: Wire] RETURNS [new: Wire] = {
            IF (new _ NARROW[HashTable.Fetch[table: visitTab, key: wire].value])=NIL THEN {
            new _ CreateWires[size: wire.size, props: CoreProperties.CopyProps[propList: wire.properties]];
                IF NOT HashTable.Insert[table: visitTab, key: wire, value: new] THEN ERROR;
            FOR i: NAT IN [0 .. wire.size) DO
            new[i] _ Copy[wire[i]];
            ENDLOOP;
            };
        };

        visitTab: HashTable.Table _ HashTable.Create[];  -- Wire to Wire
        new _ IF wire=NIL THEN NIL ELSE Copy[wire];
        };

    UnionWire: PUBLIC PROC [wire1, wire2: Wire, name: ROPE _ NIL, props: Properties _ NIL] RETURNS [union: Wire] = {
        IF wire1 = NIL THEN RETURN [wire2]; -- BS thinks we should get rid of this test one day
        IF wire2 = NIL THEN RETURN [wire1]; -- BS thinks we should get rid of this test one day
        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;
        };

<<Wire Enumeration>>
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;
};

VisitAtomicWires: PUBLIC PROC [wire: Wire, eachWire: PROC [Wire]] = {
IF wire.size=0 
THEN eachWire[wire] 
ELSE FOR i: NAT IN [0 .. wire.size) DO VisitAtomicWires[wire[i], eachWire] 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;
    };

    Conform: PUBLIC PROC [actual, public: Wire] RETURNS [BOOL] = {
        EachWirePair: EachWirePairProc = {};
        RETURN [NOT VisitBinding[actual, public, EachWirePair]];
        };

    WireBits: PUBLIC PROC [wire: Wire] RETURNS [bits: NAT] = {
        visitTab: HashTable.Table _ HashTable.Create[];  -- Wire to ATOM
        CountBits: PROC [wire: Wire] RETURNS [bits: NAT _ 0] = {
            IF NOT HashTable.Fetch[table: visitTab, key: wire].found THEN {
                IF wire.size=0 THEN bits _ 1
                ELSE FOR sub: NAT IN [0..wire.size) DO
                    bits _ bits + CountBits[wire[sub]];
                    ENDLOOP;
                IF NOT HashTable.Insert[table: visitTab, key: wire, value: $Counted] THEN ERROR;
                };
            };
        bits _ CountBits[wire];
        };
<<Wire Naming>>
    GetShortWireName: PUBLIC PROC [wire: Wire] RETURNS [name: ROPE _ NIL] = {
        name _ IF wire=NIL THEN NIL ELSE NARROW [CoreProperties.GetWireProp[wire, nameProp]];
        };

    SetShortWireName: PUBLIC PROC [wire: Wire, name: ROPE] RETURNS [sameWire: Wire] = {
        IF wire#NIL THEN CoreProperties.PutWireProp[wire, nameProp, name];
        sameWire _ wire;
        };

    GetWireIndex: PUBLIC PROC [wire: Wire, name: ROPE] RETURNS [n: INT _ -1] ~ {
        IF wire#NIL THEN 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]]];
        <<Association wire -> list of full names>>

    nameToWireCacheProp: ATOM _ CoreProperties.RegisterProperty[$CoreNameToWireCache, CoreProperties.Props[[CoreProperties.propPrint, 
    CoreProperties.PropDontPrint]]];
        <<Association full name -> wire>>

    FullWireNames: PRIVATE PROC [root: Wire] RETURNS [wireToNames, nameToWire: HashTable.Table] = {
        SetName: PUBLIC PROC [wire: Wire, name: ROPE] = {
            names: LIST OF ROPE _ NARROW [HashTable.Fetch[wireToNames, wire].value];
            previousWire: Wire _ NARROW [HashTable.Fetch[nameToWire, name].value];
            IF name#NIL AND NOT RopeList.Memb[names, name] THEN {
                names _ CONS [name, names]; 
                [] _ HashTable.Store[wireToNames, wire, names];
                };
        IF name#NIL AND ~HashTable.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 => Rope.Cat[name, "[", IO.PutR1[IO.int[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 _ HashTable.Create[WireBits[root]];
        nameToWire _ HashTable.Create[WireBits[root], HashTable.RopeEqual, HashTable.HashRope];
        <<SetName has GetShortWireName[wire] instead of NIL to make full names also work for wires in their own context, as in Sisyph.>>
        SetName[root, GetShortWireName[root]];
    CoreProperties.PutWireProp[root, wireToNamesCacheProp, wireToNames];
    CoreProperties.PutWireProp[root, nameToWireCacheProp, nameToWire];
        };

    GetFullWireNames: PUBLIC PROC [root, wire: Wire] RETURNS [names: LIST OF ROPE ] = {
        names _ NARROW [HashTable.Fetch[FullWireNames[root].wireToNames, wire].value];
        };

    GetFullWireName: PUBLIC PROC [root, wire: Wire] RETURNS [name: ROPE ] = {
        names: LIST OF ROPE _ GetFullWireNames[root, wire];
        IF names=NIL OR names.rest#NIL THEN ERROR; -- one full name only for this wire, please
        name _ names.first;
        };

    IsFullWireName: PUBLIC PROC [root, wire: Wire, name: ROPE] RETURNS [BOOL] = {
        RETURN [RopeList.Memb[GetFullWireNames[root, wire], name]]
        };

    FindWire: PUBLIC PROC [root: Wire, name: ROPE] RETURNS [wire: Wire _ NIL] = {
        wire _ NARROW [HashTable.Fetch[FullWireNames[root].nameToWire, name].value];
        };

ParseWireName: PUBLIC PROC [name: ROPE] RETURNS [base: ROPE, components: LIST OF ROPE _ NIL] = {
endBase: INT _ MIN [Rope.Index[name, 0, "."], Rope.Index[name, 0, "["]];
base _ Rope.Substr[name, 0, endBase];
name _ Rope.Substr[name, endBase];
WHILE Rope.Length[name]#0 DO
SELECT Rope.Fetch[name] FROM
'[        => {
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] = {
            CedarProcess.CheckAbort[];
            PrintIndent[indent, out, cr OR firstWire];
            IO.PutRope[out, name];
            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 level=0 AND wire.size#0 THEN IO.PutRope[out, " [...] "] ELSE FOR i: NAT IN [0 .. wire.size) DO
                subName: ROPE _ GetShortWireName[wire[i]];
                IF subName=NIL THEN subName _ IO.PutFR["[%g]", IO.int[i]];
                PrintAWire[wire[i], indent+1, level-1, subName, cr AND wire.size<=32, cr AND i=0];
                ENDLOOP;
            };

        IF out=NIL THEN out _ NARROW[ProcessProps.GetProp[$CommanderHandle], Commander.Handle].out;
        PrintAWire[wire, indent, level, IF name#NIL THEN name ELSE "<no name>", TRUE, TRUE];
        };

    FlushNameCaches: PUBLIC PROC [root: Wire] = {
    CoreProperties.PutWireProp[root, wireToNamesCacheProp, NIL];
    CoreProperties.PutWireProp[root, nameToWireCacheProp, NIL];
        };
<<Wire List Operations>>
    Reverse: PUBLIC PROC [wires: Wires] RETURNS [revWires: Wires _ NIL] = {
    WHILE wires#NIL DO revWires _ CONS [wires.first, revWires]; wires _ wires.rest ENDLOOP;
    };

    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] = {
WHILE wires#NIL DO IF wires.first=wire THEN RETURN [TRUE]; wires _ wires.rest ENDLOOP;
RETURN [FALSE];
};

RecursiveMember: PUBLIC PROC [wire, candidate: Wire] RETURNS [BOOL] = {
    FindActual: EachWireProc = {quit _ wire=candidate};
    RETURN [VisitWire[wire, FindActual]];
};
<<Miscellaneous>>
    FixStupidRef: PUBLIC PROC [ref: REF ANY] RETURNS [rope: ROPE] = {
        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] = {
        WITH ref SELECT FROM
            wire: Wire        => PrintWire[wire, out, indent, level];
            cellType: CellType    => PrintCellType[cellType, out, indent, level];
            ENDCASE        => {
                IF out=NIL THEN out _ NARROW [ProcessProps.GetProp[$CommanderHandle], Commander.Handle].out;
                IO.PutRope[out, "*** CoreOps.Print Does not know how to print argument"];
                };
        };

    END.