program xmodem50 c MODEM7-type program to send and c receive files with checksums or CRC and automatic c re-transmission of bad blocks. c translated to VAX Fortran V3.0 from TMODEM.C c and enhanced according to time-outs and CRC c in XMODEM50.ASM c J.James Belonis II c Physics Hall FM-15 c University of Washington c Seattle, WA 98195 c (206) 545-8695 c c TMODEM.C written by Richard Conn, Eliot Moss, and Lauren c Weinstein c c 6/23/84 fixed improper READONLY, open .WRK files carriagecontrol='NONE' c made EAT routine continue eating 'til nothing left to eat. c increased text conversion capability to 500 character lines. c All known bugs are again fixed. c 6/20/84 Version 5.53 increased filename ttyinlim's to 2 seconds which c greatly improved reliability of BATCH mode on heavy loaded VAX c 5/18/84 Version 5.52 makes OPENs of OLD files READONLY so can work in c unowned directories c 3/21/84 Version 5.51 replaces non-alphanumeric CP/M filename characters c by letter "A" when making a VAX filename, c commented out bad PRINT. c 3/17/84 miscellaneous error messages added. c 3/13/84 reserved space in cancel for eating characters to avoid access viol C 3/13/84 increased RECVFILE data block timeout to 2 sec c 2/27/84 Version 5.5 incorporated improvements by Steve Gill c GETACK timeout and garbage loop and NAK, CAN detection c RECVFILE receive data block with timeout c TTYIN routine removed since replaced everywhere by TTYINLIM c 1/25/84 properly placed CALL PASSALL in main program so not miss parity bit c in sendfn filename checksum c 1/ 8/84 corrected last known bugs c 1/ 2/84 Version 5.4 Added batch c 12/31/83 Version 5.3 Added wildcard filenames(but not yet batch) and c streamlined option parsing and allowed CRC TEXT c found and fixed blank trim miscalculation c again (CONN apparently got old version) c XMODEM.LOG and XMODEM.WRK put in SYS$SCRATCH directory c (usually user's main) if can't open in current directory c 12/27/83 Version 5.2 Speeded up SEND by doing only one TTYOUT call per block. c no longer hogs CPU at 9600 baud (only 15-20 percent of cpu time) c included QIO.DCK so only one file XMODEM.FOR is needed. c 6/30/83 Modified, restructured, and VAX/VMS text file c conversion added by Richard Conn c 1/17/83 touched up filename display and comments. c 1/14/83 including timeouts and CTRL-X cancellation c and CRC capability c c keeps a log file of error messages ( deletes it if no errors ) c sets terminal driver to eightbit, passall c may need altypeahd if faster than 1200 baud works to 9600 baud at least. c needs PHY_IO privilege for passall ? apparently not on UWPhys VAX c nor on ACC VAX c many debugging statements left in as comments c declare variables include '($rmsdef)' ! for LIB$FIND_FILE INTEGER*2 CHAN,STATUS(4) COMMON /QIO/ CHAN,STATUS character*128 line, filein, file, filec, filed, workf, options integer seploc, worklen, context, istat, length, lengthin logical openok, sendopt, recvopt, textopt logical getfn, sendfn logical batchopt,firstbatch common /batch/batchopt,firstbatch logical filedel common /filest/filedel integer errorcount common /err/errorcount integer high,low byte highbyte,lowbyte common /crcval/high,low equivalence (high,highbyte) equivalence (low,lowbyte) logical crc byte checksumbyte integer checksum common /checks/checksum,crc equivalence (checksum,checksumbyte) equivalence (ic,c) c define ascii characters parameter NUL=0 !ignore at SOH time parameter SOH=1 !start of header for sector parameter EOT=4 !end of transfer parameter ACK=6 !acknowlege sector parameter BEL=7 !bell warning if stupid parameter NAK=21 !not acknowlege sector parameter CAN=24 !cancel transfer parameter CRCCHAR='C' !CRC indicating character c timeouts parameter respnaklim=10 !seconds to allow for response to NAK parameter naklim=10 !seconds to allow to receive first NAK parameter eotlim=10 !seconds to wait for EOT acknowlege parameter errlim=10 !max errors on a sector c define an exit routine to get control on all exits to turn off c passall and for debug cleanup external giveup call userex( giveup ) print *,' XMODEM Version 5.53 6/23/84 [BATCH capable]' c assign terminal channel for QIO calls to send raw bytes. call sys$assign('TT',chan,,) c get command line call lib$get_foreign(line,'$_Command: ',,) c trim blanks do i=80,1,-1 length=i if(line(i:i).NE.' ') goto 25 enddo c no command on line 25 continue c separate options from filename c print *,' length=',length seploc = index( line(1:length+1),' ' ) ! +1 so find end if one argument c print *,' seploc=',seploc options=line(1:seploc-1) filein=line(seploc+1:length) c print *,'options*',options(1:seploc-1),'*' lengthin=length-seploc if(lengthin.gt.0) then ! make sure not index infinite length string if( index( filein(1:lengthin), ' ' ) .ne. 0 ) then c print *,'filein*',filein(1:lengthin),'*' c print *,'index( filein,'' '')',index(filein(1:lengthin),' ') print *,' too many arguments' goto 150 endif endif filedel=.false. c parse the options batchopt=.false. firstbatch=.false. textopt=.false. sendopt=.false. recvopt=.false. crc=.false. i=0 if( index(options,'B').NE.0 ) then batchopt=.true. firstbatch=.true. i=i+1 endif if( index(options,'T').NE.0 ) then textopt=.true. i=i+1 endif if( index(options,'S').NE.0 ) then sendopt=.true. i=i+1 endif if( index(options,'R').NE.0 ) then recvopt=.true. i=i+1 endif if( index(options,'C').NE.0 ) then crc=.true. i=i+1 endif c check options if(i.ne.seploc-1) then print *,char(BEL),' unsupported options ignored' print * endif if(sendopt.and.recvopt) then ! send and receive simultaneously print *,' incompatible options SEND and RECEIVE' call exit endif if( .not.(recvopt.and.batchopt) .and. lengthin.le.0 ) then c no options or no filename print *,' insufficient arguments' goto 150 endif if( lengthin.gt.0 .and. (recvopt.and.batchopt) ) then print *,' filename ignored on batch receive',char(BEL) endif context=0 ! initial FAB pointer for LIB$FILE_FIND call passall(CHAN,.TRUE.) ! turn on passall so typeahead ! not strip parity on unsolicited chars c BATCH option loop comes here 100 continue !GOTO at end comes here for next filename c open separate log file for each transferred file. openok=.true. workf='XMODEM.WRK' worklen=10 open(8,file='XMODEM.LOG', iostat=istat, 1 carriagecontrol='LIST',status='NEW') if(istat.ne.0) then if(firstbatch) then print *,' Can''t open XMODEM.LOG in this directory,' print *,' putting it in your main directory.',char(BEL) endif open(8,file='SYS$SCRATCH:XMODEM.LOG', 1 carriagecontrol='LIST',status='NEW') openok=.false. workf='SYS$SCRATCH:XMODEM.WRK' worklen=22 ! number of chars in file name endif if(recvopt) then ! wildcards done on other computer if(.not.batchopt) then file=filein length=lengthin endif else ! sending, need name(s) istat=lib$find_file(filein(1:lengthin),file,context,,) if(istat.eq.rms$_nmf) then ! no more files if(batchopt) then !await rcvr's request for filename call waitnlp(80) call ttyout(ACK,1) ! tell yes file endif call ttyout(EOT,1) ! tell other computer no more ! it receives EOT as first ! char of expected filename c print *,' All transfers complete.' write(8,*) ' All transfers complete.' close(8,dispose='delete') ! .LOG file call exit endif if(.not.istat) then if(firstbatch.or..not.batchopt) then print *,' LIB$FILE_FIND error' endif write(8,*) ' LIB$FILE_FIND error' call cancel endif c trim blanks do i=128,1,-1 length=i if(file(i:i).NE.' ') goto 125 enddo c print *,' couldn''t happen, filename blank' write(8,*) ' couldn''t happen, filename blank' 125 continue endif if( sendopt ) then c send if(batchopt) then c make a reasonable filename for CP/M call cleansfn( file(1:length),filec,leng) if(firstbatch) then print *,' sending BATCH mode, please run receiver' endif endif if(textopt) then if(.not.batchopt) then ! not batch print *,' Sending Text File: ',file(1:length) print *,' Do not run your receiver yet.' endif call vtoc( file(1:length), workf(1:worklen) ) c print *,' file converted' c write(8,*) ' file converted' filedel=.true. !delete working file when done if(batchopt) call sendfn( filec(1:leng) ) call sendfile( workf(1:worklen) ) else ! not text if(.not.batchopt) then print *,' Sending File: ',file(1:length) else ! batchopt call sendfn( filec(1:leng) ) endif call sendfile( file(1:length) ) endif elseif(recvopt) then c receive if(batchopt) then if(firstbatch) then print *, ' Receiving BATCH please run sender' endif if(.not.getfn(filed,leng)) then call ttyout(EOT,1) c print *,' All transfers complete.' write(8,*) ' All transfers complete.' close(8,dispose='delete') ! log file call exit endif call cleangfn(filed(1:leng),file,length) endif if(textopt) then if(.not.batchopt) then print *,' Receiving Text File: ',file(1:length) endif call recvfile( workf(1:worklen) ) filedel=.true. !delete working file when done call ctov( workf(1:worklen), file(1:length) ) else ! not text if(.not.batchopt) then print *,' Receiving File: ',file(1:length) endif call recvfile( file(1:length) ) endif else c else bad command 150 print *,' Invalid XMODEM Command --' print *,' Usage: XMODEM ' print *,' S = Send, R = Receive, C = Use CRCs, B = Batch' print *,' T = Convert text files to/from CP/M or VAX/VMS' endif if( batchopt ) then firstbatch=.false. ! don't print informational messages ! from now on goto 100 ! get next filename endif 200 call exit ! should probably have a unified exit here ?? end c------------------------------------------------------ subroutine cleansfn(file,fileclean,length) character*(*) file, fileclean integer length c clean send file name c remove too-specific parts of filename (directory and version) c and make understandable by CP/M 11 char no dot, last 3 for type fileclean=' ' start=index( file,']' )+1 end=index( file, ';' )-1 dot = start-1 + index( file(start:end),'.' ) ! VMS guarantees a dot if(start.ne.dot) fileclean(1:)=file(start:dot-1) if(dot.ne.end) fileclean(9:)=file(dot+1:end) ! note: may overwrite last char of vax 9 char filename before dot length=11 return end c------------------------------------- subroutine sendfn(file) character*(*) file c sends name for batch checksummed send byte c integer ic equivalence (ic,c) logical ttyinlim logical crc byte checksumbyte integer checksum common /checks/checksum,crc equivalence (checksum,checksumbyte) parameter BDNMCH=117 ! badname character 'u' parameter OKNMCH=6 ! good name character parameter ACK=6 ! acknowlege character parameter EOF=26 ! filename terminator 100 continue c print *,' Awaiting name NAK' c write(8,*) ' Awaiting name NAK' call waitnlp(80) ! await NAK call ttyout(ACK,1) ! tell receiver a filename follows checksum=0 c print *,file c write(8,*) file do i=1,len(file) c=ichar( file(i:i) ) c print *, ' filename character=',c c write(8,*) ' filename character=',c checksum=checksum+c c print *,' checksum=',checksum c write(8,*) ' checksum=',checksum call ttyout(c,1) 200 if( .not.ttyinlim(c,1,2) ) then c print *,' timeout during name' write(8,*) ' timeout during name' goto 300 endif c print *,' ACK char received decimal=',c c write(8,*) ' ACK char received decimal=',c if(c.ne.ACK) goto 200 ! let it time out if bad eat chars ? enddo c print *,' EOF end of filename' c write(8,*) ' EOF end of filename' checksum=checksum+EOF call ttyout(EOF,1) if( .not.ttyinlim(c,1,2) ) then ! checksum from receiver (MODEM765.ASM ! did not check for timeout) c print *,' timeout awaiting checksum in sendfn' write(8,*) ' timeout awaiting checksum in sendfn' goto 300 endif if( checksumbyte.ne.c ) then c bad filename transmission c print *,' checksum,byte,c=',checksum,checksumbyte,c write(8,*) ' checksum,byte,c=' write(8,'(3z10)') checksum,checksumbyte,c 300 continue c print *,' BDNMCH = u' c write(8,*) ' BDNMCH = u' call ttyout(BDNMCH,1) ! lower case u (but receiver ! only cares that it was not ACK) c print *,' receiver better NAK now to start again' goto 100 endif c print *,' filename sent ok' c write(8,*) ' filename sent ok' call ttyout(OKNMCH,1) ! ACK return end c--------------------------------------------------------- subroutine waitnlp(sec) integer sec c Await NAK, Cancel if not here in sec seconds, or if CAN, ignore garbage integer count logical ttyinlim byte c parameter NAK=21 parameter CAN=24 count=0 100 if( .not.ttyinlim(c,1,1) ) then ! timeout count=count+1 c print *,' waitnlp passed limit' write(8,*) ' waitnlp passed limit' if(count.ge.sec) call cancel ! passed limit goto 100 elseif( c.eq.CAN ) then c print *,' waitnlp canceled' write(8,*)' waitnlp canceled' call cancel elseif( c.ne.NAK ) then ! ignore garbage c print *,' waitnlp not NAK, got decimal=',c write(8,*) ' waitnlp not NAK, got decimal=',c goto 100 endif c must have gotten NAK return end c--------------------------------------- logical function getfn(file,length) character*(*) file integer length c get the characters of the batch mode filename (return false if no more) c note: must be declared in callers too. logical ttyinlim, hsnak integer ic ! so char(ic) works byte c logical crc byte checksumbyte integer checksum common /checks/checksum,crc equivalence (checksum,checksumbyte) parameter EOT=4 ! end of batch transfer parameter ACK=6 ! acknowledge character parameter OKNMCH=6 ! OK name character ACK parameter EOF=26 ! end of filename getfn=.true. flen=len(file) 100 checksum=0 length=0 file=' ' ! blank filename c handshake to make sure synchronized 150 if( .not.hsnak() ) goto 150 ! may hang 'til CTRL-X 200 if( .not.ttyinlim(ic,1,2) ) then c print *,' Time out receiving filename=',file write(8,*) ' Time out receiving filename=',file goto 100 ! give up and restart handshaking endif length=length+1 file(length:length)=char(ic) c print *,' filename char=',ic c write(8,*) ' filename char=',ic c print *,' filename=',file(1:length) c write(8,*) ' filename=',file(1:length) checksum=checksum+ic if(ic.eq.EOT) then ! no more filenames c write(8,*) ' getfn got EOT' getfn=.false. return endif if(ic.eq.EOF) then length=length-1 c print *,' getfn got EOF' c write(8,*) ' getfn got EOF' c print *,file(1:length) c write(8,*) file(1:length) call ttyout(checksumbyte,1) ! send calculated checksum if(.not.ttyinlim(c,1,2) ) then ! get verification of checksum ! MODEM765 had no timeout check c print *,' timeout awaiting checksum ok' write(8,*) ' timeout awaiting checksum ok' goto 100 ! restart handshake endif if(c.eq.OKNMCH) return c print *,' Checksum error, verification c=',c write(8,*) ' Checksum error, verification c=',c goto 100 ! restart handshaking endif if(length.ge.flen) then c print *,' Too many characters in filename' write(8,*) ' Too many characters in filename' goto 100 ! start again at NAK endif call ttyout(ACK,1) goto 200 ! get next char end c-------------------------------------- logical function hsnak() c true if get ACK in response to NAK, c returns null if timeout ??? c note: must be declared in callers too. byte c logical ttyinlim parameter ACK=6 parameter CAN=24 parameter NAK=21 call ttyout(NAK,1) c checking for CAN is the only way to get out of the loop that c calls hsnak if( .not.ttyinlim(c,1,2) ) then ! timeout don't care what c is write(8,*) ' hsnak timeout' hsnak=.false. elseif(c.eq.ACK) then hsnak=.true. c print *,' hsnak got ACK' c write(8,*) ' hsnak got ACK' elseif(c.eq.CAN) then write(8,*) ' hsnak canceled' call cancel c else ! bad character, ignore endif return end c------------------------------------------------------ subroutine cleangfn(file,fileclean,length) character*(*) file, fileclean integer length c clean get file name c and make understandable by VAX 13 char with dot, last 3 for type c also replaces non-alphanumeric by "A" integer leng leng=index(file//' ',' ')-1 ! add blank in case none in filename c print *,' leng=',leng leng=min(leng,8) ! in case filename and type run together c print *,' leng=',leng fileclean(1:)=file(1:leng)//'.'//file(9:) length=index(fileclean,' ')-1 do i=1,leng if( (fileclean(i:i).ge.'A' .and. fileclean(i:i).le.'Z') 1 .or. 1 (fileclean(i:i).ge.'0' .and. fileclean(i:i).le.'9') ) 1 then c do nothing else ! not alphanumeric, replace by legal character fileclean(i:i)='A' endif enddo do i=leng+2,length if( (fileclean(i:i).ge.'A' .and. fileclean(i:i).le.'Z') 1 .or. 1 (fileclean(i:i).ge.'0' .and. fileclean(i:i).le.'9') ) 1 then c do nothing else ! not alphanumeric, replace by legal character fileclean(i:i)='A' endif enddo c print *,' length=',length c write(8,*) ' cleaned filename VAX form*',fileclean(1:length),'*' return end c---------------------------------------------------------------- c send file subroutine sendfile(file) c declare variables INTEGER*2 CHAN,STATUS(4) COMMON /QIO/ CHAN,STATUS character*(*) file byte sectorread(128), sector(130), send(133), c equivalence (send(4), sector(1), sectorread(1) ) integer nakwait, stat, ic logical ttyinlim logical charintime, acked logical batchopt, firstbatch common /batch/batchopt,firstbatch logical filedel common /filest/filedel integer blocknumber byte blockbyte equivalence (blocknumber,blockbyte) integer notblocknumber byte notblockbyte equivalence (notblocknumber,notblockbyte) integer errorcount common /err/errorcount integer high,low byte highbyte,lowbyte common /crcval/high,low equivalence (high,highbyte) equivalence (low,lowbyte) logical crc byte checksumbyte integer checksum common /checks/checksum,crc equivalence (checksum,checksumbyte) equivalence (ic,c) c define ASCII characters parameter NUL=0 parameter SOH=1 parameter EOT=4 parameter ACK=6 parameter NAK=21 parameter CAN=24 parameter CRCCHAR='C' c timeouts parameter respnaklim=10 parameter naklim=10 parameter eotlim=10 parameter errlim=10 if(filedel) then ! will close(9,disp='delete') so can't readonly open(9,name=file,iostat=stat,status='OLD') c 1 carriagecontrol='NONE',recordtype='FIXED',recl=128) else ! should not delete, so readonly is ok open(9,name=file,iostat=stat,status='OLD',readonly) c 1 carriagecontrol='NONE',recordtype='FIXED',recl=128) endif if(stat) then if(.not.batchopt) then print *,'Can''t open ',file,' for send.' endif write(8,*) 'Can''t open ',file,' for send.' call cancel endif if( .not.batchopt ) then print *,file,' Open -- Please Run Your Receiver --' print * endif errorcount=0 blocknumber=1 nakwait=0 c await first NAK (or 'C') indicating receiver is ready 200 charintime=ttyinlim(c,1,naklim) ! return NUL if timeout c print *,' first NAK character=',c c write(8,*) ' character=',c if( .NOT.charintime ) then write(8,*) 'initial NAK or C timeout, trying again' nakwait=nakwait+1 c give the turkey 80 seconds to figure out how to receive a file if(nakwait.ge.80/naklim) call cancel goto 200 elseif(c.EQ.NAK) then crc=.false. c print *,' CHECKSUM mode' write(8,*) ' CHECKSUM mode' elseif(c.EQ.CRCCHAR) then crc=.true. c print *,' CRC mode' write(8,*) ' CRC mode' elseif(c.EQ.CAN) then call cancel else c unrecognized character write(8,*) 'unrecognized first NAK=',c nakwait=nakwait+1 if(nakwait.ge.80/naklim) call cancel goto 200 endif 300 continue c send new sector c use equivalence so not need to do inefficient implicit do loop in read read(9,1000,end=500) sectorread 1000 format(128a) errorcount=0 c print *,' sector as read',sector c write(8,*) ' sector as read',sector 400 continue c send sector c print *,' SOH ' c write(8,*) ' SOH' send(1)=SOH c note: equivalence used for fast integer to byte conversion c without byte overflow problems send(2)=blockbyte notblocknumber=not(blocknumber) send(3)=notblockbyte c print *,' blocknumber=',blocknumber c write(8,*) ' blocknumber=',blocknumber c sector already in sending buffer done by equivalence checksum=0 call clrcrc c calc checksum or crc if(crc) then c write(8,*) ' CRC mode' c put all bytes + two finishing zero bytes through updcrc sector(129)=0 sector(130)=0 call updcrc( sector,130 ) send(132)=highbyte send(133)=lowbyte c write(8,*) 'highbyte,lowbyte' c write(8,'(2z10)') highbyte,lowbyte c actually send call ttyout(send,133) else c write(8,*) 'CHECKSUM mode' do i=1,128 checksum=checksum+sector(i) enddo c this sends low order byte of checksum send(132)=checksumbyte c print *,' checksumbyte ',checksumbyte c write(8,*) ' checksumbyte ',checksumbyte call ttyout(send,132) endif c sector sent, see if receiver acknowleges c getack attempts to get ACK c if not, repeat sector c print *, ' should wait for ACK 10 seconds' c write(8,*) ' should wait for ACK 10 seconds' call getack(acked) c print *, ' getack returned=',acked c write(8,*) ' getack returned=',acked if(.NOT.acked) goto 400 c ACK received, send next sector blocknumber=blocknumber+1 goto 300 c end of file during read. finish up sending. 500 continue call ttyout(EOT,1) c getack attempts to get ACK up to errlim times call getack(acked) if( .NOT.acked ) goto 500 c print *,' This file Sending complete.' write(8,*) ' This file Sending complete.' if (filedel) then close(9,dispose='DELETE') else close(9) endif close(8,dispose='DELETE') ! the .LOG file return end c---------------------------------------------------------------- c receive file subroutine recvfile(file) c declare variables INTEGER*2 CHAN,STATUS(4) COMMON /QIO/ CHAN,STATUS character*(*) file byte c, notc, ck integer blocknumber, inotc, notnotc, secbytes, stat integer testblock, testprev, ic logical ttyinlim logical charintime, firstsoh byte sector(130),sectorwrite(128) equivalence (sector,sectorwrite) logical batchopt,firstbatch common /batch/batchopt,firstbatch integer errorcount common /err/errorcount integer high,low byte highbyte,lowbyte common /crcval/high,low equivalence (high,highbyte) equivalence (low,lowbyte) logical crc byte checksumbyte integer checksum common /checks/checksum,crc equivalence (checksum,checksumbyte) equivalence (ic,c) c define ASCII characters parameter NUL=0 parameter SOH=1 parameter EOT=4 parameter ACK=6 parameter NAK=21 parameter CAN=24 parameter CRCCHAR='C' c timeouts parameter respnaklim=10 parameter naklim=10 parameter eotlim=10 parameter errlim=10 parameter datalim=2 ! timeout for data block receive ! 1 second wouldn't work on moderately loaded ! VAX, more may be necessary if heavily loaded open(7,name=file,recl=128,status='NEW',iostat=stat, 1 carriagecontrol='NONE',recordtype='FIXED') if(stat) then if(batchopt) then c print *,' Can''t open ',file,' for receive.' else print *,' Can''t open ',file,' for receive.' endif write(8,*) ' Can''t open ',file,' for receive.' call cancel endif if(.not.batchopt) then print *,' Please Send Your File --' print * endif if(crc) then secbytes=130 else ! checksum mode secbytes=129 endif firstsoh=.false. errorcount=0 blocknumber=1 c start the sender by letting ttyinlim time-out in getack routine c so it sends a NAK or C goto 999 800 continue c write(8,*) ' ready for SOH' c must allow enough time for other's disk read (xmodem50.asm allows 10sec) charintime=ttyinlim(c,1,respnaklim) c if no char for a while, try NAK or C again if( .NOT.charintime ) then c print *,' no response to NAK or C, trying again' write(8,*) ' no response to NAK or C, trying again' goto 999 endif c else received a char so see what it is if(c.eq.NUL) goto 800 ! ignore nulls here for compatablity with old ! versions of modem7 if(c.EQ.CAN) then c print *,' Canceled. Aborting.' write(8,*) ' Canceled. Aborting.' call exit endif c print *,' EOT or SOH character=',c c write(8,*) ' EOT or SOH character=',c if(c.NE.EOT) then if(c.NE.SOH) then c print *,' Not SOH, was decimal ',c write(8,*) ' Not SOH, was decimal ',c goto 999 endif firstsoh=.true. c character was SOH to indicate start of header c get block number and complement charintime=ttyinlim(c,1,1) if(.not.charintime) then c print *,' timeout awaiting block number' write(8,*) ' timeout awaiting block number' goto 999 endif c print *,' block=',c c write(8,*) ' block=',c charintime=ttyinlim(notc,1,1) if(.not.charintime) then c print *,' timeout awaiting block complement' write(8,*) ' timeout awaiting block complement' goto 999 endif c print *,' block complement=',notc c write(8,*) ' block complement=',notc inotc=notc ! make integer for "not" function notnotc=iand( not(inotc),255 ) ! mask back to byte c c is low order byte of ic via equivalence statement if(ic.NE.notnotc) then c print *,' block check bad.' write(8,*) ' block check bad.' goto 999 endif c block number valid but not yet checked against expected c clear checksum and CRC checksum=0 call clrcrc c receive the sector and checksum bytes in one call (for speed) and to c keep from hogging VAX cpu time at high baud rates. c secbytes is 129 for checksum, 130 for CRC charintime=ttyinlim(sector,secbytes,datalim) C check for time out if(.not.charintime) then c print *,' Timeout on data block read' write (8,*) ' Timeout on data block read' goto 999 endif if(crc) then c put data AND CRC bytes through updcrc call updcrc(sector,secbytes) c if result non-zero, BAD. if(highbyte.NE.0 .OR. 1 lowbyte.NE.0 ) then c print *,' CRC, high,low=' write(8,*) ' CRC, high,low=' c print 3000, highbyte,lowbyte write(8,3000) highbyte,lowbyte 3000 format(2z10) goto 999 endif else c don't add received checksum byte to checksum do i=1,secbytes-1 checksum=checksum+sector(i) enddo ck=sector(129) c print 2100, ck c write(8,2100) ck c print 2100, checksum c write(8,2100) checksum c print 2100, checksumbyte c write(8,2100) checksumbyte c 2100 format(' checksum=',z10) if( checksumbyte.NE.ck ) then write(8,*) ' bad checksum' goto 999 endif endif c received OK so we can believe the block number, see which block it was c mask it to be one byte testblock=iand(blocknumber,255) testprev=iand( blocknumber-1 ,255) if( ic.EQ.testprev) then c print *, ' prev. block again, out of synch' write(8,*) ' prev. block again, out of synch' c already have this block so don't write it, but ACK anyway to resynchronize goto 985 elseif( ic.NE.testblock ) then c print *, ' block number bad.' write(8,*) ' block number bad.' goto 999 endif c else was expected block c write before acknowlege so not have to listen while write. c equivalence so not need inefficient implicit do loop write(7,2000,err=900) sectorwrite 2000 format(128a) goto 975 900 write(8,*) ' Can''t write sector. Aborting.' c print *, ' Can''t write sector. Aborting.' call cancel 975 continue c received sector ok, wrote it ok, so acknowlege it to request next. blocknumber=blocknumber+1 c comes here if re-received the previous sector 985 continue errorcount=0 c print *, ' ACKing, sector was ok.' c write(8,*) ' ACKing, sector was ok.' call ttyout(ACK,1) goto 800 c else error so eat garbage in case out of synch and try again 999 continue call eat c print *, ' receive error NAK, block=',blocknumber write(8,*) ' receive error NAK, block=',blocknumber if(crc.AND..NOT.firstsoh) then c keep sending 'C' 'til receive first SOH call ttyout(CRCCHAR,1) else call ttyout(NAK,1) endif errorcount=errorcount+1 998 if(errorcount.GE.errlim) then c print *,' Unable to receive block. Aborting.' write(8,*) ' Not receive block. Aborting.' c delete incompletely received file close(7,dispose='DELETE') call cancel endif c retry goto 800 endif c EOT received instead of SOH so file done. c should keep sending ACK 'til no more EOT's ? close(9) close(7) call ttyout(ACK,1) call ttyout(ACK,1) call ttyout(ACK,1) write(8,*) ' Completed.' c print *, ' Completed.' c transfer ok, so delete the error log file. close(8,dispose='DELETE') return end c------------------------------------------------------------- subroutine ctov(input,output) c convert file of XMODEM 128 byte records with embedded c marking end-of-line and CTRL-Z marking end-of-file c to carriage-control=LIST (normal VAX editable file) parameter linelen=500 ! if longer lines needed, change this ! and the 'line' declaration below character*80 input,output character*500 line character*1 CR,LF,recchar logical eof, eol integer len logical filedel common /filest/filedel len=0 eof=.false. eol=.false. CR=char(13) LF=char(10) if(filedel) then ! can't readonly since close(9,disp='delete') open(9,file=input,status='OLD') else open(9,file=input,status='OLD',readonly) endif c set maximum output record length (fortran default is 133) open(7,file=output,status='NEW',carriagecontrol='LIST', 1 recl=linelen) c getchar (read new record if no input characters left) c if EOF on input, write line and exit c if CR then c if getchar LF then write line c else put back char and putchar CR into line (error if too long) c endif c else putchar (write error message if line too long) c endif c loop 100 call getc(recchar,eof,eol) if(eof) goto 200 if(recchar.eq.CR) then c PRINT *,' CR' call getc(recchar,eof) if(eof.or.recchar.ne.LF) then call putback len=len+1 if(len.ge.linelen+1) 1 write(8,*)' Out line too long.' c print *,' too long line=',line line(len:len)=recchar else c was LF c PRINT *,' LEN=',LEN c print *,' after LF, line=',line(1:len) write(7,2000) line(1:len) len=0 endif else c not CR, was "ordinary" character len=len+1 if(len.ge.linelen+1) then write(8,*)' Out line too long.' c PRINT *,' LINE=',LINE(1:len) else line(len:len)=recchar endif endif go to 100 c flush last line and exit 200 continue if(len.gt.0) then write(7,2000) line(1:len) 2000 format(a) len=0 endif if (filedel) then close(9,dispose='DELETE') else close(9) endif close(7) return end c------------------------------------------ subroutine getc(c,eof) character*1 c logical eof c get character from a CP/M text file c point to next character in record (read record if necessary) character*1 CTRLZ integer point character*128 record common /reccom/point,record data point/0/ logical firsttime common /getccom/firsttime data firsttime/.true./ CTRLZ=char(26) point=point+1 if( firsttime .or. (point.gt.128) ) then firsttime=.false. 100 read(9,1000,end=200) record 1000 format(a) c PRINT *,RECORD point=1 endif c strip parity in case CP/M file had it c=char(iand(ichar(record(point:point)),127)) if(c.eq.CTRLZ) goto 200 ! end of CP/M text file return c end of file 200 eof=.true. firsttime=.true. ! ready for next file point=0 return end c---------------------------------------------- subroutine putback c point to previous input character so this character will be getchar result c even works if 1st char of record integer point character*128 record common /reccom/point,record point=point-1 return end c------------------------------------------------------------- subroutine vtoc(input,output) c convert VAX text file to c file of XMODEM 128 byte records with embedded character*80 input,output character*1 CR,LF,c logical eof,eol eof=.false. eol=.false. CR=char(13) LF=char(10) open(9,file=input,status='OLD',READONLY) open(7,file=output,status='NEW',carriagecontrol='NONE', 1 recl=128,recordtype='FIXED') c getchar (read new line if no input characters left) c putchar ( output record if full, close if EOF ) c if EOL on input, putchar CR putchar LF (output record if full) c loop 100 call getv(c,eof,eol) if(.not.eol) then call putchar(c,eof) if(eof) then return endif else c end of line call putchar(CR,eof) call putchar(LF,eof) eol=.false. if(eof) then return endif endif go to 100 end c------------------------------------------ subroutine putchar(c,eof) character*1 c logical eof c put character into record (write record if necessary) c if eof, fills out rest of record with CTRL-Z's and exits character*1 CTRLZ integer point character*128 record common /reccom/point,record data point/0/ if(eof) goto 200 point=point+1 c strip parity in case VAX file had it record(point:point)=char(iand(ichar(c),127)) c print *,' record(point:point)=',record(point:point) c print *,' point=',point 50 if(point.ge.128) then c print *,' record=',record 100 write(7,1000) record 1000 format(a) point=0 endif return c EOF fill record with 26's (CTRL-Z, CP/M end of file mark for ASCII) c output last record and exit 200 continue c print *,' in putchar EOF section' CTRLZ=char(26) do i=point+1,128 record(i:i)=CTRLZ enddo c print *,' record=',record write(7,1000) record close(9) close(7) point=0 ! ready for next file return end c------------------------------------------- subroutine getv(inchar,eof,eol) character*1 inchar logical eof,eol c get character from input line (read line if necessary) c returns character and eol=.true. if no more char on line c returns eof if end of file (no character) character*255 line integer len, pos logical firsttime common/lincom/pos,len,line data pos/0/ if(pos.eq.0) then read(9,1000,end=100)len,line(1:len) 1000 format(q,a) c print *,' line=',line endif pos=pos+1 if(pos.gt.len) then eol=.true. pos=0 return endif c print *,' pos=',pos,' line(1:pos)=',line(1:pos) c print *,' line(pos:pos)=',line(pos:pos) inchar=line(pos:pos) c print *,' pos,char',pos,inchar return c EOF 100 continue eof=.true. return end c----------------------------------------------------------- subroutine clrcrc c clears CRC integer high,low byte highbyte,lowbyte common /crcval/high,low equivalence (high,highbyte) equivalence (low,lowbyte) high=0 low=0 return end c----------------------------------------------------------- subroutine updcrc(bbyte,n) byte bbyte(*) integer n c updates the Cyclic Redundancy Code c uses x^16 + x^12 + x^5 + 1 as recommended by CCITT c and as used by CRCSUBS version 1.20 for 8080 microprocessor c and incorporated into the MODEM7 protocol of the CP/M user's group c c during sending: c call clrcrc c call updcrc for each byte c call fincrc to finish (or just put 2 extra zero bytes through updcrc) c result to send is low byte of high and low in that order. c c during reception: c call clrcrc c call updcrc all bytes PLUS the two received CRC bytes must be passed c to this routine c then zero in high and low means good checksum c c see Computer Networks, Andrew S. Tanenbaum, Prentiss-Hall, 1981 c c must declare integer to allow shifting integer byte integer bit,bitl,bith integer high,low byte highbyte,lowbyte common /crcval/high,low equivalence (high,highbyte) equivalence (low,lowbyte) c write(8,*) ' inside updcrc' do i=1,n c write(8,*) 'high,low,byte' c write(8,1000) high,low,bbyte c1000 format(3z10) byte=bbyte(i) do j=1,8 c get high bits of bytes so we don't lose them when shift c positive is left shift bit =ishft( iand(128,byte), -7) bitl=ishft( iand(128,low), -7) bith=ishft( iand(128,high), -7) c write(8,*) 'bit,bitl,bith' c write(8,1000) bit,bitl,bith c get ready for next iteration newbyte=ishft(byte,1) byte=newbyte ! introduced dummy variable newbyte ! to avoid "access violation" c write(8,*) ' byte ready for next iteration' c write(8,1000) byte c shift those bits in low =ishft(low ,1)+bit high=ishft(high,1)+bitl c write(8,*),' high,low after shifting bits in' c write(8,1000) high,low if(bith.eq.1) then high=ieor(16,high) low=ieor(33,low) c write(8,*) ' high,low after xor' c write(8,1000) high,low endif enddo enddo return end c----------------------------------------------------------- c subroutine fincrc c finish CRC calculation for sending result in high, low c merely runs updcrc with two zero bytes c NEVER ACTUALLY USED, I JUST PASS TWO EXTRA ZERO BYTES TO UPDCRC WITH SECTOR c integer high,low c byte highbyte,lowbyte c common /crcval/high,low c equivalence (high,highbyte) c equivalence (low,lowbyte) c c byte=0 c call updcrc(byte) c call updcrc(byte) c return c end c----------------------------------------------------------- subroutine eat c eats extra characters 'til pause used to re-synch after error c in case error was in header, allow at least 1 block of garbage parameter numchar=135 ! allow a few noise bytes beyond 1 block byte buffer(numchar) logical i,ttyinlim c parameter maxtime=2 100 i=ttyinlim(buffer,numchar,maxtime) c print *,' eating' c write(8,*) 'finished eating' if(istat) goto 100 ! didn't timeout, so char's still coming c print *,' finished eating' c write(8,*) ' finished eating' c write(8,'(16z5)') buffer return end c----------------------------------------------------------- LOGICAL FUNCTION TTYINLIM(LINE,N,LIMIT) BYTE LINE(*) INTEGER N,LIMIT C READ CHARACTERS FROM TERMINAL C WITH TIME LIMIT, RETURN FALSE IF NO CHARACTERS C RECEIVED FOR LIMIT SECONDS C MODIFIED BY BELONIS TO REMOVE PRIVILEGE PROBLEM C MAY HAVE PROBLEM WITH TYPE-AHEAD c apparent typeahead problem: in SENDFN, remote can send checksum c too soon after we send EOF, it is seen by typeahead since c this routine has not yet activated, so high bit already stripped c This was solved by using PASSALL routine. INTEGER*2 CHAN,STATUS(4) COMMON /QIO/ CHAN,STATUS INCLUDE '($SSDEF)' ! defines error status returns INTEGER I INTEGER SYS$QIOW INTEGER*4 terminators(2) EXTERNAL IO$M_NOECHO,IO$_TTYREADALL,IO$M_TIMED DATA TERMINATORS/0,0/ C c write(8,*) ' inside ttyinlim' TTYINLIM=.TRUE. ! DEFAULT no delay over LIMIT seconds I = SYS$QIOW(, !EVENT FLAG - %VAL(CHAN), !CHANNEL - %VAL(%LOC(IO$_TTYREADALL).OR. - %LOC(IO$M_NOECHO).OR.%LOC(IO$M_TIMED)), - STATUS,,, - LINE, !BUFFER - %VAL(N), !LENGTH - %VAL(LIMIT), !time limit in seconds - terminators,,) !no terminators c print *,' ttyinlim=',(LINE(j),j=1,N), ' STATUS=',STATUS c write(8,*) ' ttyinlim=',(LINE(j),j=1,N), ' STATUS=',STATUS if(STATUS(1).EQ.SS$_TIMEOUT) THEN TTYINLIM=.FALSE. c print *, ' ttyinlim timeout' write(8,*) ' ttyinlim timeout' return ENDIF IF (I) THEN c print *, ' returning from ttyinlim' c write(8,*) ' returning from ttyinlim return endif C C ERROR write(8,*) ' ttyinlim error.' CALL SYS$EXIT( %VAL(I) ) END c----------------------------------------------------------- SUBROUTINE TTYOUT(LINE,N) BYTE LINE(*) INTEGER*2 N C output N characters without interpretation INTEGER*2 CHAN,STATUS(4) COMMON /QIO/ CHAN,STATUS INTEGER I INTEGER SYS$QIOW EXTERNAL IO$M_NOFORMAT EXTERNAL IO$_WRITEVBLK C IF( N.LE.0 ) THEN WRITE(8,*) ' ttyout called with strange number of char ',N RETURN ENDIF C c print *, ' to be sent by ttyout ', (line(i),i=1,n) c write(8,*) ' to be sent by ttyout ', (line(i),i=1,n) I = SYS$QIOW(, - %VAL(CHAN), - %VAL(%LOC(IO$_WRITEVBLK).OR. - %LOC(IO$M_NOFORMAT)), - STATUS,,, - LINE, - %VAL(N),, - %VAL(0),, ) !NO CARRIAGE CONTROL if(I) then return endif C C ERROR write(8,*) ' ttyout error.' CALL SYS$EXIT( %VAL(I) ) END c-------------------------------------------------- subroutine giveup c this exit routine used especially in case exited via QIO problem INTEGER*2 CHAN,STATUS(4) COMMON /QIO/ CHAN,STATUS c note: if want log file message, must re-open since c system already closed all files before this exit handler got control c open(8,file='XMODEM.LOG',access='APPEND') c write(8,*) ' Exit handler.' c turn off passall call passall(CHAN,.FALSE.) return end c----------------------------------------------------- SUBROUTINE PASSALL(CHAN,SWITCH) C sets PASSALL mode for terminal connected to chanel CHAN, ON if switch true IMPLICIT INTEGER (A-Z) INCLUDE '($TTDEF)' INCLUDE '($IODEF)' LOGICAL SWITCH COMMON/CHAR/CLASS,TYPE,WIDTH,CHARAC(3),LENGTH !byte reversed LENGTH BYTE CLASS,TYPE,CHARAC,LENGTH INTEGER*2 WIDTH,SPEED EQUIVALENCE(CHARACTER,CHARAC) c sense current terminal driver mode ISTAT=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SENSEMODE),,,, 1 CLASS,,,,,) IF (.NOT.ISTAT) CALL ERROR('TERMINAL SENSEMODE',ISTAT) IF(SWITCH) THEN c turn on 8 bit passall CHARACTER=CHARACTER.OR.TT$M_PASSALL.OR. 1 TT$M_EIGHTBIT ELSE c turn off 8 bit passall CHARACTER=CHARACTER.AND..NOT.TT$M_PASSALL.AND. 1 .NOT.TT$M_EIGHTBIT ENDIF SPEED=0 !LEAVE SPEED UNCHANGED PAR=0 !LEAVE PARITY UNCHANGED c set terminal mode with desired passall ISTAT=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SETMODE),,,, 1 CLASS,,%VAL(SPEED),,%VAL(PAR),) IF (.NOT.ISTAT) CALL ERROR('TERMINAL SETMODE',ISTAT) RETURN END c--------------------------------------------------- SUBROUTINE ERROR(STRING,MSGID) c Types error message IMPLICIT INTEGER(A-Z) CHARACTER*(*) STRING CHARACTER*80 MESSAGE TYPE *,' *** ERROR: ',STRING write(8,*) ' *** ERROR: ',STRING CALL SYS$GETMSG(%VAL(MSGID),MSGLEN,MESSAGE,%VAL(15),) TYPE *,MESSAGE(1:MSGLEN),CRLF write(8,*) MESSAGE(1:MSGLEN),CRLF RETURN END c----------------------------------------------------------- subroutine cancel c called to cancel send (at least) logical ttyinlim byte c(135) ! enough space to eat everything parameter CAN=24 parameter SPACE=32 c eat garbage 100 if( ttyinlim(c,135,1) ) goto 100 c cancel other end call ttyout(CAN,1) c eat garbage again in case it didn't understand ? 200 if( ttyinlim(c,135,1) ) goto 200 c clear the CAN from far end's input in case he has already cancelled and so c has not yet read it. c ???? why ? xmodem50.asm does it call ttyout(SPACE,1) c print *,' XMODEM program canceled' write(8,*)' XMODEM program canceled' call exit end c------------------------------------------------------ subroutine getack(acked) c returns .TRUE. if gets ACK logical charintime, ttyinlim, acked byte sector(130),c integer errorcount common /err/errorcount parameter ACK=6 parameter NAK=21 parameter CAN=24 parameter errlim=10 ! max number of errors parameter acklim=15 ! seconds to wait for ACK (xmodem.asm uses 10?) ! but Stern's Northstar takes longer ! to write 128 sectors c print *,' inside getack' c write(8,*) ' inside getack' c empty typeahead in case garbage c charintime=ttyinlim(sector,130,0) c allow time for disk file write at other end. Typically 128 sectors. c Sometimes only 1 track. 10 charintime=ttyinlim(c,1,acklim) c print *,' getack got',c c write(8,*) ' getack got',c if( .NOT.charintime ) then c print *, ' timeout in GETACK' write(8,*) ' timeout in GETACK' errorcount=errorcount+1 if(errorcount.GE.errlim) then write(8,*) ' not acknowleged in 10 tries.' c print *,' Can''t send sector. Aborting.' call cancel endif goto 10 ! try again elseif( c.EQ.ACK ) then c received ACK acked=.TRUE. elseif( c.EQ.NAK ) then c print *,' not ACK, decimal=',c write(8,*) ' not ACK, decimal=',c errorcount=errorcount+1 if(errorcount.GE.errlim) then write(8,*) ' not acknowleged in 10 tries.' c print *,' Can''t send sector. Aborting.' call cancel endif acked=.FALSE. elseif(c.EQ.CAN) then write (8,*) 'Cancel received while waiting for ACK' call cancel else c received garbage, ignore it and try again. c note: this risks seeing ACK inside the burst of garbage, possibly should EAT c print *, ' not ACK, decimal=',c write(8,*) ' not ACK, decimal=',c goto 10 endif return end