ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/PASCAL/TPA22.ZIP/TPA&OOP.PAS

Pascal/Delphi Source File | 1989-07-22 | 9.4 KB | 307 lines

{════════════════════════════════ TPA_OOP ════════════════════════════════}
{ Demonstrates TP&Asm support for Object Oriented Pascal, including:      }
{                                                                         }
{ - Use of Assemble and Internal in method definitions                    }
{   (Supports both "ObjectName@MethodName" and "ObjectName.MethodName")   }
{                                                                         }
{ - Unqualified Indexed Reference to Object data within its methods       }
{   (Unindexed Reference to Static Object data uses Pascal Record syntax) }
{                                                                         }
{ - Automatic support for assembly references to "Self" and "VMT"         }
{   (Freely change object structure without rewriting any assembly code!) }
{                                                                         }
{ - Direct call to Static AND VIRTUAL methods using Unindexed MethodName  }
{                                                                         }
{ - Standard virtual call to Virtual methods using Indexed MethodName     }
{                                                                         }
{=> Compile to Disk or Memory and Run.  Move HappyFace with cursor keys <=}
{═════════════════════════════════════════════════════════════════════════}
Program TPA_OOP;

TYPE
 {- A ScreenCell is a Screen Location which can be Read or Written -}
  ScreenCell = Object
    X,Y: Byte;
    procedure Init(InitX, InitY, InitAttr : Byte; InitSym: Char);
    function GetDisplay : Word;
    procedure SetDisplay(NewContents : Word);
  end;

 {- An OccupiedCell is a ScreenCell which knows its current/prior contents -}
  OccupiedCell = Object(ScreenCell)
    Visible: Boolean;
    Occupant,Occupied: Word;
    constructor Init(InitX, InitY, InitAttr : Byte; InitSym: Char);
    destructor Done;
    Procedure Show; virtual;
    Procedure Hide; virtual;
    Procedure MoveRight; virtual;
    Procedure MoveLeft; virtual;
    Procedure MoveUp; virtual;
    Procedure MoveDown; virtual;
  end;


PROCEDURE ScreenCell.Init(InitX, InitY, InitAttr : Byte; InitSym: Char);
BEGIN
  X := InitX;
  Y := InitY;
  SetDisplay( Byte(InitSym) OR (InitAttr SHL 8) );
END; {PROCEDURE ScreenCell.Init;}


Internal ScreenCellMethods
CODE Segment
ScreenCell@GetDisplay PROC FAR     ;or use "ScreenCell.GetDisplay"

  Self EQU D [Bp+6]   ;Internal/External statements must define "Self"

  Push Bp
  Mov Bp,Sp

  Mov Ah,0F           ;get active page into Bh
  Int 10h

  Les Di,Self         ;Load pointer to "Self"
  Es Mov Dl,X[Di]     ;Indexed reference to ScreenCell.X
  Dec Dl
  Es Mov Dh,[Di+Y]    ;Indexed reference to ScreenCell.Y
  Dec Dh
  Mov Ah,02           ;set cursor position
  Int 10h
  Mov Ah,08           ;get char and attr into Ax
  Int 10h             ; (leave function result in Ax)

  Pop Bp              ;No need to  Mov Sp,Bp
  Ret 4               ;Remove "Self" parameter (using implied RetF)

ScreenCell@GetDisplay ENDP

CODE ENDS

End Internal ScreenCellMethods;


Procedure ScreenCell.SetDisplay(NewContents : Word);
BEGIN
  Assembly
    Mov Ah,0F         ;get active page into Bh
    Int 10h
    Les Di,Self       ;Assembly statements can reference "Self" parameter
    Mov Dl,Es:X[Di]   ;Indexed reference to ScreenCell.X
    Dec Dl
    Mov Dh,Es:[Di+Y]  ;Indexed reference to ScreenCell.Y
    Dec Dh
    Mov Ah,02         ;set cursor position
    Int 10h
    Mov Ax,NewContents
    Mov Bl,Ah         ;put attr in Bl
    Mov Cx,1          ;count of bytes to write
    Mov Ah,09         ;write char and attr
    Int 10h
  END; {Assembly}
  {- Standard Procedure exit code will code the required Retf 6 -}
END; {Procedure ScreenCell.SetDisplay}



constructor OccupiedCell.Init(InitX, InitY, InitAttr : Byte; InitSym: Char);
BEGIN
 {- Code part in assembly to avoid unnecessarily reloading Es:Di -}
  Assembly
    Les Di,Self               ;Load pointer to Self
    Es Mov Visible[Di],FALSE  ;- Visible := FALSE;

    Mov Al,InitX
    Es Mov X[Di],Al           ;- X := InitX;

    Mov Al,InitY
    Mov Es:[Di+Y],Al          ;- Y := InitY;

    Mov Al,InitSym
    Mov Ah,InitAttr           ;- Occupant := Byte(InitSym)
    Mov Es:[Di]Occupant,Ax    ;-            OR (InitAttr SHL 8);

  END; {Assembly}

  Show;               {- Let Turbo handle this virtual Call         -}
                      {- See MoveRight for an Assembly virtual call -}

END; {PROCEDURE ScreenCell.Init;}


Procedure OccupiedCell.Show;
BEGIN
  IF NOT Visible THEN Assembly

    Les Di,Self               ;- Visible := TRUE;
    Es Mov Visible[Di],TRUE

    Push Es,Di                ;Push "Self" parameter
    Call GetDisplay           ;Direct Call to Static Method, result in Ax
    Les Di,Self               ;Reload, most methods destroy Es:Di
    Es Mov Occupied[Di],Ax    ;- Occupied := GetDisplay;

    Es Push Occupant[Di]      ;- SetDisplay(Occupant);
    Push Es,Di                ;Push "Self" parameter
    Call SetDisplay           ;Direct Call to Static Method

  END; {IF NOT Visible THEN }
END; {Procedure OccupiedCell.Show}


Internal OccupiedCellMethods;
CODE Segment
OccupiedCell.MoveRight PROC   ;or use "OccupiedCell@MoveRight"

  Self EQU D [Bp+6]           ;Internal/External statements must define "Self"

  Push Bp
  Mov Bp,Sp

                              ;- Hide; (VMT call)
  Les Di,Self                 ;Load "Self" pointer
  Push Es,Di                  ;Pass as self parameter
  Es Mov Di,VMT[Di]           ;Pick up VMT offset from VMT field
  Call Hide[Di]               ;Indexed reference codes Virtual Call

  Les Di,Self                 ;Reload "Self" pointer
  Es Cmp X[Di],80             ;- IF X<80
  IF B Es Inc X[Di]           ;-  THEN Inc(X);

                              ;- Show; (VMT call)
  Push Es,Di                  ;Es:[Di] is still valid
  Mov Di,Es:[Di+VMT]          ;Pick up VMT offset from VMT field
  Call [Di+Show]              ;Indexed reference codes Virtual Call

  Pop Bp                      ;No need to  Mov Sp,Bp
  Ret 4                       ;Remove "Self" parameter

OccupiedCell.MoveRight ENDP


OccupiedCell@MoveLeft PROC    ;or use "OccupiedCell.MoveLeft"

  Self EQU D [Bp+6]           ;Internal/External statements must define "Self"

  Push Bp
  Mov Bp,Sp

                              ;- Hide; (Direct Call)
  Les Di,Self                 ;Load "Self" pointer
  Push Es,Di                  ;Pass as self parameter
 ;--> Use an unindexed reference to code STATIC (Direct) Calls
  Call OccupiedCell.Hide      ;STATIC (Direct) Call to virtual method

  Les Di,Self                 ;Reload "Self" pointer
  Es Cmp X[Di],1              ;- IF X>1
  IF A Es Dec X[Di]           ;-  THEN Dec(X);

                              ;- Show; (Direct Call)
  Push Es,Di                  ;Es:[Di] is still valid
  Call Show                   ;STATIC (Direct) Call to virtual method

  Pop Bp                      ;No need to  Mov Sp,Bp
  Ret 4                       ;Remove "Self" parameter

OccupiedCell@MoveLeft ENDP

CODE ENDS

End Internal OccupiedCellMethods;


{- Code remaining methods in Pascal -}

Procedure OccupiedCell.MoveUp;
BEGIN
  Hide;
  IF Y>1 THEN Dec(Y);
  Show;
END; {Procedure OccupiedCell.MoveUp}

Procedure OccupiedCell.MoveDown;
BEGIN
  Hide;
  IF Y<25 THEN Inc(Y);
  Show;
END; {Procedure OccupiedCell.MoveDown}

Procedure OccupiedCell.Hide;
BEGIN
  SetDisplay(Occupied);
  Visible := FALSE;
END; {Procedure OccupiedCell.Hide}

destructor OccupiedCell.Done;
BEGIN
  Hide;
END; {destructor OccupiedCell.Done;}


FUNCTION ReadScan: Byte; { Read keyboard scan code without echo to screen }
 Assembly             {- Inline Directive -}
  Mov Ah,0
  Int 16h
  Mov Al,Ah           ;Put Assembly/Inline Directive result in Al
 END; {Assembly}

FUNCTION GetCursor: WORD;      { Get cursor position on active video page }
 Assembly             {- Inline Directive -}
  Mov Ah,0F           ;get active page into Bh
  Int 10h
  Mov Ah,03           ;get cursor position into Dx
  Int 10h
  Mov Ax,Dx           ;Put Assembly/Inline Directive result in Ax
 END; {Assembly}

PROCEDURE RestoreCursor(SvPos: Word);     { Restore saved cursor position }
 Assembly             {- Inline Directive -}
  Mov Ah,0F           ;get active page into Bh
  Int 10h
  Pop Dx              ;Parameter to Assembly/Inline Directive
  Mov Ah,02           ;set cursor position
  Int 10h
 END; {Assembly}



CONST {- Scan Codes of cursor and escape keys -}
      UpArrow = $48;      RtArrow = $4D;      Escape  = $01;
      DnArrow = $50;      LfArrow = $4B;

VAR
  HappyFace: OccupiedCell;
  MsgBlock: ARRAY[1..20] OF OccupiedCell;
  n: Integer;
  SavedCursor: WORD;

CONST
  ExitMsg: STRING[20] = 'Press <Esc> to Exit';

BEGIN {MAIN}

  SavedCursor := GetCursor;

  FOR n := 1 TO Length(ExitMsg)
   DO MsgBlock[n].Init(n+30,1,$87,ExitMsg[n]);

  HappyFace.Init(20,5,6,#2);

  WHILE TRUE
  DO Case ReadScan OF
    UpArrow: HappyFace.MoveUp;
    DnArrow: HappyFace.MoveDown;
    RtArrow: HappyFace.MoveRight;
    LfArrow: HappyFace.MoveLeft;
    Escape:  BEGIN
               HappyFace.Done;
               FOR n := 1 TO Length(ExitMsg)
                DO MsgBlock[n].Done;
               RestoreCursor(SavedCursor);
               Halt;
             END;
  END; {DO Case ReadScan }

END.