
    <<PrintProcImpl.mesa>>
        <<Copyright © 1985 by Xerox Corporation.  All rights reserved.>>
        <<Paul Rovner, November 3, 1983 12:53 pm>>
        <<MBrown, January 13, 1984 2:49 pm>>
        <<Russ Atkinson (RRA) February 12, 1985 2:10:23 pm PST>>

    DIRECTORY
        AMTypes USING [TV, Type, nullType, Class],
        AMBridge USING [TVForReadOnlyReferent, TVForROPE, TVForATOM],
        IO USING [PutChar],
        IOUtils USING [RegisterPrintRefAny, PrintRefAnyProc],
        PrintTV USING [TVPrintProc, RefPrintProc, Print],
        Rope USING [ROPE],
        SafeStorage USING [GetCanonicalType, GetReferentType];

    PrintProcImpl: CEDAR MONITOR  -- protects printproc registries
        IMPORTS AMBridge, IO, IOUtils, SafeStorage, PrintTV
        EXPORTS PrintTV
        = BEGIN OPEN AMTypes, PrintTV, SafeStorage;

        tvPrintProcsEnabled: BOOL _ TRUE;
        classPrintProcsEnabled: BOOL _ TRUE;
        refPrintProcsEnabled: BOOL _ TRUE;

        tvPrintProcList: TVPrintProcList _ NIL;
            TVPrintProcList: TYPE = LIST OF TVPrintProcListRecord;
            TVPrintProcListRecord: TYPE = RECORD [type: Type, proc: TVPrintProc, data: REF];

        classPrintProcList: ClassPrintProcList _ NIL;
            ClassPrintProcList: TYPE = LIST OF ClassPrintProcListRecord;
            ClassPrintProcListRecord: TYPE = RECORD [class: Class, proc: TVPrintProc, data: REF];

        refPrintProcList: RefPrintProcList _ NIL;
            RefPrintProcList: TYPE = LIST OF RefPrintProcListRecord;
            RefPrintProcListRecord: TYPE = RECORD [type: Type, proc: RefPrintProc, data: REF];

        RegisterTVPrintProc: PUBLIC ENTRY PROC [type: Type, proc: TVPrintProc, data: REF _ NIL] = {
            ENABLE UNWIND => NULL;
            prev, new: TVPrintProcList _ NIL;
            type _ GetCanonicalType[type];
            FOR x: TVPrintProcList _ tvPrintProcList, x.rest UNTIL x = NIL DO
                IF LOOPHOLE[x.first.type, CARDINAL] = LOOPHOLE[type, CARDINAL]
                    THEN {
                        IF proc = NIL
                            THEN {  -- splice it out
                                IF prev = NIL THEN tvPrintProcList _ x.rest ELSE prev.rest _ x.rest;
                                }
                            ELSE {--change bindings--x.first.proc _ proc; x.first.data _ data};
                        RETURN;
                        }
                ELSE IF LOOPHOLE[x.first.type, CARDINAL] > LOOPHOLE[type, CARDINAL]
                    THEN EXIT;
                prev _ x;
                ENDLOOP;
            <<splice it in>>
            new _ LIST[[type: type, proc: proc, data: data]];
            IF prev = NIL
                THEN {
                    new.rest _ tvPrintProcList;
                    tvPrintProcList _ new}
                ELSE {
                    new.rest _ prev.rest;
                    prev.rest _ new};
            };

        RegisterClassPrintProc: PUBLIC ENTRY PROC [class: Class, proc: TVPrintProc, data: REF _ NIL] = {
            ENABLE UNWIND => NULL;
            prev, new: ClassPrintProcList _ NIL;
            FOR x: ClassPrintProcList _ classPrintProcList, x.rest UNTIL x = NIL DO
                IF x.first.class = class
                    THEN {
                        IF proc = NIL
                            THEN {  -- splice it out
                                IF prev = NIL THEN classPrintProcList _ x.rest ELSE prev.rest _ x.rest;
                                }
                            ELSE {--change bindings--x.first.proc _ proc; x.first.data _ data};
                        RETURN;
                        }
                ELSE IF LOOPHOLE[x.first.class, CARDINAL] > LOOPHOLE[class, CARDINAL]
                    THEN EXIT;
                prev _ x;
                ENDLOOP;
            <<splice it in>>
            new _ LIST[[class: class, proc: proc, data: data]];
            IF prev = NIL
                THEN {
                    new.rest _ classPrintProcList;
                    classPrintProcList _ new}
                ELSE {
                    new.rest _ prev.rest;
                    prev.rest _ new};
            };

        RegisterRefPrintProc: PUBLIC ENTRY PROC [referentType: Type, proc: RefPrintProc, data: REF _ NIL] = {
            ENABLE UNWIND => NULL;
            prev, new: RefPrintProcList _ NIL;
            type: Type _ GetCanonicalType[referentType];
            FOR x: RefPrintProcList _ refPrintProcList, x.rest UNTIL x = NIL DO
                IF LOOPHOLE[x.first.type, CARDINAL] = LOOPHOLE[type, CARDINAL]
                    THEN {
                        IF proc = NIL
                            THEN {  -- splice it out
                                IF prev = NIL THEN refPrintProcList _ x.rest ELSE prev.rest _ x.rest;
                                }
                            ELSE {--change bindings--x.first.proc _ proc; x.first.data _ data};
                        RETURN;
                        }
                ELSE IF LOOPHOLE[x.first.type, CARDINAL] > LOOPHOLE[type, CARDINAL]
                    THEN EXIT;
                prev _ x;
                ENDLOOP;
            <<splice it in>>
            new _ LIST[[type: type, proc: proc, data: data]];
            IF prev = NIL
                THEN {
                    new.rest _ refPrintProcList;
                    refPrintProcList _ new}
                ELSE {
                    new.rest _ prev.rest;
                    prev.rest _ new};
            };

        DisableTVPrintProcs: PUBLIC ENTRY PROC RETURNS [wasEnabled: BOOL] = {
            ENABLE UNWIND => NULL;
            wasEnabled _ tvPrintProcsEnabled;
            tvPrintProcsEnabled _ FALSE;
            };
        DisableClassPrintProcs: PUBLIC ENTRY PROC RETURNS [wasEnabled: BOOL] = {
            ENABLE UNWIND => NULL;
            wasEnabled _ classPrintProcsEnabled;
            classPrintProcsEnabled _ FALSE;
            };
        DisableRefPrintProc: PUBLIC ENTRY PROC RETURNS [wasEnabled: BOOL] = {
            ENABLE UNWIND => NULL;
            wasEnabled _ refPrintProcsEnabled;
            refPrintProcsEnabled _ FALSE;
            };

        EnableTVPrintProcs: PUBLIC ENTRY PROC RETURNS [wasEnabled: BOOL] = {
            ENABLE UNWIND => NULL;
            wasEnabled _ classPrintProcsEnabled;
            classPrintProcsEnabled _ TRUE;
            };
        EnableClassPrintProcs: PUBLIC ENTRY PROC RETURNS [wasEnabled: BOOL] = {
            ENABLE UNWIND => NULL;
            wasEnabled _ tvPrintProcsEnabled;
            tvPrintProcsEnabled _ TRUE;
            };
        EnableRefPrintProc: PUBLIC ENTRY PROC RETURNS [wasEnabled: BOOL] = {
            ENABLE UNWIND => NULL;
            wasEnabled _ refPrintProcsEnabled;
            refPrintProcsEnabled _ TRUE;
            };

        GetTVPrintProc: PUBLIC ENTRY PROC [type: Type] RETURNS [proc: TVPrintProc, data: REF] = {
            ENABLE UNWIND => NULL;
            <<proc # NIL => print proc provided>>
            x: TVPrintProcList;
            IF NOT tvPrintProcsEnabled THEN RETURN [NIL, NIL];
            type _ GetCanonicalType[type];
            FOR x _ tvPrintProcList, x.rest UNTIL x = NIL DO
                IF x.first.type = type THEN RETURN [x.first.proc, x.first.data];
                IF LOOPHOLE[x.first.type, CARDINAL] > LOOPHOLE[type, CARDINAL] THEN EXIT;
                ENDLOOP;
            RETURN [NIL, NIL];
            };

        GetClassPrintProc: PUBLIC ENTRY PROC [class: Class] RETURNS [proc: TVPrintProc, data: REF] = {
            ENABLE UNWIND => NULL;
            <<proc # NIL => print proc provided>>
            x: ClassPrintProcList;
            IF NOT classPrintProcsEnabled THEN RETURN [NIL, NIL];
            FOR x _ classPrintProcList, x.rest UNTIL x = NIL DO
                IF x.first.class = class THEN RETURN [x.first.proc, x.first.data];
                IF LOOPHOLE[x.first.class, CARDINAL] > LOOPHOLE[class, CARDINAL] THEN EXIT;
                ENDLOOP;
            RETURN [NIL, NIL];
            };

        GetRefPrintProc: PUBLIC ENTRY PROC [type: Type] RETURNS [proc: RefPrintProc, data: REF] = {
            ENABLE UNWIND => NULL;
            <<proc # NIL => print proc provided>>
            x: RefPrintProcList;
            IF NOT refPrintProcsEnabled THEN RETURN [NIL, NIL];
            type _ GetCanonicalType[type];
            FOR x _ refPrintProcList, x.rest UNTIL x = NIL DO
                IF x.first.type = type THEN RETURN [x.first.proc, x.first.data];
                IF LOOPHOLE[x.first.type, CARDINAL] > LOOPHOLE[type, CARDINAL] THEN EXIT;
                ENDLOOP;
            RETURN [NIL, NIL];
            };

        NextTVPrintProc: PUBLIC ENTRY PROC [after: Type _ nullType] RETURNS [type: Type, proc: TVPrintProc, data: REF] = {
            <<provides a stateless enumerator for print procs>>
            ENABLE UNWIND => NULL;
            FOR x: TVPrintProcList _ tvPrintProcList, x.rest UNTIL x = NIL DO
                IF after = nullType OR LOOPHOLE[x.first.type, CARDINAL] > LOOPHOLE[after, CARDINAL]
                    THEN RETURN [x.first.type, x.first.proc, x.first.data];
                ENDLOOP;
            RETURN [after, NIL, NIL];
            };

        NextClassPrintProc: PUBLIC ENTRY PROC [after: Class _ nil] RETURNS [class: Class, proc: TVPrintProc, data: REF] = {
            <<provides a stateless enumerator for print procs>>
            ENABLE UNWIND => NULL;
            FOR x: ClassPrintProcList _ classPrintProcList, x.rest UNTIL x = NIL DO
                IF after = nil OR LOOPHOLE[x.first.class, CARDINAL] > LOOPHOLE[after, CARDINAL]
                    THEN RETURN [x.first.class, x.first.proc, x.first.data];
                ENDLOOP;
            RETURN [after, NIL, NIL];
            };

        NextRefPrintProc: PUBLIC ENTRY PROC [after: Type _ nullType] RETURNS [type: Type, proc: RefPrintProc, data: REF] = {
            <<provides a stateless enumerator for print procs>>
            ENABLE UNWIND => NULL;
            FOR x: RefPrintProcList _ refPrintProcList, x.rest UNTIL x = NIL DO
                IF after = nullType OR LOOPHOLE[x.first.type, CARDINAL] > LOOPHOLE[after, CARDINAL]
                    THEN RETURN [x.first.type, x.first.proc, x.first.data];
                ENDLOOP;
            RETURN [after, NIL, NIL];
            };

        PrintRefAny: IOUtils.PrintRefAnyProc = {
            <<PROC [stream: STREAM, refAny: REF READONLY ANY, depth: INT, width: INT, verbose: BOOL]>>
            proc: RefPrintProc;
            data: REF;
            TRUSTED {
                [proc: proc, data: data] _ GetRefPrintProc[GetReferentType[LOOPHOLE[refAny, REF]]];
                };
            IF proc = NIL OR proc[refAny, data, stream, depth, width, verbose].useOld THEN {
                tv: AMTypes.TV;
                ra: REF ANY;
                TRUSTED {
                    ra _ LOOPHOLE[refAny];
                        <<so ROPE and ATOM arms will work (around compiler bug?)>>
                    WITH ra SELECT FROM
                        rope: Rope.ROPE => tv _ AMBridge.TVForROPE[rope];
                        atom: ATOM => tv _ AMBridge.TVForATOM[atom];
                        ENDCASE => {
                            IF ra # NIL THEN stream.PutChar['^];
                            tv _ AMBridge.TVForReadOnlyReferent[ref: refAny]}};
                PrintTV.Print[tv: tv, put: stream, depth: depth, width: width, verbose: verbose];
                };
            };
        <<>>
        <<>>
        <<START HERE>>

        IOUtils.RegisterPrintRefAny[PrintRefAny];

        END.