( Conversion between block files and ascii files. 

Copyright @ Ewald Pfau, 1994. Fidonet: 2:316/9.0

Distribution only with the unchanged version of this file 
at least as a part of what is distributed. 

For ASC2BLK, input and outputfile have to be given as string 
parameters. Input file should have been formatted in groups of 
16 lines, each line containing 64 or less characters. Leading 
blanks of a line will be cutted if elsewise the line would not 
fit. If it contains more than 64 characters after that, so the 
trailing end is cut. 

For BLK2ASC, only the output file has to be given as string 
parameters, input is taken from momentary used block-file via 
"USE <name>". Empty lines or lines only containing a leading 
'\', are output only if elsewise there would be no empty line 
between two copied blocks.)

0 value ihdl
0 value ohdl

 64 constant c/l
 16 constant l/s
255 constant #iscrt
create iscrt #iscrt 1+ 1+ 1+ allot align

: readone       ( a n hdl -- n no-eof #)
   >R 2dup bl fill 
   iscrt #iscrt R> read-line 
      ?dup if >R 2swap 2drop R> exit then
   >R ( a n0 n1)   iscrt swap -trailing
      ( a n0 a n1) rot 2dup swap u< 
   if    >R bl skip R> 2dup u<
         if drop else nip then
   else  drop
   then  >R swap R@ move R> R> 0 ;

: close-it      ( --)
                ihdl ?dup 
   if           close-file 0 to ihdl 
   else         0 then
                block-fid @ ?dup 
   if           close-file 
                ohdl block-fid !
                0 to ohdl 
   else         0 then 
                throw throw ;

: fthrow         ( # --) 
   ?dup if close-it throw then ;

: open/create   ( a n -- hdl #)
   2dup        r/w open-file 0=
   if >R 2drop R@ file-size       fthrow 
               R@ reposition-file fthrow R> 0
   else drop   r/w create-file then ;

: open-a2b      ( a1 n a2 n --)
   2swap r/o open-file fthrow to ihdl 
           open/create fthrow 
   block-fid @ to ohdl block-fid ! ;

: capacity      ( -- n)
   block-fid @ file-size fthrow 
   l/s c/l um* drop um/mod
   swap if 1+ then ;

: bl-scat       ( a n --)
   ?dup if 0 do dup c@ 
   bl u< if bl over c! then 
   1+ loop then drop ;

: oneblk        ( buf hdl -- n no-eof)
                swap dup l/s c/l um* drop bl fill
                l/s 0 
   do           2dup c/l rot readone fthrow 0= 
      if        nip nip 0 unloop exit 
      then      drop c/l + 
   loop         2drop c/l -1 ;

: asc2blk       ( a n a n --)
   open-a2b     capacity
   begin        dup  buffer 
                ihdl oneblk 
                swap if update then
   while        1+ 
   repeat       update flush close-it ;

: blk2asc      ( a n --)
                open/create throw 
                0 swap capacity ?dup
   if 0 do      i block  l/s 0 
      do        c/l 2dup bl-scat -trailing
                2dup 1 = swap c@ [char] \ 
                = and if drop 0 then
                2swap >R over or
         if     2dup  R@ write-line throw 
         then   R> rot  c/l +
      loop      drop swap
      if        dup 0. rot write-line throw 
      then      0 swap
   loop then    nip close-file throw ;