MacFormat 1996 November/macformat-043.iso/mac/Shareware Plus/Developers/Sprite Animation Toolkit 2.3.8/Add-ons/Graphic effects/MySlotVBL.p

Text File | 1996-05-11 | 4.0 KB | 178 lines | [TEXT/PJMM]

{A VBL synching unit for SAT or general use alike.}

{Based on SlotVInstall.p from DTS, but significantly enhanced; works without Color QD}
{and is a reusable unit.}
{}
{By Ingemar Ragnemalm 1996.}
{}
{Noteable features:}
{Works with both 68k and PPC, and both Think and CodeWarrior.}
{Uses SLotVBL if available, but falls back to old-style VBL on old Macs.}

{Both the unit and the routines might be renamed in future versions.}

unit MySlotVBL;

interface
    uses
{$IFC UNDEFINED THINK_PASCAL}
        Types, Devices, QuickDraw, OSUtils,
{$ELSEC}
{$SETC GENERATINGPOWERPC := FALSE}
{$ENDC}
        Retrace;

    function InstallVBL (myGDevHand: GDHandle): OSErr;
    procedure RemoveVBL;

    function GetVBLValue: Longint;
    procedure SetVBLValue (value: Longint);

{To synch SAT by VBL, install SATSynch as synch procedure.}
{CAUTION: InstallVBL must have succeeded, or SATSynch will wait forever!}
{Also, don't forget a RemoveVBL when you quit!}
    function SATSynch: Boolean;

implementation

    const
        kVBLCount = 1;

    type
        EnhVBLTask = record
                theVBLTask: VBLTask;
                theGlobal: ^LongInt;
            end;
        EnhVBLTaskPtr = ^EnhVBLTask;

    var
        myVBLTask: EnhVBLTask;
        gLong: Longint;
        installed, installedColor: Boolean;

    function GetVBLValue: Longint;
    begin
        GetVBLValue := gLong; {myVBLTask.theGlobal;}
    end; {GetVBLValue}

    procedure SetVBLValue (value: Longint);
    begin
{myVBLTask.theGlobal := }
        gLong := value;
    end; {SetVBLValue}

{$PUSH}
{$D-}

{$IFC GENERATINGPOWERPC}

    procedure MyVBLProc (theEnhVBLTaskRecPtr: EnhVBLTaskPtr);
    begin
        theEnhVBLTaskRecPtr^.theGlobal^ := theEnhVBLTaskRecPtr^.theGlobal^ + 1;
        { reset VBL }
        theEnhVBLTaskRecPtr^.theVBLTask.vblCount := kVBLCount;
    end; {MyVBLProc, PPC}

{$ELSEC}
    function GetVBLRec: EnhVBLTaskPtr;
    inline
        $2E88; { put A0 on stack }

    procedure MyVBLProc;
        var
            theEnhVBLTaskRecPtr: EnhVBLTaskPtr;
    begin
        theEnhVBLTaskRecPtr := GetVBLRec;

        theEnhVBLTaskRecPtr^.theGlobal^ := theEnhVBLTaskRecPtr^.theGlobal^ + 1;
        { reset VBL }
        theEnhVBLTaskRecPtr^.theVBLTask.vblCount := kVBLCount;
    end; {MyVBLProc, 68k}
{$ENDC}

{$POP}

    var
        myDCEHand: AuxDCEHandle;        {Kept for SlotVRemove!}

    function HasColor: Boolean;
        var
            theWorld: SysEnvRec;
    begin
        HasColor := false;
        if SysEnvirons(1, theWorld) = noErr then
            HasColor := theWorld.hasColorQD;
    end; {HasColor}

    function InstallVBL (myGDevHand: GDHandle): OSErr;
        var
            mainGDRefNum: INTEGER;
            vblGlobalLongInt, tempLongInt: LONGINT;
            retCode: OSErr;
    begin
        if installed then
            begin
                InstallVBL := -1;        {Already installed}
                Exit(InstallVBL);
            end;

{If no device is provided, use the main device as default!}
        if myGDevHand = nil then
            if HasColor then
                myGDevHand := GetMainDevice;

        if HasColor and (myGDevHand <> nil) then
            begin
                mainGDRefNum := myGDevHand^^.gdRefNum;
                myDCEHand := AuxDCEHandle(GetDctlEntry(mainGDRefNum));
                installedColor := true;
            end
        else
            installedColor := false;

    { set up VBL task }
        myVBLTask.theVBLTask.qType := ORD(vType);
{$IFC UNDEFINED THINK_PASCAL}
        myVBLTask.theVBLTask.vblAddr := NewVBLProc(@MyVBLProc);
{$ELSEC}
        myVBLTask.theVBLTask.vblAddr := @MyVBLProc;
{$ENDC}
        myVBLTask.theVBLTask.vblCount := kVBLCount;
        myVBLTask.theVBLTask.vblPhase := 0;
        myVBLTask.theGlobal := @gLong;

        vblGlobalLongInt := 0;
        tempLongInt := 0;

        if installedColor then
            retCode := SlotVInstall(@myVBLTask, myDCEHand^^.dCtlSlot)
        else
            retCode := VInstall(@myVBLTask);
        InstallVBL := retCode;

        installed := retCode = noErr;
    end; {InstallVBL}

    procedure RemoveVBL;
        var
            retCode: OSErr;
    begin
        if installed then
            if installedColor then
                retCode := SlotVRemove(@myVBLTask, myDCEHand^^.dCtlSlot)
            else
                retCode := VRemove(@myVBLTask);
{I don't return the error code. I mean, what can be done about it?}
        installed := false;
    end; { ELSE }

{A standard synch proc for SAT:}
    function SATSynch: Boolean;
    begin
        gLong := 0;                {or SetVBLValue(0);}
        while gLong = 0 do        {or GetVBLValue = 0}
            ;
        SATSynch := false;        {Always return false!}
    end; {SATSynch}

end.