home *** CD-ROM | disk | FTP | other *** search
/ Power Programming / powerprogramming1994.iso / progtool / turbopas / qwik55.arc / QINITEST.PAS < prev    next >
Pascal/Delphi Source File  |  1989-08-24  |  8KB  |  277 lines
  1. { =========================================================================== }
  2. { Qinitest.pas - tests your system configuration            ver 5.5, 08-24-89 }
  3. { =========================================================================== }
  4.  
  5. { Add "$" to include IBM's submodel ID detection: }
  6. { Define AddSubModelID }
  7. {^ add "$" here }
  8.  
  9. program QinitTest;
  10.  
  11. uses
  12.   Crt, Qwik, Strs;
  13.  
  14. type
  15.   Str9  = string[ 9];
  16.   Str33 = string[33];
  17.  
  18. var
  19.   NewMode,OldVideoMode: byte;
  20.   Strng:                string;
  21.   Ch:                   char;
  22.  
  23. const
  24.   CursorDelay = 1500;
  25.  
  26. { Since Zenith doesn't have snow on any CGAs, turn off snow checking }
  27. procedure CheckZenith;
  28. var  ZdsRom: array[1..8] of char absolute $F000:$800C;
  29. begin
  30.   if Qsnow and (ZdsRom='ZDS CORP') then
  31.     begin
  32.       Qsnow    := false;
  33.       CardSnow := false;
  34.     end;
  35. end;
  36.  
  37. procedure ClearScr;
  38. begin
  39.   Qfill (1,1,CRTrows,CRTcols,TextAttr,' ');
  40. end;
  41.  
  42. procedure InitScreen;
  43. begin
  44.   CheckZenith;
  45.   CheckSnow := Qsnow;
  46.   SetMultiTask;
  47.   if InMultiTask then
  48.     DirectVideo := false;
  49.   TextAttr  := Yellow+BlueBG;
  50.   ClearScr;
  51. end;
  52.  
  53. { -- Converts any number into a Binary character string -- }
  54. function DecToBin (Number: longint; Bits: byte): str33;
  55. const
  56.   D2B: array[0..1] of char = '01';
  57. var
  58.   BinStr: Str33;
  59.   Bit:    byte;
  60. begin
  61.   BinStr:='b';
  62.   for Bit:=0 to pred(Bits) do
  63.     BinStr:=D2B[(Number shr Bit) and 1] + BinStr;
  64.   DecToBin:=BinStr;
  65. end;
  66.  
  67. { -- Converts any number into a Hex character string -- }
  68. function DecToHex (Number: longint; HexChars: byte): str9;
  69. const
  70.   D2H: array[0..$F] of char = '0123456789ABCDEF';
  71. var
  72.   HexStr:       Str9;
  73.   HexChar,Bits: byte;
  74. begin
  75.   HexStr:='';
  76.   for HexChar:=0 to pred(HexChars) do
  77.     begin
  78.       Bits:=HexChar shl 2;
  79.       HexStr:=D2H[(Number shr Bits) and $F] + HexStr;
  80.     end;
  81.   DecToHex:='$' + HexStr;
  82. end;
  83.  
  84. procedure DisplayDev (DD: byte);
  85. begin
  86.   case DD of
  87.     $00: Strng:='No display';
  88.     $01: Strng:='MDA with 5151 monochrome';
  89.     $02: Strng:='CGA with 5153/4 color';
  90.     $04: Strng:='EGA with 5153/4 color';
  91.     $05: Strng:='EGA with 5151 monochrome';
  92.     $06: Strng:='PGC with 5175 color';
  93.     $07: Strng:='VGA with analog monochrome';
  94.     $08: Strng:='VGA with analog color';
  95.     $0B: Strng:='MCGA with analog monochrome';
  96.     $0C: Strng:='MCGA with analog color';
  97.   else Strng:='Reserved';
  98.   end; { case }
  99. end;
  100.  
  101. function StrTF (TF: boolean): Str9;
  102. begin
  103.   if TF then
  104.        StrTF:='True'
  105.   else StrTF:='False';
  106. end;
  107.  
  108. procedure DisplaySetCursor (Msg: string; Cursor: word);
  109. begin
  110.   SetCursor (Cursor);
  111.   QwriteEos (SameAttr,Msg+DecToHex(Cursor,4));
  112.   GotoEos;
  113.   delay (CursorDelay);
  114.   EosLn;
  115. end;
  116.  
  117. procedure DisplayModCursor (Msg: string; Cursor: word);
  118. begin
  119.   ModCursor (Cursor);
  120.   QwriteEos (SameAttr,Msg+DecToHex(Cursor,4)+' '+DecToHex(GetCursor,4));
  121.   GotoEos;
  122.   delay (CursorDelay);
  123.   EosLn;
  124. end;
  125.  
  126. procedure PromptKey;
  127. begin
  128.   Qwrite (CRTrows,1,SameAttr,'Press any key...');
  129.   GotoEos;
  130.   repeat
  131.     Ch:=ReadKey;
  132.   until not KeyPressed;
  133. end;
  134.  
  135. begin
  136.   InitScreen;
  137.   OldVideoMode := QVideoMode;
  138.   Qwrite (1,1,SameAttr,'Which text mode [0,1,2,3,7] ? ');
  139.   GotoEos;
  140.   repeat
  141.     Ch := readkey;
  142.   until Ch in ['0'..'3','7'];
  143.   NewMode := ord(Ch)-ord('0');
  144.   if NewMode<>OldVideoMode then
  145.     begin
  146.       TextMode (NewMode+hi(LastMode));
  147.       Qinit;
  148.     end;
  149.   InitScreen;
  150.   case CpuID of
  151.     Cpu8086:  Strng:='Intel 8086/88';
  152.     Cpu80186: Strng:='Intel 80186/188';
  153.     Cpu80286: Strng:='Intel 80286';
  154.     Cpu80386: Strng:='Intel 80386';
  155.   end;
  156.   Qwrite ( 1,1,SameAttr,'CPU ident         = '+Strng);
  157.  
  158.   {$IfDef AddSubModelID }
  159.   GetSubModelID;               { Check docs before using this procedure. }
  160.   {$EndIf }
  161.   case SystemID of
  162.     $FF: Strng:='IBM PC';
  163.     $FE: Strng:='IBM PC XT';
  164.     $FD: Strng:='IBM PCjr';
  165.     $FC: case SubModelID of
  166.            $00: Strng:='IBM PC AT (6 MHz)';
  167.            $01: Strng:='IBM PC AT (8 MHz)';
  168.            $02: Strng:='IBM PC XT (286)';
  169.            $04: Strng:='IBM PS/2 Model 50';
  170.            $05: Strng:='IBM PS/2 Model 60';
  171.          else   Strng:='IBM PS/2 VGA type';
  172.          end;
  173.     $FB: Strng:='IBM PC XT (256/640)';
  174.     $FA: case SubModelID of
  175.            $00: Strng:='IBM PS/2 Model 30';
  176.            $01: Strng:='IBM PS/2 Model 25';
  177.          else   Strng:='IBM PS/2 MCGA type';
  178.          end;
  179.     $F9: Strng:='IBM PC convertible';
  180.     $F8: case SubModelID of
  181.            $00: Strng:='IBM PS/2 Model 80 (16 MHz)';
  182.            $01: Strng:='IBM PS/2 Model 80 (20 MHz)';
  183.            $09: Strng:='IBM PS/2 Model 70 (16 MHz)';
  184.          else   Strng:='IBM PS/2 Model 70/80 type';
  185.          end;
  186.   else Strng:='Unknown, not an IBM';
  187.   end;  { case }
  188.  
  189.   Qwrite ( 2,1,SameAttr,'System ID         = '+DecToHex(SystemID,2));
  190.   {$IfDef AddSubModelID }
  191.   Qwrite ( 3,1,SameAttr,'SubModel ID       = '+StrL (SubModelID));
  192.   {$Else }
  193.   Qwrite ( 3,1,SameAttr,'SubModel ID       = ??');
  194.   {$EndIf }
  195.   Qwrite ( 4,3,SameAttr, Strng);
  196.   Qwrite ( 5,1,SameAttr,'Have PS/2 video   = '+StrTF (HavePS2));
  197.   Qwrite ( 6,1,SameAttr,'IBM 3270 PC       = '+StrTF (Have3270));
  198.   Qwrite ( 7,1,SameAttr,'Prior video mode  = '+StrL  (OldVideoMode));
  199.   Qwrite ( 8,1,SameAttr,'Video mode now    = '+StrL  (QvideoMode));
  200.   Qwrite ( 9,1,SameAttr,'Wait-for-retrace  = '+StrTF (Qsnow));
  201.   Qwrite (10,1,SameAttr,'Max page #        = '+StrL  (MaxPage));
  202.  
  203.   if Have3270 then
  204.     begin
  205.       Qwrite (11,1,SameAttr,
  206.               'Disp Dev 3270     = '+DecToHex(ActiveDispDev3270,2));
  207.       case ActiveDispDev3270 of
  208.         $00: Strng:='5151 or 5272 display and adapter';
  209.         $01: Strng:='3295 display and adapter';
  210.         $02: Strng:='5151 or 5272, adapter, XGA graphics';
  211.         $03: Strng:='5279 display, 3270 PC G adapter';
  212.         $04: Strng:='5379 C01 display, 3270 PC GX adapter';
  213.         $05: Strng:='5379 M01 display, 3270 PC GX adapter';
  214.         $FF: Strng:='Unknown, not a 3270 PC';
  215.       else Strng:='Reserved';
  216.       end;
  217.       Qwrite (12,3,SameAttr,Strng);
  218.     end
  219.   else
  220.     begin
  221.       DisplayDev (ActiveDispDev);
  222.       Qwrite (11,1,SameAttr,'Active Disp Dev   = '+DecToHex(ActiveDispDev,2));
  223.       Qwrite (12,3,SameAttr,Strng);
  224.  
  225.       if SystemID=$F9 then    { PC convertible }
  226.         Qwrite (13,1,SameAttr,
  227.                 'Alt Disp Dev PC Conv = '+DecToHex(AltDispDevPCC,4))
  228.       else
  229.         begin
  230.           DisplayDev (AltDispDev);
  231.           Qwrite (13,1,SameAttr,'Alt Disp Dev      = '+DecToHex(AltDispDev,2));
  232.           Qwrite (14,3,SameAttr,Strng);
  233.         end;
  234.  
  235.       Qwrite (15,1,SameAttr,'Hercules model    = '+StrL(HercModel));
  236.       case HercModel of
  237.         0: Strng:='No Hercules card';
  238.         1: Strng:='Hercules Graphics Card';
  239.         2: Strng:='Hercules Graphics Card Plus';
  240.         3: Strng:='Hercules InColor Card';
  241.       end;
  242.       Qwrite (16,3,SameAttr,Strng);
  243.     end;
  244.  
  245.   Qwrite (17,1,SameAttr,'CRT rows          = '+StrL(CRTrows));
  246.   Qwrite (18,1,SameAttr,'CRT columns       = '+StrL(CRTcols));
  247.   Qwrite (19,1,SameAttr,'Cursor start      = '+DecToHex(hi(CursorInitial),2));
  248.   Qwrite (20,1,SameAttr,'Cursor end        = '+DecToHex(lo(CursorInitial),2));
  249.   if (ActiveDispDev>=EgaColor) and (ActiveDispDev<=McgaColor) then
  250.     begin
  251.       Qwrite (21,1,SameAttr,'EGA rows          = '+StrL(EgaRows));
  252.       Qwrite (22,1,SameAttr,'EGA FontSize      = '+StrL(EgaFontSize));
  253.       Qwrite (23,1,SameAttr,'EGA Info          = '+DecToBin(EgaInfo,8));
  254.       Qwrite (24,1,SameAttr,'EGA Switches      = '+DecToBin(EgaSwitches,8));
  255.     end;
  256.   PromptKey;
  257.   ClearScr;
  258.   QwriteC (1,1,CRTcols,SameAttr,'Cursor Modes Test:');
  259.   Qwrite (3,1,SameAttr,'SET              MODE');
  260.   Qwrite (4,1,SameAttr,'-------------   -----');
  261.   EosLn;
  262.   DisplaySetCursor ('Initial       = ',CursorInitial);
  263.   DisplaySetCursor ('Underline     = ',CursorUnderline);
  264.   DisplaySetCursor ('Half-block    = ',CursorHalfBlock);
  265.   DisplaySetCursor ('Block         = ',CursorBlock);
  266.   EosLn;
  267.   QwriteEos (SameAttr,'MODIFY           MASK  MODE');
  268.   Qwrite (succ(EosR),1,SameAttr,'-------------   ----- -----');
  269.   EosLn;
  270.   DisplayModCursor ('Off           = ',CursorOff);
  271.   DisplayModCursor ('On            = ',CursorOn);
  272.   DisplayModCursor ('Erratic Blink = ',CursorBlink);
  273.   SetCursor (CursorInitial);
  274.   PromptKey;
  275.   TextMode (OldVideoMode+hi(LastMode));
  276. end.
  277.