
    <<KipperSupportImpl.mesa December 6, 1985 9:35:33 am PST>>
        <<Copyright Ó 1985, 1986, 1987 by Xerox Corporation.  All rights reserved.>>
        <<Sturgis, January 6, 1986 1:26:43 pm PST>>
        <<Bill Jackson (bj) October 19, 1988 3:32:45 pm PDT>>

    DIRECTORY
        Basics USING [ Card16FromH, Card32FromF, FFromCard32, FFromInt32, FWORD, HFromCard16, HFromInt16, HWORD, Int16FromH, Int32FromF, 
        LongNumber, LowHalf, RawBytes, SwapHalves ],
        IO USING [ STREAM, UnsafeGetBlock, UnsafePutBlock ],
        KipperSupport USING [ Kipperer, KippererBody, KipperCard16, KipperCard32, KipperRef, KipperRope, Reason, UnKipperCard16, 
        UnKipperCard32, UnKipperRef, UnKipperRope, UnKipperer, UnKippererBody ],
        RefTab USING [ Create, EqualProc, Fetch, HashProc, Insert, Ref ],
        RefText USING [ ObtainScratch, ReleaseScratch ],
        Rope USING [ AppendChars, Cat, FromRefText, Length, ROPE, ToRefText ];

    KipperSupportImpl: CEDAR PROGRAM
        IMPORTS Basics, IO, KipperSupport, RefTab, RefText, Rope
        EXPORTS KipperSupport ~ {
        OPEN KipperSupport;
    <<Creation procedures>>
        Error: PUBLIC ERROR [ reason: Reason ] ~ CODE;
        KipperKey: CARD32 ~ 4207557320B; -- 221EDED0h, 572448464
        KipperKeyFSwapped: CARD32 ~ 33664021036B; -- 0DED0221Eh, -556785122
        KipperVersion: TYPE ~ MACHINE DEPENDENT { unknown(0), dMachine(1), fword(2), adaptive(3) };

        CreateKipperer: PUBLIC PROC [ s: IO.STREAM ] RETURNS [ k: Kipperer ] ~ {
            context: Context ~ NEW[ContextObject _ [version: fword] ];
            k _ NEW [KippererBody _ [s, 1, NIL, context]];
            k.KipperCard32[KipperKey];
            k.KipperCard16[KipperVersion.fword.ORD];
            <<RETURN [k];>>
            };

        Context: TYPE ~ REF ContextObject;
        ContextObject: TYPE ~ RECORD [
            version: KipperVersion
            ];

        CreateUnKipperer: PUBLIC PROC [ s: IO.STREAM ] RETURNS [ u: UnKipperer ] ~ {
            key: CARD32;
            version: CARD16;
            context: Context ~ NEW[ContextObject _ [version: unknown] ];
            u _ NEW [UnKippererBody _ [s, 1, NIL, context]];
            key _ u.UnKipperCard32[];
            SELECT TRUE FROM
                ( key = KipperKey ) => { NULL };
                ( key = KipperKeyFSwapped ) => { NULL };
                ENDCASE => { Error[notAKipperStream] };
            version _ u.UnKipperCard16[];
            SELECT version FROM
                ( KipperVersion.dMachine.ORD ) => { NULL };
                ( KipperVersion.fword.ORD ) => { NULL };
                ( KipperVersion.adaptive.ORD ) => { Error[unsupportedVersion] };
                ENDCASE => { Error[wrongKipperVersion] };
            context.version _ VAL[version];
            <<RETURN [u];>>
            };
    <<Internal procedures>>
        fzero: Basics.FWORD ~ [[0, 0], [0, 0]];

        RawBytes: PROC [ local: POINTER ] RETURNS [ raw: LONG POINTER TO Basics.RawBytes ] ~
        TRUSTED INLINE { raw _ LOOPHOLE[LONG[local], LONG POINTER TO Basics.RawBytes] };

        InternalPut16: PROC [ k: Kipperer, ptr: POINTER ] ~ TRUSTED INLINE {
        k.stream.UnsafePutBlock[[RawBytes[ptr], 2, 2]]; -- magic here: dorado: 0, sparc: 2!
            };

        InternalGet16: PROC [ u: UnKipperer, ptr: POINTER ] ~ TRUSTED INLINE {
        IF ( u.stream.UnsafeGetBlock[[RawBytes[ptr], 2, 2]] # 2 ) THEN ERROR;
            };

        InternalPut32: PROC [ k: Kipperer, ptr: POINTER ] ~ TRUSTED INLINE {
        k.stream.UnsafePutBlock[[RawBytes[ptr], 0, 4]];
            };

        InternalGet32: PROC [ u: UnKipperer, ptr: POINTER ] ~ TRUSTED INLINE {
            context: Context ~ NARROW[u.private];
            IF ( context.version = dMachine )
                THEN {
                dword32: Basics.LongNumber;
                IF ( u.stream.UnsafeGetBlock[[RawBytes[@dword32], 0, 4]] # 4 ) THEN ERROR;
                    LOOPHOLE[ptr, POINTER TO Basics.LongNumber]^ _ Basics.SwapHalves[dword32];
                    }
                ELSE {
                IF ( u.stream.UnsafeGetBlock[[RawBytes[ptr], 0, 4]] # 4 ) THEN ERROR;
                    };
            };

        InternalPutBytes: PROC [ k: Kipperer, ptr: POINTER, bytes: CARD16 ] ~ TRUSTED INLINE {
        k.stream.UnsafePutBlock[[RawBytes[ptr], 0, bytes]];
            };

        InternalGetBytes: PROC [ u: UnKipperer, ptr: POINTER, bytes: CARD16 ] ~ TRUSTED INLINE {
        IF ( u.stream.UnsafeGetBlock[[RawBytes[ptr], 0, bytes]] # bytes ) THEN ERROR;
            };

    <<Client callable procedures>>
        KipperBool: PUBLIC PROC [ k: Kipperer, bool: BOOL ] ~ {
            k.KipperCard16[IF ( bool ) THEN 1 ELSE 0];
            };

        UnKipperBool: PUBLIC PROC [ u: UnKipperer ] RETURNS [ BOOL ] ~ {
            RETURN [( u.UnKipperCard16[] = 1 )];
            };

        KipperCard16: PUBLIC PROC [ k: Kipperer, card16: CARD16 ] ~ TRUSTED {
            hword: Basics.HWORD _ Basics.HFromCard16[card16];
            InternalPut16[k, @hword];
            };

        UnKipperCard16: PUBLIC PROC [ u: UnKipperer ] RETURNS [ card16: CARD16 ] ~ TRUSTED {
            fword: Basics.FWORD _ fzero; -- so we don't get trash
            InternalGet16[u, @fword];
            card16 _ Basics.Card16FromH[fword.lo];
            };

        KipperCard32: PUBLIC PROC [ k: Kipperer, card32: CARD32 ] ~ TRUSTED {
            fword: Basics.FWORD _ Basics.FFromCard32[card32];
            InternalPut32[k, @fword];
            };

        UnKipperCard32: PUBLIC PROC [u: UnKipperer] RETURNS [ card32: CARD32 ] ~ TRUSTED {
            fword: Basics.FWORD;
            InternalGet32[u, @fword];
            card32 _ Basics.Card32FromF[fword];
            };

        KipperChar: PUBLIC PROC [ k: Kipperer, char: CHAR ] ~ {
            k.KipperCard16[char.ORD];
            };

        UnKipperChar: PUBLIC PROC [ u: UnKipperer ] RETURNS [ char: CHAR ] ~ {
            RETURN [VAL[u.UnKipperCard16[]]];
            };

        KipperInt16: PUBLIC PROC [ k: Kipperer, int16: INT16 ] ~ TRUSTED {
            hword: Basics.HWORD _ Basics.HFromInt16[int16];
            InternalPut16[k, @hword];
            };

        UnKipperInt16: PUBLIC PROC [ u: UnKipperer ] RETURNS [ int16: INT16 ] ~ TRUSTED {
            fword: Basics.FWORD _ fzero; -- so we don't get trash
            InternalGet16[u, @fword];
            int16 _ Basics.Int16FromH[fword.lo];
            };

        KipperInt32: PUBLIC PROC [ k: Kipperer, int32: INT32 ] ~ TRUSTED {
            fword: Basics.FWORD _ Basics.FFromInt32[int32];
            InternalPut32[k, @fword];
            };

        UnKipperInt32: PUBLIC PROC [ u: UnKipperer ] RETURNS [ int32: INT32 ] ~ TRUSTED {
            fword: Basics.FWORD;
            InternalGet32[u, @fword];
            int32 _ Basics.Int32FromF[fword];
            };

        KipperNat31: PUBLIC PROC [ k: Kipperer, nat: NAT ] ~ TRUSTED {
            fword: Basics.FWORD _ Basics.FFromCard32[nat];
            InternalPut32[k, @fword];
            };

        UnKipperNat31: PUBLIC PROC [ u: UnKipperer ] RETURNS [ nat: NAT ]  ~ TRUSTED {
            fword: Basics.FWORD;
            InternalGet32[u, @fword];
            nat _ Basics.Card32FromF[fword];
            };

        FFromReal: PROC [n: REAL] RETURNS [Basics.FWORD]
            = INLINE { RETURN[LOOPHOLE[n]] };
        RealFromF: PROC [f: Basics.FWORD] RETURNS [REAL]
            = INLINE { RETURN[LOOPHOLE[f]] };

        KipperReal: PUBLIC PROC [ k: Kipperer, real: REAL ] ~ TRUSTED {
            fword: Basics.FWORD _ --Basics.--FFromReal[real];
            InternalPut32[k, @fword];
            };

        UnKipperReal: PUBLIC PROC [ u: UnKipperer ] RETURNS [ real: REAL ] ~ TRUSTED {
            fword: Basics.FWORD;
            InternalGet32[u, @fword];
            real _ --Basics.--RealFromF[fword];
            };

        KipperRefText: PUBLIC PROC [ k: Kipperer, refText: REF TEXT ] ~ {
            k.KipperRope[Rope.FromRefText[refText]];
            };

        UnKipperRefText: PUBLIC PROC [ u: UnKipperer ] RETURNS [ refText: REF TEXT ] ~ {
            refText _  Rope.ToRefText[u.UnKipperRope[]];
            };

            RopeBundleSize: CARD16 _ 100;

            KipperRope: PUBLIC PROC [ k: Kipperer, rope: Rope.ROPE ] ~ TRUSTED {
                IF ( k.KipperRef[rope] ) THEN {
                    textBuffer: REF TEXT _ RefText.ObtainScratch[RopeBundleSize];
                    {
                        ENABLE { UNWIND => RefText.ReleaseScratch[textBuffer] };
                        position: INT _ 0;
                        remaining: INT _ rope.Length[];
                        thisBundleSize: CARD16;
                        thisByteCount: CARD16;
                        WHILE ( remaining > 0 ) DO
                            thisBundleSize _ Rope.AppendChars[textBuffer, rope, position, RopeBundleSize];
                            thisByteCount _ ( ( thisBundleSize + 1 ) / 2 ) * 2;
                            InternalPut16[k, @thisBundleSize];
                            InternalPutBytes[k, BASE[DESCRIPTOR[textBuffer^]], thisByteCount];
                            textBuffer.length _ 0;
                            position _ position + thisBundleSize;
                            remaining _ remaining - thisBundleSize;
                            ENDLOOP;
                        thisBundleSize _ 0;
                        InternalPut16[k, @thisBundleSize];
                        };
                    RefText.ReleaseScratch[textBuffer];
                    };
                };

            UnKipperRope: PUBLIC PROC [ u: UnKipperer ] RETURNS [ rope: Rope.ROPE _ NIL ] ~ TRUSTED {
                flag: BOOL; ref: REF ANY;
                [flag, ref] _ u.UnKipperRef[];
                IF ( NOT flag )
                    THEN {
                        rope _ NARROW[ref];
                        RETURN;
                        }
                    ELSE {
                        textBuffer: REF TEXT _ RefText.ObtainScratch[RopeBundleSize];
                        {
                            ENABLE { UNWIND => RefText.ReleaseScratch[textBuffer] };
                            thisBundleSize: CARD16 _ u.UnKipperCard16[];
                                <<InternalGet16[u, @thisBundleSize]; - could be more efficient>>
                            WHILE ( thisBundleSize > 0 ) DO
                                thisByteCount: CARD16 ~ ( ( thisBundleSize + 1 ) / 2 ) * 2;
                                InternalGetBytes[u, BASE[DESCRIPTOR[textBuffer^]], thisByteCount];
                                textBuffer.length _ thisBundleSize;
                                rope _ rope.Cat[Rope.FromRefText[textBuffer]];
                                thisBundleSize _ u.UnKipperCard16[];
                                    <<InternalGet16[u, @thisBundleSize]; - could be more efficient>>
                                ENDLOOP;
                            };
                        RefText.ReleaseScratch[textBuffer];
                        RecordUnKipperedRef[u, rope];
                        RETURN;
                        };
                };

            KipperWord: PUBLIC PROC [ k: Kipperer, word: WORD ] ~ TRUSTED {
                hword: Basics.HWORD _ Basics.HFromCard16[word];
                InternalPut16[k, @hword];
                };

            UnKipperWord: PUBLIC PROC [ u: UnKipperer ] RETURNS [ word: WORD ] ~ TRUSTED {
                fword: Basics.FWORD _ fzero; -- so we don't get trash
                InternalGet16[u, @fword];
                word _ Basics.Card16FromH[fword.lo];
                };
    <<Private Procedures called by generated stubs>>
        KipperRef: PUBLIC PROC [ k: Kipperer, r: REF ANY ] RETURNS [ kipperTheBody: BOOL ] ~ TRUSTED {
            <<first a one word flag, perhaps followed by more data>>
                <<0 for body follows -- this agrees with Lupine "ref=NIL", when ref is non NIL.>>
                <<1 for NIL -- this agrees with Lupine "ref=NIL", when ref is NIL.>>
                <<2 for encoding as INT follows, assumes same ref was seen earlier>>

            IF ( r = NIL )
                THEN {
                    one: CARD16 _ 1;
                    InternalPut16[k, @one];
                    kipperTheBody _ FALSE;
                    RETURN;
                    }
                ELSE {
                    refEncoding: CARD32 _ LookUpPossiblyKipperedRef[k, r, k.refCounter];
                    IF ( refEncoding # 0 )
                        THEN {
                            two: CARD16 _ 2;
                            InternalPut16[k, @two];
                            InternalPut32[k, @refEncoding];
                            kipperTheBody _ FALSE;
                            RETURN;
                            }
                        ELSE {
                            zero: CARD16 _ 0;
                            InternalPut16[k, @zero];
                            k.refCounter _ k.refCounter.SUCC;
                            kipperTheBody _ TRUE;
                            RETURN;
                            };
                    };
            };

        UnKipperRef: PUBLIC PROC [ u: UnKipperer ]
        RETURNS [ kipperTheBody: BOOL, ref: REF ANY ] ~ TRUSTED {
            flag: CARD16 _ u.UnKipperCard16[];
                <<InternalGet16[u, @flag]; - could be more efficient>>
            SELECT flag FROM
                0 => { RETURN [TRUE, NIL] };
                1 => { RETURN [FALSE, NIL] };
                2 =>  {
                    code: CARD32;
                    InternalGet32[u, @code];
                    RETURN [FALSE, LookUpPreviouslyUnKipperedRef[u.refTable, code]];
                    };
                ENDCASE => { ERROR };
            };

        RecordUnKipperedRef: PUBLIC PROC [ u: UnKipperer, r: REF ANY ] ~ {
            IF ( u.refTable = NIL ) THEN {
                u.refTable _ RefTab.Create[equal: EqualCode, hash: HashCode];
                };
            IF ( NOT u.refTable.Insert[NEW [CARD32 _ u.refCounter], r] ) THEN ERROR;
            u.refCounter _ u.refCounter.SUCC;
            };

        LookUpPreviouslyUnKipperedRef: PROC [ t: RefTab.Ref, code: CARD32 ]
        RETURNS [ ref: REF ANY ] ~ {
            found: BOOL;
            [found, ref] _ t.Fetch[NEW [CARD32 _ code]];
            IF ( NOT found ) THEN ERROR;
            RETURN;
            };

        LookUpPossiblyKipperedRef: PROC [ k: Kipperer, r: REF ANY, c: CARD32 ]
        RETURNS [ card32: CARD32 _ 0 ] ~ {
            IF ( k.refTable = NIL ) THEN {
                k.refTable _ RefTab.Create[equal: EqualRef, hash: HashRef];
                };
            {
                found: BOOL; indexRef: REF ANY;
                [found, indexRef] _ k.refTable.Fetch[r];
                IF ( found ) THEN { card32 _ NARROW[indexRef, REF CARD32]^; RETURN};
                };
            {
                codedRef: REF CARD32;
                codedRef _ NEW [CARD32 _ c];
                IF ( NOT k.refTable.Insert[r, codedRef] ) THEN ERROR;
                };
            RETURN;
            };

        EqualRef: RefTab.EqualProc ~ CHECKED {
            RETURN [( key1 = key2 )];
            };

        HashRef: RefTab.HashProc ~ CHECKED {
            RETURN [Basics.LowHalf[LOOPHOLE[key]]];
            };

        EqualCode: RefTab.EqualProc ~ CHECKED {
            RETURN [NARROW[key1, REF CARD32]^ = NARROW[key2, REF CARD32]^];
            };

        HashCode: RefTab.HashProc ~ CHECKED {
            RETURN [Basics.LowHalf[NARROW[key, REF CARD32]^]];
            };

        }.