Celestin Apprentice 2/Apprentice-Release2.iso/Source Code/Pascal/Libraries/DBL Pascal Library/CallChain ƒ/CallChain.p

Text File | 1992-11-01 | 8.8 KB | 340 lines | [TEXT/PJMM]

unit CallChain;

interface

{Returns True so long as depth is within stack, and stack is uncorrupted.}
    function GetCallerInfo (depth: Integer; var frame: Ptr; var procName: Str255; var offset: Integer): Boolean;

{Returns True if we got a complete trace.}
    function GetStackTrace (startingDepth: Integer; dest: CharsHandle; var destSize: Size): Boolean;

implementation

{A procedure begins (optionally) with a LINK A6,#nnnn instruction, and ends with}
{one of (a) an RTS, (b) a JMP (A0), or (c) an RTD #nnnn. The ending instruction is}
{followed (optionally) by a name and constant data. The name can be in any of three}
{formats (described below). The constant data consists of a word-length byte count}
{followed by the actual data; the count is word-aligned following the name.}
{}
{The name formats are (a) fixed 8-byte, (b) fixed 16-byte, and (c) variable. The}
{16-byte format is used specifically for short class.method names in Object Pascal.}
{Valid characters are in the set [a–zA–Z0–9_%.] (blanks are used to pad fixed-length names).}
{}
{Fixed-8:}
{    First character in range $20–$7F, ignoring MSB.}
{    MSB of second character is always clear.}
{    Name is eight characters long, with trailing blanks trimmed.}
{Fixed-16:}
{    First character in range $20–$7F, ignoring MSB.}
{    MSB of second character is always set.}
{    Stored as two eight-byte names; method followed by class.}
{    Name is constructed as CLASS.METHOD – must insert period between}
{     parts of name after stripping trailing blanks.}
{Variable:}
{    First byte in range $80–$9F, including MSB.}
{    If first byte is $80, then second byte contains actual length in range $01–$FF.}
{    If first byte is $81–$9F, then clearing MSG gives actual length in range $01–$1F.}
{    Length byte(s) is (are) followed by name, without padding.}

    function CurrentA6: Ptr;
    inline
        $2E8E;    {move.l a6,(sp)}

    function NextFrame (whichFrame: univ Ptr): Ptr;
    inline
        $205F,    {movea.l (sp)+,a0}
        $2E90;    {move.l (a0),(sp)}

    function CallerRA (whichFrame: univ Ptr): Ptr;
    inline
        $205F,            {movea.l (sp)+,a0}
        $2EA8, $0004;    {move.l 4(a0),(sp)}

    function CurrentSP: Ptr;
    inline
        $2E8F;    {move.l sp,(sp)}

    function AddressInStack (theAddress: univ Longint): Boolean;
        type
            LongPtr = ^Longint;
        const
            CurStackBase = $908;
    begin
        AddressInStack := (theAddress <= LongPtr(CurStackBase)^) & (theAddress >= Longint(CurrentSP));
    end;

    type
        IntPtr = ^Integer;

    const
        LINKA6_instruction = $4E56;    {this is a two-word instruction}
        RTS_instruction = $4E75;        {this is a one-word instruction}
        JMPatA0_instruction = $4ED0;    {this is a one-word instruction}
        RTD_instruction = $4E74;        {this is a two-word instruction}
        HowFar = 32766;

    function MaybeFindName (startingAt: univ Longint): Ptr;
        var
            where, stopAt: Longint;
    begin
        stopAt := startingAt + HowFar;
        where := startingAt;
        MaybeFindName := nil;
        while where < stopAt do
            begin
                case IntPtr(where)^ of
                    LINKA6_instruction:
                        Leave;
                    RTS_instruction, JMPatA0_instruction:
                        begin
                            MaybeFindName := Ptr(where + SIZEOF(Integer));
                            Leave;
                        end;
                    RTD_instruction:
                        begin
                            MaybeFindName := Ptr(where + 2 * SIZEOF(Integer));
                            Leave;
                        end;
                    otherwise
                        ;
                end;
                where := where + SIZEOF(Integer);
            end;
    end; {MaybeFindName}

    function AddressInHeap (where: univ Ptr): Boolean;
        var
            theZone: THz;
    begin
        theZone := GetZone;
        AddressInHeap := (ORD(where) >= ORD(@theZone^.heapData)) & (ORD(where) < ORD(theZone^.bkLim));
    end;

    type
        CharPtr = ^SignedByte;

    function GetName (where: univ Longint; var theName: Str255): Boolean;

        function CopyName (start: univ Longint; expectedLength: Integer; howManyMSBs: Integer; dest: StringPtr): Boolean;

            procedure Fail;
            begin
                CopyName := False;
                Exit(CopyName);
            end; {Fail}

            const
                ValidChars = ['a'..'z', 'A'..'Z', '0'..'9', '_', '%', '.', ' '];
            var
                where: Longint;
                i, actualLength: Integer;
                theChar: Char;

        begin {CopyName}
            where := start;
            actualLength := expectedLength;
            for i := 1 to expectedLength do
                begin
                    theChar := Char(CharPtr(where)^);
                    if (i > howManyMSBs) & BTST(theChar, 7) then
                        Fail;
                    theChar := Char(BAND(theChar, $7F));
                    if theChar in ValidChars then
                        begin
                            if (actualLength = expectedLength) & (theChar = ' ') then
                                actualLength := i - 1;
{$PUSH}
{$R-}
            {Turn off range checking because string length isn’t yet set…}
                            dest^[i] := theChar;
{$POP}
                            where := where + SIZEOF(SignedByte);
                        end
                    else
                        Fail;
                end;
{$PUSH}
{$R-}
            dest^[0] := CHR(actualLength);
{$POP}
            CopyName := True;
        end; {CopyName}

        procedure NotAName;
        begin
            theName := '';
            GetName := False;
            Exit(GetName);
        end;

        var
            name2: string[8];

    begin {GetName}
        GetName := True;
        if not AddressInHeap(where) then
            NotAName;
        case BAND(CharPtr(where)^, $FF) of
            $20..$7F, $A0..$FF:
                if BTST(CharPtr(where + SIZEOF(SignedByte))^, 7) then
                    begin    {fixed-16}
                        if CopyName(where, 8, 2, @name2) & CopyName(where + 8 * SIZEOF(SignedByte), 8, 0, @theName) then
                            theName := CONCAT(theName, '.', name2)
                        else
                            NotAName;
                    end
                else
                    begin    {fixed-8}
                        if not CopyName(where, 8, 1, @theName) then
                            NotAName;
                    end;
            $80:
                begin    {variable, 1–255 char}
                    if not CopyName(where + 2 * SIZEOF(SignedByte), BAND(CharPtr(where + SIZEOF(SignedByte))^, $7F), 0, @theName) then
                        NotAName;
                end;
            $81..$9F:
                begin    {variable, 1–31 char}
                    if not CopyName(where + SIZEOF(SignedByte), BAND(CharPtr(where)^, $7F), 0, @theName) then
                        NotAName;
                end;
            otherwise
                NotAName;
        end;
    end; {GetName}

    function MaybeFindEntry (startingAt: univ Longint): Ptr;
        var
            where, stopAt: Longint;
    begin
        stopAt := startingAt - HowFar;
        where := startingAt;
        MaybeFindEntry := nil;
        while where > stopAt do
            begin
                case IntPtr(where)^ of
                    LINKA6_instruction:
                        if IntPtr(where + SIZEOF(Integer))^ < 0 then
                            begin    {• This could give spurious positives.}
                                MaybeFindEntry := Ptr(where);
                                Leave;
                            end;
                    RTS_instruction, JMPatA0_instruction, RTD_instruction:
                        Leave;        {• This could give spurious negatives.}
                    otherwise
                        ;
                end;
                where := where - SIZEOF(Integer);
            end;
    end; {MaybeFindEntry}

    function GetCallerInfo (depth: Integer; var frame: Ptr; var procName: Str255; var offset: Integer): Boolean;

        procedure Fail;
        begin
            GetCallerInfo := False;
            frame := nil;
            procName := '';
            offset := 0;
            Exit(GetCallerInfo);
        end; {Fail}

        var
            frameAddress, procReturn, procEntry: Ptr;
            i: Integer;

    begin {GetCallerInfo}
        GetCallerInfo := True;    {We’ll change this later, if we fail…}
        frameAddress := CurrentA6;
        for i := 1 to depth do
            if not AddressInStack(frameAddress) then
                Fail
            else
                frameAddress := NextFrame(frameAddress);
        frame := frameAddress;
        procReturn := CallerRA(frameAddress);
        if not GetName(MaybeFindName(procReturn), procName) then
            Fail;
        procEntry := MaybeFindEntry(procReturn);
        if procEntry <> nil then
            offset := ORD(procReturn) - ORD(procEntry)
        else
            offset := 0;
    end; {GetCallerInfo}

    function GetStackTrace (startingDepth: Integer; dest: CharsHandle; var destSize: Size): Boolean;

        procedure MakeHex (num: univ Longint; dest: CharsPtr; digits: Integer);
            var
                i, digit: Integer;
        begin
            for i := digits - 1 downto 0 do
                begin
                    digit := num mod 16;
                    if digit < 10 then
                        dest^[i] := CHR(digit + ORD('0'))
                    else
                        dest^[i] := CHR(digit + ORD('A') - 10);
                    num := num div 16;
                end;
        end; {MakeHex}

        const
            addSize = 15;    {8 digits, space, '+', 4 digits, CR}

        var
            i: Integer;
            aFrame: Ptr;
            aName: Str255;
            aNameLength: Integer;
            anOffset: Integer;
            stillOK: Boolean;
            outSize: Size;
            outPtr: CharPtr;

    begin {GetStackTrace}
        GetStackTrace := True;
        outPtr := CharPtr(dest^);
        outSize := 0;
        i := startingDepth + 1;
        repeat
            stillOK := GetCallerInfo(i, aFrame, aName, anOffset);
            if stillOK then
                begin
                    aNameLength := length(aName);
                    if outSize + aNameLength + addSize < destSize then
                        begin
                            MakeHex(aFrame, CharsPtr(outPtr), 8);
                            outPtr := CharPtr(ORD(outPtr) + 8);

                            outPtr^ := ORD(' ');
                            outPtr := CharPtr(ORD(outPtr) + SIZEOF(SignedByte));

                            BlockMove(@aName[1], Ptr(outPtr), aNameLength);
                            outPtr := CharPtr(ORD(outPtr) + aNameLength);

                            outPtr^ := ORD('+');
                            outPtr := CharPtr(ORD(outPtr) + SIZEOF(SignedByte));

                            MakeHex(anOffset, CharsPtr(outPtr), 4);
                            outPtr := CharPtr(ORD(outPtr) + 4);

                            outPtr^ := 13;
                            outPtr := CharPtr(ORD(outPtr) + SIZEOF(SignedByte));

                            outSize := ORD(outPtr) - ORD(dest^);
                        end
                    else
                        begin
                            GetStackTrace := False;
                            Leave;
                        end;
                end
            else
                Leave;
            i := i + 1;
        until False;
        destSize := outSize;
    end; {GetStackTrace}

end.