home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / sigm / vol149 / xmodem.for < prev    next >
Encoding:
Text File  |  1984-04-29  |  19.6 KB  |  747 lines
  1.     program xmodem50
  2. c
  3. c        MODEM7-type program to send and
  4. c        receive files with checksums or CRC and automatic
  5. c        re-transmission of bad blocks.
  6. c        translated to VAX Fortran V3.0 from TMODEM.C by
  7. c        and enhanced according to time-outs and CRC
  8. C        in XMODEM50.ASM
  9. c        J.James Belonis II
  10. c        Physics Hall FM-15
  11. c        University of Washington
  12. c        Seattle, WA 98195
  13. c
  14. c  1/17/83    touched up filename display and comments.
  15. c  1/14/83    including timeouts and CTRL-X cancellation
  16. c        and CRC capability
  17. c
  18. c  keeps a log file of error messages ( deletes it if no errors )
  19. c  sets terminal driver to eightbit, passall
  20. c  may need altypeahd if faster than 1200 baud works to 9600 baud at least.
  21. c  needs PHY_IO privilege for passall ? apparently not on UWPhys VAX
  22. c  nor on ACC VAX
  23. c  many debugging statements left in as comments
  24.  
  25. c  declare variables
  26.     include 'QIO.DCK'
  27.     character*80 line, file
  28.     byte sector(130), c, notc, checksumbyte, ck
  29.     integer blocknumber, sloc, rloc, stat, inotc, ic
  30.     integer notnotc, secbytes
  31.     integer nakwait, testblock, testprev
  32.     logical ttyinlim, charintime, getack, acked, firstsoh
  33.  
  34.     logical logdel
  35.     common /logfile/logdel
  36.  
  37.     integer errorcount
  38.     common /err/errorcount
  39.  
  40.     integer high,low
  41.     common /crcval/high,low
  42.  
  43.     logical crc
  44.     integer checksum
  45.     common /checks/checksum,crc
  46.  
  47.     equivalence (checksum,checksumbyte)
  48.     equivalence (ic,c)
  49.  
  50. c  define ascii characters
  51.     parameter NUL=0        !ignore at SOH time
  52.     parameter SOH=1        !start of header for sector
  53.     parameter EOT=4        !end of transfer
  54.     parameter ACK=6        !acknowlege sector
  55.     parameter NAK=21    !not acknowlege sector
  56.     parameter CAN=24    !cancel transfer
  57.     parameter CRCCHAR='C'    !CRC indicating character
  58.  
  59. c  timeouts
  60.     parameter respnaklim=10    !seconds to allow for response to NAK
  61.     parameter naklim=10     !seconds to allow to receive first NAK
  62.     parameter eotlim=10    !seconds to wait for EOT acknowlege
  63.  
  64.     parameter errlim=10    !max errors on a sector
  65.  
  66. c  define an exit routine to get control on all exits to turn off
  67. c  passall and for debug cleanup
  68.     external giveup
  69.     call userex( giveup )
  70.  
  71.     print *,' XMODEM ver 5.0 on VAX [CRC capable]'
  72. c  log file for debugging
  73.     open(8,file='XMODEM.LOG',carriagecontrol='LIST',status='NEW')
  74. c  assign terminal channel for QIO calls to send raw bytes.
  75.     call sys$assign('TT',chan,,)
  76.  
  77. c  get command line
  78.     call lib$get_foreign(line,'$_command: ',)
  79. c  trim blanks
  80.     do i=80,1,-1
  81.         if(line(i:i).NE.' ') goto 25
  82.         len=i
  83.     enddo
  84.   25    continue
  85.  
  86. c  send
  87.     sloc=index(line,'S ')
  88.     if(sloc.NE.0) then
  89.         file=line(sloc+2:)
  90.         len=len-2
  91.         goto 50
  92.     endif
  93. c  receive with checksum
  94.     rloc=index(line,'R ')
  95.     if(rloc.NE.0) then
  96.         file=line(sloc+2:)
  97.         len=len-2
  98.         crc=.false.
  99.         secbytes=129
  100.         goto 600
  101.     endif
  102. c  receive with CRC
  103.     rcloc=index(line,'RC ')
  104.     if(rcloc.NE.0) then
  105.         file=line(sloc+3:)
  106.         len=len-3
  107.         crc=.true.
  108.         secbytes=130
  109.         goto 600
  110.     endif
  111.  
  112. c  else bad command
  113.     print *,' Invalid command.'
  114.     print *,'    usage: xmodem  <s, r, or rc>  <file> '
  115.     call exit
  116.  
  117. c  send file
  118.   50    open(6,name=file(1:len),iostat=stat,status='OLD',READONLY)
  119. c     1        carriagecontrol='NONE',recordtype='FIXED',recl=128)
  120.  
  121.     if(stat) then
  122.         print *,'Can''t open',file(1:len),' for send.'
  123.         call exit
  124.     endif
  125.     if(crc) then
  126.         print *,' CRC mode'
  127.     else
  128.         print *,' Checksum mode'
  129.     endif
  130.     print *,file(1:len),' open, ready to send.  Run your receiver.'
  131.     errorcount=0
  132.     blocknumber=1
  133.  
  134. c  await first NAK (or 'C') indicating receiver is ready
  135.   200    charintime=ttyinlim(c,1,naklim)        ! return NUL if timeout
  136. c    print *,' character=',c
  137.     if( .NOT.charintime ) then
  138.         nakwait=nakwait+1
  139. c  give the turkey 80 seconds to figure out how to receive a file
  140.         if(nakwait.EQ.80) call cancel
  141.         goto 200
  142.     elseif(c.EQ.NAK) then
  143.         crc=.false.
  144.     elseif(c.EQ.CRCCHAR) then
  145.         crc=.true.
  146.     elseif(c.EQ.CAN) then
  147.         call cancel
  148.     else
  149. c  unrecognized character
  150.         nakwait=nakwait+1
  151.         if(nakwait.eq.80) call cancel
  152.         goto 200
  153.     endif
  154.     
  155.   300    continue
  156. c  send new sector
  157.     read(6,1000,end=500) (sector(i),i=1,128)
  158.  1000    format(128a)
  159.     errorcount=0
  160. c    print *,' sector as read',sector
  161.   400    continue
  162. c  send sector
  163. c    print *,' SOH '
  164.     call ttyout(SOH,1)
  165.     call ttyout(blocknumber,1)
  166.     call ttyout( not(blocknumber),1 )
  167. c    print *,' blocknumber=',blocknumber
  168.  
  169.     checksum=0
  170.     call clrcrc
  171. c  separate calls to slow down in case other end slow (can even introduce
  172. c  delay between characters).
  173.     do i=1,128
  174.         call ttyout(sector(i),1)
  175.     enddo
  176. c  calc checksum or crc
  177.     if(crc) then
  178. c  put all bytes + two finishing zero bytes through updcrc
  179.         sector(129)=0
  180.         sector(130)=0
  181.         call updcrc( sector,130 )
  182.         call ttyout(high,1)
  183.         call ttyout(low,1)
  184.     else
  185.         do i=1,128
  186.             checksum=checksum+sector(i)
  187.         enddo
  188. c  this sends low order byte of checksum
  189.         call ttyout(checksum,1)
  190. c        print *,' checksum',checksum
  191.     endif
  192.  
  193. c  sector sent, see if receiver acknowleges
  194. c  function getack attempts to get ACK
  195. c  if not, repeat sector
  196. c    print*, ' should wait for ACK 10 seconds'
  197.     call getack(acked)
  198. c    print*, ' getack returned=',acked
  199.     if(.NOT.acked) goto 400
  200.  
  201. c  ACK received, send next sector
  202.     blocknumber=blocknumber+1
  203.     goto 300
  204.  
  205. c  end of file during read.  finish up sending.
  206.   500    continue
  207.     call ttyout(EOT,1)
  208. c  function getack attempts to get ACK up to errlim times
  209.     call getack(acked)
  210.     if( .NOT.acked ) goto 500
  211.  
  212. c    print *,' Sending complete.'
  213.     call exit
  214.  
  215. c  receive file
  216.   600    continue
  217.     open(7,name=file(1:len),recl=128,status='NEW',iostat=stat,
  218.      1        carriagecontrol='NONE',recordtype='FIXED')
  219.     if(stat) then
  220.         print *,' Can''t open ',file(1:len),' for recieve.'
  221.         call exit
  222.     endif
  223.  
  224.     print *,' Please send.'
  225.     call passall(CHAN,.TRUE.)
  226.  
  227.     firstsoh=.false.
  228.     errorcount=0
  229.     blocknumber=1
  230.  
  231. c  start the sender by letting ttyinlim time-out in getack routine
  232. c  so it sends a NAK or C
  233.     goto 999
  234.  
  235.   800    continue
  236. c    write(8,*) ' ready for SOH'
  237. c  must allow enough time for other's disk read (xmodem50.asm allows 10 sec)
  238.     charintime=ttyinlim(c,1,respnaklim)
  239. c  if no char for a while, try NAK or C again
  240.     if( .NOT.charintime ) then
  241. c        print*,' no response to NAK or C, trying again'
  242.         write(8,*) ' no response to NAK or C, trying again'
  243.         goto 999
  244.     endif
  245. c  else received a char so see what it is
  246.     if(c.eq.NUL) goto 800    ! ignore nulls here for compatablity with old
  247.                 ! versions of modem7
  248.     if(c.EQ.CAN) then
  249.         print *,' Canceled.  Aborting.'
  250.         write(8,*) ' Canceled.  Aborting.'
  251.         call exit
  252.     endif
  253. c    write(8,*) ' EOT or SOH character=',c
  254.     if(c.NE.EOT) then
  255.         IF(c.NE.SOH) then
  256.             write(8,*) ' Not SOH, was decimal ',c
  257.             goto 999
  258.         endif
  259.         firstsoh=.true.
  260.  
  261. c  character was SOH to indicate start of header
  262. c  get block number and complement
  263.         call ttyin(c,1)
  264. c        write(8,*) ' block=',c
  265.  
  266.         call ttyin(notc,1)
  267. c        write(8,*) ' block complement=',notc
  268.         inotc=notc    ! make integer for "not" function
  269.         notnotc=iand( not(inotc),255 )    ! mask back to byte
  270.  
  271. c  c is low order byte of ic via equivalence statement
  272.         if(ic.NE.notnotc) then
  273.             write(8,*) ' block check bad.'
  274.             goto 999
  275.         endif
  276. c  block number valid but not yet checked against expected
  277.  
  278. c  clear checksum and CRC
  279.         checksum=0
  280.         call clrcrc
  281.  
  282. c  receive the sector and checksum bytes in one call (for speed).
  283. c  secbytes is 129 for checksum, 130 for CRC
  284.         call ttyin(sector,secbytes)
  285.  
  286.         if(crc) then
  287. c  put data AND CRC bytes through updcrc
  288.             call updcrc(sector,secbytes)
  289. c  if result non-zero, BAD.
  290.             if(iand(high,255).NE.0
  291.     1        .OR.iand(low,255).NE.0) then
  292.                 write(8,*) ' CRC, high,low='
  293.                 write(8,3000) high,low
  294.  3000                format(2z10)
  295.                 goto 999
  296.             endif
  297.         else
  298. c  don't add received checksum byte to checksum
  299.             do i=1,secbytes-1
  300.                 checksum=checksum+sector(i)
  301.             enddo
  302.             ck=sector(129)
  303. c            write(8,2100) ck
  304.  
  305. c            write(8,2100) checksum
  306. c            write(8,2100) checksumbyte
  307. c2100            format(' checksum=',z10)
  308.             if( checksumbyte.NE.ck ) then
  309.                 write(8,*) ' bad checksum'
  310.                 goto 999
  311.             endif
  312.         endif
  313.  
  314. c  received OK so we can believe the block number, see which block it was
  315. c  mask it to be one byte
  316.         testblock=iand(blocknumber,255)
  317.         testprev=iand( blocknumber-1 ,255)
  318.         if( ic.EQ.testprev) then
  319.             write(8,*) ' prev. block again, out of synch'
  320. c  already have this block so don't write it, but ACK anyway to resynchronize
  321.             goto 985
  322.         elseif( ic.NE.testblock ) then
  323.             write(8,*) ' block number bad.'
  324.             goto 999
  325.         endif
  326. c  else was expected block
  327.  
  328. c  write before acknowlege so not have to listen while write.
  329.         write(7,2000,err=900) (sector(i),i=1,128)
  330.  2000        format(128a)
  331.         goto 975
  332.   900        write(8,*) ' Can''t write sector. Aborting.'
  333.         print*, ' Can''t write sector. Aborting.'
  334.         call exit
  335.  
  336.   975        continue
  337. c  recieved sector ok, wrote it ok, so acknowlege it to request next.
  338.         blocknumber=blocknumber+1
  339. c  comes here if re-received the previous sector
  340.   985        continue
  341.         errorcount=0
  342. c        write(8,*) ' ACKing, sector was ok.'
  343.         call ttyout(ACK,1)
  344.         goto 800
  345.  
  346. c  else error so eat garbage in case out of synch and try again
  347.   999        continue
  348.         call eat
  349.         write(8,*) ' receive error NAK, block=',blocknumber
  350.         if(crc.AND..NOT.firstsoh) then
  351. c  keep sending 'C'  'til receive first SOH
  352.             call ttyout(CRCCHAR,1)
  353.         else
  354.             call ttyout(NAK,1)
  355.         endif
  356.         errorcount=errorcount+1
  357.   998        if(errorcount.GE.errlim) then
  358.             print*,' Unable to receive block. Aborting.'
  359.             write(8,*) ' Not receive block. Aborting.'
  360. c  delete incompletely received file
  361.             close(7,dispose='DELETE')
  362.             call exit
  363.         endif
  364. c  retry
  365.         goto 800
  366.     endif
  367.  
  368. c  EOT received instead of SOH so file done.
  369. c  should keep sending ACK 'til no more EOT's ?
  370.     close(6)
  371.     close(7)
  372.     call ttyout(ACK,1)
  373.     call ttyout(ACK,1)
  374.     call ttyout(ACK,1)
  375.  
  376. c    write(8,*) ' Completed.'
  377. c    print *,   ' Completed.'
  378. c  transfer ok, so delete the error log file.
  379.     close(8,status='DELETE')
  380.     call exit
  381.     end
  382. c-----------------------------------------------------------
  383.     subroutine clrcrc
  384. c  clears CRC
  385.     integer high,low
  386.     common /crcval/high,low
  387.  
  388.     high=0
  389.     low=0
  390.     return
  391.     end
  392. c-----------------------------------------------------------
  393.     subroutine updcrc(bbyte,n)
  394.     byte bbyte(*)
  395.     integer n
  396. c  updates the Cyclic Redundancy Code
  397. c  uses x^16 + x^12 + x^5 + 1 as recommended by CCITT
  398. c    and as used by CRCSUBS version 1.20 for 8080 microprocessor
  399. c    and incorporated into the MODEM7 protocol of the CP/M user's group
  400. c
  401. c  during sending:
  402. c  call clrcrc
  403. c  call updcrc   for each byte
  404. c  call fincrc   to finish (or just put 2 extra zero bytes through updcrc)
  405. c  result to send is low byte of high and low in that order.
  406. c
  407. c  during reception:
  408. c  call clrcrc
  409. c  call updcrc   all bytes PLUS the two received CRC bytes must be passed
  410. c       to this routine
  411. c       then zero in high and low means good checksum
  412. c
  413. c  see Computer Networks, Andrew S. Tanenbaum, Prentiss-Hall, 1981
  414. c
  415. c  must declare integer to allow shifting
  416.     integer byte
  417.     integer high
  418.     integer low
  419.     common /crcval/high,low
  420.     integer bit,bitl,bith
  421.  
  422. c    write(8,*) ' inside updcrc'
  423.     do i=1,n
  424. c        write(8,*) high,low,byte'
  425. c        write(8,1000),high,low,bbyte
  426.  1000        format(3z10)
  427.         byte=bbyte(i)
  428.  
  429.         do j=1,8
  430. c  get high bits of bytes so we don't lose them when shift
  431. c  positive is left shift
  432.             bit =ishft( iand(128,byte), -7)
  433.             bitl=ishft( iand(128,low),  -7)
  434.             bith=ishft( iand(128,high), -7)
  435. c            write(8,*) 'bit,bitl,bith'
  436. c            write(8,1000),bit,bitl,bith
  437. c  get ready for next iteration
  438.             newbyte=ishft(byte,1)
  439.             byte=newbyte        ! introduced dummy variable newbyte
  440.                         ! to avoid "access violation"
  441. c            write(8,*) ' byte ready for next iteration'
  442. c            write(8,1000),byte
  443. c  shift those bits in
  444.             low =ishft(low ,1)+bit
  445.             high=ishft(high,1)+bitl
  446. c            write(8,*),' high,low after shifting bits in'
  447. c            write(8,1000),high,low
  448.  
  449.             if(bith.eq.1) then
  450.                 high=ieor(16,high)
  451.                 low=ieor(33,low)
  452. c                write(8,*) ' high,low  after xor'
  453. c                write(8,1000) high,low
  454.             endif
  455.         enddo
  456.     enddo
  457.     return
  458.     end
  459. c-----------------------------------------------------------
  460. c    subroutine fincrc
  461. c  finish CRC calculation for sending    result in high, low
  462. c  merely runs updcrc with two  zero bytes
  463. c    integer high,low
  464. c    common /crcval/high,low
  465. c
  466. c    byte=0
  467. c    call updcrc(byte)
  468. c    call updcrc(byte)
  469. c    return
  470. c    end
  471. c-----------------------------------------------------------
  472.       SUBROUTINE TTYIN(LINE,N)
  473.       BYTE LINE(*)
  474.       INTEGER N
  475. C              READ CHARACTERS FROM TERMINAL
  476. C              MODIFIED BY BELONIS TO REMOVE PRIVILEGE
  477. C              MAY HAVE PROBLEM WITH TYPE-AHEAD
  478. c  should convert to time-out properly with loops in main ?
  479.       INCLUDE 'QIO.DCK'
  480. c      INCLUDE '($SSDEF)'
  481.       parameter ss$_timeout='22c'x
  482.       INTEGER I
  483.       INTEGER SYS$QIOW
  484.       INTEGER*4 terminators(2)
  485.  
  486. c      logical crc
  487. c      integer checksum
  488. c      common /checks/checksum,crc
  489.  
  490.       EXTERNAL IO$M_NOECHO,IO$_TTYREADALL,IO$M_TIMED
  491.       DATA terminators/0,0/
  492. C
  493.     write(8,*) ' inside ttyin, N=',N
  494.       I = SYS$QIOW(,           !EVENT FLAG
  495.      -              %VAL(CHAN),         !CHANNEL
  496.      -              %VAL(%LOC(IO$_TTYREADALL).OR.
  497.      -                   %LOC(IO$M_NOECHO)),         !   .OR.%LOC(IO$M_TIMED)),
  498.      -              STATUS,,,
  499.      -              LINE,       !BUFFER
  500.      -              %VAL(N),    !LENGTH
  501.      -              ,        ! max time   beware other disk time
  502.      -                !            and Quit or Retry time
  503.      -              terminators,,)  !no terminators
  504. c      if(crc) then
  505. c         write(8,1000) (LINE(j),j=1,N)
  506. c         write(8,*) ' status=',STATUS
  507. c      else
  508. c         write(8,2000) (line(j),j=1,N)
  509. c         write(8,*) ' status=',status
  510. c      endif
  511.  1000 format(' ttyin=',6(20z3/),10z3)
  512.  2000 format(' ttyin=',6(20z3/),9z3)
  513. c      if(STATUS(1).EQ.SS$_TIMEOUT) THEN
  514. c         write(8,*) ' 10 second timeout in ttyin'
  515. c         print*,    ' 10 second timeout in ttyin'
  516. c         call exit
  517. c      endif
  518.  
  519.       IF (I) THEN
  520. c        write(8,*) ' returning from ttyin'
  521.          return
  522.       endif
  523. C
  524. C              ERROR
  525.       write(8,*) ' ttyin error.'
  526.       CALL SYS$EXIT( %VAL(I) )
  527.       END
  528. c-----------------------------------------------------------
  529.     subroutine eat
  530. c  eats extra characters 'til 1 second pause   used to re-synch after error
  531.     byte buffer(135)
  532.     integer numchar
  533.     logical i,ttyinlim
  534. c
  535.     parameter maxtime=1
  536. c  in case mis-interpreted header, allow at least 1 block of garbage
  537.     numchar=135
  538.  
  539.     i=ttyinlim(buffer,numchar,maxtime)
  540. c    print*,' finished eating'
  541. c    write(8,*) ' finished eating'
  542.     return
  543.     end
  544. c-----------------------------------------------------------
  545.       LOGICAL FUNCTION TTYINLIM(LINE,N,LIMIT)
  546.       BYTE LINE(*)
  547.       INTEGER N,LIMIT
  548. C              READ CHARACTERS FROM TERMINAL
  549. C              WITH TIME LIMIT, RETURN FALSE IF NO CHARACTERS
  550. C              RECEIVED FOR LIMIT SECONDS
  551. C              MODIFIED BY BELONIS TO REMOVE PRIVILEGE PROBLEM
  552. C              MAY HAVE PROBLEM WITH TYPE-AHEAD
  553.       INCLUDE 'QIO.DCK'
  554. c      INCLUDE '($SSDEF)'    ! defines error status returns
  555.       parameter ss$_timeout='22c'x
  556.       INTEGER I
  557.       INTEGER SYS$QIOW
  558.       INTEGER*4 terminators(2)
  559.       EXTERNAL IO$M_NOECHO,IO$_TTYREADALL,IO$M_TIMED
  560.       DATA TERMINATORS/0,0/
  561. C
  562. c    write(8,*) ' inside ttyinlim'
  563.       TTYINLIM=.TRUE.          ! DEFAULT no delay over LIMIT seconds
  564.       I = SYS$QIOW(,           !EVENT FLAG
  565.      -              %VAL(CHAN),         !CHANNEL
  566.      -              %VAL(%LOC(IO$_TTYREADALL).OR.
  567.      -                   %LOC(IO$M_NOECHO).OR.%LOC(IO$M_TIMED)),
  568.      -              STATUS,,,
  569.      -              LINE,       !BUFFER
  570.      -              %VAL(N),   !LENGTH
  571.      -              %VAL(LIMIT),    !time limit in seconds
  572.      -              terminators,,)  !no terminators
  573. c     print*,' ttyinlim=',(LINE(j),j=1,N), ' STATUS=',STATUS
  574. c     write(8,*) ' ttyinlim=',(LINE(j),j=1,N), ' STATUS=',STATUS
  575.       if(STATUS(1).EQ.SS$_TIMEOUT) THEN
  576.          TTYINLIM=.FALSE.
  577.          write(8,*) ' timeout'
  578.          return
  579.       ENDIF
  580.  
  581.       IF (I) THEN
  582. c        write(8,*) ' returning from ttyinlim'
  583.          return
  584.       endif
  585. C
  586. C              ERROR
  587.       write(8,*) ' ttyinlim error.'
  588.       CALL SYS$EXIT( %VAL(I) )
  589.       END
  590. c-----------------------------------------------------------
  591.       SUBROUTINE TTYOUT(LINE,N)
  592.       BYTE LINE(*)
  593.       INTEGER*2 N
  594. C  output N characters without interpretation
  595.       INCLUDE 'QIO.DCK'
  596.       INTEGER I
  597.       INTEGER SYS$QIOW
  598.       EXTERNAL IO$M_NOFORMAT
  599.       EXTERNAL IO$_WRITEVBLK
  600. C
  601.       IF ( N.LE.0 ) RETURN
  602. C
  603. c    print *, ' to be sent by ttyout ', line(1)
  604.       I = SYS$QIOW(,
  605.      -              %VAL(CHAN),
  606.      -              %VAL(%LOC(IO$_WRITEVBLK).OR.
  607.      -                   %LOC(IO$M_NOFORMAT)),
  608.      -              STATUS,,,
  609.      -              LINE,
  610.      -              %VAL(N),,
  611.      -              %VAL(0),, )         !NO CARRIAGE CONTROL
  612.       if(I) then
  613.          return
  614.       endif
  615. C
  616. C              ERROR
  617.       write(8,*) ' ttyout error.'
  618.       CALL SYS$EXIT( %VAL(I) )
  619.       END
  620. c--------------------------------------------------
  621.     subroutine giveup
  622. c  this exit routine used especially in case exited via QIO problem
  623.     include 'qio.dck'
  624.  
  625. c  note: if want log file message, must re-open since
  626. c  system already closed all files before this exit handler got control
  627. c    open(8,file='XMODEM.LOG',access='APPEND')
  628. c    write(8,*) ' Exit handler.'
  629.  
  630. c  turn off passall
  631.     call passall(CHAN,.FALSE.)
  632.     return
  633.     end
  634. c-----------------------------------------------------
  635.     SUBROUTINE PASSALL(CHAN,SWITCH)
  636. C  sets PASSALL mode for terminal connected to chanel CHAN, ON if switch true
  637.     IMPLICIT INTEGER (A-Z)
  638. c    INCLUDE '($TTDEF)'
  639.     parameter tt$m_passall=1
  640.     parameter tt$m_eightbit='8000'x
  641.     parameter io$_sensemode='27'x
  642.     parameter io$_setmode='23'x
  643. c    INCLUDE '($IODEF)'
  644.     LOGICAL SWITCH
  645.     COMMON/CHAR/CLASS,TYPE,WIDTH,CHARAC(3),LENGTH    !byte reversed LENGTH
  646.     BYTE CLASS,TYPE,CHARAC,LENGTH
  647.     INTEGER*2 WIDTH,SPEED
  648.     EQUIVALENCE(CHARACTER,CHARAC)
  649.  
  650. c  sense current terminal driver mode
  651.     ISTAT=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SENSEMODE),,,,
  652.     1 CLASS,,,,,)
  653.     IF (.NOT.ISTAT) CALL ERROR('TERMINAL SENSEMODE',ISTAT)
  654.  
  655.     IF(SWITCH) THEN
  656. c  turn on 8 bit passall
  657.         CHARACTER=CHARACTER.OR.TT$M_PASSALL.OR.
  658.     1                TT$M_EIGHTBIT
  659.     ELSE
  660. c  turn off 8 bit passall
  661.         CHARACTER=CHARACTER.AND..NOT.TT$M_PASSALL.AND.
  662.     1                               .NOT.TT$M_EIGHTBIT
  663.     ENDIF
  664.     SPEED=0    !LEAVE SPEED UNCHANGED
  665.     PAR=0    !LEAVE PARITY UNCHANGED
  666.  
  667. c  set terminal mode with desired passall
  668.     ISTAT=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SETMODE),,,,
  669.     1               CLASS,,%VAL(SPEED),,%VAL(PAR),)
  670.     IF (.NOT.ISTAT) CALL ERROR('TERMINAL SETMODE',ISTAT)
  671.     RETURN
  672.     END
  673. c---------------------------------------------------
  674.     SUBROUTINE ERROR(STRING,MSGID)
  675. c        Types error message
  676.     IMPLICIT INTEGER(A-Z)
  677.     CHARACTER*(*) STRING
  678.     CHARACTER*80 MESSAGE
  679.  
  680.     TYPE *,' *** ERROR: ',STRING
  681.     write(8,*) ' *** ERROR: ',STRING
  682.     CALL SYS$GETMSG(%VAL(MSGID),MSGLEN,MESSAGE,%VAL(15),)
  683.     TYPE *,MESSAGE(1:MSGLEN),CRLF
  684.     write(8,*) MESSAGE(1:MSGLEN),CRLF
  685.     RETURN
  686.     END
  687. c-----------------------------------------------------------
  688.     subroutine cancel
  689.     INCLUDE 'QIO.DCK'
  690. c  called to cancel send (at least)
  691.     logical charintime,ttyinlim
  692.     byte c
  693.     parameter CAN=24
  694.     parameter SPACE=32
  695.  
  696. c  eat garbage
  697.   100    charintime=ttyinlim(c,1,1)
  698.     if(.NOT.charintime) goto 100
  699. c  cancel other end
  700.     call ttyout(CAN,1)
  701.  
  702. c  eat garbage in case it didn't understand ?
  703.   200    charintime=ttyinlim(c,1,1)
  704.     if(.NOT.charintime) goto 200
  705. c  clear the CAN from far end's input  ???? why ? xmodem50.asm does it
  706.     call ttyout(SPACE,1)
  707.  
  708. c    print*,' XMODEM program canceled'
  709.     write(8,*)' XMODEM program canceled'
  710.     call exit
  711.     end
  712. c------------------------------------------------------
  713.     subroutine getack(acked)
  714. c  returns .TRUE. if gets ACK
  715.     logical charintime, ttyinlim, acked
  716.     byte sector(130),c
  717.  
  718.     integer errorcount
  719.     common /err/errorcount
  720.  
  721.     parameter ACK=6
  722.     parameter errlim=10    ! max number of errors
  723.     parameter eotlim=10    ! seconds to wait for eot
  724.  
  725. c    print*,' inside getack'
  726. c  empty typeahead in case garbage
  727. c    charintime=ttyinlim(sector,130,0)
  728. c  allow time for file close at other end.
  729.     charintime=ttyinlim(c,1,eotlim)
  730. c    print*,' getack got',c
  731.     if( .NOT.charintime .OR. c.NE.ACK ) then
  732. c        print*, ' not ACK, decimal=',c
  733.         write(8,*) ' not ACK, decimal=',c
  734.         errorcount=errorcount+1
  735.         if(errorcount.GE.errlim) then
  736.             write(8,*) ' not acknowleged in 10 tries.'
  737.             print*,' Can''t send sector. Aborting.'
  738.             call exit
  739.         endif
  740.         acked=.FALSE.
  741.     else
  742. c  received ACK
  743.         acked=.TRUE.
  744.     endif
  745.     return
  746.     end
  747.