
    <<RoseRecordImpl.mesa>>
        <<Copyright © 1985 by Xerox Corporation.  All rights reserved.>>
        <<Barth, September 5, 1985 6:37:22 pm PDT>>
        <<Spreitzer, November 18, 1985 10:36:53 pm PST>>

    DIRECTORY Basics, BitTwiddling, Convert, CoreOps, IO, PrincOpsUtils, Rope, RoseBehavior, RoseWireClasses, RoseWireFormats, 
    RoseWireTypes, RoseWireTypeUse, RoseWiring, VFonts;

    RoseRecordImpl: CEDAR PROGRAM
        IMPORTS BitTwiddling, CoreOps, IO, Rope, RoseWireFormats, RoseWireTypeUse, RoseWireTypes, RoseWiring
        EXPORTS RoseWireClasses, RoseWireTypes =

    BEGIN OPEN CO: CoreOps, RoseWireTypes;

    SwitchVal: TYPE = RoseBehavior.SwitchVal;
    Level: TYPE = RoseBehavior.Level;

    RecordClass: TYPE = REF RecordClassPrivate;
    RecordClassPrivate: TYPE = RECORD [
        name: ROPE,
        bitSize, wordSize: NAT,
        repAux: Mesa _ [],
        fields: SEQUENCE length: NAT OF RecordClassField
        ];

    RecordClassField: TYPE = RECORD [
        name: ROPE,
        rwc: RoseWireClass,
        bitOffset, bitCount: NAT
        ];

    RecordType: TYPE = REF RecordTypePrivate;
    RecordTypePrivate: TYPE = RECORD [
        rwt: RoseWireType,
        fields: SEQUENCE length: NAT OF RecordTypeField
        ];

    RecordTypeField: TYPE = RECORD [
        rwt: RoseWireType
        ];

    GetRecord: PUBLIC PROC [prototype: Wire, flavor: WireFlavor] RETURNS [rwc: RoseWireClass] = {
        name: ROPE = RoseWiring.WireName[prototype];
        rc: RecordClass _ NEW [RecordClassPrivate[prototype.elements.size]];
        rwtUser: RoseWireTypeUse.RoseWireTypeUser = RoseWireTypeUse.CreateUser[];
        bitOffset: NAT _ 0;
        afterPrev: NAT _ 0;
        ComputeOffset: PROC [index, bitCount: NAT] = {
            w0: NAT _ bitOffset / Basics.bitsPerWord;
            w1: NAT _ (bitOffset + bitCount - 1) / Basics.bitsPerWord;
            om: NAT  _ bitOffset MOD Basics.bitsPerWord;
            IF bitCount > Basics.bitsPerWord AND bitCount MOD Basics.bitsPerWord # 0 THEN ERROR;
            IF w1 > w0 AND om # 0 THEN {
                delta: NAT _ Basics.bitsPerWord - om;
                bitOffset _ bitOffset + delta;
                IF index > 0 THEN rc.fields[index - 1].bitOffset _ rc.fields[index - 1].bitOffset + delta;
                };
            };
        def: IO.STREAM _ IO.ROS[];
        firstDefdField: BOOL _ TRUE;
        addressContaining: BOOL _ FALSE;
        AddField: PROC [varFmt, typeFmt: ROPE, first, last: INT, v1, v2: IO.Value _ [null[]] ] = {
            firstRem: INT = first MOD Basics.bitsPerWord;
            align: ROPE = IO.PutFR[
                "(%g:%g..%g)",
                [integer[first/Basics.bitsPerWord]],
                [integer[firstRem]],
                [integer[last - first + firstRem]]
                ];
            IF firstDefdField THEN firstDefdField _ FALSE ELSE def.PutRope[","];
            def.PutRope["\n\t"];
            def.PutF[varFmt.Cat[align, typeFmt], v1, v2];
            };
        fillCount: NAT _ 0;
        moduleRefs: ARRAY RoseWireTypeUse.ModuleRefType OF LOR;
        bitBucket: ROPE;
        IF StructureOfWire[prototype] # record THEN ERROR;
        rc.name _ name.Cat[WireFlavorName[flavor]];
        def.PutF["%g: TYPE = MACHINE DEPENDENT RECORD [", [rope[rc.name]]];
        FOR i: NAT IN [0 .. rc.length) DO
            ew: Wire = prototype.elements[i];
            ewc: RoseWireClass = RoseWiring.GetWiring[ew, flavor];
            bitCount: NAT = ewc.super.Bits[ewc];
            IF bitCount < 1 THEN ERROR;
            ComputeOffset[i, bitCount];
            IF CO.GetWireName[ew].Length[] = 0 THEN ERROR;
            rc.fields[i] _ [
                name: CO.GetWireName[ew],
                rwc: ewc,
                bitOffset: bitOffset,
                bitCount: bitCount
                ];
            addressContaining _ addressContaining OR ewc.dereference OR ewc.addressContaining;
            bitOffset _ bitOffset + bitCount;
            ENDLOOP;
        IF bitOffset > Basics.bitsPerWord AND bitOffset MOD Basics.bitsPerWord # 0 THEN {
            delta: NAT _ Basics.bitsPerWord - (bitOffset MOD Basics.bitsPerWord);
            bitOffset _ bitOffset + delta;
            rc.fields[rc.length-1].bitOffset _ rc.fields[rc.length-1].bitOffset + delta;
            };
        rc.bitSize _ bitOffset;
        rc.wordSize _ (bitOffset + Basics.bitsPerWord - 1)/Basics.bitsPerWord;
        FOR i: NAT IN [0 .. rc.length) DO
            bitOffset: NAT = rc.fields[i].bitOffset;
            swc: RoseWireClass = rc.fields[i].rwc;
            sm: Mesa = swc.super.MesaRepresentation[swc];
            rwtUser.NoteMesa[sm];
            IF afterPrev # bitOffset THEN AddField[
                "fill%g", ": [0 .. %g]",
                afterPrev,
                bitOffset-1,
                [integer[fillCount _ fillCount + 1]],
                [cardinal[BitTwiddling.oneLessThanTwoToThe[bitOffset-afterPrev]]]
                ];
            afterPrev _ bitOffset + rc.fields[i].bitCount;
            AddField[
                "%g", ": %g",
                bitOffset,
                afterPrev-1,
                [rope[rc.fields[i].name]],
                [rope[sm.mesa]]
                ];
            ENDLOOP;
        def.PutRope["]"];
        [bitBucket, moduleRefs] _ rwtUser.DestroyUser[];
        IF bitBucket.Length[] # 0 THEN ERROR;
        rc.repAux.directory _ moduleRefs[Directory];
        rc.repAux.imports _ moduleRefs[Import];
        IF moduleRefs[Export] # NIL OR moduleRefs[Open] # NIL THEN ERROR;
        rc.repAux.mesa _ def.RopeFromROS[];
        rwc _ NEW[RoseWireClassRec _ [
            structure: record,
            dereference: FALSE,
            addressContaining: addressContaining,
            length: rc.length,
            classData: rc,
            super: recordSuperClasses[flavor]]];
        };

    recordSuperClasses: ARRAY WireFlavor OF RoseWireSuperClass _ ALL[NIL];

    RecordGetType: PROC [rwc: RoseWireClass, wire: Wire] RETURNS [rwt: RoseWireType] = {
        rc: RecordClass = NARROW[rwc.classData];
        rt: RecordType = NEW [RecordTypePrivate[wire.elements.size]];
        IF StructureOfWire[wire] # record THEN ERROR;
        IF rt.length # rc.length THEN ERROR;
        FOR i: NAT IN [0 .. rt.length) DO
            ew: Wire = wire.elements[i];
            ewc: RoseWireClass = rc.fields[i].rwc;
            rt.fields[i] _ [
                rwt: ewc.super.GetType[ewc, ew]
                ];
            ENDLOOP;
        rwt _ NEW[RoseWireTypeRec _ [
            class: rwc,
            typeData: rt,
            length: rt.length,
            other: NIL]];
        };

    RecordListFormats: PROC [rwt: RoseWireType] RETURNS [lor: LOR] = {
        lor _ LIST["idiosyncratic", "2", "4", "8", "16"];
        };

    RecordGetFormat: PROC [rwt: RoseWireType, formatName: ROPE] RETURNS [format: Format] = {
        format _ SELECT TRUE FROM
            formatName.Equal["2"] => RoseWireFormats.constructNumericRecord[1],
            formatName.Equal["4"] => RoseWireFormats.constructNumericRecord[2],
            formatName.Equal["8"] => RoseWireFormats.constructNumericRecord[3],
            formatName.Equal["16"], formatName=NIL => RoseWireFormats.constructNumericRecord[4],
            formatName.Equal["idiosyncratic"] => RoseWireFormats.constructIdiosyncraticRecord,
            ENDCASE => ERROR;
        };

    RecordSelectorOffset: PROC [rwt: RoseWireType, sel: Selector] RETURNS [dBits: NAT] = {
        rc: RecordClass = NARROW[rwt.class.classData];
        WITH sel SELECT FROM
            whole => RETURN [0];
            field => RETURN [rc.fields[index].bitOffset];
            subscript => ERROR
            ENDCASE => ERROR;
        };

    RecordFieldName: PROC [rwc: RoseWireClass, index: INT] RETURNS [ROPE] = {
        rc: RecordClass = NARROW[rwc.classData];
        RETURN [rc.fields[index].name];
        };

    RecordSubType: PROC [rwt: RoseWireType, sel: Selector] RETURNS [RoseWireType] = {
        rt: RecordType = NARROW[rwt.typeData];
        WITH sel SELECT FROM
            whole => RETURN [rwt];
            field => RETURN [rt.fields[index].rwt];
            subscript => ERROR
            ENDCASE => ERROR;
        };

    RecordSubClass: PROC [rwc: RoseWireClass, sel: Selector] RETURNS [RoseWireClass] = {
        rc: RecordClass = NARROW[rwc.classData];
        WITH sel SELECT FROM
            whole => RETURN [rwc];
            field => RETURN [rc.fields[index].rwc];
            subscript => ERROR
            ENDCASE => ERROR;
        };

    RecordBits: PROC [rwc: RoseWireClass] RETURNS [n: INT] = {
        rc: RecordClass = NARROW[rwc.classData];
        n _ rc.bitSize;
        };

    RecordMesaRepresentation: PROC [rwc: RoseWireClass] RETURNS [mesa: Mesa] = {
        rc: RecordClass = NARROW[rwc.classData];
        mesa _ [mesa: rc.name];
        };

    RecordMesaRepAux: PROC [rwc: RoseWireClass] RETURNS [mesa: Mesa] = {
        rc: RecordClass = NARROW[rwc.classData];
        mesa _ rc.repAux;
        };

    RecordInitialize: PROC [rwt: RoseWireType, p: Ptr, steady: BOOL] = {
        rc: RecordClass = NARROW[rwt.class.classData];
        rt: RecordType = NARROW[rwt.typeData];
        FOR i: NAT IN [0 .. rc.length) DO
            rt.fields[i].rwt.class.super.Initialize[
                rt.fields[i].rwt,
                BitTwiddling.OffsetPtr[p, rc.fields[i].bitOffset],
                steady
                ];
            ENDLOOP;
        steady _ steady;
        };

    RecordTransduce: PROC [fromS: Strength, fromT, toT: RoseWireType, fromP, toP: Ptr] = {
        rc: RecordClass = NARROW[fromT.class.classData];
        rt: RecordType = NARROW[fromT.typeData];
        IF fromT.class.structure # record THEN ERROR;
        IF toT.class.structure # record THEN ERROR;
        IF fromT.length # toT.length THEN ERROR;
        IF toT.class.dereference THEN toP _ BitTwiddling.DeReferencePtr[toP];
        FOR i: NAT IN [0 .. rc.length) DO
            subFrom: Ptr = BitTwiddling.OffsetPtr[fromP, rc.fields[i].bitOffset];
            sel: Selector = [field[i]];
            subTo: Ptr = BitTwiddling.OffsetPtr[toP, toT.class.super.SelectorOffset[toT, sel]];
            rt.fields[i].rwt.class.super.Transduce[
                fromS: fromS,
                fromT: rt.fields[i].rwt,
                toT: toT.class.super.SubType[toT, sel],
                fromP: subFrom,
                toP: subTo];
            toT _ toT;
            ENDLOOP;
        toT _ toT;
        };

    RecordInitQ: PROC [rwt: RoseWireType, p: Ptr, cap: Strength] = TRUSTED {
        rc: RecordClass = NARROW[rwt.class.classData];
        rt: RecordType = NARROW[rwt.typeData];
        FOR i: NAT IN [0 .. rc.length) DO
            subType: RoseWireType = rt.fields[i].rwt;
            subType.class.super.InitQ[
                subType,
                BitTwiddling.OffsetPtr[p, rc.fields[i].bitOffset],
                cap];
            cap _ cap;
            ENDLOOP;
        cap _ cap;
        };

    RecordInitUD: PROC [rwt: RoseWireType, p: Ptr, cap: Strength] RETURNS [isInput: BOOL] = TRUSTED {
        rc: RecordClass = NARROW[rwt.class.classData];
        rt: RecordType = NARROW[rwt.typeData];
        isInput _ TRUE;
        FOR i: NAT IN [0 .. rc.length) DO
            subType: RoseWireType = rt.fields[i].rwt;
            subInput: BOOL _ subType.class.super.InitUD[
                subType,
                BitTwiddling.OffsetPtr[p, rc.fields[i].bitOffset],
                cap];
            isInput _ isInput AND subInput;
            ENDLOOP;
        cap _ cap;
        };

    RecordComputeLevel: PROC [rwt: RoseWireType, p: Ptr, xPhobic: BOOL] RETURNS [delay: BOOL] = TRUSTED {
        rc: RecordClass = NARROW[rwt.class.classData];
        rt: RecordType = NARROW[rwt.typeData];
        delay _ FALSE;
        FOR i: NAT IN [0 .. rc.length) DO
            subType: RoseWireType = rt.fields[i].rwt;
            subDelay: BOOL _ subType.class.super.ComputeLevel[
                subType,
                BitTwiddling.OffsetPtr[p, rc.fields[i].bitOffset],
                xPhobic];
            delay _ delay OR subDelay;
            ENDLOOP;
        xPhobic _ xPhobic;
        };

    WireValBreak: PUBLIC PROC [char: CHAR] RETURNS [IO.CharClass] --IO.BreakProc-- = {
        RETURN [SELECT char FROM
            IN [IO.NUL .. IO.SP] => sepr,
            ',, ':, '[, '] => break,
            ENDCASE => other
            ];
        };

    Start: PROC = {
        FOR wf: WireFlavor IN WireFlavor DO
            recordSuperClasses[wf] _ NEW[RoseWireSuperClassRec _ [
                GetType: RecordGetType,
                ListFormats: RecordListFormats,
                GetFormat: RecordGetFormat,
                SelectorOffset: RecordSelectorOffset,
                FieldName: RecordFieldName,
                SubType: RecordSubType,
                SubClass: RecordSubClass,
                Bits: RecordBits,
                MesaRepresentation: RecordMesaRepresentation,
                MesaRepAux: RecordMesaRepAux,
                flavor: wf,
                Initialize: RecordInitialize,
                Transduce: RecordTransduce,
                InitQ: RecordInitQ,
                InitUD: RecordInitUD,
                ComputeLevel: RecordComputeLevel
                ]];
            ENDLOOP;
        };

    Start[];

    END.