home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / PCSTATUS.ZIP / PCSTATUS.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1985-12-28  |  13.5 KB  |  522 lines
  1. {$C-}
  2. {$R-}
  3. program pc_status;
  4.  
  5. const   dos_ds     = $0040;
  6.         dos_ds_str = '0040:';
  7.  
  8. type    registers = record
  9.                       ax, bx, cx, dx, bp, si, di, ds, es, flags: integer
  10.                     end;
  11.  
  12.         info = record case integer of
  13.                  1 : (b: byte);
  14.                  2 : (i: integer);
  15.                  3 : (pac: packed array[0..7] of char)
  16.                end;
  17.  
  18.         addr_ptr     = ^full_address;
  19.         full_address = record
  20.                          offset,
  21.                          segment: integer
  22.                        end;
  23.  
  24.         page_ptr = ^page;
  25.         page     = packed array[0..4095] of char;
  26.  
  27.         s80 = string[80];
  28.  
  29. var     regs         : registers;
  30.         crt_mode_set,
  31.         data_ptr     : ^info;
  32.         old_int_vec,
  33.         new_int_vec  : addr_ptr;
  34.         p0, p1       : page_ptr;
  35.         equip_flag,
  36.         mem_size,
  37.         max_drives,
  38.         i            : integer;
  39.         CGA80        : boolean;
  40.  
  41.         { DOS command line area in our PSP not otherwise used in this program }
  42.         error     : integer absolute cseg:$0080;
  43.  
  44.  
  45. function use_env(which: boolean; var name: s80; var value: s80): boolean;
  46.                  external 'useenv.com';
  47.  
  48.  
  49. { Get an interrupt vector's address }
  50. procedure get_vector(vec_num: byte; var address: addr_ptr);
  51. begin
  52.   regs.ax := $3500 + vec_num;
  53.   msdos(regs);
  54.   address := ptr(regs.es, regs.bx)
  55. end;
  56.  
  57.  
  58. { Set an interrupt vector's address }
  59. procedure set_vector(vec_num: byte; var address: addr_ptr);
  60. begin
  61.   regs.ax := $2500 + vec_num;
  62.   regs.ds := seg(address^);
  63.   regs.dx := ofs(address^);
  64.   msdos(regs)
  65. end;
  66.  
  67. { Handler is enterred at its first byte of user-specified code.
  68.   This means we bypass Turbo's set up for a normal procedure entry.
  69.   All Handler does is save the error code reported by DOS (we assume
  70.   a disk error), clean up the stack, and pass control directly back
  71.   to the Turbo code file location following the INT 21 which resulted
  72.   in the critical handler being invoked }
  73.  
  74. procedure handler;
  75. begin
  76.  
  77.   { move the error code in DI into our error variable }
  78.   inline ($FB/$2E/$89/$3E/$80/$00);
  79.   { FB            STI
  80.     2E            CS:
  81.     893E8000      MOV     [0080],DI }
  82.  
  83.   { pop off the DOS return info and a set of registers }
  84.   inline ($58/$58/$58/$58/$5B/$59/$5A/$5E/$5F/$5D/$1F/$07);
  85.   { 58            POP     AX      DOS return address
  86.     58            POP     AX      "                "
  87.     58            POP     AX      DOS flags register
  88.     58            POP     AX      Turbo registers
  89.     5B            POP     BX      "             "
  90.     59            POP     CX      "             "
  91.     5A            POP     DX      "             "
  92.     5E            POP     SI      "             "
  93.     5F            POP     DI      "             "
  94.     5D            POP     BP      "             "
  95.     1F            POP     DS      "             "
  96.     07            POP     ES      "             " }
  97.  
  98.   { override the normal Turbo return with an IRET }
  99.   inline ($CF);
  100.   { CF            IRET }
  101. end;
  102.  
  103.  
  104. procedure write_hex( value: integer );
  105. const     hexes : array[0..$F] of char = '0123456789ABCDEF';
  106. var       bump, divisor : integer;
  107. begin
  108.   if value < 0 then
  109.     begin
  110.       value := value - 32767 - 1;
  111.       bump  := 8
  112.     end
  113.   else
  114.     bump := 0;
  115.   divisor := 4096;
  116.   while divisor >= 1 do
  117.     begin
  118.       write( hexes[bump + (value div divisor)] );
  119.       value := value mod divisor;
  120.       divisor := divisor div 16;
  121.       bump := 0
  122.     end
  123. end;
  124.  
  125.  
  126. procedure blank_display;
  127. begin
  128.   crt_mode_set := ptr(dos_ds, $0065);
  129.   crt_mode_set^.b := crt_mode_set^.b and $F7;
  130.   port[$03d8] := crt_mode_set^.b
  131. end;
  132.  
  133.  
  134. procedure restore_display;
  135. begin
  136.   crt_mode_set := ptr(dos_ds, $0065);
  137.   crt_mode_set^.b := crt_mode_set^.b and $F7;
  138.   crt_mode_set^.b := crt_mode_set^.b + $08;
  139.   port[$03d8] := crt_mode_set^.b
  140. end;
  141.  
  142.  
  143. procedure move_page( from_page, to_page: page_ptr);
  144. begin
  145.   blank_display;
  146.   move(from_page^, to_page^, sizeof(page));
  147.   restore_display
  148. end;
  149.  
  150.  
  151. function has_cga: boolean;
  152. var      base_6845: ^integer;
  153. begin
  154.   base_6845 := ptr($0040, $0063);
  155.   has_cga := base_6845^ = $3D4
  156. end;
  157.  
  158.  
  159. procedure save_a_copy;
  160. begin
  161.   p0 := ptr($B800, 0);
  162.   p1 := ptr($B800, 4096);
  163.   move_page(p0, p1)
  164. end;
  165.  
  166.  
  167. procedure layout;
  168. begin
  169. clrscr;
  170. if has_cga then textbackground(blue);
  171. textcolor(cyan);
  172. writeln('IMMMMMMMMMMMMMMMMMMMQMMMMMMMMMMMMMMMMMMMQMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM;');
  173. write(  ':');
  174. textcolor(yellow);
  175. write(   ' MEMORY:');
  176. textcolor(cyan);
  177. write('3':12);
  178. textcolor(yellow);
  179. write(' EQUIPMENT:');
  180. textcolor(cyan);
  181. write('3': 9);
  182. textcolor(yellow);
  183. write(' VIDEO:  ');
  184. textcolor(cyan);
  185. writeln(':':29);
  186. writeln(': Planar            3 Printers          3 Initial Mode',':':25);
  187. writeln(': Total             3 Serial Ports      3 Current Mode',':':25);
  188. writeln(': Free              3 Floppy Drives     3 Attribute @ Cursor',':':19);
  189. writeln(': From              3 Game Adaptor      3 Buffer Offset, Length',':':16);
  190. writeln('GDDDDDDDDDDDDDDDDDDDADDDDDDDDDDDDDDDDDDD4 Video Page',':':27);
  191. write(':');
  192. textcolor(yellow);
  193. write(' KEYBOARD BUFFER:');
  194. textcolor(cyan);
  195. writeln('3':23,' Cursor Mode',':':26);
  196. writeln(': Capacity           Start              3 6845 Mode',':':28);
  197. writeln(': ( characters )       End              3 6845 Pallette',':':24);
  198. writeln('GDDDDDDDDDDDDDDDDDDDBDDDDDDDDDDDDDDDDDDDEDDDDDDDDDDDDDDDDDBDDDDDDDDDDDDDDDDDDD6');
  199. write(':');
  200. textcolor(yellow);
  201. write(' DOS VER:');
  202. textcolor(cyan);
  203. write('3':11);
  204. textcolor(yellow);
  205. write(' ROM VER:');
  206. textcolor(cyan);
  207. write('3':11);
  208. textcolor(yellow);
  209. write(' ^C CHECK:');
  210. textcolor(cyan);
  211. write('3':8);
  212. textcolor(yellow);
  213. write(' DISK VERIFY:');
  214. textcolor(cyan);
  215. writeln(':':7);
  216. writeln('GDDDDDDDDDDDDDDDDDDDADDDDDDDDDDDDDDDDDDDADDDDDDDDDDDDDDDDDADDDDDDDDDDDDDDDDDDD6');
  217. write(':');
  218. textcolor(yellow);
  219. write(' FREE SPACE ON DISKETTE DRIVES:');
  220. textcolor(cyan);
  221. writeln(':':47);
  222. writeln(':',':':78);
  223. writeln(':',':':78);
  224. writeln('GDDDDDDDDDDDDDDDDDDDDBDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD6');
  225. write(':');
  226. textcolor(yellow);
  227. write(' F. D. PARAMETERS:');
  228. textcolor(cyan);
  229. write('3':3);
  230. textcolor(yellow);
  231. write(' ENVIRONMENT SETTINGS:');
  232. textcolor(cyan);
  233. writeln(':':35);
  234. writeln(': On Time         ms 3',':':57);
  235. writeln(': Off Time        s  3',':':57);
  236. writeln(': Settling        ms 3',':':57);
  237. writeln(': B/S, S/T           3',':':57);
  238. writeln('HMMMMMMMMMMMMMMMMMMMMOMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM<');
  239. write(' PC-STATUS','Copyright  1985  John D. Falconer ':69);
  240. textcolor(green)
  241. end;
  242.  
  243.  
  244. procedure show_equipment;
  245. begin
  246.   data_ptr   := ptr(dos_ds, $0010);
  247.   equip_flag := data_ptr^.i;
  248.   max_drives := ((equip_flag shr 6) and 3) * (1 and equip_flag)
  249.                 + (1 and equip_flag);
  250.   gotoxy(38,3); write(equip_flag shr 14:2);
  251.   gotoxy(38,4); write((equip_flag shr 9) and 7:2);
  252.   gotoxy(38,5); write(max_drives:2);
  253.   gotoxy(38,6); write((equip_flag shr 12) and 1:2);
  254.   gotoxy(13,3); write(((equip_flag shr 2) and 3) * 16 + 16:6, 'K');
  255. end;
  256.  
  257.  
  258. procedure show_total_memory;
  259. begin
  260.   data_ptr := ptr(dos_ds, $0013);
  261.   mem_size := data_ptr^.i;
  262.   gotoxy(13, 4); write(mem_size:6,'K')
  263. end;
  264.  
  265.  
  266. procedure show_mem_usage;
  267. begin
  268.   gotoxy(16, 5); write(mem_size - (cseg + 16) div 64,'K');
  269.   gotoxy(10, 6); write_hex(cseg); write(':0100H')
  270. end;
  271.  
  272.  
  273. procedure show_kb_info;
  274. var       kb_start, kb_end: integer;
  275. begin
  276.   data_ptr := ptr(dos_ds, $0080);
  277.   kb_start := data_ptr^.i;
  278.   gotoxy( 30, 9); write(dos_ds_str); write_hex(kb_start); write('H');
  279.   data_ptr := ptr(dos_ds, $0082);
  280.   kb_end := data_ptr^.i;
  281.   gotoxy( 30,10); write(dos_ds_str); write_hex(kb_end); write('H');
  282.   gotoxy( 14, 9); writeln((kb_end - kb_start)/2 - 1:0:0)
  283. end;
  284.  
  285.  
  286. procedure show_video_info;
  287.  
  288. procedure show_initial_video( mode: integer );
  289. begin
  290.   gotoxy(64,3);
  291.   case (mode) and 3 of
  292.     1: write('40 x 25 BW/CGA');
  293.     2: write('80 x 25 BW/CGA');
  294.     3: write('80 x 25 BW/BW');
  295.   end
  296. end;
  297.  
  298.  
  299. procedure show_current_video;
  300. begin
  301.   data_ptr := ptr(dos_ds, $0049);
  302.   gotoxy(64, 4);
  303.   case (data_ptr^.b) of
  304.     0: write('40 x 25 BW');
  305.     1: write('40 x 25 color');
  306.     2: write('80 x 25 BW');
  307.     3: write('80 x 25 color');
  308.   end;
  309.   CGA80 := data_ptr^.b = 3
  310. end;
  311.  
  312.  
  313. procedure show_attribute;
  314.  
  315. function get_attr: byte;
  316. begin
  317.   regs.ax := $0800;
  318.   regs.bx := $0100;
  319.   intr($10, regs);
  320.   get_attr := regs.ax shr 8
  321. end;
  322.  
  323. begin { show_attribute }
  324.   gotoxy(72, 5);
  325.   write(get_attr:6)
  326. end;
  327.  
  328.  
  329. begin { show_video_info }
  330.   show_initial_video(equip_flag shr 4);
  331.   show_current_video;
  332.   show_attribute;
  333.   data_ptr := ptr(dos_ds, $004E);              { crt_start }
  334.   gotoxy(65, 6); write(data_ptr^.i:6,',');
  335.   data_ptr := ptr(dos_ds, $004C);              { crt_len }
  336.   gotoxy(72, 6); write(data_ptr^.i:6);
  337.   data_ptr := ptr(dos_ds, $0062);              { active_page }
  338.   gotoxy(72, 7); write(data_ptr^.b:6);
  339.   data_ptr := ptr(dos_ds, $0060);              { cursor_mode }
  340.   gotoxy(72, 8); write(data_ptr^.i:6);
  341.   gotoxy(72, 9); write(data_ptr^.b:6);
  342.   data_ptr := ptr(dos_ds, $0066);              { crt_pallette }
  343.   gotoxy(72, 10); write(data_ptr^.b:6)
  344. end;
  345.  
  346.  
  347. procedure show_version_info;
  348. type      s4 = string[4];
  349. var       dos_version: s4;
  350.  
  351. procedure get_version( var dos_version: s4 );
  352. begin
  353.   dos_version := ' .00';
  354.   regs.ax := $3000;
  355.   msdos(regs);
  356.   dos_version[1] := chr(lo(regs.ax) + ord('0'));
  357.   if hi(regs.ax) >= 10 then
  358.     dos_version[3] := chr((hi(regs.ax) div 10) + ord('0'));
  359.   dos_version[4] := chr((hi(regs.ax) mod 10) + ord('0'));
  360. end;
  361.  
  362. begin { show_version_info }
  363.   get_version(dos_version);
  364.   gotoxy(16, 12); write(dos_version);
  365.   data_ptr := ptr($F000, $FFF5);
  366.   gotoxy(32, 12); for i := 0 to 7 do write(data_ptr^.pac[i]);
  367. end;
  368.  
  369.  
  370. procedure show_control_C;
  371.  
  372. function control_C_check: boolean;
  373. begin
  374.   regs.ax := $3300;
  375.   msdos(regs);
  376.   control_C_check := (regs.dx and $01) = 1
  377. end;
  378.  
  379. begin
  380.   gotoxy(55, 12);
  381.   if control_C_check then write('ON':3) else write('OFF')
  382. end;
  383.  
  384.  
  385. procedure show_disk_verify;
  386.  
  387. function disk_verify_check: boolean;
  388. begin
  389.   regs.ax := $5400;
  390.   msdos(regs);
  391.   disk_verify_check := (regs.ax and $01) = 1
  392. end;
  393.  
  394. begin
  395.   gotoxy(75, 12);
  396.   if disk_verify_check then write('ON':3) else write('OFF')
  397. end;
  398.  
  399.  
  400. procedure show_env_info;
  401. var       env_name,
  402.           env_value: s80;
  403.  
  404. procedure show_env(env_name: s80);
  405. begin
  406.   write(env_name + ' = ':10);
  407.   if use_env( false, env_name, env_value ) then
  408.     write(env_value)
  409.   else
  410.     write('undefined');
  411. end;
  412.  
  413. begin { show_env_info }
  414.   gotoxy(24, 19); show_env('COMSPEC');
  415.   gotoxy(24, 20); show_env('PROMPT');
  416.   gotoxy(24, 21); show_env('PATH')
  417. end;
  418.  
  419.  
  420. procedure show_disk_parms;
  421. const     disk_pointer = $0078;
  422. type      disk_info    = record
  423.                            misc1,        misc2,          motor_wait,
  424.                            bytes_sector, sectors_track,  gap_length,
  425.                            dtl,          fmt_gap_length, fmt_fill_byte,
  426.                            settle,       motor_start
  427.                              : byte
  428.                          end;
  429. var       disk_vector  : addr_ptr;
  430.           disk_parms   : ^disk_info;
  431. begin
  432.   disk_vector := ptr($0000, disk_pointer);
  433.   disk_parms  := ptr(disk_vector^.segment, disk_vector^.offset);
  434.   with disk_parms^ do
  435.     begin
  436.       gotoxy(15, 19); write(125 * motor_start:3);
  437.       gotoxy(15, 20); write(motor_wait / 18.5:3:1);
  438.       gotoxy(15, 21); write(     settle:3);
  439.       gotoxy(14, 22); write(256 * bytes_sector:3,',');
  440.       gotoxy(18, 22); write(sectors_track:3);
  441.     end
  442. end;
  443.  
  444.  
  445. procedure show_drive_space;
  446. var       drive: byte;
  447.           avail: real;
  448.  
  449. function free_space(drv_num: byte): real;
  450. var       a, b, c: real;
  451. begin
  452.   regs.ax := $3600;
  453.   regs.dx := drv_num;
  454.   msdos(regs);
  455.   if regs.ax <> $FFFF then
  456.     begin
  457.       a := regs.ax;
  458.       b := regs.bx;
  459.       c := regs.cx;
  460.       free_space := a * b * c
  461.     end
  462.   else
  463.     free_space := -1
  464. end;
  465.  
  466. begin
  467.   drive := 0;
  468.   while drive < max_drives do
  469.     begin
  470.       error := 0;
  471.       gotoxy( 3 + drive mod 4 * 20, 15 + drive div 4);
  472.       drive := drive + 1;
  473.       write(chr(drive - 1 + ord('A')),': ');
  474.  
  475.       {
  476.       If DOS generates a critical error interrupt because of a problem
  477.       during free_space's use of a drive, the interrupt will be handled
  478.       by "handler" which will load the code of the error into our "error"
  479.       variable.
  480.       }
  481.  
  482.       avail := free_space(drive);
  483.       if error > 0 then
  484.         begin
  485.           textcolor(red + blink);
  486.           case error of
  487.             1 : write('UNK. UNIT');
  488.             2 : write('NOT READY');
  489.             4 : write('CRC ERROR');
  490.             8 : write('SECTOR ERROR')
  491.           end;
  492.           textcolor(green)
  493.         end
  494.       else
  495.         if avail = -1 then write('UNAVAILABLE')
  496.       else
  497.         write(avail:8:0);
  498.     end
  499. end;
  500.  
  501.  
  502. begin
  503.   get_vector($24, old_int_vec);
  504.   new_int_vec := ptr(cseg, ofs(handler) + 7);
  505.   set_vector($24, new_int_vec);
  506.   layout;
  507.   show_equipment;
  508.   show_total_memory;
  509.   show_mem_usage;
  510.   show_kb_info;
  511.   show_video_info;
  512.   show_version_info;
  513.   show_control_C;
  514.   show_disk_verify;
  515.   show_env_info;
  516.   show_disk_parms;
  517.   show_drive_space;
  518.   gotoxy(1, 24);
  519.   if has_cga then save_a_copy;
  520.   set_vector($24, old_int_vec)
  521. end.
  522.