
    <<CoreFlattenImpl.mesa>>
        <<Copyright © 1985 by Xerox Corporation.  All rights reserved.>>
        <<Spreitzer, August 15, 1985 8:09:21 pm PDT>>

    DIRECTORY Atom, Convert, Core, CoreFlatten, CoreOps, CoreProperties, CoreRecordCellClass, Process, Rope;

    CoreFlattenImpl: CEDAR MONITOR
        IMPORTS CoreOps, CoreProperties, CoreRecordCellClass, Process
        EXPORTS CoreFlatten
        <<INVARIANT>>
            <<Sym.inUse describes whether some process is using that Sym.>>
        =

    BEGIN OPEN Core, CoreRecordCellClass, CoreFlatten;
<<Introduction>>
    <<This interface implements a utility for flattening the data structure defined in Core.>>
<<Flat Core>>
    instantiationPath: PUBLIC ATOM _ $CoreFlatInstantiationPath;
    wireSource: PUBLIC ATOM _ $CoreFlatWireSource;

    InstantiationPath: TYPE = REF InstantiationPathRep;
    InstantiationPathRep: PUBLIC TYPE = RECORD [
        head: InstanceList,
            <<deeper earlier>>
        tail: InstanceList
            <<points to the last CONS cell in the list>>
        ];

    easyExhibitDirection: InstantiationPathDirection _ shallower;

    IsEmpty: PUBLIC PROC [ip: InstantiationPath] RETURNS [BOOL] =
        {RETURN [ip.head = NIL]};

    Split: PUBLIC PROC [ip: InstantiationPath, end: InstantiationPathDirection] RETURNS [step: Instance, rest: InstantiationPath] = {
        SELECT end FROM
            deeper => RETURN [
                ip.head.first,
                NEW [InstantiationPathRep _ [
                    head: ip.head.rest,
                    tail: IF ip.head.rest = NIL THEN NIL ELSE ip.tail
                    ]]
                ];
            shallower => {
                rest: InstantiationPath _ NEW [InstantiationPathRep _ [NIL, NIL]];
                FOR il: InstanceList _ ip.head, il.rest WHILE il # ip.tail DO
                    rest _ IPAdd[rest, il.first, shallower, TRUE];
                    ENDLOOP;
                RETURN [ip.tail.first, rest];
                };
            ENDCASE => ERROR;
        };

    Exhibit: PUBLIC PROC [ip: InstantiationPath, later: InstantiationPathDirection, to: PROC [step: Instance]] = {
        WorkD: PROC [il: InstanceList] = {
            IF il # NIL THEN {WorkD[il.rest]; to[il.first]};
            };
        SELECT later FROM
            shallower => {
                IF ip.tail # NIL THEN FOR il: InstanceList _ ip.head, il.rest WHILE il # ip.tail.rest DO
                    to[il.first];
                    ENDLOOP;
                ip _ ip;
                };
            deeper => WorkD[ip.head];
            ENDCASE => ERROR;
        };

    IPAdd: PROC [ip: InstantiationPath, step: Instance, end: InstantiationPathDirection, destructively: BOOL] RETURNS [longer: 
    InstantiationPath] = {
        longer _ ip;
        SELECT destructively FROM
            FALSE => SELECT end FROM
                shallower => {
                    longer _ IPCopy[ip];
                    longer _ IPAdd[longer, step, shallower, TRUE];
                    };
                deeper => {
                    longer _ NEW [InstantiationPathRep _ ip^];
                    longer.head _ CONS[step, longer.head];
                    IF longer.tail = NIL THEN longer.tail _ longer.head;
                    };
                ENDCASE => ERROR;
            TRUE => SELECT end FROM
                shallower => {
                    this: InstanceList _ LIST[step];
                    IF longer.tail # NIL THEN longer.tail.rest _ this ELSE longer.head _ this;
                    longer.tail _ this;
                    };
                deeper => {
                    longer.head _ CONS[step, longer.head];
                    IF longer.tail = NIL THEN longer.tail _ longer.head;
                    };
                ENDCASE => ERROR;
            ENDCASE => ERROR;
        };

    IPCopy: PROC [ip: InstantiationPath] RETURNS [copy: InstantiationPath] = {
        copy _ EmptyPath[];
        IF ip.tail # NIL THEN FOR il: InstanceList _ ip.head, il.rest WHILE il # ip.tail.rest DO
            copy _ IPAdd[copy, il.first, shallower, TRUE];
            ENDLOOP;
        copy _ copy;
        };

    IPCat: PROC [shallow, deep: InstantiationPath, destroyShallow, destroyDeep: BOOL] RETURNS [both: InstantiationPath] = {
        IF shallow.tail = NIL THEN RETURN [deep];
        IF deep.head = NIL THEN RETURN [shallow];
        IF shallow = deep THEN ERROR;
        SELECT destroyShallow FROM
            TRUE => {
                shallow.tail.rest _ deep.head;
                shallow.tail _ deep.tail;
                RETURN [shallow];
                };
            FALSE => {
                shallow _ IPCopy[shallow];
                RETURN [IPCat[shallow, deep, TRUE, destroyDeep]];
                };
            ENDCASE => ERROR;
        };

    EmptyPath: PROC RETURNS [empty: InstantiationPath] =
        {empty _ NEW [InstantiationPathRep _ [NIL, NIL]]};

    UnitPath: PROC [step: Instance] RETURNS [ip: InstantiationPath] = {
        this: InstanceList _ LIST[step];
        ip _ NEW [InstantiationPathRep _ [this, this]]};
<<Symbols>>
    <<A Symbol is like a property, except that it logically is retained for only a bounded period of time.>>
    <<The following implementation assumes there will be only one instance of itself in any VM.>>

    Sym: TYPE = REF SymRec;
    SymRec: TYPE = RECORD [atom: ATOM, curKey: Key _ Key.FIRST, inUse: BOOL _ FALSE];
    Key: TYPE = LONG CARDINAL;

    Holder: TYPE = REF HolderRec;
    HolderRec: TYPE = RECORD [key: Key, value: REF ANY];

    symChange: CONDITION;

    AllocSym: ENTRY PROC [s: Sym] = {
        ENABLE UNWIND => NULL;
        WHILE s.inUse DO WAIT symChange ENDLOOP;
        IF s.curKey = Key.LAST THEN ERROR;
        s.curKey _ s.curKey + 1;
        s.inUse _ TRUE;
        };

    ReleaseSym: ENTRY PROC [s: Sym] = {
        s.inUse _ FALSE;
        BROADCAST symChange;
        };

    CreateSym: PROC [atom: ATOM] RETURNS [s: Sym] = {
        s _ NEW [SymRec _ [atom]];
        CoreProperties.RegisterProperty[s.atom];
        };

    GetSym: PROC [from: Core.Properties, sym: Sym] RETURNS [value: REF ANY] = {
        h: Holder _ NARROW[CoreProperties.GetProp[from, sym.atom]];
        value _ IF (h = NIL) OR (h.key # sym.curKey) THEN NIL ELSE h.value;
        };

    PutSym: PROC [on: Core.Properties, sym: Sym, value: REF ANY] RETURNS [updated: Core.Properties] = {
        h: Holder _ NARROW[CoreProperties.GetProp[on, sym.atom]];
        IF h # NIL THEN {
            h.key _ sym.curKey;
            h.value _ value;
            RETURN [on]};
        updated _ CoreProperties.PutProp[on, sym.atom, NEW [HolderRec _ [sym.curKey, value]] ];
        };
<<Wire Binding>>
    AssocWire: PROC [key: Sym, from, to: Wire] = {
        from.properties _ PutSym[from.properties, key, to];
        IF from.elements # NIL THEN {
            FOR i: INT IN [0 .. from.elements.size) DO
                AssocWire[key, from.elements[i], to.elements[i]];
                ENDLOOP;
            key _ key};
        };

    GetWireAssoc: PROC [key: Sym, from: Wire] RETURNS [to: Wire] =
        {to _ NARROW[GetSym[from.properties, key]]};
<<Flattening>>
    Promotions: TYPE = REF PromotionsRec;
    PromotionsRec: TYPE = RECORD [
        count: NAT _ 0,
        wires: WireList _ NIL];

    WireList: TYPE = LIST OF Wire;

    formalToActual: Sym _ CreateSym[$CoreFlattenFormalToActual];
    templateToCopy: Sym _ CreateSym[$CoreFlattenTemplateToCopy];
    partPublic: Sym _ CreateSym[$CoreFlattenPartPublic];

    FlattenOnce: PROC [design: Design, cellType: CellType, control: FlattenControl] RETURNS [flat: CellType] = {
        <<Each child is expanded or not, depending on what control says.>>
        oldRec, newRec: RecordCellType;
        promotions: Promotions _ NEW [PromotionsRec _ []];
        AllocSym[formalToActual];
        AllocSym[templateToCopy];
        AllocSym[partPublic];
        {ENABLE UNWIND => {
            ReleaseSym[formalToActual];
            ReleaseSym[templateToCopy];
            ReleaseSym[partPublic];
            };
        cellType _ Recordify[design, cellType];
        [oldRec, newRec, flat] _ CopyCellType[design, templateToCopy, cellType];
        newRec.instances _ NIL;
        FOR cl: InstanceList _ oldRec.instances, cl.rest WHILE cl # NIL DO
            child: Instance _ cl.first;
            childType: CellType _ Recordify[design, child.type];
            childRec: RecordCellType _ NARROW[childType.data];
            childPath: InstantiationPath _ UnitPath[child];
            SELECT control.Decide[control.data, childPath] FROM
                expand => {
                    AssocWire[formalToActual, child.type.publicWire, child.actualWire];
                    PromotePrivates[design, flat, newRec, childType, childRec, formalToActual, templateToCopy, partPublic, promotions, UnitPath[child]];
                    FOR gl: InstanceList _ childRec.instances, gl.rest WHILE gl # NIL DO
                        oldGrandchild: Instance _ gl.first;
                        gcPath: InstantiationPath _ IPAdd[childPath, oldGrandchild, deeper, FALSE];
                        newGrandchild: Instance;
                        newGrandchild _ CopyInstance[design, oldGrandchild, formalToActual, templateToCopy, gcPath, childPath];
                        newRec.instances _ CONS[newGrandchild, newRec.instances];
                        ENDLOOP;
                    child _ child;
                    };
                leaf => {
                    newChild: Instance _ CopyInstance[design, child, formalToActual, templateToCopy, childPath, EmptyPath[]];
                    newRec.instances _ CONS[newChild, newRec.instances];
                    };
                ENDCASE => ERROR;
            child _ child;
            ENDLOOP;
        flat _ flat;
        IF promotions.count # 0 THEN {
            oldPW: Wire _ flat.publicWire;
            newPW: Wire _ NEW [WireRec _ [
                name: NIL,
                structure: record,
                elements: NEW [WireSequenceRec[oldPW.elements.size + promotions.count]],
                properties: oldPW.properties
                ]];
            i: NAT _ 0;
            <<Don't need to NoteWireSource[newPW, oldPW, NIL] because already done in CopyCellType>>
            IF oldPW.structure # record THEN ERROR;
            THROUGH [0 .. oldPW.elements.size) DO
                newPW.elements[i] _ oldPW.elements[i];
                i _ i + 1;
                ENDLOOP;
            FOR wl: WireList _ promotions.wires, wl.rest WHILE wl # NIL DO
                newPW.elements[i] _ wl.first;
                i _ i + 1;
                ENDLOOP;
            IF i # (oldPW.elements.size + promotions.count) THEN ERROR;
            flat.publicWire _ newPW;
            };
        };
        ReleaseSym[formalToActual];
        ReleaseSym[templateToCopy];
        ReleaseSym[partPublic];
        };

    Recordify: PROC [design: Design, ct: CellType] RETURNS [rct: CellType] = {
        FOR rct _ ct, CoreOps.Recast[rct] UNTIL rct.class = recordCellClass DO NULL ENDLOOP;
        rct _ rct};

    CopyCellType: PROC [design: Design, templateToCopy: Sym, old: CellType] RETURNS [oldRec, newRec: RecordCellType, new: CellType] = {
        oldRec _ NARROW[old.data];
        newRec _ NEW [RecordCellTypeRec _ [
            internalWire: CoreOps.CopyWire[oldRec.internalWire],
            instances: oldRec.instances]];
        NoteWireSource[newRec.internalWire, [EmptyPath[], oldRec.internalWire], TRUE];
        AssocWire[templateToCopy, oldRec.internalWire, newRec.internalWire];
        new _ NEW [CellTypeRec _ old^];
        new.data _ newRec;
        new.properties _ CoreProperties.CopyProps[old.properties];
        new.publicWire _ DuplicatePublicWire[design, templateToCopy, old.publicWire];
        new _ new};

    DuplicatePublicWire: PROC [design: Design, templateToCopy: Sym, oldPublicWire: Wire] RETURNS [newPublicWire: Wire] = {
        newPublicWire _ GetWireAssoc[templateToCopy, oldPublicWire];
        IF newPublicWire # NIL --means this is part of internalWire-- THEN RETURN;
        newPublicWire _ NEW [WireRec _ [
            name: NIL,
            structure: oldPublicWire.structure,
            elements: NIL,
            properties: CoreProperties.CopyProps[oldPublicWire.properties]
            ]];
        NoteWireSource[newPublicWire, [EmptyPath[], oldPublicWire], FALSE];
        IF oldPublicWire.elements # NIL THEN {
            newPublicWire.elements _ NEW [WireSequenceRec[oldPublicWire.elements.size]];
            FOR i: INT IN [0 .. oldPublicWire.elements.size) DO
                newPublicWire.elements[i] _ DuplicatePublicWire[design, templateToCopy, oldPublicWire.elements[i]];
                ENDLOOP;
            design _ design};
        design _ design};

    PromotePrivates: PROC [design: Design, parent: CellType, parentRec: RecordCellType, child: CellType, childRec: RecordCellType, 
    formalToActual, templateToCopy, partPublic: Sym, promotions: Promotions, path: InstantiationPath] = {
        FindPublic: PROC [childsInternal: Wire] RETURNS [somePublic: BOOL] = {
            somePublic _ GetWireAssoc[formalToActual, childsInternal] # NIL;
            IF (NOT somePublic) AND childsInternal.structure # atom THEN {
                FOR i: NAT IN [0 .. childsInternal.elements.size) DO
                    subWire: Wire _ childsInternal.elements[i];
                    subSomePublic: BOOL _ FindPublic[subWire];
                    somePublic _ somePublic OR subSomePublic;
                    ENDLOOP;
                child _ child;
                };
            IF somePublic THEN childsInternal.properties _ PutSym[childsInternal.properties, partPublic, $T];
            };
        DoForPrivateCover: PROC [childsInternal: Wire] = {
            allPublic: BOOL _ GetWireAssoc[formalToActual, childsInternal] # NIL;
            somePublic: BOOL _ allPublic OR (GetSym[childsInternal.properties, partPublic] = $T);
            IF NOT somePublic THEN {
                new: Wire _ CoreOps.CopyWire[childsInternal];
                NoteWireSource[new, [path, childsInternal], TRUE];
                AssocWire[templateToCopy, childsInternal, new];
                promotions.count _ promotions.count + 1;
                promotions.wires _ CONS[new, promotions.wires];
                }
            ELSE IF allPublic THEN {
                AssocToCopy[childsInternal];
                }
            ELSE {
                FOR i: NAT IN [0 .. childsInternal.elements.size) DO
                    DoForPrivateCover[childsInternal.elements[i]];
                    ENDLOOP;
                design _ design;
                };
            };
        AssocToCopy: PROC [childsInternal: Wire] = {
            actual: Wire _ GetWireAssoc[formalToActual, childsInternal];
            copy: Wire _ GetWireAssoc[templateToCopy, actual];
            IF copy # NIL
                THEN AssocWire[templateToCopy, childsInternal, copy]
                ELSE {
                    FOR i: NAT IN [0 .. childsInternal.elements.size) DO
                        AssocToCopy[childsInternal.elements[i]];
                        ENDLOOP;
                    design _ design;
                    };
            };
        [] _ FindPublic[childRec.internalWire];
        DoForPrivateCover[childRec.internalWire];
        };

    CopyInstance: PROC [design: Design, old: Instance, formalToActual, templateToCopy: Sym, longPath, shortPath: InstantiationPath] 
    RETURNS [new: Instance] = {
        CopyActual: PROC [old: Wire] RETURNS [new: Wire] = {
            new _ GetWireAssoc[templateToCopy, old];
            IF new # NIL THEN RETURN;
            new _ NEW [WireRec _ [
                name: NIL,
                structure: old.structure,
                elements: NIL,
                properties: CoreProperties.CopyProps[old.properties]
                ]];
            NoteWireSource[new, [shortPath, old], FALSE];
            IF old.elements = NIL THEN ERROR --this recursion must ground out in a piece of already copied template--;
            new.elements _ NEW [WireSequenceRec[old.elements.size]];
            FOR i: INT IN [0 .. old.elements.size) DO
                new.elements[i] _ CopyActual[old.elements[i]];
                ENDLOOP;
            new _ new;
            };
        new _ NEW [InstanceRec _ [
            name: NIL,
            actualWire: CopyActual[old.actualWire],
            type: old.type,
            properties: CoreProperties.CopyProps[old.properties]
            ]];
        NoteInstanceSource[new, longPath];
        };

    Flatten: PUBLIC PROC [design: Design, cellType: CellType, control: FlattenControl] RETURNS [flat: CellType] = {
        <<Each descendent is expanded or not, depending on what control says.>>
        oldRec, newRec: RecordCellType;
        promotions: Promotions _ NEW [PromotionsRec _ []];
        AllocSym[formalToActual];
        AllocSym[templateToCopy];
        AllocSym[partPublic];
        {ENABLE UNWIND => {
            ReleaseSym[formalToActual];
            ReleaseSym[templateToCopy];
            ReleaseSym[partPublic];
            };
        Work: PROC [cl: InstanceList, pathPrefix: InstantiationPath] = {
            flat _ flat;
            FOR cl _ cl, cl.rest WHILE cl # NIL DO
                child: Instance _ cl.first;
                path: InstantiationPath _ IPAdd[pathPrefix, child, deeper, FALSE];
                childType: CellType _ Recordify[design, child.type];
                childRec: RecordCellType _ NARROW[childType.data];
                SELECT control.Decide[control.data, path] FROM
                    expand => {
                        AssocWire[formalToActual, child.type.publicWire, child.actualWire];
                        PromotePrivates[design, flat, newRec, childType, childRec, formalToActual, templateToCopy, partPublic, promotions, path];
                        Work[childRec.instances, path];
                        child _ child;
                        };
                    leaf => {
                        newChild: Instance _ CopyInstance[design, child, formalToActual, templateToCopy, path, pathPrefix];
                        newRec.instances _ CONS[newChild, newRec.instances];
                        };
                    ENDCASE => ERROR;
                child _ child;
                ENDLOOP;
            flat _ flat;
            };
        cellType _ Recordify[design, cellType];
        [oldRec, newRec, flat] _ CopyCellType[design, templateToCopy, cellType];
        newRec.instances _ NIL;
        Work[oldRec.instances, EmptyPath[]];
        IF promotions.count # 0 THEN {
            oldPW: Wire _ flat.publicWire;
            newPW: Wire _ NEW [WireRec _ [
                name: NIL,
                structure: record,
                elements: NEW [WireSequenceRec[oldPW.elements.size + promotions.count]],
                properties: oldPW.properties
                ]];
            i: NAT _ 0;
            <<Don't need to NoteWireSource[newPW, oldPW, NIL] because already done in CopyCellType>>
            IF oldPW.structure # record THEN ERROR;
            THROUGH [0 .. oldPW.elements.size) DO
                newPW.elements[i] _ oldPW.elements[i];
                i _ i + 1;
                ENDLOOP;
            FOR wl: WireList _ promotions.wires, wl.rest WHILE wl # NIL DO
                newPW.elements[i] _ wl.first;
                i _ i + 1;
                ENDLOOP;
            IF i # (oldPW.elements.size + promotions.count) THEN ERROR;
            flat.publicWire _ newPW;
            };
        };
        ReleaseSym[formalToActual];
        ReleaseSym[templateToCopy];
        ReleaseSym[partPublic];
        };
<<Backpointers>>
    FlattenInstantiationPath: PROC [org: InstantiationPath] RETURNS [flat: InstantiationPath] = {
        alreadyFlat: BOOL _ TRUE;
        Test: PROC [step: Instance] = {
            IF CoreProperties.GetProp[step.properties, instantiationPath] # NIL THEN alreadyFlat _ FALSE;
            };
        Cons: PROC [step: Instance] = {
            ip: InstantiationPath _ NARROW[CoreProperties.GetProp[step.properties, instantiationPath]];
            IF ip = NIL
                THEN flat _ IPAdd[flat, step, easyExhibitDirection, TRUE]
                ELSE SELECT easyExhibitDirection FROM
                    deeper => flat _ IPCat[ip, flat, FALSE, TRUE];
                    shallower => flat _ IPCat[flat, ip, TRUE, FALSE];
                    ENDCASE => ERROR;
            };
        Exhibit[org, easyExhibitDirection, Test];
        IF alreadyFlat THEN RETURN [org];
        flat _ EmptyPath[];
        Exhibit[org, easyExhibitDirection, Cons];
        flat _ flat;
        };

    NoteInstanceSource: PROC [newInstance: Instance, path: InstantiationPath] = {
        flatPath: InstantiationPath _ FlattenInstantiationPath[path];
        newInstance.properties _ CoreProperties.PutProp[newInstance.properties, instantiationPath, flatPath];
        };

    NoteWireSource: PROC [newWire: Wire, source: WireSourceRec, recursively: BOOL] = {
        source.instantiationPath _ FlattenInstantiationPath[source.instantiationPath];
        DO
            oldSource: WireSource _ GetWireSource[source.wire];
            IF oldSource = NIL THEN EXIT;
            source _ [
                instantiationPath: IPCat[source.instantiationPath, FlattenInstantiationPath[oldSource.instantiationPath], FALSE, FALSE],
                wire: oldSource.wire];
            ENDLOOP;
        newWire.properties _ CoreProperties.PutProp[newWire.properties, wireSource, NEW [WireSourceRec _ source] ];
        IF recursively AND newWire.elements # NIL THEN {
            FOR i: NAT IN [0 .. newWire.elements.size) DO
                NoteWireSource[newWire.elements[i], [source.instantiationPath, source.wire.elements[i]], recursively];
                ENDLOOP;
            newWire _ newWire;
            };
        };

    GetWireSource: PROC [w: Wire] RETURNS [ws: WireSource] = {
        ws _ NARROW[CoreProperties.GetProp[w.properties, wireSource]];
        };
<<Control by File>>
    ControlByFile: PUBLIC PROC [fileName: ROPE] RETURNS [control: FlattenControl] = {ERROR --not yet implemented--};
<<Start Code>>
    Start: PROC = TRUSTED {
        Process.InitializeCondition[@symChange, Process.SecondsToTicks[60]];
        Process.EnableAborts[@symChange];
        };

    Start[];

END.