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