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