Лабораторная работа / COROUT

Unit Corout;
Interface
Type
    arptr    = ^artype;
    artype   = array[0..999] of word; {Ї®¤ б⥪ - 1000 б«®ў}

    descptr  = ^procdesc;
    procdesc = record
      ssreg,
      spreg  : word;
      SaveArPtr : ArPtr;
    end;

Procedure Transfer(OldProc,NewProc:descptr);

Procedure NewProcess(body:pointer; Var proc:descptr);
Procedure DelProcess( Var proc:descptr);

{ -= Џаאַ© ўлў®¤ ў ўЁ¤Ґ®Ї ¬пвм =- }
Type
  TScreenChar = Record
    Data : Char;
    Attr : Byte;
  End;

Var TextScreenBuffer : Array [0..24,0..79] of TScreenChar
          Absolute $A000:$0000;

Type
  TDirectS = Object
    ScrCol,ScrRow : Word;
    Constructor Init;
    Procedure Out( C:Char );
  End;

Var DirectS : TDirectS;

Var
     main : descptr;
{--------------------------------------------------------------------------}
Implementation

Procedure NewProcess(body : pointer; Var proc : descptr);
Var
     ar : arptr;
Begin
     New(proc);
     New(ar);
     writeln('ar: ',seg(ar^),' ',ofs(ar^));
{     writeln('spreg: ',ofs(ar^) + 1998 - 14);}
     with proc^ do begin
          ssreg := seg(ar^);
          spreg := ofs(ar^) + 1998 - 14;
          memw[ssreg:spreg+2] := ofs(body^);
          memw[ssreg:spreg+4] := seg(body^);
          SaveArPtr := ar;
     end {with};
     writeln('+spreg: ',proc^.spreg);
End {NewProcess};
{--------------------------------------------------------------------------}
Procedure DelProcess( Var proc : descptr);
Var
     ar : arptr;
Begin
  with proc^ do
    Dispose(SaveArPtr);
  Dispose(proc);
End {DelProcess};
{-----------------------------------------------------}
Procedure Transfer(OldProc, NewProc : descptr);
Assembler;
Asm                    {Є®¬ЇЁ«пв®а Ї®б«Ґ Call Transfer
                        Ї®¤бв ў«пҐв push bp; mov bp,sp}
   les di,oldproc
   mov es:[di],ss      {oldproc.ssreg := ss;}
   mov es:[di+2],sp    {oldproc.spreg := sp;  ¤аҐб ў®§ўа в  ў sp+2}
   les di,newproc
   mov ss,es:[di]      {ss := newproc.ssreg;}
   mov sp,es:[di+2]    {sp := newproc.spreg;}
   pop bp      {ўлв «ЄЁў ­ЁҐ bp ўлў®¤Ёв б⥪ ­   ¤аҐб ў®§ўа в }
   ret 8
       {§ в®«Є­г«Ё 8 Ў ©в®ў - 4 б«®ў  - §­ зҐ­Ёп oldproc Ё newproc}
End {Transfer};
{-----------------------------------------------------}

Constructor TDirectS.Init;
Var I,J : Word;
Begin
  For I:=0 to 24 do
    For J:=0 to 79 do
      With TextScreenBuffer[ScrRow,ScrCol] do
        Begin
          Data := ' ';
          Attr := $07;
        End;
  ScrRow := 0;
  ScrCol := 0;
End;

Procedure TDirectS.Out( C:Char );
Begin
  If ScrRow>24 then Init;
  TextScreenBuffer[ScrRow,ScrCol].Data := C;
  Inc(ScrCol);
  if ScrCol>79 then
    Begin
      ScrCol := 0;
      Inc(ScrRow);
    End;
End;

Begin
  DirectS.Init;
  New(main);
End {Corout}.