<<>>
<<MimBodyCorrectImpl.mesa>>
    <<Copyright Ó 1989, 1990, 1991, 1992 by Xerox Corporation.  All rights reserved.>>
    <<Russ Atkinson (RRA) August 3, 1990 10:38:13 am PDT>>
    <<>>
    <<This module takes a list of procedures and creates BodyRecord objects in the symbol table for all procedures that do not have 
    valid BodyRecord objects.>>
    <<>>
    DIRECTORY
        Alloc,
        IntCodeDefs,
        IntCodeUtils,
        IO,
        MimBodyCorrect,
        MimData,
        MimZonePort,
        Rope,
        Symbols,
        Table;

MimBodyCorrectImpl: CEDAR PROGRAM
    IMPORTS Alloc, IntCodeUtils, IO, MimData, MimZonePort, Rope
    EXPORTS MimBodyCorrect
    = BEGIN OPEN IntCodeDefs, Symbols;

    ROPE: TYPE = Rope.ROPE;

    BadBti: CARD = 100000;

    Notify: Alloc.Notifier = {
        <<called by allocator whenever tables are repacked>>
        bb Ź base[Symbols.bodyType];
        seb Ź base[Symbols.seType];
        };

    bb: Symbols.Base;
    seb: Symbols.Base;

    bbZoneScratch: MimZonePort.Scratch;
    bbZone: UNCOUNTED ZONE = NewUZone[];

    NewUZone: PROC RETURNS [UNCOUNTED ZONE] = TRUSTED {
        RETURN [MimZonePort.MakeZone[alloc: BbZoneProc, free: NIL, scratch: @bbZoneScratch]];
        };

    BbZoneProc: UNSAFE PROC
    [self: UNCOUNTED ZONE, size: CARDINAL] RETURNS [ptr: LONG POINTER] = UNCHECKED {
        index: Alloc.OrderedIndex = (MimData.table).Units[Symbols.bodyType, size];
        ptr Ź @bb[index];
        };

    CBTRelative: UNSAFE PROC
    [ptr: LONG POINTER TO BodyRecord.Callable] RETURNS [CBTIndex]
    = UNCHECKED INLINE {
        RETURN [LOOPHOLE[ptr-LOOPHOLE[bb, LONG POINTER TO BodyRecord.Callable]]];
        };

    CantHappen: SIGNAL = CODE;

    AllocateBody: PROC [lambda: LambdaNode] RETURNS [CBTIndex] = TRUSTED {
        <<Allocates a new BodyRecord object with reasonable defaults for all of the fields.  No linking to parents or children is performed.>>
        bPtr: LONG POINTER TO BodyRecord.Callable Ź bbZone.NEW[BodyRecord.Callable Ź [
            link: [which: sibling, index: Symbols.BTNull],
            firstSon: Symbols.BTNull,
            type: Symbols.RecordSENull,
            localCtx: Symbols.CTXNull,
            sourceIndex: 0,
            info: Symbols.BodyInfo[cases: External[0, 0, 0, 0]],
            level: Symbols.lZ,
            class: Blank,
            extension: Callable[
                id: Symbols.ISENull,
                ioType: Symbols.typeANY,
                frameOffset: 0,
                entryIndex: 0,
                hints: [safe: FALSE, argUpdated: TRUE, nameSafe: FALSE, noStrings: TRUE, pad: 0],
                entry: FALSE, internal: FALSE, inline: FALSE,
                monitored: FALSE, noXfers: FALSE, resident: FALSE,
                kind: Other]
            ]];
        bti: CBTIndex = CBTRelative[bPtr];
        RETURN [bti];
        };

    FindVarBti: PROC [bti: BTIndex, ctx: CTXIndex] RETURNS [BTIndex] = TRUSTED {
        <<Recursive search for the BTIndex that contains the given ctx starting with the given bti>>
        IF bti = Symbols.BTNull OR bb[bti].localCtx = ctx THEN RETURN [bti];
        WHILE bti # Symbols.BTNull AND bb[bti].link.which # parent DO
            son: BTIndex = FindVarBti[bb[bti].firstSon, ctx];
            IF son # Symbols.BTNull THEN RETURN [son];
            bti Ź bb[bti].link.index;
            ENDLOOP; 
        RETURN [Symbols.BTNull];
        };

    ParentBti: PROC [bti: BTIndex] RETURNS [BTIndex] = TRUSTED {
        IF bti = Symbols.BTNull OR bti = Symbols.RootBti THEN ERROR;
        WHILE bti # Symbols.BTNull DO
            link: BTIndex = bb[bti].link.index;
            IF bb[bti].link.which = parent THEN RETURN [link];
            bti Ź link;
            ENDLOOP; 
        ERROR;
        };

    LastSon: PROC [bti: BTIndex] RETURNS [BTIndex] = TRUSTED {
        lastSon: BTIndex Ź bb[bti].firstSon;
        WHILE lastSon # Symbols.BTNull AND bb[lastSon].link.which # parent DO
            lastSon Ź bb[lastSon].link.index;
            ENDLOOP;
        RETURN [lastSon];
        };

    DelinkBti: PROC [bti: BTIndex] = TRUSTED {
        parent: BTIndex = ParentBti[bti];
        prev: BTIndex Ź bb[parent].firstSon;
        firstSon: BTIndex Ź bb[bti].firstSon;
        lastSon: BTIndex Ź LastSon[bti];
        IF prev = bti
            THEN {
                <<The bti is the first in the chain>>
                link: BTIndex = bb[bti].link.index;
                bb[parent].firstSon Ź IF link = parent THEN BTNull ELSE link;
                IF firstSon # Symbols.BTNull THEN {
                    <<At this point we have to take all of the sons and put them where the original node was (more or less).>>
                    bb[parent].firstSon Ź firstSon;
                    bb[lastSon].link.which Ź IF link = parent THEN parent ELSE sibling;
                    bb[lastSon].link.index Ź link;
                    };
                }
            ELSE {
                <<The bti is somewhere in the chain>>
                DO
                    next: BTIndex Ź bb[prev].link.index;
                    IF next = parent OR next = Symbols.BTNull THEN ERROR;
                    IF next = bti THEN {bb[prev].link Ź bb[bti].link; EXIT};
                    prev Ź next;
                    ENDLOOP;
                IF firstSon # Symbols.BTNull THEN {
                    <<At this point we have to take all of the sons and put them where the original node was (more or less).>>
                    bb[lastSon].link Ź bb[prev].link;
                    bb[prev].link.which Ź sibling;
                    bb[prev].link.index Ź firstSon;
                    };
                };
        bb[bti].link.index Ź Symbols.BTNull;
        bb[bti].firstSon Ź Symbols.BTNull;
        };

    MakeFirstSon: PROC [bti: BTIndex, parent: BTIndex] = TRUSTED {
        son: BTIndex = bb[parent].firstSon;
        IF bti = BTNull OR parent = BTNull THEN ERROR CantHappen;
        IF son = BTNull
            THEN bb[bti].link Ź [which: parent, index: parent]
                <<No sons, so this procedure is the only child>>
            ELSE bb[bti].link Ź [which: sibling, index: son];
                <<Insert this body just after the last seen variable>>
        bb[parent].firstSon Ź bti;
        };

    RelinkBodies: PROC [bodies: NodeList] = {
        zeroPass: PROC [procBti: BTIndex, startBti: BTIndex] = TRUSTED {
            <<Recursively visit the linked bodies, initializing the relOffset fields.>>
            sonBti: BTIndex Ź bb[startBti].firstSon;
            IF sonBti = BTNull THEN RETURN;
            DO
                link: BTIndex Ź bb[sonBti].link.index;
                WITH body: bb[sonBti] SELECT FROM
                    Callable => zeroPass[sonBti, sonBti];
                    Other => {
                        otherBodies Ź otherBodies + 1;
                        body.relOffset Ź -1;
                        zeroPass[procBti, sonBti];
                        };
                    ENDCASE => ERROR;
                IF link = startBti THEN EXIT;
                IF link = BTNull THEN ERROR;
                IF bb[sonBti].link.which = parent THEN ERROR;
                sonBti Ź link;
                ENDLOOP;
            };
        firstPass: PROC = {
            FOR each: NodeList Ź bodies, each.rest WHILE each # NIL DO
                WITH each.first SELECT FROM
                    parent: LabelNode => {
                        inner: IntCodeUtils.Visitor = {
                            <<[node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]>>
                            WITH node SELECT FROM
                                decl: DeclNode => {
                                    var: Var = decl.var;
                                    IF var # NIL AND var.flags[named] THEN {
                                        <<We may have changed the scope of the body for this var>>
                                        ctx: CTXIndex = CtxForVar[var];
                                        IF ctx # CTXNull THEN {
                                            bti: BTIndex = BtiForCtx[Symbols.RootBti, ctx];
                                            IF bti # BTNull THEN TRUSTED {
                                                WITH body: bb[bti] SELECT FROM
                                                    Other => body.relOffset Ź LOOPHOLE[parentBti];
                                                    Callable => {};
                                                    ENDCASE => ERROR;
                                                };
                                            };
                                        };
                                    };
                                ENDCASE;
                            IntCodeUtils.MapNode[node, inner];
                            RETURN [node];
                            };
                        parentBti: BTIndex = LOOPHOLE[parent.label.id];
                        IntCodeUtils.MapNode[parent, inner];
                        };
                    ENDCASE;
                ENDLOOP;
            };
        secondPass: PROC [procBti: BTIndex, startBti: BTIndex] = TRUSTED {
            <<Recursively visit the linked bodies, moving those that are incorrectly linked.>>
            sonBti: BTIndex Ź bb[startBti].firstSon;
            IF sonBti = BTNull THEN RETURN;
            DO
                link: BTIndex Ź bb[sonBti].link.index;
                WITH body: bb[sonBti] SELECT FROM
                    Callable => secondPass[sonBti, sonBti];
                    Other => {
                        IF body.relOffset >= 0 THEN {
                            desiredParent: BTIndex = LOOPHOLE[body.relOffset, BTIndex];
                            WITH cbody: bb[startBti] SELECT FROM
                                Callable => IF desiredParent = startBti THEN GO TO linkOK;
                                Other => {
                                    cdp: BTIndex = LOOPHOLE[cbody.relOffset, BTIndex];
                                    IF cdp = desiredParent THEN GO TO linkOK;
                                    };
                                ENDCASE => ERROR;
                            DelinkBti[sonBti];
                            MakeFirstSon[sonBti, desiredParent];
                            secondPass[desiredParent, sonBti];
                            GO TO linkChanged;
                            EXITS linkOK => {};
                            };
                        secondPass[procBti, sonBti];
                        EXITS linkChanged => {
                            <<A link was changed so we scan all of the sons again>>
                            link Ź bb[startBti].firstSon;
                            IF link = BTNull THEN EXIT;
                            };
                        };
                    ENDCASE => ERROR;
                IF link = startBti THEN EXIT;
                IF link = BTNull THEN ERROR;
                sonBti Ź link;
                ENDLOOP;
            };
        otherBodies: INT Ź 0;
        zeroPass[Symbols.RootBti, Symbols.RootBti];
        IF debug # NIL THEN {
            IO.PutRope[debug, "\n**** After RelinkBodies Pass 0 ****\n"];
            PrintBodies[debug, Symbols.RootBti, 0];
            };
        IF otherBodies # 0 THEN {
            firstPass[];
            IF debug # NIL THEN {
                IO.PutRope[debug, "\n**** After RelinkBodies Pass 1 ****\n"];
                PrintBodies[debug, Symbols.RootBti, 0];
                };
            secondPass[Symbols.RootBti, Symbols.RootBti];
            IF debug # NIL THEN {
                IO.PutRope[debug, "\n**** After RelinkBodies Pass 2 ****\n"];
                PrintBodies[debug, Symbols.RootBti, 0];
                };
            };
        };

    debug: IO.STREAM Ź NIL;
    BadBody: ERROR = CODE;
    PrintBodies: PROC [st: IO.STREAM, bti: BTIndex, depth: NAT] = TRUSTED {
        start: BTIndex = bti;
        IF depth > 100 THEN {
            IO.PutRope[st, "ERROR!  Too Deep!\n"];
            ERROR BadBody;
            };
        THROUGH [0..depth) DO IO.PutRope[st, "  "]; ENDLOOP;
        IF bti = BTNull THEN {IO.PutRope[st, "{null bti}\n"]; RETURN};
        IO.PutF1[st, "bti: %g, ", [integer[LOOPHOLE[bti]]]];
        SELECT bb[bti].class FROM
            Blank => {};
            Outer => IO.PutRope[st, "outer "];
            Inner => IO.PutRope[st, "inner "];
            Install => IO.PutRope[st, "install "];
            Init => IO.PutRope[st, "init "];
            Catch => IO.PutRope[st, "catch "];
            Scope => IO.PutRope[st, "scope "];
            Fork => IO.PutRope[st, "fork "];
            ENDCASE => IO.PutRope[st, "?? "];
        WITH body: bb[bti] SELECT FROM
            Callable => IO.PutF[st, "Callable (ctx: %g, src: %g)\n",
            [integer[LOOPHOLE[bb[bti].localCtx]]],
            [cardinal[bb[bti].sourceIndex]] ];
            Other => IO.PutF[st, "Other (ctx: %g, src: %g, ip: %g)\n",
            [integer[LOOPHOLE[bb[bti].localCtx]]],
            [cardinal[bb[bti].sourceIndex]],
            [integer[body.relOffset]] ];
            ENDCASE => ERROR;
        IF bb[bti].firstSon # BTNull THEN {
            son: BTIndex Ź bb[bti].firstSon;
            count: NAT Ź 0;
            DO
                link: BTIndex Ź bb[son].link.index;
                PrintBodies[st, son, depth+1];
                IF link = bti THEN EXIT;
                IF bb[son].link.which = parent THEN {
                    IO.PutF1[st, "ERROR!  Bad Parent Link = %g!!!!\n", [integer[LOOPHOLE[link]]]];
                    ERROR BadBody;
                    };
                IF link = BTNull THEN {
                    IO.PutRope[st, "ERROR!  Link = BTNull!!!!\n"];
                    ERROR BadBody;
                    };
                count Ź count + 1;
                IF count > 100 THEN {
                    IO.PutRope[st, "ERROR!  Too Wide!\n"];
                    ERROR BadBody;
                    };
                son Ź link;
                ENDLOOP;
            };
        };

    BtiForCtx: PROC [startBti: BTIndex, ctx: CTXIndex] RETURNS [BTIndex] = TRUSTED {
        <<Starting at the given bti, return the bti corresponding to the given ctx.  Use recursive search to find such a bti in sons.>>
        IF startBti # BTNull THEN {
            IF bb[startBti].localCtx = ctx AND ctx # CTXNull THEN RETURN [startBti];
            FOR son: BTIndex Ź bb[startBti].firstSon, bb[son].link.index
            WHILE son # BTNull AND son # startBti DO
                sbti: BTIndex = BtiForCtx[son, ctx];
                IF sbti # BTNull THEN RETURN [sbti];
                ENDLOOP;
            };
        RETURN [BTNull];
        };

    CtxForVar: PROC [var: Var] RETURNS [CTXIndex] = {
        varId: INT = var.id;
        IF var.flags[named] AND varId > 0 THEN {
            tag: CARD = LOOPHOLE[Table.IndexRep[tag: Symbols.seTag, highBits: 0, lowBits: 0]];
            IF CARD[varId] < tag THEN TRUSTED {
                sei: Symbols.SEIndex = LOOPHOLE[tag+varId];
                WITH se: seb[sei] SELECT FROM
                    id => RETURN [se.idCtx];
                    ENDCASE => ERROR;
                };
            };
        RETURN [Symbols.CTXNull];
        };

    FixBodies: PUBLIC PROC [bodies: NodeList] = {
        TRUSTED {(MimData.table).AddNotify[Notify]};
        <<First, establish the renaming of labels (pass 1: count, pass 2: rename)>>
        FOR each: NodeList Ź bodies, each.rest WHILE each # NIL DO
            WITH each.first SELECT FROM
                labelNode: REF NodeRep.label => 
                    WITH labelNode.label.node SELECT FROM
                        lambda: REF NodeRep.lambda => TRUSTED {
                            id: CARD = LOOPHOLE[labelNode.label.id];
                            bti: CBTIndex Ź LOOPHOLE[id];
                            class: Symbols.ProcClass = SELECT lambda.kind FROM
                                outer => Outer, inner => Inner, install => Install, init => Init,
                                catch => Catch, scope => Scope, fork => Fork, ENDCASE => Blank;
                            IF id >= BadBti THEN {
                                <<This lambda needs a new BodyRecord in the symbol table>>
                                bti Ź AllocateBody[lambda];
                                labelNode.label.id Ź LOOPHOLE[bti];
                                };
                            IF class = Install THEN {
                                <<The installation proc is always the sibling of the init procedure, which is the root bti.  Neither one has a parent.>>
                                bb[Symbols.RootBti].link Ź [which: sibling, index: bti];
                                bb[bti].link Ź [which: parent, index: BTNull];
                                };
                            bb[bti].class Ź class;
                            };
                        ENDCASE;
                ENDCASE;
            ENDLOOP;
        <<Now fix up the world>>
        FOR each: NodeList Ź bodies, each.rest WHILE each # NIL DO
            inner: IntCodeUtils.Visitor = {
                <<[node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]>>
                WITH node SELECT FROM
                    var: Var => IF var.flags[named] THEN recentVar Ź var;
                    assign: AssignNode => prevAssign Ź assign;
                    block: REF NodeRep.block => {
                        oldVar: Var Ź recentVar;
                        IntCodeUtils.MapNodeList[block.nodes, inner];
                        recentVar Ź oldVar;
                        RETURN [node];
                        };
                    source: REF NodeRep.source => {
                        oldSource: Node Ź recentSource;
                        recentSource Ź source;
                        IntCodeUtils.MapNodeList[source.nodes, inner];
                        recentSource Ź oldSource;
                        RETURN [node];
                        };
                    apply: REF NodeRep.apply =>
                        WITH apply.proc SELECT FROM
                            mc: REF NodeRep.machineCode => {
                                guts: ROPE = mc.bytes;
                                SELECT TRUE FROM
                                    Rope.Equal[guts, "XR_Enable"] => {
                                        scopeId: CARD = IdFromOperNode[apply.args.first];
                                        catchId: CARD = IdFromOperNode[apply.args.rest.first];
                                        InsertBody[scopeId, recentSource];
                                        InsertBody[catchId, recentSource];
                                        };
                                    ENDCASE;
                                };
                            operNode: REF NodeRep.oper => WITH operNode.oper SELECT FROM
                                code: REF OperRep.code => {
                                    id: CARD = LOOPHOLE[code.label.id];
                                    IF id >= BadBti THEN GO TO failed;
                                    };
                                mesa: REF OperRep.mesa =>
                                    SELECT mesa.mesa FROM
                                        fork =>
                                            IF prevAssign # NIL THEN WITH prevAssign.rhs SELECT FROM
                                                aVar: Var => WITH aVar.location SELECT FROM
                                                    comp: REF LocationRep.composite =>
                                                        IF comp.parts # NIL THEN {
                                                            id: CARD = IdFromOperNode[comp.parts.first];
                                                            IF id # CARD.LAST THEN InsertBody[id, recentSource];
                                                            };
                                                    ENDCASE;
                                                ENDCASE;
                                        ENDCASE;
                                ENDCASE;
                            ENDCASE;
                    labelNode: REF NodeRep.label =>
                        WITH labelNode.label.node SELECT FROM
                            lambda: REF NodeRep.lambda => {
                                recentLambda Ź lambda;
                                recentSource Ź NIL;
                                recentVar Ź NIL;
                                recentLambdaBti Ź LOOPHOLE[labelNode.label.id];
                                IF LOOPHOLE[labelNode.label.id, CARD] >= BadBti THEN SIGNAL CantHappen;
                                };
                            ENDCASE;
                    ENDCASE;
                IntCodeUtils.MapNode[node, inner];
                RETURN [node];
                EXITS failed => {SIGNAL CantHappen; RETURN [node]};
                };
            IdToLambda: PROC [id: CARD] RETURNS [LambdaNode] = {
                FOR each: NodeList Ź bodies, each.rest WHILE each # NIL DO
                    WITH each.first SELECT FROM
                        labelNode: REF NodeRep.label => 
                            WITH labelNode.label.node SELECT FROM
                                ln: REF NodeRep.lambda =>
                                    IF id = LOOPHOLE[labelNode.label.id, CARD] THEN RETURN [ln];
                                ENDCASE;
                        ENDCASE;
                    ENDLOOP;
                RETURN [NIL];
                };
            InsertBody: PROC [id: CARD, src: Node] = TRUSTED {
                bti: CBTIndex = LOOPHOLE[id];
                lambda: LambdaNode Ź IdToLambda[id];
                IF id >= BadBti OR lambda = NIL THEN SIGNAL CantHappen;
                WITH src SELECT FROM
                    srcNode: REF NodeRep.source =>
                        IF srcNode.source.start > 0 THEN bb[bti].sourceIndex Ź srcNode.source.start;
                    ENDCASE;
                SELECT lambda.kind FROM
                    catch, scope, fork => {
                        <<These procedures were synthesized>>
                        parent: BTIndex Ź recentLambdaBti;
                        IF recentVar # NIL THEN {
                            <<This is the most recently found "live" variable, so it should be in a scope that is a better parent than simply the lambda>>
                            varId: CARD = LOOPHOLE[recentVar.id];
                            tag: CARD = LOOPHOLE[Table.IndexRep[tag: Symbols.seTag, highBits: 0, lowBits: 0]];
                            IF varId >= tag
                                THEN SIGNAL CantHappen
                                ELSE {
                                    sei: Symbols.ISEIndex = LOOPHOLE[tag+varId];
                                    varBti: BTIndex Ź FindVarBti[parent, seb[sei].idCtx];
                                    IF varBti # Symbols.BTNull
                                    AND varBti # recentLambdaBti THEN {
                                        <<Insert this cookie as the sibling of the most recent variable>>
                                        bb[bti].link Ź bb[varBti].link;
                                        bb[varBti].link Ź [which: sibling, index: bti];
                                        RETURN;
                                        };
                                    };
                            };
                        <<For now, just insert as the first son of the parent.  This needs to be fixed when we consider the source.>>
                        MakeFirstSon[bti, parent];
                        };
                    ENDCASE => GO TO failed;
                        <<These cases should never need an insertion!>>
                EXITS failed => SIGNAL CantHappen;
                };
            recentSource: Node Ź NIL;
            recentVar: Var Ź NIL;
            prevAssign: AssignNode Ź NIL;
            recentLambda: LambdaNode Ź NIL;
            recentLambdaBti: CBTIndex Ź Symbols.CBTNull;
            each.first Ź inner[each.first];
            ENDLOOP;
        RelinkBodies[bodies];
        <<Now shut down the world>>
        TRUSTED {(MimData.table).DropNotify[Notify]};
        };

    IdFromOperNode: PROC [node: Node] RETURNS [CARD] = {
        WITH node SELECT FROM
            opNode: REF NodeRep.oper => WITH opNode.oper SELECT FROM
                code: REF OperRep.code => RETURN [LOOPHOLE[code.label.id]];
                ENDCASE;
            ENDCASE;
        RETURN [CARD.LAST];
        };

    END.