home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / sigm / vol255 / dpio86.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1986-03-22  |  17.3 KB  |  741 lines
  1. MODULE DPIO86;          { I/O module for CP/M86 }
  2. {-------------------------------------------------------------}
  3. {                                                             }
  4. {       Program Title: Floppy Disk  Patch Program             }
  5. {                                                             }
  6. {       Program  file:  DPM.PAS         ... Main control      }
  7. {                       DPEDIT.PAS      ... Edit module       }
  8. {                       DPIO.PAS        ... I/O  module       }
  9. {                       DPL.CMD         ... Linkage parameter }
  10. {                                                             }
  11. {       Last update : 21-Oct-1984 by K.Maeda                  }
  12. {                                                             }
  13. {           Note : This program was originally written by     }
  14. {               Keizo Maeda and checked (and enhanced) by     }
  15. {               Sakurao Nemoto and is a Public Domain Soft-   }
  16. {               ware (JUG-CP/M). If you make revisions, etc.  }
  17. {               please leave the author and modifiers name    }
  18. {               in the source file. Thank you.                }
  19. {                                                             }
  20. {          Ver-Rev :                                          }
  21. {                       0.0 : 7 July, 83       by  K.Maeda    }
  22. {                       2.0 : 28 July,83                      }
  23. {                             ...check sum...  by  S.Nemoto   }
  24. {                       3.0 : 20 September,83                 }
  25. {                             ...8 inch support...            }
  26. {                       5.3 : 6 November, 83                  }
  27. {                             ...Printing Hard Copy...        }
  28. {                       5.5 : 23 December,83                  }
  29. {                             ...Read EBCDIK code...          }
  30. {                       6.0 : 12 May,84                       }
  31. {                             ...Make File...                 }
  32. {                       6.1 : 18 May,84                       }
  33. {                             ...Exclusive Find...            }
  34. {                       6.2 : 17 June,84                      }
  35. {                       6.3 : 21 October,84                   }
  36. {                             ...beep at print_mode...        }
  37. {                                                             }
  38. {-------------------------------------------------------------}
  39.  
  40.  
  41. const
  42.         ctrl_a= 1;
  43.         ctrl_j=10;
  44.         ctrl_k=11;
  45.         ctrl_l=12;
  46.         ctrl_o=15;
  47.         ctrl_p=16;
  48.         esc  = 27;
  49.         cr   = 13;
  50.         bs   =  8;
  51.  
  52. type
  53. cpmoperation = (coldboot,warmboot,constat,conin,conout,list,
  54.                 punout,rdrin,home,seldsk,settrk,setsec,setdma,
  55.                 dskread,dskwrite,listst,sectran,setdmab,getsegb);
  56. iooperation  = (get_disk, put_disk);
  57. buffer = array [0..255] of byte ;
  58. ptr = ^integer;
  59.  
  60. var
  61.   ebcdik:       external boolean; { flag of EBCDIK code }
  62.  
  63.   sb_last_x,
  64.   sb_last_y:    external integer;
  65.  
  66.   cdisk:        external integer; { current Drive no. }
  67.  
  68.  
  69.   in_drive,in_trk,in_sec,in_skew,            { variables for FD i/o }
  70.   in_trk_num,in_sec_num,
  71.   e_trk,e_sec,
  72.   o_drive,o_trk,o_sec,o_skew,
  73.   o_trk_num,o_sec_num   :       external integer;
  74.  
  75.   ch_drv, ch_drv_o :            external char;
  76.  
  77.   skew_tab:     external array[0..2,1..52] of byte;   { skew table }
  78.  
  79.   buff:         external array[0..15] of buffer;      { I/O Buffer }
  80.  
  81.   flg_85 : external boolean;
  82.   pr_flg : external boolean;
  83.   pr2_flg: external boolean;
  84.  
  85.   rqtab : array[1..6] of byte;
  86.   integ_to_ptr : record
  87.         case boolean of
  88.           true : (lo : integer;
  89.                   hi : integer);
  90.           false: (pointr : ptr );
  91.         end;
  92.  
  93.  
  94. EXTERNAL FUNCTION @BDOS86(FUNC:INTEGER; PARM:PTR):INTEGER;
  95.                         { func=50 :  direct BIOS call }
  96.  
  97.  
  98. procedure sb_bios_call(func:cpmoperation; parm:integer);
  99. var
  100.   idum  : integer;
  101. begin
  102.   rqtab[1]:=ord(func);
  103.   rqtab[2]:=lo(parm);
  104.   rqtab[3]:=hi(parm);
  105.   rqtab[4]:=0;
  106.   rqtab[5]:=0;
  107.  
  108.   idum := @bdos86( 50,addr(rqtab[1]) )
  109.  
  110. end;
  111.  
  112. function bios_func( func:cpmoperation; parm:integer): integer;
  113. var
  114.   idum  : integer;
  115. begin
  116.   rqtab[1]:=ord(func);
  117.   rqtab[2]:=lo(parm);
  118.   rqtab[3]:=hi(parm);
  119.   rqtab[4]:=0;
  120.   rqtab[5]:=0;
  121.  
  122.   idum := @bdos86( 50,addr(rqtab[1]) );
  123.  
  124.   bios_func := idum;
  125.  
  126. end;
  127.  
  128. procedure prologue;        (* start routine *)
  129. var a,i,j:   integer;
  130.     sk3,sk6: integer;
  131.     ch : char;
  132. begin
  133.   ebcdik :=false;
  134.  
  135.   flg_85:=false;  pr_flg:=false;
  136.  
  137.  
  138.   cdisk:=@bdos86( 25,addr(i) );     { save current Drive No.  }
  139.  
  140.   sk3:=1; sk6:=1;                   { Set skew table }
  141.   for i:=1 to 26 do
  142.   begin
  143.     skew_tab[0,i]:=i;
  144.  
  145.     skew_tab[1,i]:=sk3;
  146.     sk3:=sk3+3;
  147.     if sk3 > 26 then sk3:=sk3-26;
  148.  
  149.     skew_tab[2,i]:=sk6;
  150.     sk6:=sk6+6;
  151.     if sk6 > 26 then sk6:=sk6-26;
  152.     if sk6 = 1  then sk6:=2;
  153.   end;
  154.  
  155.   for i:=27 to 52 do
  156.   begin
  157.     j:=i-26;
  158.     skew_tab[0,i]:=i;
  159.     skew_tab[1,i]:=skew_tab[1,j]+26;
  160.     skew_tab[2,i]:=skew_tab[2,j]+26
  161.   end;
  162. end;
  163.  
  164.  
  165.  
  166. procedure wboot;                { return to CP/M }
  167. var
  168.   i : integer;
  169. begin
  170.   xygoto( 1,23);
  171.   set_drive( cdisk );
  172.   sb_bios_call(home,0);
  173.   i:=@bdos86( 0,addr(i) );
  174. end;
  175.  
  176. procedure rset_drv;
  177. var
  178.   i : integer;
  179. begin
  180.   i:=@bdos86(13,addr(i)); {------ Reset Drive ------}
  181. end;
  182.  
  183. procedure get_buff( var a_buff:buffer; var noerr:boolean );
  184. var
  185.   sec1,sec2    : integer;
  186.   ior:           byte;
  187.   ch:            char;
  188. begin
  189.   noerr:=true;
  190.   sec2:=skew_tab[in_skew,in_sec];
  191.   sec2:=sec2+sec2;
  192.   sec1:=sec2-1;
  193.  
  194.   if in_sec_num=13 then     { for fd1  }
  195.   begin
  196.     sec2:=in_sec+in_sec;
  197.     sec1:=sec2-1;
  198.     sec2:=skew_tab[2,sec2];
  199.     sec1:=skew_tab[2,sec1]
  200.   end;
  201.  
  202.   set_drive(in_drive);
  203.  
  204.   sb_bios_call(settrk,in_trk  );
  205.   sb_bios_call(setsec,sec1    );
  206.   def_dma( addr(a_buff[0]) );
  207.  
  208.   ior:=bios_func(dskread,0      );
  209.   if ior<>0 then noerr:=false;
  210.  
  211.   sb_bios_call(settrk,in_trk  );
  212.   sb_bios_call(setsec,sec2    );
  213.   def_dma( addr(a_buff[128]) );
  214.  
  215.   ior:=bios_func(dskread,0      );
  216.   if ior<>0 then noerr:=false;
  217.  
  218. end;
  219.  
  220. procedure put_buff( var a_buff:buffer; var noerr:boolean );
  221. var
  222.   sec1,sec2 :     integer;
  223.   ior :           byte;
  224.   ch:             char;
  225. begin
  226.   noerr:=true;
  227.   sec2:=skew_tab[o_skew,o_sec];
  228.   sec2:=sec2+sec2;
  229.   sec1:=sec2-1;
  230.  
  231.   if o_sec_num = 13 then  { for fd1  }
  232.   begin
  233.     sec2:=o_sec+o_sec;
  234.     sec1:=sec2-1;
  235.     sec2:=skew_tab[2,sec2];
  236.     sec1:=skew_tab[2,sec1]
  237.   end;
  238.  
  239.   set_drive(o_drive);
  240.  
  241.   sb_bios_call(settrk,o_trk  );
  242.   sb_bios_call(setsec,sec1   );
  243.   def_dma( addr(a_buff[0]) );
  244.  
  245.   ior:=bios_func(dskwrite,1    );
  246.   if ior<>0 then noerr:=false;
  247.  
  248.   sb_bios_call(settrk,o_trk  );
  249.   sb_bios_call(setsec,sec2   );
  250.   def_dma( addr(a_buff[128]) );
  251.  
  252.   ior:=bios_func(dskwrite,1    );
  253.   if ior<>0 then noerr:=false
  254.  
  255. end;
  256.  
  257. procedure set_drive(drive:integer);
  258. var
  259.   i : integer;
  260. begin
  261.   integ_to_ptr.hi := 0;
  262.   integ_to_ptr.lo := drive;
  263.   i:=@bdos86( 14,integ_to_ptr.pointr );
  264.  
  265.   sb_bios_call(seldsk,drive)
  266. end;
  267.  
  268. procedure def_dma( adres:ptr );
  269. var
  270.   i : integer;
  271. begin
  272.  
  273.   integ_to_ptr.pointr := adres;
  274.   sb_bios_call(setdma, integ_to_ptr.lo );
  275.   sb_bios_call(setdmab,integ_to_ptr.hi );
  276.  
  277. end;
  278.  
  279.  
  280. procedure KIND_DSK( DRIVE:integer; var FL_TYPE:string;
  281.                     var TRK_NUM,SEC_NUM,SKEW : integer;var NOERR:boolean );
  282. var
  283.   SEC,D_ADR,DPB_ADR : integer ;
  284. begin
  285.   set_drive( drive );
  286.  
  287.   INLINE( $06 / $b1 / $1f /     { push es  ! mov cl,1f  }
  288.           $cd / $e0 /           { int  e0               }
  289.           $26 / $8b / $07 /     { mov ax,es:[bx]        }
  290.           $89 / $86 / sec /     { mov sec[bp],ax        }
  291.           $07           );      { pop es                }
  292.  
  293.  
  294.   NOERR:=false;
  295.   FL_TYPE:='    ';
  296.   TRK_NUM:=40;
  297.   SEC_NUM:=32;
  298.  
  299.   case SEC of
  300.   32: begin
  301.         FL_TYPE:='MD2-98';
  302.         TRK_NUM:=159;   { for MD2-DD }
  303.         SEC_NUM:=16;
  304.         SKEW:=0;
  305.         NOERR:=true
  306.       end;
  307.   64: begin
  308.         FL_TYPE:='MD2D';
  309.         TRK_NUM:=40;
  310.         SEC_NUM:=32;
  311.         SKEW:=0;
  312.         NOERR:=true
  313.       end;
  314.   26: begin
  315.         FL_TYPE:='FD1 ';
  316.         TRK_NUM:=77;
  317.         SEC_NUM:=13;
  318.         SKEW:=0;
  319.         NOERR:=true
  320.       end;
  321.   104:begin
  322.         FL_TYPE:='FD2D';
  323.         TRK_NUM:=77;
  324.         SEC_NUM:=52;
  325.         SKEW:=-1;
  326.         NOERR:=true
  327.       end;
  328.   end;
  329. end;
  330.  
  331. procedure dump_buff;           {  Make HEX and ASCII dump of var. BUFF }
  332. var
  333.   i,j,k,l : integer;
  334.   blkno   : integer;
  335.   sum     : integer;
  336.   vsum    : array [0..15] of integer;
  337. begin
  338.   sb_clr_scrn;
  339.   if in_trk_num > 40                                       { blk-no }
  340.      then blkno:=( (in_trk -2)*52 + in_sec-1 )  div 16     { 8 inch }
  341.      else blkno:=(in_trk - 2)*4+((in_sec -1) div 8);       { 5 inch }
  342.  
  343.   if pr_flg then writeln([addr(lst_out)]);
  344.  
  345.   write([addr(pr_out_ch)],'     Drive: ',ch_drv:1,'   Track: ',in_trk:2,
  346.                           '   Sector: ',in_sec:2 ,
  347.                           '   Block: ');hex(blkno);
  348.   if ebcdik then write([addr(pr_out_ch)],'                  EBCDIK')
  349.             else write([addr(pr_out_ch)],'                  JIS 8');
  350.   writeln([addr(sb_out_ch)]);
  351.   writeln([addr(pr_out_ch)]);
  352.  
  353.   write([addr(pr_out_ch)],'     ');
  354.   for i:=0 to 15 do begin
  355.     if i=8 then write([addr(pr_out_ch)],' ');
  356.     vsum[i]:=0;
  357.     hex1(i)
  358.   end;
  359.   writeln([addr(pr_out_ch)],'  Hsum');
  360.  
  361.   for i:=0 to 15 do
  362.   begin
  363.     k:=i*16;
  364.     hex(k); write([addr(pr_out_ch)],':  ');
  365.     sum:=0;
  366.     begin
  367.       for l:=0 to 15 do
  368.       begin
  369.         if l=8 then write([addr(pr_out_ch)],' ');
  370.         sum:=sum+buff[0][k+l];
  371.         hex(buff[0][k+l]);
  372.         vsum[l]:=vsum[l]+buff[0][k+l];
  373.         write([addr(pr_out_ch)],' ');
  374.       end;
  375.       write([addr(pr_out_ch)],'   ');  hex(sum)
  376.     end;
  377.  
  378.     write([addr(pr_out_ch)],'   ');
  379.     for j:=k to k+15 do ascii(buff[0][j]);
  380.     writeln([addr(pr_out_ch)])
  381.   end;
  382.  
  383.     write([addr(pr_out_ch)],'------');
  384.     sum:=0;
  385.     for i:=0 to 15 do
  386.     begin
  387.       sum:=sum+vsum[i];
  388.       write([addr(pr_out_ch)],'---')
  389.     end;
  390.     writeln([addr(pr_out_ch)],'-----');
  391.  
  392.     write([addr(pr_out_ch)],'VSum:');
  393.     for i:=0 to 15 do
  394.     begin
  395.       if i=8 then write([addr(pr_out_ch)],' ');
  396.       hex(vsum[i]);
  397.       write([addr(pr_out_ch)],' ');
  398.     end;
  399.     write([addr(pr_out_ch)],'   ');hex(sum);
  400.     writeln([addr(pr_out_ch)]);
  401.     writeln([addr(pr_out_ch)]);
  402.  
  403. end;
  404.  
  405.  
  406. procedure COUNT_UP( var TRK,SEC,SEC_NUM : integer );
  407. begin
  408.   SEC:=SEC+1;
  409.   if SEC > SEC_NUM  then
  410.   begin
  411.      SEC:=1;
  412.      TRK:=TRK+1
  413.   end;
  414. end;
  415.  
  416. procedure COUNT_DWN( var TRK,SEC,SEC_NUM : integer );
  417. begin
  418.   SEC:=SEC-1;
  419.   if SEC < 1 then
  420.   begin
  421.      SEC:=SEC_NUM;
  422.      TRK:=TRK-1;
  423.      if TRK < 0 then begin
  424.                        TRK:=0;
  425.                        SEC:=1
  426.                      end;
  427.   end
  428. end;
  429.  
  430.  
  431. procedure lst_out(ch:char);
  432. begin
  433.   sb_bios_call(list,ord(ch))
  434. end;
  435.  
  436. procedure pr_out_ch(ch:char);
  437. begin
  438.   sb_bios_call(conout,ord(ch));
  439.   if pr_flg then lst_out(ch)
  440. end;
  441.  
  442.  
  443. PROCEDURE SB_OUT_CH(CH:CHAR);
  444. BEGIN
  445.   SB_BIOS_CALL(CONOUT,ORD(CH))
  446. END;
  447.  
  448. FUNCTION  SB_GETCH:CHAR;
  449. VAR
  450.   ICH : BYTE;
  451.   ch  : char;
  452. begin
  453.  
  454.   repeat
  455.      ICH := BIOS_FUNC(CONIN,0);
  456.      ch := CHR(ICH);
  457.      if ch=chr(ctrl_p) then begin
  458.                             pr_flg:= not pr_flg;
  459.                             if pr_flg then sb_out_ch(chr(7)); {beep}
  460.                             pr2_flg:=pr_flg
  461.                        end;
  462.      if ch=chr(ctrl_o) then ebcdik:= not ebcdik;
  463.  
  464.   until (ch<>chr(ctrl_p)) and (ch<>chr(ctrl_o));
  465.  
  466.   sb_getch := ch
  467. end;
  468.  
  469. procedure xygoto( x,y:integer);
  470. begin
  471.   sb_out_ch(chr(esc));
  472.   sb_out_ch('=');
  473.   sb_out_ch(chr(y+32));
  474.   sb_out_ch(chr(x+32));
  475.   sb_last_x := x;
  476.   sb_last_y := y
  477. end;
  478.  
  479. procedure sb_clr_scrn;
  480. begin
  481.   sb_out_ch(chr(esc)); sb_out_ch('*');
  482.   xygoto(0,0)
  483. end;
  484.  
  485. procedure sb_clr_eos;
  486. begin
  487.   sb_out_ch(chr(esc));
  488.   sb_out_ch('Y');
  489. end;
  490.  
  491.  
  492. procedure sb_clr_line;
  493. begin
  494.   sb_out_ch(chr(esc));
  495.   sb_out_ch('T')
  496. end;
  497.  
  498. function sb_stcon : byte;
  499. var
  500.   i : integer;
  501.   x : byte;
  502. begin
  503.   x:=bios_func( constat,0 );
  504.   sb_stcon:=x
  505. end;
  506.  
  507. procedure prnt_at( row,col:integer; s:string);
  508. begin
  509.   xygoto( col,row);
  510.   write([addr(sb_out_ch)],s)
  511. end;
  512.  
  513. function  sb_up_case(ch:char):char;
  514. begin
  515.   if (ch >= 'a') and (ch <= 'z') then
  516.     sb_up_case := chr(ch & $df)
  517.   else
  518.     sb_up_case := ch
  519. end;
  520.  
  521. procedure hex1( x: byte);
  522. var     ml : integer;
  523.         cl : char;
  524. begin
  525.   ml:=x mod 16 ;
  526.   if ml > 9 then cl:=chr(ml+55) else cl:=chr(ml+48);
  527.   write([addr(pr_out_ch)],'+',cl,' ')
  528. end;
  529.  
  530. procedure hex( x : byte );
  531. var
  532.   mh,ml : integer;
  533.   ch,cl : char;
  534. begin
  535.   mh:=x div 16 ;  ml:=x mod 16 ;
  536.   if mh > 9 then ch:=chr(mh+55) else ch:=chr(mh+48);
  537.   if ml > 9 then cl:=chr(ml+55) else cl:=chr(ml+48);
  538.   write([addr(pr_out_ch)],ch,cl)
  539. end;
  540.  
  541. procedure chex( x : byte );
  542. var
  543.   mh,ml : integer;
  544.   ch,cl : char;
  545. begin
  546.   mh:=x div 16 ;  ml:=x mod 16 ;
  547.   if mh > 9 then ch:=chr(mh+55) else ch:=chr(mh+48);
  548.   if ml > 9 then cl:=chr(ml+55) else cl:=chr(ml+48);
  549.   write([addr(sb_out_ch)],ch,cl)
  550. end;
  551.  
  552. procedure ascii( code_ch : byte );
  553. var
  554.   x : byte;
  555.   tab_ptr: ^buffer;
  556.   i : integer;
  557. begin
  558.   tab_ptr:=addr( tran_tbl );
  559.   i := code_ch;
  560.   if ebcdik then x:=tab_ptr^[i+8]
  561.             else x:=code_ch;
  562.   if (x > $1f) and (x < $ff)
  563.   then write([addr(pr_out_ch)],chr(x))
  564.   else write([addr(pr_out_ch)],'.'   )
  565. end;
  566.  
  567. procedure cascii( code_ch : byte );
  568. var
  569.   x : byte;
  570.   tab_ptr: ^buffer;
  571.   i : integer;
  572. begin
  573.   tab_ptr:=addr( tran_tbl );
  574.   i:=code_ch;
  575.   if ebcdik then x:=tab_ptr^[i+8]
  576.             else x:=code_ch;
  577.   if (x > $1f) and (x < $ff)
  578.   then write([addr(sb_out_ch)],chr(x))
  579.   else write([addr(sb_out_ch)],'.'   )
  580. end;
  581.  
  582. function cval( ch : char ) : byte;
  583. var
  584.   x : byte;
  585.   tab_ptr: ^buffer;
  586.   i : integer;
  587. begin
  588.   tab_ptr:=addr( tran_tbl );
  589.   x := ord(ch);
  590.  
  591.   if ebcdik then
  592.   begin
  593.         i:=-1;
  594.         repeat
  595.           i:=i+1;
  596.         until (x=tab_ptr^[i+8]) or (i=255);
  597.         x:=i;
  598.   end;
  599.  
  600.   cval := x
  601. end;
  602.  
  603.  
  604.  
  605. procedure tran_tbl;
  606.                        {  Table for     EBCDIK  --->  JIS 8   }
  607.  
  608. begin
  609. inline( $00/$01/$02/$03/$9C/$09/$86/$7F/$97/$8D/$8E/$0B/$0C/$0D/$0E/$0F/
  610.         $10/$11/$12/$13/$9D/$0A/$08/$87/$18/$19/$92/$8F/$1C/$1D/$1E/$1F/
  611.         $80/$81/$82/$83/$84/$85/$17/$1B/$88/$89/$8A/$8B/$8C/$05/$06/$07/
  612.         $90/$91/$16/$93/$94/$95/$96/$04/$98/$99/$9A/$9B/$14/$15/$9E/$1A/
  613.         $20/$A1/$A2/$A3/$A4/$A5/$A6/$A7/$A8/$A9/$5B/$2E/$3C/$28/$2B/$21/
  614.         $26/$AA/$AB/$AC/$AD/$AE/$AF/$A0/$B0/$61/$5D/$5C/$2A/$29/$3B/$5E/
  615.         $2D/$2F/$62/$63/$64/$65/$66/$67/$68/$69/$7C/$2C/$25/$5F/$3E/$3F/
  616.         $6A/$6B/$6C/$6D/$6E/$6F/$70/$71/$72/$60/$3A/$23/$40/$27/$3D/$22/
  617.         $73/$B1/$B2/$B3/$B4/$B5/$B6/$B7/$B8/$B9/$BA/$74/$BB/$BC/$BD/$BE/
  618.         $BF/$C0/$C1/$C2/$C3/$C4/$C5/$C6/$C7/$C8/$C9/$75/$76/$CA/$CB/$CC/
  619.         $77/$7E/$CD/$CE/$CF/$D0/$D1/$D2/$D3/$D4/$D5/$78/$D6/$D7/$D8/$D9/
  620.         $79/$7A/$E0/$E1/$E2/$E3/$E4/$E5/$E6/$E7/$DA/$DB/$DC/$DD/$DE/$DF/
  621.         $7B/$41/$42/$43/$44/$45/$46/$47/$48/$49/$E8/$E9/$EA/$EB/$EC/$ED/
  622.         $7D/$4A/$4B/$4C/$4D/$4E/$4F/$50/$51/$52/$EE/$EF/$F0/$F1/$F2/$F3/
  623.         $24/$9F/$53/$54/$55/$56/$57/$58/$59/$5A/$F4/$F5/$F6/$F7/$F8/$F9/
  624.         $30/$31/$32/$33/$34/$35/$36/$37/$38/$39/$FA/$FB/$FC/$FD/$FE/$FF  );
  625. end;
  626.  
  627. procedure hlp_msg;   { display help message }
  628. var
  629.   fhlp    : text;    { file }
  630.   dat_hlp : string;  { i/o buffer }
  631.   ch      : char;
  632.  
  633. begin
  634.   set_drive(cdisk);
  635.   sb_bios_call( home,0 );
  636.  
  637.   assign( fhlp,'DP.HLP');
  638.   reset ( fhlp );
  639.  
  640.   sb_clr_scrn;
  641.  
  642.   while  (not eof( fhlp )) and (ioresult<>255) do
  643.   begin
  644.     readln(fhlp,dat_hlp);
  645.     writeln([addr(sb_out_ch)],dat_hlp)
  646.   end;
  647.  
  648.   if ioresult=255 then writeln([addr(sb_out_ch)],'HELP file not found.');
  649.  
  650.   write([addr(sb_out_ch)],'Hit any key! ');
  651.   ch:=sb_getch
  652. end;
  653.  
  654. function get_str( var str:string; var delimiter:char ) : integer;
  655. var
  656.   c_num : integer;
  657.   ch : char ;
  658.   w_str : string;
  659. begin
  660.   c_num := 0;
  661.   w_str := '';
  662.   ch := sb_getch;
  663.  
  664.   while (ch<>chr(CR)) & (ch<>chr(ctrl_K)) & (ch<>chr(ctrl_J))
  665.       & (ch<>chr(ESC)) do
  666.    begin
  667.      if (ch>=' ') & (ch<chr(241))
  668.       then begin
  669.                 sb_out_ch( ch );
  670.                 c_num := c_num+1;
  671.                 w_str := concat( w_str,ch )
  672.       end else
  673.      if ch=chr(BS)
  674.       then begin
  675.                 c_num := c_num-1;
  676.                 if c_num < 0 then begin
  677.                                 c_num := 0;
  678.                                 w_str := ''
  679.                 end else begin
  680.                                 delete( w_str,c_num+1,1 );
  681.                                 sb_out_ch(ch);
  682.                                 sb_out_ch(' ');
  683.                                 sb_out_ch(ch);
  684.                 end;
  685.       end;
  686.  
  687.      ch := sb_getch;
  688.    end; {while}
  689.  
  690.   str := w_str;
  691.   delimiter := ch;
  692.   get_str := c_num
  693. end;
  694.  
  695. function get_num( var str : string; delimiter : char ) : integer;
  696. var
  697.   i, source_l,
  698.   get_l         : integer;
  699.   g_str         : string ;
  700.   num           : integer;
  701. begin
  702.   source_l := length( str );
  703.  
  704.   repeat
  705.    if source_l = 0 then begin
  706.                         get_num := 0;
  707.                         exit            { empty data }
  708.                   end;
  709.    if str[1]=' ' then begin
  710.                          delete( str,1,1 );
  711.                          source_l := source_l - 1;
  712.                  end;
  713.   until (str[1]<>' ') and (source_l>0);
  714.  
  715.   i := pos( delimiter,str );
  716.   if i=0 then begin
  717.                 get_l := source_l;
  718.                 g_str := str;
  719.                 str   := ''
  720.          end else begin
  721.                 get_l := i-1;
  722.                 g_str := copy( str,1,get_l );
  723.                 str   := copy( str,i+1,source_l-i)
  724.          end;
  725.  
  726.   num:=0;
  727.   for i:=1 to get_l do
  728.     begin
  729.         if (g_str[i] >='0') & (g_str[i] <='9')
  730.            then num := ord(g_str[i])-48 + num*10
  731.            else begin { error code }
  732.                 get_num := -1;
  733.                 exit
  734.            end;
  735.     end;
  736.  
  737.   get_num := num
  738. end;
  739.  
  740. modend.
  741.