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