
    <<RefPrintImpl.mesa>>
        <<Copyright Ó 1988, 1990, 1991 by Xerox Corporation.  All rights reserved.>>
        <<Michael Plass, June 11, 1991 0:09 am PDT>>
        <<>>
    DIRECTORY Commander, CommanderOps, Atom, Rope, Convert, Basics, List, RefPrint, SafeStorage, IO, CardTab, ProcessProps;


    RefPrintImpl: CEDAR MONITOR
    IMPORTS Commander, CommanderOps, Atom, Rope, Convert, List, SafeStorage, IO, CardTab, ProcessProps
    EXPORTS RefPrint
    ~ BEGIN

        ROPE: TYPE ~ Rope.ROPE;

        printers: CardTab.Ref ~ CardTab.Create[];
        fallbacks: LIST OF RefPrint.PrintRefProc Ź NIL;


        RefTest: UNSAFE PROC [candidate: WORD, szp: POINTER TO INT, ptrfreep: POINTER TO BOOLEAN] RETURNS [hdrPointer: WORD] ~ UNCHECKED 
        MACHINE CODE {
            "XR_PtrTest"
            };

        headerUnits: CARD = 8;

        DesparatePrintReferent: PROC [stream: IO.STREAM, maybeRef: WORD] RETURNS [BOOL] ~ TRUSTED {
            nBytes: INT Ź 0;
            pointerFree: BOOL Ź FALSE;
            hdrPointer: WORD Ź RefTest[maybeRef, @nBytes, @pointerFree];
            IF hdrPointer # 0 AND hdrPointer + headerUnits = maybeRef THEN {
                ref: REF ~ LOOPHOLE[maybeRef];
                p: POINTER TO WORD Ź LOOPHOLE[maybeRef];
                <<last: POINTER TO WORD _ p + ((nBytes-headerUnits-1)/BYTES[WORD])*UNITS[WORD];>>
                type: SafeStorage.Type ~ SafeStorage.GetCanonicalReferentType[ref];
                ordType: CARD16 ~ ORD[type];
                nBytes Ź nBytes - headerUnits;
                IO.PutF[stream, "TC%g%g[", [cardinal[ORD[type]]], [rope[IF pointerFree THEN "pf" ELSE ""]]];
                WHILE nBytes > 0 DO
                    IF maybeRef # LOOPHOLE[p] THEN IO.PutRope[stream, " "];
                    PrintWord[stream, p­, pointerFree];
                    p Ź p + UNITS[WORD];
                    nBytes Ź nBytes - BYTES[WORD];
                    ENDLOOP;
                IO.PutRope[stream, "]"];
                RETURN [TRUE]
                };
            <<IO.PutF[stream, "(nBytes=%g pointerFree=%g hdrPointer=%08xH\n)", [integer[nBytes]], [integer[ORD[pointerFree]]], 
            [cardinal[hdrPointer]]];>>
            RETURN [FALSE]
            };

        PrintWord: PROC [stream: IO.STREAM, value: WORD, refFree: BOOL] ~ TRUSTED {
            nBytes: INT Ź 0;
            pointerFree: BOOL Ź FALSE;
            hdrPointer: WORD Ź IF refFree THEN 0 ELSE RefTest[value, @nBytes, @pointerFree];
            IF hdrPointer # 0 AND hdrPointer + headerUnits = value
                THEN { [] Ź PrintREF[stream, LOOPHOLE[value]] }
                ELSE { IO.PutF1[stream, "%08x", [cardinal[value]]] }
            };

        PrintReferent: PUBLIC PROC [stream: IO.STREAM, ref: REF] RETURNS [ok: BOOL Ź TRUE] ~ {
            type: SafeStorage.Type ~ SafeStorage.GetCanonicalReferentType[ref];
            ordType: CARD16 ~ ORD[type];
            printer: REF RefPrint.PrintRefProc ~ NARROW[CardTab.Fetch[x: printers, key: ordType].val];
            IF printer = NIL
                THEN {
                    FOR tail: LIST OF RefPrint.PrintRefProc Ź fallbacks, tail.rest UNTIL tail = NIL DO
                        IF tail.first[stream, ref] THEN RETURN [TRUE];
                        ENDLOOP;
                    TRUSTED { RETURN DesparatePrintReferent[stream, LOOPHOLE[ref]] };
                    }
                ELSE RETURN printer­[stream, ref];
            };

        defaultDepthLimit: INT Ź 2;
        RefPrintControl: TYPE ~ REF RefPrintControlRep;
        RefPrintControlRep: TYPE ~ RECORD [
            seen: CardTab.Ref,
            depthLimit: INT
            ];
        PrintREF: PUBLIC PROC [stream: IO.STREAM, ref: REF] RETURNS [ok: BOOL Ź TRUE] ~ {
            IF ref = NIL
                THEN { IO.PutRope[stream, "NIL"] }
                ELSE {
                    newDepthLimit: INT Ź -1;
                    control: RefPrintControl Ź NIL;
                    Inner: PROC ~ {
                        IO.PutF[stream, "(%l%08x%l)", [rope["b"]], [cardinal[LOOPHOLE[ref]]], [rope["B"]]];
                        IF control.depthLimit = 0 OR CardTab.Fetch[control.seen, LOOPHOLE[ref]].found
                            THEN { }
                            ELSE {
                                control.depthLimit Ź control.depthLimit - 1;
                                IO.PutRope[stream, "^="];
                                [] Ź CardTab.Insert[control.seen, LOOPHOLE[ref], $TRUE];
                                ok Ź PrintReferent[stream, ref];
                                control.depthLimit Ź control.depthLimit + 1;
                                };
                        };
                    WITH ProcessProps.GetProp[$RefPrintControl] SELECT FROM
                        ctl: RefPrintControl => { control Ź ctl };
                        rope: ROPE => { newDepthLimit Ź Convert.CardFromRope[rope] };
                        ENDCASE => { newDepthLimit Ź defaultDepthLimit };
                    IF control = NIL
                        THEN {
                            control Ź NEW[RefPrintControlRep Ź [seen: CardTab.Create[], depthLimit: newDepthLimit]];
                            ProcessProps.AddPropList[List.PutAssoc[$RefPrintControl, control, NIL], Inner];
                            }
                        ELSE { Inner[] };
                    };
            };

        Register: PUBLIC ENTRY PROC [printer: RefPrint.PrintRefProc, type: SafeStorage.Type] ~ {
            ordType: CARD16 ~ ORD[type];
            [] Ź CardTab.Store[x: printers, key: ordType, val: NEW[RefPrint.PrintRefProc Ź printer]]
            };

        RegisterFallback: PUBLIC ENTRY PROC [printer: RefPrint.PrintRefProc] ~ {
            fallbacks Ź CONS[printer, fallbacks];
            };

        UnRegister: PUBLIC ENTRY PROC [printer: RefPrint.PrintRefProc] ~ {
            EachPair: CardTab.EachPairAction = {
                <<[key: CardTab.Key, val: CardTab.Val] RETURNS [quit: BOOL _ FALSE]>>
                valPrinter: REF RefPrint.PrintRefProc ~ NARROW[val];
                IF valPrinter­ = printer THEN [] Ź CardTab.Delete[x: printers, key: key];
                };
            fallbacks Ź UnRegisterFallbacks[printer, fallbacks];
            [] Ź CardTab.Pairs[x: printers, action: EachPair];
            };

        UnRegisterFallbacks: INTERNAL PROC [printer: RefPrint.PrintRefProc, list: LIST OF RefPrint.PrintRefProc] RETURNS [LIST OF 
        RefPrint.PrintRefProc] ~ {
            SELECT TRUE FROM
                list = NIL => RETURN [NIL];
                list.first = printer => RETURN UnRegisterFallbacks[printer, list.rest];
                ENDCASE => {
                    tail: LIST OF RefPrint.PrintRefProc ~ UnRegisterFallbacks[printer, list.rest];
                    RETURN [IF tail = list.rest THEN list ELSE CONS[list.first, tail]]
                    };
            };

        ATOMPrinter: RefPrint.PrintRefProc = {
            IO.PutF1[stream, "$%g", [rope[Atom.GetPName[NARROW[ref]]]]];
            };

        REFLongNumberPrinter: RefPrint.PrintRefProc = {
            refLongNumber: REF Basics.LongNumber ~ NARROW[ref];
            IO.PutF1[stream, "[lc[%08xH]]", [cardinal[refLongNumber­.lc]]];
            };

        PrintRopeLiteral: PROC [stream: IO.STREAM, rope: ROPE] ~ {
            i: INT Ź 0;
            Action: PROC [c: CHAR] RETURNS [quit: BOOL Ź FALSE] ~ {
                IF i > 120 THEN {IO.PutRope[stream, "..."]; RETURN [TRUE]};
                IF c = '" OR c='\\ THEN IO.PutChar[stream, '\\];
                IO.PutChar[stream, c];
                i Ź i + 1;
                };
            IO.PutChar[stream, '"];
            [] Ź Rope.Map[base: rope, action: Action];
            IO.PutChar[stream, '"];
            };

        ROPEPrinter: RefPrint.PrintRefProc ~ {
            PrintRopeLiteral[stream, NARROW[ref]];
            };

        LORAPrinter: RefPrint.PrintRefProc ~ {
            WITH ref SELECT FROM
                lora: LIST OF REF => {
                    IO.PutRope[self: stream, r: "LIST["];
                    FOR tail: LIST OF REF Ź lora, tail.rest UNTIL tail = NIL DO
                        IF tail # lora THEN IO.PutRope[self: stream, r: ", "];
                        [] Ź PrintREF[stream, tail.first];
                        ENDLOOP;
                    IO.PutRope[self: stream, r: "]"];
                    };
                ENDCASE => RETURN [FALSE];
            };

        RefPrintCommand: Commander.CommandProc ~ {
            ENABLE Convert.Error => CommanderOps.Failed[cmd.procData.doc];
            arg: ROPE Ź CommanderOps.NextArgument[cmd];
            depthLimit: INT Ź -1;
            Inner: PROC ~ {
                addr: CARD ~ Convert.CardFromRope[arg];
                PrintWord[cmd.out, addr, FALSE];
                <<IF NOT DesparatePrintReferent[cmd.out, addr] THEN IO.PutF[cmd.out, "Not a REF: %g (0%08xH) \n", [cardinal[addr]], 
                [cardinal[addr]]];>>
                };
            IF Rope.Equal[arg, "-d", FALSE] THEN {
                depthLimit Ź Convert.CardFromRope[CommanderOps.NextArgument[cmd]];
                arg Ź CommanderOps.NextArgument[cmd];
                };
            IO.PutF1[cmd.out, "%l", [rope["f"]]];
            IF depthLimit >= 0
                THEN  {
                    control: RefPrintControl Ź NEW[RefPrintControlRep Ź [seen: CardTab.Create[], depthLimit: depthLimit]];
                    ProcessProps.AddPropList[List.PutAssoc[$RefPrintControl, control, NIL], Inner];
                    }
                ELSE { Inner[] };
            IO.PutF1[cmd.out, "%l\n", [rope["F"]]];
            };

        Register[ATOMPrinter, SafeStorage.GetCanonicalReferentType[$a]];
        Register[ROPEPrinter, SafeStorage.GetCanonicalReferentType[Rope.Flatten[""]]];
        RegisterFallback[LORAPrinter];

        Commander.Register["RefPrint", RefPrintCommand, "args: [ -d depthLimit ] address\nPrint the referent of a REF"];


    END.