home *** CD-ROM | disk | FTP | other *** search
/ SPACE 2 / SPACE - Library 2 - Volume 1.iso / program / 18 / forthsup / xmodem.fth < prev   
Encoding:
Text File  |  1986-09-18  |  7.8 KB  |  268 lines
  1. \ Xmodem protocol file transfer.
  2. \ Commands:
  3. \   send filename        \ Sends the file
  4. \   receive filename     \ Receives the file
  5. \ The serial line parameters are established by "init-modem", which you
  6. \ may edit if you need to use different ones.  The xmodem protocol requires
  7. \ 8 data bits, so changing that parameter won't work.
  8.  
  9. only forth also definitions
  10. needs modem modem.fth
  11. needs get-ticks interval.fth
  12.  
  13. only forth also modem also definitions
  14. decimal
  15.  
  16. variable checksum
  17. variable #errors    4 constant max#errors  variable #naks
  18. variable receive-sector#
  19. variable send-sector#
  20. variable expected-sector
  21. variable #control-z's
  22.  
  23. create sector-buf  128 allot    variable sector-ptr
  24.  
  25.  0 constant nul   24 constant can    1 constant soh
  26.  4 constant eot    6 constant ack   21 constant nak
  27. variable timer-init   variable timer
  28.  
  29. : timeout:  \ name  ( seconds -- )
  30.    create ,
  31.    does>  @ ( seconds ) ticks/second  *   timer-init !
  32. ;
  33. 3 timeout: short-timeout  6 timeout: long-timeout  60 timeout: initial-timeout
  34. short-timeout
  35.  
  36. \ Interface to the serial line:
  37. \
  38. \ init-modem   --
  39. \       Establishes the desired baud rate and # of bits on the serial line
  40. \ m-key?     -- flag
  41. \       Flag is true if a character is available on the serial line
  42. \ m-key      -- char
  43. \       Gets a character from the serial line
  44. \ m-emit        char --
  45. \       Puts the character out on the serial line.
  46.  
  47. : init-modem
  48.    8-bits  1-stop-bit  no-parity  9600-baud  no-flow-control set-line
  49. ;
  50.  
  51. \ Interface to disk files:
  52. \
  53. \ open-receive-file --  \ Input Stream: filename
  54. \       Opens file for writing.
  55. \ write-sector   addr --
  56. \       Writes the 128 byte record starting at addr to the file.
  57. \ close-file     --
  58. \       Closes the currently-open file
  59. \ read-sector    addr -- flag
  60. \       Reads the next 128 sector from the file to the buffer
  61. \       at addr.  Returns true on failure (i.e. end-of-file)
  62. \ open-send-file        --      Input Stream: name
  63. \       Opens the named file for reading.
  64. \ file-size      -- l.size
  65. \       l.size is a 32-bit number which is the length of the
  66. \       current file in bytes.
  67.  
  68. variable modem-file   \ file descriptor for current file
  69. modem-file off
  70. : close-file ( -- )
  71.    modem-file @ ?dup if  close  then
  72.    modem-file off
  73. ;
  74. : abort-end ( -- ) \ abort and clean up
  75.    ." aborting." cr  close-file  quit
  76. ;
  77. : get-filename  \ filename ( -- str )
  78.    bl word  dup count upper  pad 18 cmove  pad
  79. ;
  80. : bigbuf  ( -- )
  81.    pad 8192  modem-file @  fsetbuffer
  82. ;
  83. : open-receive-file  \ name ( -- )
  84.    get-filename dup file-exists?  ( name flag )
  85.    if
  86.         dup ".  ."  already exists.  Clobber it? "
  87.         key dup emit cr upc ascii Y <>  if  abort then  ( name )
  88.    then
  89.    new-file  ofd @ modem-file !
  90.    bigbuf
  91. ;
  92. : open-send-file  \ name ( -- )
  93.    get-filename  read  open
  94.    dup 0= abort" can't open file"  modem-file !
  95.    bigbuf
  96. ;
  97. : read-sector  ( addr -- end-of-file? )
  98.    dup  128  modem-file @  fgets  ( addr count )
  99.    tuck +                         ( count end-addr )
  100.    \ Pad with control z's if necessary
  101.    over 128 swap -  control z  fill    ( count )
  102.    0=
  103. ;
  104. : write-sector  ( addr -- ) \ write out the sector
  105.    \ Dump out any control z's left over from last time
  106.    #control-z's @  0
  107.    ?do  control z modem-file @  fputc  loop
  108.  
  109.    \ Count the control z's at the end of the buffer
  110.    #control-z's off
  111.    dup dup 127 +          ( addr addr end-address )
  112.    do
  113.       i c@  control z  <>
  114.       if leave then
  115.       1 #control-z's +!
  116.    -1 +loop               ( addr )
  117.    128 #control-z's @ -  modem-file @ fputs
  118. ;
  119. : file-size  ( -- l.size )
  120.    modem-file @ fsize
  121. ;
  122.  
  123. \ End of disk file interface words
  124.  
  125. \ It would be nice to use control C, but the BDOS snarfs it
  126. : ?interrupt  ( -- ) \ aborts if user types control Z
  127.    key? if  key control z =  if  abort-end   then  then
  128. ;
  129. : receive-setup  \ filename  ( -- )
  130.    init-modem
  131.    open-receive-file
  132.    decimal
  133.    receive-sector# off   1 expected-sector !   #naks off   #control-z's off
  134. ;
  135. variable last-char
  136. : timed-in  ( -- char | -1 ) \ get a character unless timeout
  137.    get-ticks  timer-init @  +  timer !
  138.    begin  m-key?  if  m-key  exit   then
  139.           timer @  reached?
  140.    until  -1
  141. ;
  142. : gobble  ( -- ) \ eat characters until they stop coming
  143.    short-timeout
  144.    begin  timed-in  -1 =  until
  145.    long-timeout
  146. ;
  147. : receive-error ( -- ) \ eat rest of packet and send a nak
  148.    gobble
  149.    1 #naks +!   #naks @ max#errors >
  150.    if  can m-emit   ." too many errors." cr
  151.        abort-end
  152.    then
  153.    ." sent nak." cr  nak m-emit
  154. ;
  155. : normal-end ( -- ) ( clean up )
  156.    ." reception completed" cr
  157.    ack m-emit   close-file
  158. ;
  159. : receive-header ( -- f ) \ true if header error
  160.    timed-in  dup  -1 =  if  ." h1 "  exit then
  161.    dup receive-sector# !
  162.    timed-in  dup  -1 =  if  ." h2 "  exit then
  163.    255 xor <>
  164. ;
  165. : .bogus-char ( char -- )
  166.    base @ >r hex    cr dup 2 .r   r> base !
  167.    ." h(" emit ." ) unexpectedly seen."
  168. ;
  169. : receive-sector ( -- f ) \ true if runt sector
  170.    0 checksum !
  171.    false
  172.    sector-buf  128   bounds
  173.    do   timed-in dup -1 =
  174.         if  ( false -1 )  nip  leave then   ( false char )
  175.         dup  i c!   checksum +!
  176.    loop ( runt-sector? )
  177. ;
  178. : receive-checksum ( -- f ) \ true if checksum error
  179.    timed-in dup -1 <>               ( char true  |  -1 false )
  180.    if    checksum @ 255 and  <>  then
  181. ;
  182. : receive-packet ( -- f ) \ true if end of transfer
  183.    false timed-in
  184.    case
  185.      soh of                                  endof
  186.      nul of   1- exit                        endof
  187.      can of   ." remote cancel" cr abort-end endof
  188.      eot of   1- normal-end        exit      endof
  189.      -1  of   ." timeout" receive-error exit      endof
  190.      ( default) .bogus-char receive-error exit
  191.    endcase
  192.    receive-header    if ." h" receive-error exit then
  193.    receive-sector    if ." s" receive-error exit then
  194.    receive-checksum  if ." c" receive-error exit then
  195.    sector-buf write-sector
  196.    ack m-emit
  197.    (cr expected-sector @ .
  198.    1 expected-sector +!
  199.    #naks off
  200. ;
  201. : receive \ filename ( -- )
  202.    receive-setup
  203.    gobble  nak m-emit
  204.    begin   ?interrupt  receive-packet  until
  205. ;
  206. : wait-ack ( -- ) \ wait for ack or can
  207.    0 #errors !
  208.    begin  #errors @  max#errors >  #naks @  max#errors > or
  209.      if  ." too many errors." cr can m-emit  abort-end  then
  210.      ?interrupt
  211.      timed-in
  212.      case
  213.        -1  of   1 #errors +!  ." timeout"  cr       endof
  214.        can of   ." remote cancel" cr abort-end      endof
  215.        ack of   #naks off  exit                     endof
  216.        nak of   1 #naks +! exit                     endof
  217.        ( default) dup .bogus-char
  218.      endcase
  219.    again
  220. ;
  221. : wait-nak ( -- ) \ wait for nak
  222.    initial-timeout  timed-in
  223.    case
  224.       -1  of   ." timeout" cr  abort-end           endof
  225.       can of   ." remote cancel" cr abort-end      endof
  226.       nak of   1 #naks +! exit                     endof
  227.       ( default) dup .bogus-char
  228.    endcase  long-timeout
  229. ;
  230. : send-header ( -- ) \ header is  soh sector#  sector#not
  231.    soh m-emit
  232.    send-sector# @  255 and  dup m-emit
  233.    255 xor m-emit
  234.    (cr send-sector# @ .
  235. ;
  236. : send-sector ( -- )
  237.    0 checksum !
  238.    sector-buf  128  bounds
  239.    do    i c@   dup m-emit   checksum +!     loop
  240. ;
  241. : send-checksum ( -- )
  242.    checksum @  255 and  m-emit
  243. ;
  244. : end-send ( -- )
  245.    close-file
  246.    begin   eot m-emit  wait-ack   #naks @ 0=   until
  247.    ." file sent."
  248. ;
  249. : send-setup
  250.    init-modem
  251.    open-send-file
  252.    decimal
  253.    ." File size: " file-size dup ul.
  254.    ."     Estimated # sectors: "  127 + 128 / ul. cr
  255.    1 send-sector# !
  256. ;
  257. : send  \ filename ( -- )
  258.    send-setup
  259.    gobble   wait-nak   #naks off
  260.    begin  ?interrupt
  261.      #naks @ 0=
  262.         if  sector-buf read-sector  if  end-send  exit  then  then
  263.       send-header  send-sector  send-checksum
  264.       wait-ack
  265.       #naks @ 0=  if  1 send-sector# +! then
  266.    again
  267. ;
  268.