home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / STREAM15.ZIP / XMSSTRM.INC < prev   
Encoding:
Text File  |  1993-03-27  |  10.4 KB  |  385 lines
  1. { This include file is a slightly modified version of XMSSTRM.PAS, by Stefan
  2.   Boether, included here with his kind permission. -djm }
  3.  
  4.   (*****************************************************************************)
  5.   (*                                                                           *)
  6.   (*        Filename        : XMSSTRM.INC                                      *)
  7.   (*        Autor           : Stefan Boether / Compuserve Id : 100023,275      *)
  8.   (*        System          : TURBO 6.00 / MS-DOS 3.2 / Netzwerk               *)
  9.   (*        Aenderung       :                                                  *)
  10.   (*        wann     was                                                wer    *)
  11.   (*---------------------------------------------------------------------------*)
  12.   (*        22.03.92 Error fixed with NewBlock and UsedBlocks           Stefc  *)
  13.   (*        28.04.92 Size field added, BlockSize made constant          DJM    *)
  14.   (*        15.10.92 Off-by-one bug fixed in Seek method                DJM    *)
  15.   (*****************************************************************************)
  16.   (*        Beschreibung:  Object for an Stream in XMS-Memory                  *)
  17.   (*****************************************************************************)
  18.   {Header-End}
  19.  
  20. {!!!!!!!!!!!!!!!
  21.  program Test;
  22.  
  23.  uses objects, XmsStrm;
  24.  
  25.  var T : TXmsStream;
  26.      P : PString;
  27.  
  28. begin
  29.    writeln( xms_MaxAvail, ' ', xms_MemAvail );
  30.    T.Init(  20, 20 );
  31.    T.WriteStr( NewStr( 'Hello' ));
  32.    T.WriteStr( NewStr( 'World' ));
  33.    T.Seek( 0 );
  34.    P := T.ReadStr;
  35.    writeln( P^ );
  36.    P := T.ReadStr;
  37.    writeln( P^ );
  38.    T.Done;
  39. end.
  40.  
  41. !!!!!!!!!!!!!!!!}
  42.  
  43. var xms_IOsts : Byte;
  44.   xms_Addr : Pointer;
  45.  
  46. const
  47.   xms_Initialized : Boolean = False;
  48.   { This allows us to avoid a unit initialization section }
  49.  
  50.   xms_BlockSize = 1024;
  51.  
  52.   { - Some Xms - Procedures that I need ! -}
  53.  
  54.   (* /////////////////////////////////////////////////////////////////////// *)
  55.  
  56.   procedure MoveMem(ToAddress : Pointer; ToHandle : Word;
  57.                     FromAddress : Pointer; FromHandle : Word;
  58.                     Size : LongInt);
  59.   begin
  60.     asm
  61.       mov     byte ptr xms_IOsts,0
  62.       mov     ah,$0B
  63.       lea     si,Size
  64.       push    ds
  65.       pop     es
  66.       push    ss
  67.       pop     ds
  68.       call    es:[xms_Addr]
  69.       push    es
  70.       pop     ds
  71.       or      ax,ax
  72.       jnz     @@1
  73.       mov     byte ptr xms_IOsts,bl
  74. @@1:
  75.     end;
  76.   end;
  77.  
  78.   (* /////////////////////////////////////////////////////////////////////// *)
  79.  
  80.   function GetByte(Handle : Word; FromAddress : LongInt) : Byte;
  81.   var TempBuf : array[0..1] of Byte;
  82.   begin
  83.     MoveMem(@TempBuf, 0, Pointer(FromAddress and $FFFFFFFE), Handle, 2);
  84.     GetByte := TempBuf[FromAddress and $00000001];
  85.   end;
  86.  
  87.   (* /////////////////////////////////////////////////////////////////////// *)
  88.  
  89.   procedure SetByte(Handle : Word; ToAddress : LongInt; Value : Byte);
  90.   var TempBuf : array[0..1] of Byte;
  91.   begin
  92.     MoveMem(@TempBuf, 0, Pointer(ToAddress and $FFFFFFFE), Handle, 2);
  93.     TempBuf[ToAddress and $00000001] := Value;
  94.     MoveMem(Pointer(ToAddress and $FFFFFFFE), Handle, @TempBuf, 0, 2);
  95.   end;
  96.  
  97.   (* /////////////////////////////////////////////////////////////////////// *)
  98.  
  99.   procedure xms_Init;
  100.   begin
  101.     if not xms_Initialized then
  102.     begin
  103.       xms_IOsts := 0;
  104.       xms_Addr := nil;
  105.       asm
  106.         mov     ax,$4300
  107.         int     $2F
  108.         cmp     al,$80
  109.         jne     @@1
  110.         mov     ax,$4310
  111.         int     $2F
  112.         mov     word ptr xms_Addr,bx
  113.         mov     word ptr xms_Addr+2,es
  114.         jmp     @@2
  115. @@1:
  116.         mov     byte ptr xms_IOsts,$80
  117. @@2:
  118.       end;
  119.       if xms_IOsts = 0 then
  120.         xms_Initialized := True;
  121.     end;
  122.   end;
  123.  
  124.   (* /////////////////////////////////////////////////////////////////////// *)
  125.  
  126.   function xms_GetMem(KB : Word) : Word; Assembler;
  127.   asm
  128.     mov     xms_IOsts,0
  129.     mov     ah,$09
  130.     mov     dx,word ptr KB
  131.     call    [xms_Addr]
  132.     or      ax,ax
  133.     jz      @@1
  134.     mov     ax,dx
  135.     jmp     @@2
  136. @@1:
  137.     mov     byte ptr xms_IOsts,bl
  138. @@2:
  139.   end;
  140.  
  141.   (* /////////////////////////////////////////////////////////////////////// *)
  142.  
  143.   procedure xms_FreeMem(Handle : Word);
  144.   begin
  145.     asm
  146.       mov     xms_IOsts,0
  147.       mov     ah,$0A
  148.       mov     dx,word ptr Handle
  149.       call    [xms_Addr]
  150.       or      ax,ax
  151.       jnz     @@1
  152.       mov     byte ptr xms_IOsts,bl
  153. @@1:
  154.     end;
  155.   end;
  156.  
  157.   (* /////////////////////////////////////////////////////////////////////// *)
  158.  
  159.   procedure xms_ResizeMem(Size, Handle : Word);
  160.   begin
  161.     asm
  162.       mov     ah,$0F
  163.       mov     bx,word ptr Size
  164.       mov     dx,word ptr Handle
  165.       call    [xms_Addr]
  166.       or      ax,ax
  167.       jnz     @@1
  168.       mov     byte ptr xms_IOsts,bl
  169. @@1:
  170.     end;
  171.   end;
  172.  
  173.   (* /////////////////////////////////////////////////////////////////////// *)
  174.  
  175.   procedure xms_MoveFrom(Size, Handle : Word; FromAddress : LongInt;
  176.                          ToAddress : Pointer);
  177.   type ByteArr = array[0..MaxInt] of Byte;
  178.     BytePtr = ^ByteArr;
  179.   begin
  180.     if Size = 0 then Exit;
  181.     if Odd(FromAddress) then begin
  182.       BytePtr(ToAddress)^[0] := GetByte(Handle, FromAddress);
  183.       if xms_IOsts <> 0 then Exit;
  184.       Dec(Size);
  185.       Inc(FromAddress);
  186.       Inc(LongInt(ToAddress));
  187.     end;
  188.     MoveMem(ToAddress, 0, Pointer(FromAddress), Handle, Size and $FFFE);
  189.     if xms_IOsts <> 0 then Exit;
  190.     if Odd(Size)
  191.     then BytePtr(ToAddress)^[Size-1] := GetByte(Handle, FromAddress+Size-1);
  192.     if xms_IOsts <> 0 then Exit;
  193.   end;
  194.  
  195.   (* /////////////////////////////////////////////////////////////////////// *)
  196.  
  197.   procedure xms_MoveTo(Size, Handle : Word; FromAddress : Pointer;
  198.                        ToAddress : LongInt);
  199.   type ByteArr = array[0..MaxInt] of Byte;
  200.     BytePtr = ^ByteArr;
  201.   begin
  202.     if Size = 0 then Exit;
  203.     if Odd(ToAddress) then begin
  204.       SetByte(Handle, ToAddress, BytePtr(FromAddress)^[0]);
  205.       if xms_IOsts <> 0 then Exit;
  206.       Dec(Size);
  207.       Inc(LongInt(FromAddress));
  208.       Inc(ToAddress);
  209.     end;
  210.     MoveMem(Pointer(ToAddress), Handle, FromAddress, 0, Size and $FFFE);
  211.     if xms_IOsts <> 0 then Exit;
  212.     if Odd(Size)
  213.     then SetByte(Handle, ToAddress+Size-1, BytePtr(FromAddress)^[Size-1]);
  214.     if xms_IOsts <> 0 then Exit;
  215.   end;
  216.  
  217.   (* /////////////////////////////////////////////////////////////////////// *)
  218.  
  219.   constructor TXMSStream.Init(MinSize, MaxSize : longint);
  220.   var
  221.     MinBlocks,MaxBlocks : word;
  222.   begin
  223.     TStream.Init;
  224.     xms_Init;
  225.     BlocksUsed := 0;
  226.     Size := 0;
  227.     Position := 0;
  228.     Handle := 0;
  229.     MaxSize := MinLong(MaxSize,xms_Maxavail);
  230.     MaxBlocks := (MaxSize + xms_Blocksize -1) div xms_Blocksize;
  231.     MinBlocks := (MinSize + xms_Blocksize -1) div xms_Blocksize;
  232.     if MinBlocks < 1 then
  233.       MinBlocks := 1;
  234.     if MaxBlocks < MinBlocks then
  235.       MaxBlocks := MinBlocks;
  236.     if xms_IOsts <> $00 then
  237.       Error(stInitError, xms_IOsts)
  238.     else
  239.     begin
  240.       Handle := xms_GetMem(MaxBlocks);
  241.       if xms_IOsts <> $00 then
  242.         Error(stInitError, xms_IOsts)
  243.       else
  244.       begin
  245.         xms_ResizeMem(MinBlocks,Handle);
  246.         BlocksUsed := MinBlocks;
  247.         if xms_IOsts <> $00 then
  248.           Error(stInitError, xms_IOsts);
  249.       end;
  250.     end;
  251.   end;
  252.  
  253.   function TXMSStream.GetPos : LongInt;
  254.   begin
  255.     GetPos := Position;
  256.   end;
  257.  
  258.   function TXMSStream.GetSize : LongInt;
  259.   begin
  260.     GetSize := Size;
  261.   end;
  262.  
  263.   procedure TXMSStream.Read(var Buf; Count : Word);
  264.   begin
  265.     if Status = stOK then
  266.       if Position+Count > Size then
  267.         Error(stReaderror, 0)
  268.       else
  269.       begin
  270.         xms_MoveFrom(Count, Handle, Position, @Buf);
  271.         if xms_IOsts <> 0 then
  272.           Error(stReaderror, xms_IOsts)
  273.         else
  274.           Inc(Position, Count);
  275.       end;
  276.   end;
  277.  
  278.   procedure TXMSStream.Seek(Pos : LongInt);
  279.   begin
  280.     if Status = stOK then
  281.       if Pos > Size then            { 1.4:  bug fix }
  282.         Error(stReaderror, Pos)
  283.       else
  284.         Position := Pos;
  285.   end;
  286.  
  287.   procedure TXMSStream.Truncate;
  288.   begin
  289.     if Status = stOK then
  290.     begin
  291.       Size := Position;
  292.       while (BlocksUsed > (Size div xms_BlockSize+1)) do FreeBlock;
  293.     end;
  294.   end;
  295.  
  296.   procedure TXMSStream.Write(var Buf; Count : Word);
  297.   begin
  298.     while (Status = stOK)
  299.     and (Position+Count > LongMul(xms_BlockSize, BlocksUsed)) do
  300.       NewBlock;
  301.     if Status = stOK then
  302.     begin
  303.       xms_MoveTo(Count, Handle, @Buf, Position);
  304.       if xms_IOsts <> 0 then
  305.         Error(stWriteError, xms_IOsts)
  306.       else
  307.         Inc(Position, Count);
  308.       if Position > Size then
  309.         Size := Position;
  310.     end;
  311.   end;
  312.  
  313.   procedure TXMSStream.NewBlock;
  314.   begin
  315.     xms_ResizeMem(Succ(BlocksUsed), Handle);
  316.     if xms_IOsts <> 0 then
  317.       Error(stWriteError, xms_IOsts)
  318.     else
  319.       Inc(BlocksUsed);
  320.   end;
  321.  
  322.   procedure TXMSStream.FreeBlock;
  323.   begin
  324.     Dec(BlocksUsed);
  325.     xms_ResizeMem(BlocksUsed, Handle);
  326.   end;
  327.  
  328.   function xms_MaxAvail : Longint;
  329.   begin
  330.     xms_Init;
  331.     if xms_IOsts = 0 then
  332.     asm
  333.       xor       bx, bx          { for better error checking, since qemm
  334. 6.0 leaves bl unchanged on success }
  335.       mov     ah,$08
  336.       call    [xms_Addr]
  337.       or      bl, bl            { extended error checking by MM 22.02.93 }
  338.       jz      @OK
  339.       mov     byte ptr xms_IOsts,bl
  340.       xor     ax,ax
  341. @OK:
  342.       mov     dx,xms_Blocksize
  343.       mul     dx
  344.       mov     word ptr @result,ax
  345.       mov     word ptr @result[2],dx
  346.     end
  347.     else
  348.       xms_MaxAvail := 0;
  349.   end;
  350.  
  351.   (* /////////////////////////////////////////////////////////////////////// *)
  352.  
  353.   function xms_MemAvail : Longint;
  354.   begin
  355.     xms_Init;
  356.     if xms_IOsts = 0 then
  357.     asm
  358.       xor       bx, bx          { for better error checking, since qemm
  359. 6.0 leaves bl unchanged on success }
  360.       mov     ah,$08
  361.       call    [xms_Addr]
  362.       or      bl, bl            { extended error checking by MM 22.02.93 }
  363.       jz      @OK
  364.       mov     byte ptr xms_IOsts,bl
  365.       xor     dx,dx
  366. @OK:
  367.       mov     ax,dx
  368.       mov     dx,xms_blocksize
  369.       mul     dx
  370.       mov     word ptr @result,ax
  371.       mov     word ptr @result[2],dx
  372.     end
  373.     else
  374.       xms_MemAvail := 0;
  375.   end;
  376.  
  377.   destructor TXMSStream.Done;
  378.   begin
  379. {    Seek(0);
  380.     Truncate; }
  381.     if xms_Initialized and (BlocksUsed > 0) then
  382.       xms_FreeMem(Handle);
  383.   end;
  384.  
  385.