home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / visionix / test / txms.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-12-29  |  4.2 KB  |  171 lines
  1. program TXms;
  2.  
  3. uses
  4.  
  5.   vCrtu,
  6.   VXmsu;
  7.  
  8. const
  9.   XmsStr : String[15] = 'Hello XMS world';
  10.  
  11. type
  12.  
  13.   TXMBHandle2 = RECORD
  14.  
  15.     Case Byte of
  16.  
  17.       0 : (RealPtr : POINTER);
  18.  
  19.       1 : (ProtectedPtr : LONGINT);
  20.  
  21.   END;
  22.  
  23. procedure MoveTest;
  24. var
  25.   Err    : Byte;
  26.   Handle : TXMBHandle;
  27.   ps, pd : TXMBHandle2;
  28.   S      : String[15];
  29.  
  30. begin
  31.   WriteLn('Performing Move Test');
  32.   Err := VXMBNew( 1, Handle );
  33.   WriteLn('AllocateExtMem: ', VXmsErrorToStr(Err));
  34.   if Err <> 0 then
  35.     Exit;
  36.   ps.RealPtr := @XmsStr;
  37.   pd.ProtectedPtr := 0;
  38.   Err := VXMBMoveBlock(Succ(Length(XmsStr)), 0, ps, Handle, pd);
  39.   WriteLn('MoveExtMemBlock: ', XmsErrorToStr(Err));
  40.   if Err <> 0 then begin
  41.     Err := FreeExtMem(Handle);
  42.     Exit;
  43.   end;
  44.   FillChar(S, SizeOf(S), 0);
  45.   pd.RealPtr := @S;
  46.   ps.ProtectedPtr := 0;
  47.   Err := MoveExtMemBlock(Succ(Length(XmsStr)), Handle, ps, 0, pd);
  48.   if Err = 0 then
  49.     WriteLn(S);
  50.   WriteLn('MoveExtMemBlock: ', VXmsErrorToStr(Err));
  51.   Err := FreeExtMem(Handle);
  52.   WriteLn('FreeExtMem: ', VXmsErrorToStr(Err));
  53. end;
  54.  
  55. procedure AllocateTest;
  56. var
  57.   Total, Largest, Handle : Word;
  58.   Err : Byte;
  59. begin
  60.   WriteLn('Performing Allocate Test');
  61.   Err := QueryFreeExtMem(Total, Largest);
  62.   WriteLn('Total   = ', Total);
  63.   WriteLn('Largest = ', Largest);
  64.   Err := AllocateExtMem(Largest, Handle);
  65.   WriteLn('Attempt to allocate ', Largest,'K of XMS returned: ', VXmsErrorToStr(Err));
  66.   Err := FreeExtMem(Handle);
  67.   WriteLn('Attempt to free extended memory block returned: ', VXmsErrorToStr(Err));
  68.   Err := AllocateExtMem(Largest+1, Handle);
  69.   WriteLn('Attempt to allocate ', Largest+1,'K of XMS returned: ', VXmsErrorToStr(Err));
  70. end;
  71.  
  72. procedure HMATest;
  73. var
  74.   Err : Byte;
  75. begin
  76.   WriteLn('Performing HMA Test');
  77.   Err := RequestHMA($FFFF);
  78.   WriteLn('RequestHMA returned: ', VXmsErrorToStr(Err));
  79.   if Err = 0 then begin
  80.     Err := ReleaseHMA;
  81.     WriteLn('ReleaseHMA returned: ', VXmsErrorToStr(Err));
  82.   end;
  83. end;
  84.  
  85. procedure LockTest;
  86. var
  87.   Handle : Word;
  88.   Err : Byte;
  89.   LinearPtr : ExtMemPtr;
  90.  
  91. begin
  92.   WriteLn('Performing Lock Test');
  93.   Err := AllocateExtMem(1, Handle);
  94.   WriteLn('Attempt to allocate 1K of XMS returned: ', VXmsErrorToStr(Err));
  95.   Err := LockExtMemBlock(Handle, LinearPtr);
  96.   WriteLn('LockExtMemBlock returned: ', VXmsErrorToStr(Err));
  97.   if Err = 0 then
  98.     WriteLn('Block''s 32 bit linear address = $', HexL(LinearPtr.ProtectedPtr));
  99.   Err := UnlockExtMemBlock(Handle);
  100.   WriteLn('UnlockExtMemBlock returned: ', VXmsErrorToStr(Err));
  101.   Err := FreeExtMem(Handle);
  102.   WriteLn('Attempt to free extended memory block returned: ', VXmsErrorToStr(Err));
  103. end;
  104.  
  105. procedure ResizeTest;
  106. var
  107.   Handle : Word;
  108.   Err : Byte;
  109. begin
  110.   WriteLn('Performing Resize Test');
  111.   Err := AllocateExtMem(1, Handle);
  112.   WriteLn('Attempt to allocate 1K of XMS returned: ', VXmsErrorToStr(Err));
  113.  
  114.   Err := ResizeExtMemBlock(Handle, 2);
  115.   WriteLn('ResizeExtMemBlock returned: ', VXmsErrorToStr(Err));
  116.  
  117.   Err := FreeExtMem(Handle);
  118.   WriteLn('Attempt to free extended memory block returned: ', VXmsErrorToStr(Err));
  119. end;
  120.  
  121. procedure UMBTest;
  122. var
  123.   Largest, SegBase : Word;
  124.   Err : Byte;
  125.   P : ^String;
  126. begin
  127.   WriteLn('Performing Upper Memory Block Test');
  128.   Err := AllocUpperMemBlock($FFFF, SegBase, Largest);
  129.   if Err = FuncNotImplemented then begin
  130.     WriteLn('Upper memory block functions are not implemented by this XMS driver');
  131.     Exit;
  132.   end;
  133.   WriteLn('The largest upper memory block available is ', Largest*16);
  134.   Err := AllocUpperMemBlock(Largest, SegBase, Largest);
  135.   WriteLn('Attempt to allocate ', Largest*16,' byte UMB: ', VXmsErrorToStr(Err));
  136.   if Err <> 0 then
  137.     Exit;
  138.   P := Ptr(SegBase, 0);
  139.   P^ := XmsStr;
  140.   WriteLn(P^);
  141.   Err := FreeUpperMemBlock(SegBase);
  142.   WriteLn('FreeUpperMemBlock returned: ', VXmsErrorToStr(Err));
  143. end;
  144.  
  145. procedure Pause;
  146.  
  147. begin
  148.   Write('Press any key to continue');
  149.   if ReadKey = #0 then ;
  150.   WriteLn;
  151. end;
  152.  
  153. begin
  154.   if not XmsInstalled then begin
  155.     WriteLn('There is no XMS memory manager installed.');
  156.     Halt;
  157.   end;
  158.   WriteLn('XMS Control function at ', HexPtr(XmsControl));
  159.   HMATest;
  160.   Pause;
  161.   AllocateTest;
  162.   Pause;
  163.   MoveTest;
  164.   Pause;
  165.   LockTest;
  166.   Pause;
  167.   ResizeTest;
  168.   Pause;
  169.   UMBTest;
  170. end.
  171.