*comdeck comcker cc comcker - kermit symbol definitions. c c this comdeck contains all symbol definitions needed by kermit. it c contains items found in several different areas in the texas c version of kermit, and cleans up usage conflicts among the various c parameter values. this comdeck should be *called into every c kermit module. c implicit integer (a - z) cc kermit site definitions. c c character set information. c c ipc641 = ip.c64.1 (from iptext). c ipc642 = ip.c64.2 (from iptext). c ipc63 = ip.c63 (from iptext). c ipcset = ip.cset = character set in use at your site. c n.b. ipcset is ignored if ut2d = 1. c parameter (ipc641=0, ipc642=1, ipc63=2) *if def,63cset,1 parameter (ipcset=ipc63) *if def,641cset,1 parameter (ipcset=ipc641) *if def,642cset,1 parameter (ipcset=ipc642) cc o.s. definitions. set your o.s. to 1, all others to 0. c *if def,nos,1 parameter (ut2d=0, nos=1, nosbe=0, scope=0) *if def,nosbe,1 parameter (ut2d=0, nos=0, nosbe=1, scope=0) *if def,scope,1 parameter (ut2d=0, nos=0, nosbe=0, scope=1) *if def,ut2d,1 parameter (ut2d=1, nos=0, nosbe=0, scope=0) cc site definitions. used for sites with non-standard opsys. c *if def,uariz,1 parameter (utexas=0, uariz=1) *if def,utexas,1 parameter (utexas=1, uariz=0) *if def,other,1 parameter (utexas=0, uariz=0) cc nos definitions. used for nos sites. c c nosver = version number (14, 20, 21, etc). c noslvl = psr level. parameter (nosver = 22, noslvl=602) cc file i/o definitions. c parameter (stdin=1, stdout=2) cc ascii character definitions. c parameter (soh=1, tab=9, lf=10, cr=13, blank=32, minus=45) parameter (qmark=63, del=127, nel=o"0205", null=o"4000", eof=-1) cc miscellaneous. c parameter (ok=1, error=-2, on=1, off=0, yes=1, no=0) cc protocol definitions. c parameter (unknown=0, fulldup=1, halfdup=2) parameter (none=0, even=1, odd=2, mark=3, space=4) parameter (maxinit=20, maxtry=5) parameter (maxpack=94, mytime=10, mypad=0, mypadch=0) parameter (myeol=13, myquote=35, quot8ch=78, mycktyp=49) parameter (prefxch=126) cc packet types. c parameter (a=65, b=66, c=67, d=68, e=69, f=70, g=71, l=76, n=78) parameter (r=82, s=83, y=89, z=90) cc packet error definitions c parameter (toomany=o"1000", invalid=o"2000", seqerr=o"4000") parameter (lclfile=o"10000", notlcl=o"20000", invfn=o"40000") parameter (srvcmd=o"100000") parameter (sending=o"100", reading=o"200") parameter (initerr=1, filerr=2, dataerr=4, eoferr=o"10") parameter (brkerr=o"20") cccc kermit saved common block header c c all common blocks to be saved when executing monitor c commands must be placed between /header/ and /trailer/ c common /header/ header cccc kermit command processor common block. c common /kermcmd/ autoret, dskcset, rdelay cccc kermit packet description common block. c c do not allocate any storage between packsiz and sndsync! c allocate storage for what i want. common /packet/ packsiz, timeout, npad, padch, eolch, quotech, + quote8, chktyp, rprefix, reserve(2), sync, c allocate storage for what partner wants. + spksiz, stimout, spad, spadch, speol, spquote, + s8quote, schktyp, srepeat, unused(2), sndsync cccc kermit protocol common block. c common /proto/ packet(maxpack), recpack(maxpack), + filestr(maxpack), + psize, packnum, numtry, maxrtry, maxrini, state, ifd, ofd, ffd, + delayfp, savedpx, c storage for statistics. + abortyp, startim, endtim, schcnt, rchcnt, schovrh, rchovrh cccc debug common block. c parameter (dbgoff=0, dbgstat=1, dbgpack=2, dbgall=3) common /debug/ debug, debugfd, debugfn(8) cccc ascii string message common block defintions. c integer errmsg(maxpack) common /msg/ errmsg cccc kermit saved common block trailer c common /trailer/ trailer cccc file i/o common block definitions. c parameter (maxfile=5) c cio related parameters. c c ciord = cio read function code. c ciowt = cio write function code. c ciobufl = cio buffer length (must be .gt. pru size of device). c fetl = fet length in words. c maxwd = line size in words; must be an even number. c normal = flag to exitpgm that this is a normal exit. boolean ciord, ciowt parameter (ciord = o"10", ciowt = o"14") parameter (asciiio = 43, nosbit = 42, cioodd = o"2") parameter (ciobufl=129, fetl=6, maxwd=32) parameter (closed=0, rd=1, wr=2, create=3) parameter (nopar=0, evepar=1, oddpar=2, mrkpar=3, spcpar=4) parameter (dskdpc=0, dsknos8=1, dskut8=2, dskimag=4) parameter (dskasci = dsknos8 .or. dskut8) character*10 fname(maxfile) common /fileioc/ fname boolean fchbuf(maxwd,maxfile) boolean fets(0:fetl - 1,maxfile), ciobuff(ciobufl,maxfile) integer fmode(maxfile), fnwds(maxfile), fwptr(maxfile), + fwshft(maxfile) logical feof(maxfile), ctdev(maxfile), rawmode, binmode logical normal common /fileio/ fmode, fwptr, fnwds, feof, fwshft, + ctdev, rawmode, binmode, parity, duplex, normal common /fetcom/ fets, ciobuff, fchbuf c common // ciobuff, fchbuf cccc message common block. c character*37 version character*15 ambig character*38 nomatch character*24 follow character*53 nodigit character*31 missing character*33 confmsg character*19 notconf character*42 hlpdlfp character*37 hlpdbfn character*24 hlpplen character*34 hlppadl character*74 hlpasch character*29 hlpiprc character*21 hlpprtr character*43 hlptimo character*19 hlpsnfn character*41 hlprdel common /message/ version, ambig, nomatch, follow, nodigit, + missing, confmsg, notconf, + hlpasch, hlpdlfp, hlpdbfn, hlpplen, hlppadl, hlpiprc, hlpprtr, + hlptimo, hlpsnfn, hlprdel cccc character conversion tables. c c dpctbl = ascii to display code table. c lascii = display code to lower case ascii. c uascii = display code to upper case ascii. boolean dpctbl(0:127), lascii(0:63), uascii(0:63) common /charcom/ dpctbl, lascii, uascii *comdeck kermcom same as comcker, but turns off listing. c$ list(s=0) c c the following c$ lines are here instead of comcker because c ftn5 flags them as errors in a block data module (grrrr). c c$ collate(fixed) c$ do(ot=0) *call comcker c$ list(s=1) *deck kermit *if def,ovcap ident kermit lcc overlay(0,0,ov=8) ldset lib ldset lib=kermlib/azlib/ftn5lib ldset omit=syserr. saves 2000b+ words entry kermit syscom b1 kermit title kermit - micro computer file exchange/kermit protocol. comment micro computer file exchange/kermit protocol. kermit space 4,10 ***** kermit - micro computer file exchange/kermit protocol. * * kermit is a file shipping program used by micro computers to * transfer files to/from another computer. it was originally * developed by columbia university for their decsystem-20, and * adapted by the university of texas for their cyber and ut2d * operating system. kermit space 4,10 *** micro computer file interchange/kermit protocol. * * this version is for use under nos/be. in case you are * wondering, kermit stands for (k)l10 (e)rror-free (r)eciprocal * (m)icroprocessor (i)nterchange over (t)ty lines. (x) * indicates a letter in the acronym. a kl-10 (aka kl-20) is a * digital equipment corporation 36 bit cpu. kermit space 4,10 ** internal documentation. * * due to the nasty habit intercom has of swapping out jobs that * go into terminal input wait, kermit's field length must be * kept to a minimum. since kermit does ascii i/o, it cannot * use fortran read and write statements. thus, an easy way to * save memory is to kick out most ftn5lib modules. this is * complicated by some needed modules calling 'syserr.', which * in turn drags in about 3000b words of other stuff. for this * reason, i have included an 'ldset omit=syserr.' in this * module. thus, should some error condition arise that * would cause ichar, char, xovcap, or whoever to call 'syserr.', * an error mode 1 at will happen in the routine making the * call. since this should not occur, i am willing to live * with the user hostile diagnostic. for debugging purposes, * the ldset may be commented out so you get the ftn5 error * diagnostic. * * i also used ovcaps instead of segmenting kermit so the core * image can be installed in nucleus, with the ovcaps in sysovl. * cdc has not yet answered a psr we submitted regarding fdl.ocr * not looking in sysovl for caps for nucleus programs. thus, * without our suggested code, ovcaps will need to be in nucleus * also. * * each ovcap has a compass front-end so that the comment field * of the binary has useful information in it. this is useful * when you itemize a deadstart tape. also, making the main * be in compass gets rid of a call to 'q5ntry=' which also * saves some memory. kermit title main program. ** main program. kermit sb1 1 if def,actr,1 sa1 actr get control card parameter count if def,ra.act,1 sa1 ra.act get control card parameter count sx1 x1 zr x1,kermit1 if no parameters message (=c* kermit - too many parameters.*),,rcl abort ,nd,s kermit1 rj =xkermain call the real workhorse endrun end kermit *if def,nos ident nostuff title nostuuf - nos version 2 *kermit* assist. *comment nostuuf - nos version 2 *kermit* assist. entry memstat entry nosinit entry nosexit entry nosetlf entry nosctab entry noswait ldset lib=srvlib/symlib sst syscom b1 nostuff space 4,10 *** nostuuf - nos version 2 *kermit* assist. * bill russell. 84/07/01. nostuff space 4,10 *** nostuff contains various subroutines that interface * kermit to nos version 2. title nosinit - initialize *kermit* in a nos system. nosinit space 4,10 *** nosinit - initialize *kermit* in a nos system. * * entry none. * * exit the following will be true: * all nos/iaf prompts will be *off* * the terminal will be in *ascii* mode nosinit subr sb1 1 prompt off cset ascii eq nosinit title nosexit - terminate *kermit* in a nos system. nosexit space 4,10 *** nosexit - terminate *kermit* in a nos system. * * entry none. * * exit final status message will be issued. nosexit subr sb1 1 move endcl,endc,endb sx6 3 sa6 mema rj memstat endrun title memstat - issue *b display* kermit memory status. memstat space 4,10 *** memstat - issue *b display* kermit memory status. * * entry none. * * exit kermit status message will be displayed on the * *b display*. * * calls cmm.gss (in nos system library symlib). * cmm.op4 (to shrink memory). memstat subr sb1 1 rj =xcmm.op4 shrink at end of memory rj =xcmm.gss fetch memory stats sa1 x1+b1 rj =xcod= sa1 endb+2 mx0 42 lx6 18 bx6 x0*x6 bx7 -x0*x1 bx6 x6+x7 sa6 a1 sa4 mema message endb,x4,r eq memstat mema con 1 only line 1 of the display enda con 0 endb data c* kermit running. xxxxxxb cm used.* endc data c* kermit complete. xxxxxxb cm used.* * 1234567890123456789012345678901234567890 endcl equ *-endc title nosetlf - set the list-of-files. nosetlf space 4,10 *** nosetlf - set the list-of-files. * * entry arg1 = fet pointer. * arg2 = fet ordinal. * * exit (ra+arg2) = 42/ file name, 18/ fet address nosetlf subr sb1 1 mx0 42 sa3 x1 bx3 x0*x3 file name only sa4 a1+b1 sa4 x4 file ordinal sx6 x4-3 check if special name pl x6,slf1 if not a special name sa3 slfa+x4 fetch special nos name slf1 sx6 x1 bx6 x6+x3 file name + pointer to fet sa6 x4+b1 set name in lof eq nosetlf slfa bss 0 special list of files filenames vfd 60/0 for *nothing* vfd 42/0linput,18/0 for *stdin* vfd 42/0loutput,18/0 for *stdout* title nosctab - check type-ahead buffer in a nos system. nosctab space 4,10 *** nosctab - check type-ahead buffer in a nos system. * * entry none. * * exit (x6) = 0 = if no characters in the type-ahead buffer. nosctab subr sb1 1 system tlx,r,ctab,1600b *check* type-ahead buffer sa1 ctab bx6 x1 eq nosctab return ctab bssz 1 type-ahead present flag title noswait - wait at a control point for 24 milli-seconds. noswait space 4,10 *** noswait - wait at a control point for 24 milli-seconds. * * entry none. noswait subr sb1 1 wait 24 ** current nos 2.2 system default ** eq noswait end *endif *if def,ovcap subroutine kermain *endif *if -def,ovcap program kermit *endif ccc kermit - a cyber file transfer program using the kermit protocol c c this program may not be sold for profit. c c modifications: c c 2.2 8/22/84 ric anderson, university of arizona at tuscon c add update ifdefs for character set, operating system, and site c selection. fix execmd to work under nos/be. fix cfe for use c under nos/be. correct spelling errors. c c 2.1 8/16/84 bill russell, new york university c added nos 2.2 support (up through level 602). add c timeout during reads (nos 2.2 level 602 or above only). c problems with the nos version should be directed to: c c bill russell c new york university c courant institute of mathematical sciences c 251 mercer street c ny, ny 10012 c c arpa: russell@nyu.arpa c uucp: ...!allegra!cmcl2!russell c c 2.0 4/17/84 jim knutson, university of texas at austin c fix filename packet to send uppercase file names only. c cleanup error packet handling (added to state table handlers). c fix retry counts to use proper number. modify character tables. c merge ric anderson's nos/be code. try to organize the c source a little better. added push and ! commands. c add read delay for performance tuning. changed nel back to c 205b. the binary data-mode ignores nel though. c ut2d requires the nel be a 205b. changed character tables c to use octal constants for non-representable characters. c c 1.1 01/21/84 ric anderson, university of arizona at tuscon c add ovcaps for installation in nucleus. add display code c support. remove gobs and gobs of field length. changed c nel to 4012b to avoid confusion with data byte. updated c character tables for 63 and 64 character sets. changed c percents in fprintfs to at-signs since 63 character set has c no percent sign. c c 1.0 10/14/83 jim knutson, university of texas at austin c original implementation. c c jim knutson c computation center room 1 c univerisity of texas c austin, tx 78712 c c aprpanet address: knutson@ut-ngp c c special thanks to king ables for his contribution. c c modified for nos/be by ric anderson c university of arizona c computer center c tucson, arizona 85721 c c c future enhancements: c 8th bit quoting c repeat counts c wild card sends c conditional code generation for i/o checks c c c build sequence: c build an update oplpl from the source file. c create the compile file, changing the site parameter in the c common deck comcker. also use *defines for ovcaps vs. c segload version and site dependent compass. see c implementation notes. c for the ovcap version: c ftn5,i,opt=2. c ftn5,i,opt=2,b=librel. c libgen,p=kermlib,f=librel. c load,lgo. c nogo,kermit. c for the segload version: c ftn5,i,opt=2. c segload,i=segdef,b=kermit. c load,lgo. c nogo. c load it with the following segload directives: c tree kermit-(set,hlpcmd,execmd,server-(receive,send)) c set include show,status,match,setval c receive include rinit,rfile,rdata c send include sinit,sfile,sdata,seof,sbreak c kermit global proto,packet,debug,message,fileio,fileioc c end kermit c c implementation notes: c c there are now two versions available for kermit. one uses c segload the other uses ovcaps. only the ovcap version may c be installed on the system nucleus (cld for you ut2d fans). c the default version you get from update is for segload. c the ovcap version may be obtained by using the update c directive *define,ovcap. c the following defines have also been setup to select character c set, operating system, and site. nos sites still need to c modify the nosver and noslvl parameter in deck comcker. c c *define cset (63cset, 641cset, 642cset) c *define opsys (ut2d, nos, nosbe, scope) c *define site (utexas, uariz, other) c c this version of kermit should be portable to other cdc sites c except for the above mentioned conditional updates and the c following cases. c c the delay subroutine uses subroutine rtime to return the system c real time clock (number of jifs since deadstart). nos and c nos/be rtime macros allegedly return slightly different c formats of data, so nos sites may need to modify delay(). c c the server knows how to logout on ut2d and nos/be sites. c ut2d uses a local funtion called bellc to perform this. nos/be c and nos sites use a function to essentially pcc a logout c control command. for nos sites, only those running level c 596 or above may logout. see subroutine logout(). c c the ascii i/o is also probably not portable since c cdc does not really support ascii i/o yet. c ascii i/o on ut2d (univ. of texas op. sys.) is done by c setting bit 2**43 in fet+1. the ascii character set that c is used is "8 in 12". this is 8 bits of an ascii character c stored in a 12 bit byte. nulls are represented as 4000b, c and the newline character (nel) is 205b. this is slightly c different from the cdc end-of-line which is 0000b in the c low order byte of the word. currently, 0000b bytes are ignored c since nulls are guarded. c c the display code character mappings for ut2d are different c than the 64 and 63 character set (sigh). these should c already be taken care of in the conditional compilation. c c sites that modify kermit to run on their system should c modify the appropriate parameter definition to allow c conditional compilation for their site. try to be c as general as you can when making mods. c c ****** above all send your mods back to ut ******* c c kermit i/o considerations: c c kermit uses two modes of i/o. it does coded i/o when reading c from the terminal to get commands. this causes the front c end to map the cr/lf pair into a single nel character. c normal cyber sites will have the nel character added for c them by the subroutine findeol. c command editing (backspace and cancel) and parity is taken c careof by the front-end. binary i/o is used when reading c and sending packets. this allows kermit to control the c parity bit. other nos sites may have to set transparent mode c to do this. binary i/o also causes no command editing to be c done (backspaces are treated as regular ascii characters) and c cr/lf is not mapped to nel. rawmode is a mode internal c to kermit that causes no cr/lf <-> nel mapping. c c kermit opens two files (stdin and stdout) and connects c them to the terminal for doing the ascii i/o. this was c done to prevent problems with trying to buffer reads and c writes to the same file. when reading/writing disk files, c kermit will try to buffer 2 disk sectors (128 words) worth c of data per read/write. this was changed from the 8 disk c sectors (512 words) since this reduced wasted space for c the terminal files and helped reduce field length. c all i/o is done through interface routines to the compass c i/o macros. c c the only implementation dependent i/o routines should be c the compass i/o interface routines, stty() and perhaps c the rtime() subroutine. c see these routines for more info on what they do. c c subroutine ordering: c main program and initialization c kermit c blkdat. c exitpgm c abtp c kermit command subroutines c execmd c hlpcmd c rcvfile c sndfile c set c show c status c server c c kermlib routines: c c dmodcmd c dbugcmd c setpack c dplxcmd c parcmd c command parsing subroutines c match c outtbl c setval c confirm c server subroutines c logout c kermit receive state protocol subroutines c receive c rinit c rfile c rdata c kermit send state protocol subroutines c send c sinit c sfile c sdata c seof c sbreak c packet i/o subroutines c sndpack c rdpack c buffill c bufemp c standard i/o subroutines c fopen c fclose c fflush c getc c ungetc c getword c putc c fread c fwrite c putstr c putint c putday c putmnth c fprintf c sprintf c doprnt c stty c gtty c utility subroutines c as2dpc c asc c dpc2as c ctoi c itos c getemsg c creat c getnow c filchk c rdparam c remove c strcpy c slen c sndpar c sleep c delay c nos/be utility modules. c echoplx c getrec c findeol c edl c cfe c getrec c nos utility routines c conbuff c *call kermcom logical cfe external exitpgm parameter (tsize=11) character*10 cmd(tsize) data cmd / 'exit', 'help', 'push', 'quit', 'receive', 'send', + 'server', 'set', 'show', 'status', '!' / c c insure we are an interactive job. c c$ if (nosbe .eq. 1) then call xgjo(ipriv,iorig) if(iorig .ne. 3) then call remark(' kermit - incorrect job origin.') call abtp("nd,s") endif c$ endif c$ if (ut2d .eq. 1) call jobinfo(11,iorig) if ((iorig.and.4) .ne. 4) then call remark(' kermit - incorrect job origin.') call abtp("nd,s") endif c$ endif c c if running from a system library, set infinite cpu c time limit for this job step. c c$ if (nosbe .eq. 1) then if(ipriv .eq. -1) call entl(o"77777") c$ endif c c if running under nos - initialize kermit. c c$ if (nos .eq. 1) call nosinit c$ endif c c open the i/o files c if (fopen('stdin',rd) .ne. stdin) then call displa(' cannot open standard input') call abtp("nd") else if (fopen('stdout',wr) .ne. stdout) then call displa(' cannot open standard output') call abtp("nd") endif c c read in environment if needed c if (cfe('zzzzken')) then cfd = fopen('zzzzken',rd) if (cfd .eq. error) then call displa(' cannot open temp file') else call fread(cfd,header,locf(trailer)-locf(header)) call fclose(cfd) endif call retfile('zzzzken') endif c c make sure things get fixed during aborts c c$ if (nos .eq. 1) call recovr(exitpgm,o"277",0) c$ else call recovr(exitpgm,o"77",0) c$ endif c c parse and execute any commands c 5 call fprintf(stdout,'^kermit-170>',0,0,0,0) call fflush(stdout) c$ if (nos .eq. 1) c c if running under nos - issue memory status message. c call writer(fets(0,stdout)) call memstat c$ endif call fflush(stdin) indx = match(cmd,tsize,.true.) if (indx .eq. error .or. indx .eq. 0) go to 5 if (indx .eq. eof) then normal = .true. call exitpgm endif go to (10, 20, 30, 10, 40, 50, 60, 70, 80, 90, 100), indx c c thats all folks c 10 normal = .true. call exitpgm c c give some help c *if def,ovcap 20 call xovcap('kermhlp') call uovcap('kermhlp') *endif *if -def,ovcap 20 call hlpcmd *endif go to 5 c c same as exit and quit but allows you to reenter with c the same environment as before c 30 autoret = no *if def,ovcap call xovcap('kermxcc') call uovcap('kermxcc') *endif *if -def,ovcap call execmd *endif go to 5 c c receive a file c *if def,ovcap 40 call xovcap('kermrcv') call uovcap('kermrcv') *endif *if -def,ovcap 40 call rcvfile *endif go to 5 c c send a file c *if def,ovcap 50 call xovcap('kermsnd') call uovcap('kermsnd') *endif *if -def,ovcap 50 call sndfile *endif go to 5 c c enter server mode c *if def,ovcap 60 call xovcap('kermsrv') call uovcap('kermsrv') *endif *if -def,ovcap 60 call server *endif go to 5 c c set some attributes c *if def,ovcap 70 call xovcap('kermset') call uovcap('kermset') *endif *if -def,ovcap 70 call set *endif go to 5 c c show current settings c *if def,ovcap 80 call xovcap('kermsho') call uovcap('kermsho') *endif *if -def,ovcap 80 call show *endif go to 5 c c give the status of last transfer c *if def,ovcap 90 call xovcap('kermsta') call uovcap('kermsta') *endif *if -def,ovcap 90 call status *endif go to 5 c c exec a control command c 100 autoret = yes *if def,ovcap call xovcap('kermxcc') call uovcap('kermxcc') *endif *if -def,ovcap call execmd *endif go to 5 end block data *call comcker data fmode / maxfile*closed / data fwptr,fnwds / maxfile*0, maxfile*0 / data rawmode, binmode / 2*.false. / data parity, duplex / nopar, fulldup / data dskcset / dskdpc / data normal / .false. / data ifd, ofd / stdin, stdout / data ffd / 0 / data maxrtry, maxrini / maxtry, maxinit / data packnum / 0 / data startim, endtim / 2*0 / data schcnt , rchcnt / 2*0 / data schovrh, rchovrh / 2*0 / data state / c / data delayfp / 5 / data rdelay / 100 / data sync , sndsync / 2*soh / data packsiz, spksiz / 2*maxpack / data timeout, stimout / 2*mytime / data npad , spad / 2*mypad / data padch , spadch / 2*mypadch / data eolch , speol / 2*myeol / data quotech, spquote / 2*myquote / data quote8 , s8quote / 2*quot8ch / data chktyp , schktyp / 2*mycktyp / data rprefix, srepeat / 2*prefxch / data debug , debugfd / dbgoff, 0 / data debugfn / 75, 69, 82, 77, 76, 79, 71, 0 / c k e r m l o g data (errmsg(i),i=1,14) / 63, 75, 101, 114, 109, 105, 116, 45, 49, c ? k e r m i t - 1 + 55, 48, 58, 2*32 / c 7 0 : data version / '^cyber-170 ^k^e^r^m^i^t version 2.2\n' / data ambig / '?^ambiguous - "' / data nomatch / '?^does not match switch or keyword - "' / data follow / '^one of the following:\n' / data nodigit / + '?^invalid, ^first nonspace character is not a digit\n' / data missing / '?^invalid, ^missing parameter\n' / data confmsg / '^confirm with a carriage return\n' / data notconf / '?^not confirmed - "' / data hlpasch / '^decimal, octal (^b), or hexidecimal (^h) code for + ^a^s^c^i^i character \n' / data hlpdlfp / '^number of seconds to delay first packet\n' / data hlpdbfn / '^debug output logfile specification\n' / data hlpplen / '^maximum packet length\n' / data hlppadl / '^number of pad characters to use\n' / data hlpiprc / '^initial packet retry count\n' / data hlpprtr / '^packet retry count\n' / data hlptimo / '^number of seconds to wait before timeout\n' / data hlpsnfn / '^filename to send\n' / data hlprdel / '^milliseconds to delay each ^t^t^y read\n' / c$ if (ut2d .eq. 1) data dpctbl/r" ",31*r" ",r" ",r"!",r"""",o"65",r"$",o"71",r"&", + o"64",r"(",r")",r"*",r"+",r",",r"-",r".",r"/",r"0", + r"1",r"2",r"3",r"4",r"5",r"6",r"7",r"8",r"9", + o"63",r";",r"<",r"=",r">",o"75",r"@", + r"a",r"b",r"c",r"d",r"e",r"f",r"g",r"h",r"i", + r"j",r"k",r"l",r"m",r"n",r"o",r"p",r"q",r"r", + r"s",r"t",r"u",r"v",r"w",r"x",r"y",r"z", + r"[",o"76",r"]",o"70",r" ",r" ", + r"a",r"b",r"c",r"d",r"e",r"f",r"g",r"h",r"i", + r"j",r"k",r"l",r"m",r"n",r"o",r"p",r"q",r"r", + r"s",r"t",r"u",r"v",r"w",r"x",r"y",r"z", + 5*r" "/ data lascii/0,97,98,99,100,101,102,103,104,105,106,107,108,109, c a b c d e f g h i j k l m + 110,111,112,113,114,115,116,117,118,119,120,121,122, c n o p q r s t u v w x y z + 48,49,50,51,52,53,54,55,56,57, c 0 1 2 3 4 5 6 7 8 9 + 43,45,42,47,40,41,36,61,32,44,46,34,91,93,58, c + - * / ( ) $ = , . " [ ] : + 39,35,33,38,94,37,60,62,64,63,92,59/ c ' # ! & ^ < > @ ? \ ; data uascii/0,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81, c a b c d e f g h i j k l m n o p q + 82,83,84,85,86,87,88,89,90,48,49,50,51,52,53,54,55, c r s t u v w x y z 0 1 2 3 4 5 6 7 + 56,57,43,45,42,47,40,41,36,61,32,44,46,34,91,93,58, c 8 9 + - * / ( ) $ = , . " [ ] : + 39,35,33,38,94,37,60,62,64,63,92,59/ c ' # ! & ^ < > @ ? \ ; c$ else c$ if(ipcset .eq. ipc63) data dpctbl/r" ",31*r" ",r" ",r"!",r"""",o"60",r"$",r" ",r"&", + o"70",r"(",r")",r"*",r"+",r",",r"-",r".",r"/",r"0", + r"1",r"2",r"3",r"4",r"5",r"6",r"7",r"8",r"9", + o"63",r";",r"<",r"=",r">",o"71",r"@", + r"a",r"b",r"c",r"d",r"e",r"f",r"g",r"h",r"i", + r"j",r"k",r"l",r"m",r"n",r"o",r"p",r"q",r"r", + r"s",r"t",r"u",r"v",r"w",r"x",r"y",r"z", + r"[",o"75",r"]",o"76",o"65",r"@", + r"a",r"b",r"c",r"d",r"e",r"f",r"g",r"h",r"i", + r"j",r"k",r"l",r"m",r"n",r"o",r"p",r"q",r"r", + r"s",r"t",r"u",r"v",r"w",r"x",r"y",r"z", + r"[",r"\",r"]",r"^",r" "/ data lascii/32,97,98,99,100,101,102,103,104,105,106,107,108,109, c a b c d e f g h i j k l m + 110,111,112,113,114,115,116,117,118,119,120,121,122, c n o p q r s t u v w x y z + 48,49,50,51,52,53,54,55,56,57, c 0 1 2 3 4 5 6 7 8 9 + 43,45,42,47,40,41,36,61,32,44,46,35,91,93,58, c + - * / ( ) $ = , . % [ ] : + 34,95,33,38,39,63,60,62,64,92,94,59/ c " # ! & ' ? < > @ \ ^ ; data uascii/32,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80, c a b c d e f g h i j k l m n o p + 81,82,83,84,85,86,87,88,89,90,48,49,50,51,52,53,54, c q r s t u v w x y z 0 1 2 3 4 5 6 + 55,56,57,43,45,42,47,40,41,36,61,32,44,46,35,91,93, c 7 8 9 + - * / ( ) $ = , . % [ ] + 58,34,95,33,38,39,63,60,62,64,92,94,59/ c : " # ! & ' ? < > @ \ ^ ; c$ else data dpctbl/r" ",31*r" ",r" ",r"!",r"""",o"60",r"$",o"63",r"&", + o"70",r"(",r")",r"*",r"+",r",",r"-",r".",r"/",r"0", + r"1",r"2",r"3",r"4",r"5",r"6",r"7",r"8",r"9", + o"0",r";",r"<",r"=",r">",o"71",r"@", + r"a",r"b",r"c",r"d",r"e",r"f",r"g",r"h",r"i", + r"j",r"k",r"l",r"m",r"n",r"o",r"p",r"q",r"r", + r"s",r"t",r"u",r"v",r"w",r"x",r"y",r"z", + r"[",o"75",r"]",o"76",o"65",r"@", + r"a",r"b",r"c",r"d",r"e",r"f",r"g",r"h",r"i", + r"j",r"k",r"l",r"m",r"n",r"o",r"p",r"q",r"r", + r"s",r"t",r"u",r"v",r"w",r"x",r"y",r"z", + r"[",r"\",r"]",r"^",r" "/ data lascii/58,97,98,99,100,101,102,103,104,105,106,107,108,109, c : a b c d e f g h i j k l m + 110,111,112,113,114,115,116,117,118,119,120,121,122, c n o p q r s t u v w x y z + 48,49,50,51,52,53,54,55,56,57, c 0 1 2 3 4 5 6 7 8 9 + 43,45,42,47,40,41,36,61,32,44,46,35,91,93,37, c + - * / ( ) $ = , . % [ ] + 34,95,33,38,39,63,60,62,64,92,94,59/ c " # ! & ' ? < > @ \ ^ ; data uascii/58,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80, c : a b c d e f g h i j k l m n o p + 81,82,83,84,85,86,87,88,89,90,48,49,50,51,52,53,54, c q r s t u v w x y z 0 1 2 3 4 5 6 + 55,56,57,43,45,42,47,40,41,36,61,32,44,46,35,91,93, c 7 8 9 + - * / ( ) $ = , . % [ ] + 37,34,95,33,38,39,63,60,62,64,92,94,59/ c " # ! & ' ? < > @ \ ^ ; c$ endif c$ endif end subroutine exitpgm ccc exitpgm - exit the program c *call kermcom c c set complete bit in all fets, in case we died in mid-cio call. c if(.not. normal) then call remark (' kermit aborted.') do 10 i = 1, maxfile fets(0,i) = or(fets(0,i),1) 10 continue endif call fflush(stdout) call stty('raw',off) call stty('binary',off) if (savedpx .ne. halfdup) call stty('duplex',fulldup) call fclose(stdin) call fclose(stdout) if (debugfd.ne.0) call fclose(debugfd) c c if running under nos - issue memory status message. c c$ if (nos .eq. 1) call nosexit c$ else call endrun c$ endif end subroutine abtp(type) cc abtp - abort program. c c this subroutine should not return. c *call kermcom boolean type c$ if (ut2d .eq. 1) then call abort c$ else call abort(type) c$ endif return end *if def,ovcap ident kermxcc entry kermxcc lcc ovcap. ldset noept=unlfile kermxcc title kermxcc - kermit execute control command processor. comment kermxcc - kermit execute control command processor. kermxcc space 4,10 ** kermxcc - kermit execute control command processor. * kermxcc subr entry/exit rj =xexecmd call the real workhorse eq kermxccx return end *endif subroutine execmd ccc execmd - execute a control command c c execute a control command and return to command mode or c exit to the operating system. next execution of kermit c will return with current environment. this subroutine c does not return. c *call kermcom logical confirm, eatline c$ if (nos .eq. 1) c c if running under nos - issue memory status message. c call memstat c$ endif c c before we do anything rash c if (autoret .eq. no) then if (.not. confirm(stdin)) return endif c c write out the current environment c call retfile('zzzzken') cfd = fopen('zzzzken',wr) if (cfd .eq. error) then call remark(' cannot create environment file.') return endif call fwrite(cfd,header,locf(trailer)-locf(header)) call fclose(cfd) c c if only exit to the operating system c if (autoret .eq. no) then normal = .true. call exitpgm endif c c write the control command file c dskcset = dskdpc call retfile('zzzzkcc') fd = fopen('zzzzkcc',create) if (fd .eq. error) then call remark(' cannot create ccl file.') fd = closed return endif c$ if (nos .eq. 1 .or. nosbe .eq. 1) call fprintf(fd, '.proc,zzzzkcc.\n',0,0,0,0) c$ endif c c copy command to command file c eatline = .false. 10 if (getc(stdin,ch) .eq. blank) then go to 10 else if (ch .eq. qmark) then eatline = .true. call fprintf(stdout,'^monitor command to execute\n',0,0,0,0) c$ if (nos .eq. 1) call fflush(stdout) call writer(fets(0,stdout)) c$ endif else call putc(ch,fd) endif endif 20 ch = getc(stdin,ch) if (.not. eatline) call putc(ch,fd) if (ch .ne. nel) go to 20 c c copy cleanup commands to command file c c$ if (nosbe .eq. 1) then call fprintf(fd,'skip(ok)\nexit(s)\nendif(ok)\n' // + 'return(zzzzkcc)\nkermit.\n',0,0,0,0) c$ endif c$ if (ut2d .eq. 1) call fprintf(fd,'.skipcc\n.exit\n.return zzzzkcc\n.kermit\n', + 0,0,0,0) c$ endif c$ if (nos .eq. 1) call fprintf(fd, 'return(zzzzkcc)\nrevert,ex.kermit.\n', + 0,0,0,0) call fprintf(fd, 'exit.\nreturn(zzzzkcc)\nrevert,ex.kermit.\n', + 0,0,0,0) c$ endif call fclose(fd) c c execute the command file c c$ if (nosbe .eq. 1) then call excst('begin,,zzzzkcc.') c$ endif c$ if (ut2d .eq. 1) call excst('.cntrl,zzzzkcc') c$ endif c$ if (nos .eq. 1) call excst('zzzzkcc.') c$ endif end *if def,ovcap ident kermhlp entry kermhlp lcc ovcap. ldset noept=unlfile kermhlp title kermhlp - kermit help command processor. comment kermit help command processor. kermhlp space 4,10 ** kermhlp - kermit help command processor. kermhlp subr entry/exit rj =xhlpcmd call the real workhorse eq kermhlpx return end *endif subroutine hlpcmd ccc hlpcmd - process the help command. c *call kermcom parameter (tsize=12) character*10 hlptyp(tsize) logical confirm data hlptyp / 'exit', 'help', 'kermit', 'push', 'quit', 'receive', + 'send', 'server', 'set', 'show', 'status', '!' / c$ if (nos .eq. 1) c c if running under nos - issue memory status message. c call memstat c$ endif indx = match(hlptyp,tsize,.true.) if (indx .eq. eof .or. indx .eq. error) return if (indx .eq. 0) go to 30 if (.not. confirm(stdin)) return go to (10, 20, 30, 40, 10, 50, 60, 70, 80, 90, 100, 110), indx c c help exit c 10 call fprintf(stdout,'^exit from ^kermit-170\n') return c c help help c 20 call fprintf(stdout,'\n^h^e^l^p [topic]\n\n^typing ^h^e^l^p alone +prints a brief summary of ^kermit-170 and its commands.\n^you can +also type\n\n ^h^e^l^p command\n\nfor any ^kermit-170 command, e +.g. "help send", to get more detailed information\nabout a specifi +c command. ^type\n\n ^h^e^l^p ?\n\nto see a list of all the ava +ilable help commands, or consult the ^kermit ^users\n^guide.\n\n') return c c help kermit c 30 call fprintf(stdout,'\n^kermit is a file transfer protocol for use + over an asynchronous serial\ntelecommunication line. ^files are +broken up into "packets" with checksums and\nother control informa +tion to ensure (with high probability) error-free and\ncomplete tr +ansmission.\n\n^kermit-170 is the implementation for the ^cyber 17 +0/730 and is\nrun "remotely" from another computer (e.g. a microco +mputer).\n\n^you can run ^kermit interactively by typing repeated +commands in response to\nits "^kermit-170>" prompt, or you can run + it as a remote server.\n\n^kermit-170 command summary -- optional + parts are in [brackets]:\n\n') call fprintf(stdout,'* ^for exchanging files: ^s^e^n^d fil +e\n') call fprintf(stdout,' ^r^e^c^e^i^v^ +e\n\n') call fprintf(stdout,'* ^for acting as a server: ^s^e^r^v^e^r +\n\n') call fprintf(stdout,'* ^setting nonstandard transmission and file +parameters:\n ^s^e^t ^d^e^b^u^g, ^d^e^l^a^y, ^d^u^p^l^e^x, +^p^a^r^i^t^y, ^i^n^i^t-^r^e^t^r^y, ^r^e^t^r^y\n') call fprintf(stdout,' ^s^e^t ^s^e^n^d (or ^r^e^c^e^i^v^e) ^ +end-of-^line, ^packet-length, ^pad-^character,\n ^p +ad-^length, ^quote-^character, ^sync-^character, ^time-^out\n') call fprintf(stdout,'* ^getting information: ^h^e^l^p [to +pic], ^s^t^a^t^u^s, ^s^h^o^w\n\n') call fprintf(stdout,'* ^leaving the program: ^e^x^i^t, ^q +^u^i^t\n\n') call fprintf(stdout,'^for further information, type "help" for any + of the above, e.g. "help set",\nor see the "^kermit ^users ^guide +" and the "^kermit ^protocol ^manual" for complete\ndetails.\n\n') return c c help push c 40 call fprintf(stdout,'\n^p^u^s^h\n\n^exit from ^kermit-170 saving t +he current environment. ^the environment will be\nrestored upon r +eentering ^kermit-170.\n') return c c help receive c 50 call fprintf(stdout,'\n^r^e^c^e^i^v^e\n\n^receive a file or group +of files from the other host. ^if the name in the\n') call fprintf(stdout,'header packet is not a legal ^cyber file name +, the first 7 legal characters\n') call fprintf(stdout,'will be used.\n\n^if the file already exits a +s a local file, ^kermit will abort the transfer.\n') call fprintf(stdout,'^if an error occurs during transfer, the file + being received will be\nremoved from the local file list to allow + the transfer to be retried.\n') call fprintf(stdout,'^you should escape back to your local ^kermit + after entering ^r^e^c^e^i^v^e\nmode and give the ^s^e^n^d command +.\n\n') return c c help send c 60 call fprintf(stdout,'\n^s^e^n^d filename\n\n') call fprintf(stdout,'^send a file to the other host. ^the name of + the file is passed\nto the other host in a file header packet, so + that the file can be\nstored there with the same name.\n\n') call fprintf(stdout,'^you should escape back to your local ^kermit + and give the ^r^e^c^e^i^v^e\ncommand. ^if you don''t do this fas +t enough the "send-init" packet may\narrive prematurely. ^to prev +ent this, use ^s^e^t ^d^e^l^a^y or hit the ^r^e^t^u^r^n key\non yo +ur microcomputer if it does not timeout.\n\n') return c c help server c 70 call fprintf(stdout,'\n^s^e^r^v^e^r\n\n') c$ if(ut2d .eq. 1) call fprintf(stdout,'^act as a server for another ^kermit. ^take +all further commands only from\nthe other ^kermit. ^after issuing + this command, escape back to your local\nsystem and issue ^s^e^n^ +d, ^r^e^c^e^i^v^e or ^g^e^t, ^b^y^e, or other server-oriented\ncom +mands from there. ^if your local ^kermit does not have a ^b^y^e c +ommand,\nit does not have the full ability to communicate with a ^ +kermit server (in\nwhich case you can only use the ^s^e^n^d comman +d). ^if your local ^kermit\ndoes have a ^b^y^e command, use it to + shut down and log out the ^kermit\nserver when you are done with +it; otherwise, connect back to the ^cyber, type\nseveral ^control- +^c''s to stop the server, and logout.\n\n') c$ else c$ if(nosbe .eq. 1 .or. scope .eq. 1) call fprintf(stdout,'^act as a server for another ^kermit. ^take +all further commands only from\nthe other ^kermit. ^after issuing + this command, escape back to your local\nsystem and issue ^s^e^n^ +d, ^r^e^c^e^i^v^e or ^g^e^t, ^b^y^e, or other server-oriented\ncom +mands from there. ^if your local ^kermit does not have a ^b^y^e c +ommand,\nit does not have the full ability to communicate with a ^ +kermit server (in\nwhich case you can only use the ^s^e^n^d comman +d). ^if your local ^kermit\ndoes have a ^b^y^e command, use it to + shut down and log out the ^kermit\nserver when you are done with +it; otherwise, connect back to the ^cyber, type\nseveral ^percent- +^a''s to stop the server, and logout.\n\n') c$ else call fprintf(stdout,'^act as a server for another ^kermit. ^take +all further commands only from\nthe other ^kermit. ^after issuing + this command, escape back to your local\nsystem and issue ^s^e^n^ +d, ^r^e^c^e^i^v^e or ^g^e^t, ^b^y^e, or other server-oriented\ncom +mands from there. ^if your local ^kermit does not have a ^b^y^e c +ommand,\nit does not have the full ability to communicate with a ^ +kermit server (in\nwhich case you can only use the ^s^e^n^d comman +d). ^if your local ^kermit\ndoes have a ^b^y^e command, use it to + shut down and log out the ^kermit\nserver when you are done with +it; otherwise, connect back to the ^cyber, type\nseveral ^control- +^t''s to stop the server, and logout.\n\n') c$ endif c$ endif return c c help set c 80 call fprintf(stdout,'\n^s^e^t\n') call fprintf(stdout,' ^establish system-dependent parameters. ^y +ou can examine their values with the\n ^s^h^o^w command. ^numeri +c values may be decimal, octal (postfixed with a ^b),\n or hexade +cimal (postfixed by an ^h). ^the following may be ^s^e^t:\n\n') call fprintf(stdout,' ^d^a^t^a-^m^o^d^e keyword\n') call fprintf(stdout,' ^declares the data mode to be used while p +rocessing disk files. ^the choices\n are ^a^s^c^i^i, ^d^i^s^p^l +^a^y, and ^image-^a^s^c^i^i. ^a^s^c^i^i means the disk file conta +ins\n ^a^s^c^i^i data, ^d^i^s^p^l^a^y means the file contains ^d +isplay ^code data, and ^image-\n ^a^s^c^i^i means the file conta +ins 8-bit ^a^s^c^i^i data. ^the default is ^d^i^s^p^l^a^y.\n\n') call fprintf(stdout,' ^d^e^b^u^g options\n ^show packet traffic +explicitly. ^options are:\n') call fprintf(stdout,' ^a^l^l ^set all debug options.\n') call fprintf(stdout,' ^l^o^g-^f^i^l^e ^log states and packets to + the specified file. ^the default\n log-file is file ^ +k^e^r^m^l^o^g.\n') call fprintf(stdout,' ^o^f^f ^don''t display debugging info +rmation (this is the default). ^if\n debugging was in +effect, turn it off and close any log file.\n') call fprintf(stdout,' ^p^a^c^k^e^t^s ^display each incoming and + outgoing packet (lengthy).\n') call fprintf(stdout,' ^s^t^a^t^e^s ^show kermit state transiti +ons and packet numbers (brief).\n\n') call fprintf(stdout,' ^d^e^l^a^y decimal-number\n') call fprintf(stdout,' ^how many seconds to wait before sending t +he first packet. ^this gives you\n time to "escape" back and is +sue a ^r^e^c^e^i^v^e command.\n\n') call fprintf(stdout,' ^d^u^p^l^e^x keyword\n') call fprintf(stdout,' ^changes the method of echoing characters +when being prompted for commands.\n ^the choices are ^f^u^l^l an +d ^h^a^l^f. ^full means the ^cyber will echo the\n characters y +ou type. ^half means the local systems echos them. ^full is\n +the default, and is used by most hosts.\n\n') call fprintf(stdout,' ^i^n^i^t-^r^e^t^r^y decimal-number\n') call fprintf(stdout,' ^set the maximum number of retries allowed + for the initial connection\n before giving up.\n\n') call fprintf(stdout,' ^p^a^r^i^t^y keyword\n') call fprintf(stdout,' ^if the other computer is using parity on +the communication line, you must\n inform ^kermit-170, so it can + send the desired parity on outgoing characters,\n and strip it +from incoming ones.\n') call fprintf(stdout,'\n ^this must be set in ^kermit and the fro +nt-end. ^see a system manual for\n setting parity in the front- +end.\n') call fprintf(stdout,'\n ^choices are ^n^o^n^e (the default), ^e^ +v^e^n, ^o^d^d, ^m^a^r^k, and ^s^p^a^c^e.\n ^n^o^n^e means no par +ity processing is done, and the 8th bit of each character\n can +be used for data when transmitting binary files.\n\n') call fprintf(stdout,' ^r^d^e^l^a^y decimal-number\n') call fprintf(stdout,' ^set the number of milliseconds of delay b +efore issuing a read to the\n terminal. ^this may be used to tu +ne reads so that data is ready\n when the read function is issue +d and swapping does not take place.\n\n') call fprintf(stdout,' ^r^e^t^r^y decimal-number\n') call fprintf(stdout,' ^set the maximum number of retries allowed + for sending a particular packet.\n\n') call fprintf(stdout,' ^s^e^n^d parameter\n ^parameters for outgo +ing packets as follows:\n\n') call fprintf(stdout,' ^end-of-^line octal-number\n') call fprintf(stdout,' ^the octal value of the ^a^s^c^i^i chara +cter to be used as a line terminator\n for packets, if one is +required by the other system. ^carriage\n return (15^b) by de +fault.\n\n') call fprintf(stdout,' ^packet-^length decimal-number\n') call fprintf(stdout,' ^maximum packet length to send, decimal +number, between 20 and 94,\n 94 by default.\n\n') call fprintf(stdout,' ^pad-^character octal-number\n') call fprintf(stdout,' ^character to use for padding. ^default + is ^n^u^l.\n\n') call fprintf(stdout,' ^pad-^length decimal-number\n') call fprintf(stdout,' ^how much padding to send before a packe +t. ^default is no padding.\n\n') call fprintf(stdout,' ^quote-^character octal-number\n') call fprintf(stdout,' ^what printable character to use for quo +ting of control characters.\n ^the default is "#" (43^b). ^th +ere should be no reason to change this.\n\n') call fprintf(stdout,' ^sync-^character octal-number\n') call fprintf(stdout,' ^the control character that marks the be +ginning of the packet. ^normally\n ^s^o^h (^control-^a, ^a^s^ +c^i^i 1). ^there should be no reason to change this.\n\n') call fprintf(stdout,' ^time-^out decimal-number\n') call fprintf(stdout,' ^how many seconds the other ^kermit want +s before being asked\n for retransmission. ^unfortunately, th +e ^cyber has no way of timing\n out so this parameter is ignor +ed.\n\n') call fprintf(stdout,' ^r^e^c^e^i^v^e parameter\n ^parameters to +request or expect for incoming packets, as follows:\n\n') call fprintf(stdout,' ^end-of-^line octal-number\n') call fprintf(stdout,' ^the octal value of the ^a^s^c^i^i chara +cter to be used as a line terminator\n for packets, if one is +required by the other system. ^carriage\n return (15^b) by de +fault.\n\n') call fprintf(stdout,' ^packet-^length decimal-number\n') call fprintf(stdout,' ^maximum packet length to send, decimal +number, between 20 and 94,\n 94 by default.\n\n') call fprintf(stdout,' ^pad-^character octal-number\n') call fprintf(stdout,' ^character to use for padding. ^default + is ^n^u^l.\n\n') call fprintf(stdout,' ^pad-^length decimal-number\n') call fprintf(stdout,' ^how much padding to send before a packe +t. ^default is no padding.\n\n') call fprintf(stdout,' ^quote-^character octal-number\n') call fprintf(stdout,' ^what printable character to use for quo +ting of control characters.\n ^the default is "#" (43^b). the +re should be no reason to change this.\n\n') call fprintf(stdout,' ^sync-^character octal-number\n') call fprintf(stdout,' ^the control character that marks the be +ginning of the packet. ^normally\n ^s^o^h (^control-^a, ^a^s^ +c^i^i 1). ^there should be no reason to change this.\n\n') call fprintf(stdout,' ^time-^out decimal-number\n') call fprintf(stdout,' ^how many seconds the other ^kermit shou +ld wait for a packet before\n asking for retransmission.\n\n') return c c help show c 90 call fprintf(stdout,'^display current ^s^e^t parameters, version o +f ^kermit-170, and other info.\n') return c c help status c 100 call fprintf(stdout,'^give statistics about the most recent file t +ransfer.\n') return c c help ! c 110 call fprintf(stdout,'\n! ^monitor-^command\n\n^execute a monitor c +ommand from within ^kermit-170. ^the current settings\nwill be pr +eserved.\n') c$ if (nos .eq. 1) call fprintf(stdout,'\n^note: ^the command must be formmated corre +ctly with a ^n^o^s terminator [. or )].\n') c$ endif return end *if def,ovcap ident kermrcv entry kermrcv lcc ovcap. ldset noept=unlfile kermrcv title kermrcv - kermit receive file processor. comment kermit receive file processor. kermrcv space 4,10 ** kermrcv - kermit receive file processor. kermrcv subr entry/exit rj =xrcvfile call the real workhorse eq kermrcvx return end *endif subroutine rcvfile ccc rcvfile - top level subroutine to start receive state. c *call kermcom logical confirm c$ if (nos .eq. 1) c c if running under nos - issue memory status message. c call memstat c$ endif c c confirm the command c if (.not. confirm(stdin)) return c c insure their is no junk in the file array. this keeps remove c happy, in the event we blow off before we get a file spec. c do 10 i = 1, maxpack filestr(i) = 0 10 continue call stty('binary',on) if(dskcset .eq. dskimag) call stty('raw',on) savedpx = gtty('duplex') call stty('duplex',halfdup) if (receive(r) .eq. ok) then call fprintf(stdout,'^receive complete.\n',0,0,0,0) else call fprintf(stdout,'^receive failed.\n',0,0,0,0) endif if(dskcset .eq. dskimag) call stty('raw',off) call stty('binary',off) if (savedpx .ne. halfdup) call stty('duplex',fulldup) return end *if def,ovcap ident kermsnd entry kermsnd lcc ovcap. ldset noept=unlfile kermsnd title kermsnd - kermit send file processor. comment kermit send file processor. kermsnd space 4,10 ** kermsnd - kermit send file processor. kermsnd subr entry/exit rj =xsndfile call the real workhorse eq kermsndx return end *endif subroutine sndfile ccc sndfile - send a file to other kermit. c *call kermcom logical cfe character*10 lfn c$ if (nos .eq. 1) c c if running under nos - issue memory status message. c call memstat c$ endif c c pick up the file name and save it for opening later c call setval(filestr,'s',iret,7,0,0,hlpsnfn,.true.) if (iret .eq. error) return c c make sure the name is legal. c call as2dpc(filestr,lfn) if (xvfn(lfn) .ne. 0) then call fprintf(stdout,'?^illegal file name: @s.\n',filestr,0,0,0) return endif c c map it to upper-case c call dpc2as(lfn,filestr,slen(filestr)) c c check to make sure it's there to send c if (.not. cfe(lfn)) then call fprintf(stdout,'?^file @s is not local.\n',filestr,0,0,0) return endif c c delay the first packet c if (delayfp .gt. 0) call sleep(delayfp) call stty('binary',on) if(dskcset .eq. dskimag) call stty('raw',on) savedpx = gtty('duplex') call stty('duplex',halfdup) c c start sending packets c packnum = 0 if (send() .eq. ok) then call fprintf(stdout,'^send complete.\n',0,0,0,0) else call fprintf(stdout,'^send failed.\n',0,0,0,0) endif if(dskcset .eq. dskimag) call stty('raw',off) call stty('binary',off) if (savedpx .ne. halfdup) call stty('duplex',fulldup) return end *if def,ovcap ident kermset entry kermset lcc ovcap. ldset noept=unlfile kermset title kermset - kermit set command processor. comment kermit set command processor. kermset space 4,10 ** kermset - kermit set command processor. kermset subr entry/exit rj =xset call the real workhorse eq kermsetx return end *endif subroutine set ccc set - set some attributes. c *call kermcom parameter (tsize=10) character*10 settyp(tsize) data settyp / 'data-mode', 'debug', 'delay', 'duplex', + 'init-retry', 'parity', 'receive', 'rdelay', + 'retry', 'send' / c$ if (nos .eq. 1) c c if running under nos - issue memory status message. c call memstat c$ endif indx = match(settyp,tsize,.false.) if (indx .le. 0) return go to (10, 20, 30, 40, 50, 60, 70, 75, 80, 90), indx c c set character set c 10 call dmodcmd return c c set debugging modes c 20 call dbugcmd return c c set first packet delay c 30 call setval(delayfp,'i',0,30,0,30,hlpdlfp,.true.) return c c set the duplex c 40 call dplxcmd return c c set intial packet retry count c 50 call setval(maxrini,'i',1,50,1,50,hlpiprc,.true.) return c c set parity c 60 call parcmd return c c set receive packet attributes c 70 call setpack(packsiz) return c c set read data delay c 75 call setval(rdelay,'i',0,2000,0,2000,hlprdel,.true.) return c c set packet retry count c 80 call setval(maxrtry,'i',1,50,1,50,hlpprtr,.true.) return c c set send packet attributes c 90 call setpack(spksiz) return end *if def,ovcap ident kermsho entry kermsho lcc ovcap. ldset noept=unlfile kermsho title kermsho - kermit show command processor. comment kermit show command processor. kermsho space 4,10 ** kermsho - kermit show command processor. kermsho subr entry/exit rj =xshow call the real workhorse eq kermshox return end *endif subroutine show ccc show the current program settings c *call kermcom logical confirm c$ if (nos .eq. 1) c c if running under nos - issue memory status message. c call memstat c$ endif c c confirm the command c if (.not. confirm(stdin)) return call fprintf(stdout,version,0,0,0,0) c$ if (nos .eq. 1) call fprintf(stdout,'^n^o^s ^version @d.@d - ^level @d ', + nosver/10, (nosver-((nosver/10)*10)), noslvl, 0, 0) c$ endif c c display the current date and time c call getnow(mm,dd,yy,hr,min,sec) call putday(stdout,mm,dd,yy) call fprintf(stdout,', ',0,0,0,0) call putmnth(stdout,mm) call fprintf(stdout,' @d, @d ',dd,yy,0,0) if (hr .lt. 10) call putc(asc('0'),stdout) call fprintf(stdout,'@d:',hr,0,0,0) if (min .lt. 10) call putc(asc('0'),stdout) call fprintf(stdout,'@d:',min,0,0,0) if (sec .lt. 10) call putc(asc('0'),stdout) call fprintf(stdout,'@d\n\n',sec,0,0,0) c c display disk character set c call fprintf(stdout,' ^data-mode: ',0,0,0,0) if(dskcset .eq. dsknos8) then call fprintf(stdout,'^n^o^s 812 ^a^s^c^i^i\n',0,0,0,0) elseif(dskcset .eq. dskut8) then call fprintf(stdout,'^u^t 812 ^a^s^c^i^i\n',0,0,0,0) elseif(dskcset .eq. dskdpc) then call fprintf(stdout,'^display-^code\n',0,0,0,0) elseif(dskcset .eq. dskimag) then call fprintf(stdout,'^image-^a^s^c^i^i\n',0,0,0,0) else call fprintf(stdout,'^unknown',0,0,0,0) endif c c display known parity c call fprintf(stdout,' ^parity: ',0,0,0,0) parity = gtty('parity') if (parity .eq. none) then call fprintf(stdout,'^none\n',0,0,0,0) else if (parity .eq. even) then call fprintf(stdout,'^even\n',0,0,0,0) else if (parity .eq. odd) then call fprintf(stdout,'^odd\n',0,0,0,0) else if (parity .eq. mark) then call fprintf(stdout,'^mark\n',0,0,0,0) else if (parity .eq. space) then call fprintf(stdout,'^space\n',0,0,0,0) else call fprintf(stdout,'^unknown\n',0,0,0,0) endif c c display the current duplex c call fprintf(stdout,' ^duplex: ',0,0,0,0) duplex = gtty('duplex') if (duplex .eq. fulldup) then call fprintf(stdout,'^full\n',0,0,0,0) else if (duplex .eq. halfdup) then call fprintf(stdout,'^half\n',0,0,0,0) else call fprintf(stdout,'^unknown\n',0,0,0,0) endif c c display current debug modes c call fprintf(stdout,' ^debugging: ',0,0,0,0) if ((debug.and.dbgstat).ne.0) call fprintf(stdout,'^states ', + 0,0,0,0) if ((debug.and.dbgpack).ne.0) call fprintf(stdout,'^packets', + 0,0,0,0) if (debug.eq.dbgoff) call fprintf(stdout,'^off',0,0,0,0) call putc(nel,stdout) if (debug .ne. dbgoff) then call fprintf(stdout,' ^log file: @s\n',debugfn,0,0,0) endif c c display packet settings c call fprintf(stdout,'\n^packet ^parameters\n',0,0,0,0) call fprintf(stdout, + ' ^receive ^send\n',0,0,0,0) call fprintf(stdout,' ^size: @d @d\n', + packsiz,spksiz,0,0) call fprintf(stdout,' ^timeout: @d @d\n', + timeout,stimout,0,0) call fprintf(stdout,' ^padding: @d',npad,0,0,0) if (npad .lt. 10) call putc(blank,stdout) call fprintf(stdout,' @d\n',spad,0,0,0) call fprintf(stdout,' ^pad character: \^@c \^@c\n', + o"100".xor.(padch),o"100".xor.(spadch),0,0) call fprintf(stdout,' ^end-of-^line: \^@c \^@c\n', + o"100".xor.(eolch),o"100".xor.(speol),0,0) call fprintf(stdout,' ^control quote: @c @c\n', + quotech,spquote,0,0) call fprintf(stdout,' ^start-of-^packet: \^@c \^@c\n', + o"100".xor.(sync),o"100".xor.(sndsync),0,0) c c display protocol stuff c call fprintf(stdout,'\n^delay before sending first packet: @d\n', + delayfp,0,0,0) call fprintf(stdout, + '^delay @d milliseconds before each ^t^t^y read\n',rdelay,0,0,0) call fprintf(stdout,'^init packet retry count: @d\n',maxrini,0,0, + 0) call fprintf(stdout,'^packet retry count: @d\n\n',maxrtry,0,0,0) return end *if def,ovcap ident kermsta entry kermsta lcc ovcap. ldset noept=unlfile kermsta title kermsta - kermit status command processor. comment kermit status command processor. kermsta space 4,10 ** kermsta - kermit status command processor. kermsta subr entry/exit rj =xstatus call the real workhorse eq kermstax return end *endif subroutine status ccc status - tell how long last transfer took. c *call kermcom logical confirm c$ if (nos .eq. 1) c c if running under nos - issue memory status message. c call memstat c$ endif c c confirm the command c if (.not. confirm(stdin)) return call fprintf(stdout, + '^max characters in packet: @d received; @d sent\n',packsiz, + spksiz,0,0) if (endtim .lt. startim) endtim = endtim + 86400 nsec = endtim - startim hr = nsec / 3600 nsec = nsec - (hr * 3600) min = nsec / 60 nsec = nsec - (min * 60) call fprintf(stdout,'^number of characters transmitted in ', + 0,0,0,0) if (hr .gt. 0) call fprintf(stdout,'@d hours ',hr,0,0,0) if (min .gt. 0) call fprintf(stdout,'@d minutes ',min,0,0,0) call fprintf(stdout,'@d seconds\n\n',nsec,0,0,0) call fprintf(stdout,' ^sent: @20d',schcnt,0,0,0) call fprintf(stdout,' ^overhead: @d\n',schovrh,0,0,0) call fprintf(stdout,' ^received: @20d',rchcnt,0,0,0) call fprintf(stdout,' ^overhead: @d\n',rchovrh,0,0,0) call fprintf(stdout,'^total transmitted: @20d',schcnt+rchcnt,0,0, + 0) call fprintf(stdout,' ^overhead: @d\n',schovrh+rchovrh,0,0,0) call fprintf(stdout, + '^total characters transmitted per sec: @d\n', + (schcnt+rchcnt) / (endtim-startim),0,0,0) call fprintf(stdout, + '^effective data rate: @d baud\n', ((schcnt+rchcnt) - + (schovrh+rchovrh)) / (endtim-startim) * 10,0,0,0) if (state .ne. c) then call getemsg(packet) call fprintf(stdout,'?^kermit: @s\n',packet,0,0,0) endif return end *if def,ovcap ident kermsrv entry kermsrv lcc ovcap. ldset noept=unlfile kermsrv title kermsrv - kermit server-mode processor. comment kermit server-mode processor. kermsrv space 4,10 ** kermsrv - kermit server-mode processor. kermsrv subr entry/exit rj =xserver call the real workhorse eq kermsrvx return end *endif subroutine server ccc server - start kermit server c c the server currently knows about the send and receive packets c and also the generic kermit packets logout and finish. using c logout can cause problem due to files not being made permanent c before leaving. i suppose implementing system command packets c would allow files to be saved but what other kermit allows c system command packets and is there a standard what to c checkpoint programs on the cyber? c *call kermcom character*10 lfn logical confirm, cfe c$ if (nos .eq. 1) c c if running under nos - issue memory status message. c call memstat c$ endif c c confirm the command c if (.not. confirm(stdin)) return c c initialize msg #, say no tries yet c packnum = 0 numtry = 0 call fprintf(stdout,'[^kermit server running on ^cyber host. ^ple +ase type your escape sequence to\n return to your local machine. ^ +shut down the server by typing the ^kermit ^b^y^e \n command on yo +ur local machine.]\n',0,0,0,0) c$ if (nos .eq. 1) call fflush(stdout) c$ endif call stty('binary',on) savedpx = gtty('duplex') call stty('duplex',halfdup) 1 ptyp = rdpack(len,num,recpack) if (ptyp .eq. s) then packnum = num call rdparam(recpack) i = sndpar(packet) call sndpack(y,packnum,i,packet) numtry = 0 packnum = mod(packnum+1,64) recstat = receive(f) if (debug .ne. 0) then if (recstat .eq. error) then call fprintf(debugfd,'^receive failed.\n',0,0,0,0) else call fprintf(debugfd,'^receive completed.\n',0,0,0,0) endif endif else if (ptyp .eq. r) then i = 0 call strcpy(recpack,filestr) call as2dpc(filestr,lfn) if (xvfn(lfn) .ne. 0) then abortyp = invfn call getemsg(errmsg(15)) call sndpack(e,packnum,slen(errmsg),errmsg) else if (.not. cfe(lfn)) then abortyp = notlcl call getemsg(errmsg(15)) call sndpack(e,packnum,slen(errmsg),errmsg) else sndstat = send() packnum = 0 if (debug .ne. 0) then if (sndstat .eq. error) then call fprintf(debugfd,'^send failed.\n',0,0,0,0) else call fprintf(debugfd,'^send completed.\n',0,0,0,0) endif endif endif else if (ptyp .eq. g) then if (recpack(1) .eq. l) then call sndpack(y,num,0,0) call logout else if (recpack(1) .eq. f) then call sndpack(y,num,0,0) normal = .true. call exitpgm else abortyp = srvcmd call getemsg(errmsg(15)) call sndpack(e,packnum,slen(errmsg),errmsg) endif else if (debug .ne. 0) call fprintf + (debugfd,'server: invalid packet type: @d\n',ptyp,0,0,0) abortyp = invalid.or.reading.or.srvcmd call getemsg(errmsg(15)) call sndpack(e,packnum,slen(errmsg),errmsg) endif go to 1 end *if def,ovcap *cweor *endif *deck kermlib subroutine dmodcmd ccc dmodcmd - perform a set data-mode xxxx command. c *call kermcom logical confirm c$ if (ut2d .eq. 1) parameter (tsize=4) c$ endif c$ if (ut2d .ne. 1) parameter (tsize=3) c$ endif character*15 datatyp(tsize) c$ if (ut2d .eq. 1) data datatyp /'ascii', 'display-code', 'image-ascii', 'nos-ascii'/ c$ endif c$ if (ut2d .ne. 1) data datatyp / 'ascii', 'display-code', 'image-ascii' / c$ endif c c match the parameter. c indx = match(datatyp,tsize,.false.) if (indx .le. 0) return if (.not. confirm(stdin)) return c c take the appropriate action. c c$ if (ut2d .eq. 1) go to (10, 20, 30, 40), indx c$ endif c$ if (ut2d .ne. 1) go to (10, 20, 30), indx c$ endif c c set ascii character set. c c$ if (ut2d .eq. 1) 10 dskcset = dskut8 c$ endif c$ if (ut2d .ne. 1) 10 dskcset = dsknos8 c$ endif return c c set display character set. c 20 dskcset = dskdpc return c c set image data mode. c 30 dskcset = dskimag return c$ if (ut2d .eq. 1) c c set nos 812 ascii c 40 dskcset = dsknos8 return c$ endif end subroutine dbugcmd ccc dbugcmd - set the debugging modes. c *call kermcom character*10 fn logical confirm parameter (tsize=5) character*10 dbgtyp(tsize) data dbgtyp / 'all', 'log-file', 'off', 'packets', 'states' / indx = match(dbgtyp,tsize,.false.) if (indx .le. 0) return go to (10, 20, 30, 40, 50), indx c c set all debug modes c 10 if (.not. confirm(stdin)) return debug = dbgall go to 100 c c set debug logfile c 20 call setval(debugfn,'s',iret,7,0,0,hlpdbfn,.true.) if (iret .eq. ok) then if (debugfd .ne. 0) then call fclose(debugfd) debugfd = 0 endif go to 100 endif return c c turn off all debugging c 30 if (.not. confirm(stdin)) return debug = dbgoff if (debugfd .ne. 0) then call fclose(debugfd) debugfd = 0 endif return c c toggle debug packets c 40 if (.not. confirm(stdin)) return debug = debug .xor. dbgpack go to 100 c c toggle debug states c 50 if (.not. confirm(stdin)) return debug = debug .xor. dbgstat go to 100 c c open the debug file if not done already c 100 if (debugfd .eq. 0) then call as2dpc(debugfn,fn) debugfd = fopen(fn,wr) endif return end subroutine setpack(attr) ccc set packet send or receive attributes. c c setpack will wet the attributes of the passed attribute c list. this subroutine will set the appropriate packet c parameter. the parameter to set is passed in an array c and is very order dependent. see common block /packet/ c for the ordering. note that send and receive parameter c ordering and storage size in the common block are c identical. keep it that way! c *call kermcom integer attr(12) parameter (tsize=7) character*15 attrtyp(tsize) data attrtyp / 'end-of-line', 'packet-length', 'pad-character', + 'pad-length', 'quote-character', 'sync-character', + 'time-out' / indx = match(attrtyp,tsize,.false.) if (indx .le. 0) return go to (10, 20, 30, 40, 50, 60, 70), indx c c set eol character c 10 call setval(attr(5),'i',1,31,127,127,hlpasch,.true.) return c c set maximum packet length c 20 call setval(attr(1),'i',20,94,20,94,hlpplen,.true.) return c c set pad character c 30 call setval(attr(4),'i',0,31,127,127,hlpasch,.true.) return c c set pad length c 40 call setval(attr(3),'i',0,94,0,94,hlppadl,.true.) return c c set quote character c 50 call setval(attr(6),'i',33,62,96,126,hlpasch,.true.) return c c set sync character c 60 call setval(attr(12),'i',0,127,0,127,hlpasch,.true.) return c c set timeout value c 70 call setval(attr(2),'i',0,94,0,94,hlptimo,.true.) return end subroutine dplxcmd ccc dplxcmd - perform a set duplex xxxx command c *call kermcom logical confirm parameter (tsize=2) character*10 duptyp(tsize) data duptyp / 'full', 'half' / c c match the parameter c indx = match(duptyp,tsize,.false.) if (indx .le. 0) return if (.not. confirm(stdin)) return c c take the appropriate action c go to (10, 20), indx c c set full duplex c 10 call stty('duplex',fulldup) return c c set half duplex c 20 call stty('duplex',halfdup) return end subroutine parcmd ccc parcmd - set the parity for terminal i/o. c *call kermcom logical confirm parameter (tsize=5) character*10 partyp(tsize) data partyp / 'even', 'mark', 'none', 'odd', 'space' / c c match the parameter c indx = match(partyp,tsize,.false.) if (indx .le. 0) return if (.not. confirm(stdin)) return c c set the proper parity c go to (10, 20, 30, 40, 50), indx 10 call stty('parity',even) return 20 call stty('parity',mark) return 30 call stty('parity',none) return 40 call stty('parity',odd) return 50 call stty('parity',space) return end integer function match(table,tablen,nelok) ccc match - match input with a table of possibilities. c c table should be an array of character strings defining what c is reasonable input. match will read input and return the c index of the table entry that matches or "error" if a proper c match couldn't be made. matchs will fail if the input match c is ambiguous or doesn't match at all. a question mark in the c input will output the possible matches according to the input c previously read and then return as if no match was made. c *call kermcom character*(*) table(tablen) logical nelok character*40 word integer astr(41) c c get the word to match c len = getword(stdin,astr,40) if (len .eq. 0 .or. len .eq. eof) then match = len if (len .eq. 0 .and. .not. nelok) then match = error call fprintf(stdout,'?^null switch or keyword given\n',0,0, + 0,0) endif call fflush(stdin) return endif call as2dpc(astr,word) c c begin the matching here; tables must be in alphabetical order c t1 = 1 t2 = tablen chp = 1 10 if (chp .le. len) then c c if we find a "?", then give the possibilities c if (word(chp:chp) .eq. '?') then call fprintf(stdout,follow,0,0,0,0) call outtbl(table,t1,t2) call fflush(stdin) match = error return endif c c while word is less than lower table entry c 20 if (word(chp:chp) .gt. table(t1)(chp:chp) .and. + t1 .le. t2) then t1 = t1 + 1 go to 20 endif c c while word is greater than upper table entry c 30 if (word(chp:chp) .lt. table(t2)(chp:chp) .and. + t2 .ge. t1) then t2 = t2 - 1 go to 30 endif c c if we know we have a mismatch c if (t2 .lt. t1) then call fprintf(stdout,nomatch,0,0,0,0) call putstr(stdout,astr) call fprintf(stdout,'"\n',0,0,0,0) call fflush(stdin) match = error return endif chp = chp + 1 go to 10 endif c c after looking at the whole word, is it still ambiguous? c if (t1 .ne. t2) then call fprintf(stdout,ambig,0,0,0,0) call putstr(stdout,astr) call fprintf(stdout,'"\n',0,0,0,0) call fflush(stdin) match = error else match = t1 endif return end subroutine outtbl(table,start,fin) ccc outtbl - output a string array in tabular format. c *call kermcom character*(*) table(fin) integer start, fin character*80 line integer astr(81) integer colwid, ncols colwid = len(table(1)) + 2 ncols = 80 / colwid line = ' ' icol = 1 do 100 i = start,fin ipos = (icol-1)*colwid + 1 line(ipos:) = table(i) icol = icol + 1 if (icol .gt. ncols .or. i .eq. fin) then call dpc2as(line,astr,len(line)) c c delete trailing blanks c j = len(line) 10 if (line(j:j) .eq. ' ') then astr(j) = 0 j = j - 1 go to 10 endif call putstr(stdout,astr) call putc(nel,stdout) line = ' ' icol = 1 endif 100 continue return end subroutine setval(var,vtyp,mn1,mx1,mn2,mx2,hlpmsg,confrm) ccc setval - set a variable value. c c setval will read a token from input and set a variable to c that value. if the token is a question mark then the c help message will be displayed and setval will return c without setting a value. c c entry: (vtyp) = character 's' for string variable. c = character 'i' for integer variable. c (mn1-mx1) = range #1 for var to fit in if integer. c = mn1 is return code for error and mx1 is c max size of string if string var. c (mn2-mx2) = secondary range for var to fit in if c integer var. c = unused for string var. c (hlpmsg) = fprintf message format to display if c a question mark is read. c c exit: (var) = int value read if integer var. or string c value read if string var. c *call kermcom character*(*) vtyp, hlpmsg integer var(41), str(41) logical confrm, confirm c c check var type c if (vtyp .ne. 's' .and. vtyp .ne. 'i') then call fprintf(stdout,'setval - invalid var type @c\n',asc(vtyp), + 0,0,0) return endif if (vtyp .eq. 's' .and. mx1 .gt. 40) then call fprintf(stdout,'setval - string max of @d is too large\n', + mx1,0,0,0) return endif len = getword(stdin,str,mx1) if (len .eq. 0 .or. len .eq. eof) then if (vtyp .eq. 'i') then call fprintf(stdout,nodigit,0,0,0,0) else call fprintf(stdout,missing,0,0,0,0) mn1 = error endif return endif if (str(1) .eq. qmark) then call fprintf(stdout,hlpmsg,0,0,0,0) call fflush(stdin) if (vtyp .eq. 's') mn1 = error return endif c c confirm the request if necessary c if (confrm) then if (.not. confirm(stdin)) then if (vtyp .eq. 's') mn1 = error return endif endif c c go ahead and set the variable c if (vtyp .eq. 'i') then i = ctoi(str) if (i .ge. mn1 .and. i .le. mx1) then var(1) = i else if (i .ge. mn2 .and. i .le. mx2) then var(2) = i else call fprintf(stdout, + '?^value is not within range of @d - @d', + mn1,mx1,0,0) if (mn1 .ne. mn2 .or. mx1 .ne. mx2) call fprintf(stdout, + ' or @d - @d',mn2,mx2,0,0) call putc(nel,stdout) endif else do 100 i = 1,len var(i) = str(i) 100 continue var(len+1) = 0 mn1 = ok endif return end logical function confirm(fd) ccc confirm - look for a newline. c c confirm will expect that the next token of input be a c newline for confirmation to be true. if the next token c is a question mark, then confirmation is false and c a "confirm with a carriage return" message will be displayed. c any other text will cause a 'not confirmed "text"' message c to be displayed and confirm will return false. c *call kermcom c c get leading blanks til a token is found c confirm = .false. 10 if (getc(fd,ch) .eq. nel) then confirm = .true. else if (ch .eq. eof) then return else if (ch .eq. blank .or. ch .eq. tab) then go to 10 else if (ch .eq. qmark) then call fprintf(stdout,confmsg,0,0,0,0) else call fprintf(stdout,notconf,0,0,0,0) 20 call putc(ch,stdout) ch = getc(fd,ch) if (ch .ne. nel .and. ch .ne. eof) go to 20 call fprintf(stdout,'"\n',0,0,0,0) endif return end subroutine logout ccc logout - log out the job c c this is site dependent. *call kermcom iret = error c$ if (ut2d .eq. 1) call bellc(l"logout",0,iret) c$ endif c$ if(nosbe .eq. 1) if(savedpx .ne. halfdup) call stty('duplex',fulldup) call excst('logout.') c$ endif c$ if(nos .eq. 1) c$ if(noslvl .ge. 596) if(savedpx .ne. halfdup) call stty('duplex',fulldup) call excst('logout.') c$ endif c$ endif if (iret .ne. 0) call displa('logout error',iret) return end integer function receive(istate) ccc receive - receive file state switching routine. c *call kermcom c c initialize statistics variables c call getnow(mm,dd,yy,hr,min,sec) startim = hr * 3600 + min * 60 + sec schcnt = 0 rchcnt = 0 schovrh = 0 rchovrh = 0 c c set packet retry count & current state c numtry = 0 state = istate c c take appropriate action for the current state c 10 if (state .eq. d) then state = rdata() else if (state .eq. f) then state = rfile() else if (state .eq. r) then state = rinit() else if (state .eq. c) then call getnow(mm,dd,yy,hr,min,sec) endtim = hr * 3600 + min * 60 + sec receive = ok return else if (state .eq. e) then receive = error if (ffd .ne. closed) then call fclose(ffd) call remove(filestr) endif return else if (state .eq. a) then call getnow(mm,dd,yy,hr,min,sec) endtim = hr * 3600 + min * 60 + sec receive = error if (ffd .ne. closed) then call fclose(ffd) call remove(filestr) endif call getemsg(errmsg(15)) call sndpack(e,packnum,slen(errmsg),errmsg) return else call displa(' receive - state error = ',state) if (ffd .ne. closed) call fclose(ffd) receive = error return endif if ((debug.and.dbgstat).ne.0) then call fprintf(debugfd,'@c@2d ',state,packnum,0,0) if (mod(packnum+1,16) .eq. 0) call putc(nel,debugfd) endif go to 10 end integer function rinit() ccc rinit - receive a send-init packet. c *call kermcom c c clean out filestr array so remove does not do dire things c to the previously received file if we die before we get c the new file specification. c do 10 i = 1, maxpack filestr(i) = 0 10 continue c c check retry count c if (numtry .gt. maxrini) then rinit = a abortyp = toomany.or.reading.or.initerr return endif numtry = numtry + 1 c c read a packet and hope for the best c ptyp = rdpack(len,num,packet) c c is it a valid packet type? c if (ptyp .eq. s) then packnum = num call rdparam(packet) len = sndpar(packet) call sndpack(y,num,len,packet) numtry = 0 packnum = mod(packnum+1,64) rinit = f c c did we get a checksum error c else if (ptyp .eq. error) then rinit = state call sndpack(n,num,0,0) else rinit = a abortyp = invalid.or.reading.or.initerr endif return end integer function rfile() ccc rfile read a filename packet. c c rfile expects to see a filename (type f) packet. however, it may c find a send-init retry, end-of-file retry or break packet. c *call kermcom if (numtry .gt. maxrtry) then rfile = a abortyp = toomany.or.reading.or.filerr return endif numtry = numtry + 1 c c read a packet c ptyp = rdpack(len,num,packet) c c is it a filename packet? c if (ptyp .eq. f) then if (num .ne. packnum) then rfile = a abortyp = seqerr.or.reading.or.filerr return endif ffd = creat(packet) if (ffd .eq. error) then ffd = closed rfile = a abortyp = lclfile.or.reading.or.filerr else if (debug .ne. 0) call fprintf(debugfd, + '^receiving file @s\n',packet,0,0,0) call strcpy(packet,filestr) call sndpack(y,num,0,0) numtry = 0 packnum = mod(packnum+1,64) rfile = d endif c c is it an old send-init packet c else if (ptyp .eq. s) then if (mod(num+1,64) .eq. packnum) then len = sndpar(packet) call sndpack(y,num,len,packet) numtry = 0 rfile = state else rfile = a abortyp = seqerr.or.reading.or.initerr endif c c is it an old eof packet? c else if (ptyp .eq. z) then if (mod(num+1,64) .eq. packnum) then call sndpack(y,num,0,0) numtry = 0 rfile = state else rfile = a abortyp = seqerr.or.reading.or.eoferr endif c c is it a break packet? c else if (ptyp .eq. b) then if (num .ne. packnum) then rfile = a abortyp = seqerr.or.reading.or.brkerr else call sndpack(y,packnum,0,0) rfile = c endif c c did we get an error packet? c else if (ptyp .eq. e) then rfile = e return c c did we get a checksum error? c else if (ptyp .eq. error) then rfile = state call sndpack(n,num,0,0) c c invalid packet type, so abort c else rfile = a abortyp = invalid.or.reading.or.filerr endif return end integer function rdata() ccc rdata - read a data packet. c *call kermcom c c check retry count c if (numtry .gt. maxrtry) then rdata = a abortyp = toomany.or.reading.or.dataerr return endif numtry = numtry + 1 c c read a packet c ptyp = rdpack(len,num,packet) c c did we get a data packet? c if (ptyp .eq. d) then if (num .ne. packnum) then if (mod(num+1,64) .eq. packnum) then call sndpack(y,num,0,0) rdata = state else rdata = a abortyp = seqerr.or.reading.or.dataerr endif else call bufemp(packet,ffd,len) call sndpack(y,packnum,0,0) numtry = 0 packnum = mod(packnum+1,64) rdata = state endif c c is it an old filename packet? c else if (ptyp .eq. f) then if (mod(num+1,64) .eq. packnum) then call sndpack(y,num,0,0) numtry = 0 rdata = state else rdata = a abortyp = seqerr.or.reading.or.filerr endif c c is it an eof packet? c else if (ptyp .eq. z) then if (num .ne. packnum) then rdata = a abortyp = seqerr.or.reading.or.eoferr else call sndpack(y,packnum,0,0) call fclose(ffd) ffd = 0 packnum = mod(packnum+1,64) rdata = f endif c c did we get an error packet? c else if (ptyp .eq. e) then rdata = e return else if (ptyp .eq. error) then rdata = state call sndpack(n,num,0,0) else rdata = a abortyp = invalid.or.reading.or.dataerr endif return end integer function send() ccc send - send file state switching routine c c the filename to send is assumed to have already been c obtained and set in ascii string buffer filestr. c *call kermcom c c initialize statics variables c call getnow(mm,dd,yy,hr,min,sec) startim = hr * 3600 + min * 60 + sec schcnt = 0 rchcnt = 0 schovrh = 0 rchovrh = 0 state = s numtry = 0 c c take appropriate action for the current state c 10 if (state .eq. d) then state = sdata() else if (state .eq. f) then state = sfile() else if (state .eq. z) then state = seof() else if (state .eq. s) then state = sinit() else if (state .eq. b) then state = sbreak() else if (state .eq. c) then call getnow(mm,dd,yy,hr,min,sec) endtim = hr * 3600 + min * 60 + sec send = ok return else if (state .eq. e) then call getnow(mm,dd,yy,hr,min,sec) endtim = hr * 3600 + min * 60 + sec send = error if (ffd .ne. closed) call fclose(ffd) return else if (state .eq. a) then call getnow(mm,dd,yy,hr,min,sec) endtim = hr * 3600 + min * 60 + sec send = error if (ffd .ne. closed) call fclose(ffd) call getemsg(errmsg(15)) call sndpack(e,packnum,slen(errmsg),errmsg) return else call displa(' send - state error = ',state) send = error if (ffd .ne. closed) call fclose(ffd) return endif if ((debug.and.dbgstat).ne.0) then call fprintf(debugfd,'@c@2d ',state,packnum,0,0) if (mod(packnum+1,16) .eq. 0) call putc(nel,debugfd) endif go to 10 end integer function sinit() ccc sinit - send the send-init packet and wait for reply. c c assumes filestr has already been checked for legal filename c and being local. c *call kermcom character*10 filenam c c check number of retries c if (numtry .gt. maxrini) then sinit = a abortyp = toomany.or.sending.or.initerr return endif numtry = numtry + 1 c c send the send-init packet with the right info c len = sndpar(packet) call sndpack(s,packnum,len,packet) c c pick up and process the reply c ptyp = rdpack(len,num,recpack) if (ptyp .eq. n) then sinit = state return else if (ptyp .eq. y) then if (packnum .ne. num) then sinit = state return endif call rdparam(recpack) numtry = 0 packnum = mod(packnum+1,64) call as2dpc(filestr,filenam) ffd = fopen(filenam,rd) if (ffd .eq. error) then sinit = a ffd = closed else sinit = f endif c c did we get an error packet? c else if (ptyp .eq. e) then sinit = e return else if (ptyp .eq. error) then sinit = state else sinit = a abortyp = invalid.or.sending.or.initerr endif return end integer function sfile() ccc sfile - send a filename packet and wait for reply. c c the filename is assumed to have been previously obtained c and stored in the ascii string buffer filestr in upper case. c *call kermcom c c have we tried this too many times? c if (numtry .gt. maxrtry) then sfile = a abortyp = toomany.or.sending.or.filerr return endif numtry = numtry + 1 c c send the filename packet c call sndpack(f,packnum,slen(filestr),filestr) c c check on the reply c ptyp = rdpack(len,num,recpack) if (ptyp .eq. n) then if (mod(packnum+1,64) .ne. num) then sfile = state return else ptyp = y num = num - 1 endif endif if (ptyp .eq. y) then if (packnum .ne. num) then sfile = state return endif numtry = 0 packnum = mod(packnum+1,64) c c get first packet of data from the file c psize = buffill(ffd,packet) sfile = d c c did we get an error packet? c else if (ptyp .eq. e) then sfile = e return else if (ptyp .eq. error) then sfile = state else sfile = a abortyp = invalid.or.sending.or.filerr endif return end integer function sdata() ccc sdata - send a data packet and wait for reply. c *call kermcom c c have we tried this too many times? c if (numtry .gt. maxrtry) then sdata = a abortyp = toomany.or.sending.or.dataerr return endif numtry = numtry + 1 c c send the current data buffer c if (psize .eq. eof) then sdata = z return endif call sndpack(d,packnum,psize,packet) c c check on the reply c ptyp = rdpack(len,num,recpack) if (ptyp .eq. n) then if (mod(packnum+1,64) .ne. num) then sdata = state return else ptyp = y num = num - 1 endif endif if (ptyp .eq. y) then if (packnum .ne. num) then sdata = state return endif numtry = 0 packnum = mod(packnum+1,64) psize = buffill(ffd,packet) if (psize .eq. eof) then sdata = z else sdata = state endif c c did we get an error packet? c else if (ptyp .eq. e) then sdata = e return else if (ptyp .eq. error) then sdata = state else sdata = a abortyp = invalid.or.sending.or.dataerr endif return end integer function seof() ccc seof - send an eof packet and wait for the reply. c *call kermcom c c have we tried this too many times? c if (numtry .gt. maxrtry) then seof = a abortyp = toomany.or.sending.or.eoferr return endif numtry = numtry + 1 c c send the eof packet c call sndpack(z,packnum,0,0) c c check the reply c ptyp = rdpack(len,num,recpack) if (ptyp .eq. n) then if (mod(packnum+1,64) .ne. num) then seof = state return else ptyp = y num = num - 1 endif endif if (ptyp .eq. y) then if (packnum .ne. num) then seof = state return endif numtry = 0 packnum = mod(packnum+1,64) call fclose(ffd) seof = b c c did we get an error packet? c else if (ptyp .eq. e) then seof = e return else if (ptyp .eq. error) then seof = state else seof = a abortyp = invalid.or.sending.or.eoferr endif return end integer function sbreak() ccc sbreak - send the break packet and wait for reply. c *call kermcom c c have we tried this too many times? c if (numtry .gt. maxrtry) then sbreak = a abortyp = toomany.or.sending.or.brkerr return endif numtry = numtry + 1 c c send the break packet c call sndpack(b,packnum,0,0) c c check on the reply c ptyp = rdpack(len,num,recpack) if (ptyp .eq. n) then if (mod(packnum+1,64) .ne. num) then sbreak = state return else ptyp = y num = num - 1 endif endif if (ptyp .eq. y) then if (packnum .ne. num) then sbreak = state return endif numtry = 0 packnum = mod(packnum+1,64) sbreak = c c c did we get an error packet? c else if (ptyp .eq. e) then sbreak = e return else if (ptyp .eq. error) then sbreak = state else sbreak = a abortyp = invalid.or.sending.or.brkerr endif return end subroutine sndpack(type,num,len,data) ccc sndpack - send a packet down an output stream c c sndpack will send a packet of information and log it c if debug is turned on. this subroutine could be made c more efficient by not calling a subroutine for each c character, but that might cause portability problems. c *call kermcom integer data(200) c c define the tochar statement function c tochar(ascch) = ascch + blank if ((debug.and.dbgpack).ne.0) call fprintf(debugfd,'^sending...', + 0,0,0,0) c c put out pad chars c do 100 i = 1,spad call putc(spadch,ofd) if ((debug.and.dbgpack).ne.0) then call putc(spadch,debugfd) endif 100 continue call putc(sndsync,ofd) c c packet len assumes one character checksums c chksum = tochar(len+3) call putc(chksum,ofd) tmp = tochar(num) chksum = chksum + tmp call putc(tmp,ofd) chksum = chksum + type call putc(type,ofd) do 110 i = 1,len chksum = chksum + (data(i) .and. o"377") call putc(data(i),ofd) 110 continue chksum = (chksum + (chksum.and.o"300") / o"100") .and. o"77" call putc(tochar(chksum),ofd) call putc(speol,ofd) if ((debug.and.dbgpack).ne.0) then call putc(sndsync,debugfd) call putc(tochar(len+3),debugfd) call putc(tochar(num),debugfd) call putc(type,debugfd) if (len .gt. 0) call putstr(debugfd,data) call putc(tochar(chksum),debugfd) call putc(speol,debugfd) call putc(nel,debugfd) endif c force buffer flush since desired eol char won't. under nos/be, c scope, and (i suspect) nos, we need 12 bits of zero in the c low order 12 bits of a word to be the eol, or the data gets left c in an intercom small buffer till the eol (or a writer) comes c along. the conditional code adds a 60 bit eol in the case c where the data is a multiple of 5 characters. in all other c cases the eol is present, as the word was zeroed before any c data was put in it. if(fwshft(ofd) .eq. 0) then fwshft(ofd) = 48 fnwds(ofd) = fnwds(ofd) + 1 fchbuf(fnwds(ofd),ofd) = 0 endif call fflush(ofd) c c update the statistics c nch = spad + 5 + len + 1 schcnt = schcnt + nch schovrh = schovrh + nch - len return end integer function rdpack(len,num,data) ccc rdpack - read a packet of information. c c rdpack will read a packet of data and return the packet type c as a result. if the packet contains an error (checksum) then c error will be returned. len, num, and data will be set according c to the fields of the packet. c *call kermcom integer data(*) c c define the unchar statement function c unchar(ascch) = ascch - blank c c is debug packets turned on? c if ((debug.and.dbgpack).ne.0) then call fprintf(debugfd,'^reading...',0,0,0,0) endif nch = 0 c c hunt for the start of packet c 10 if(getc(ifd,ch) .eq. eof) then call remark(' rdpack - found unexpected eof.') call abtp("nd") endif nch = nch + 1 if ((debug.and.dbgpack).ne.0) call putc(ch,debugfd) if (ch .ne. sync) go to 10 chksum = 0 len = 0 c c parse each field of the packet c c for (field=1; field <= 5; field++) field = 1 20 if (field .le. 5) then c c a character read in field 4 here is the first char of the c data field or the checksum character if the data field is empty c if (field .ne. 5 .or. len .gt. 0) then if(getc(ifd,ch) .eq. eof) then call remark(' rdpack - found unexpected eof.') call abtp("nd") endif if (ch .eq. sync) field = 0 nch = nch + 1 if ((debug.and.dbgpack).ne.0) call putc(ch,debugfd) endif if (field .le. 3) chksum = chksum + ch c c if resync if (field .eq. 0) then chksum = 0 if ((debug.and.dbgpack).ne.0) then call fprintf(debugfd,'\n^reading...@c',sync,0,0,0) endif c c if data length else if (field .eq. 1) then len = unchar(ch-3) c c if packet number else if (field .eq. 2) then num = unchar(ch) c c if packet type else if (field .eq. 3) then type = ch c c if data field is not empty else if (field .eq. 4 .and. len .gt. 0) then c c read 2nd-len chars of data & checksum char c do 100 i = 1,len if (i .gt. 1) then ch = getc(ifd,ch) if(ch .eq. eof) then call remark(' rdpack - found unexpected eof.') call abtp("nd") endif nch = nch + 1 if (ch .eq. sync) then field = 0 go to 20 endif if ((debug.and.dbgpack).ne.0) call putc(ch,debugfd) endif chksum = chksum + ch data(i) = ch 100 continue c c if chksum char else if (field .eq. 5) then data(len+1) = 0 chksum = (chksum + ((chksum .and. o"300") / o"100")) + .and. o"77" endif c c process next packet field c field = field + 1 go to 20 endif if ((debug.and.dbgpack).ne.0) call putc(nel,debugfd) c c does the checksum match? c if (chksum .ne. unchar(ch)) then rdpack = error rchovrh = rchovrh + nch if (debug .ne. 0) then call fprintf(debugfd,'chksum error, found @d needed @d\n', + unchar(ch),chksum,0,0) endif else rdpack = type rchovrh = rchovrh + nch - len endif rchcnt = rchcnt + nch c c flush any end-of-line characters and other garbage c call fflush(ifd) return end integer function buffill(fd,buffer) ccc buffill - get some data to send. c c buffill reads from the file to send and performs all c the proper escaping of control characters and mapping c newlines into crlf sequences. if it ever gets smart c enough, it will also do the 8 bit quoting and repeat c counts. c c *** note: this algorithm assumes 5 overhead characters for the c packet and leaves 3 characters in case the last character c to buffer is a nel (expands to 4 characters). c *call kermcom boolean buffer(*) c c define ctl statement function c ctl(ascch) = ascch .xor. o"100" c c get a packet worth of data c i = 0 10 if (getc(fd,ch) .ne. eof) then if(ch .eq. null) ch = 0 tch = ch .and. o"177" if (tch.lt.blank .or. tch.eq.del .or. tch.eq.spquote) then if (ch .eq. nel .and. dskcset .ne. dskimag) then buffer(i+1) = spquote buffer(i+2) = ctl(cr) i = i + 2 ch = lf endif i = i + 1 buffer(i) = spquote if (tch.lt.blank .or. tch.eq.del) ch = ctl(ch) endif i = i + 1 buffer(i) = ch if (i .ge. spksiz-8) then buffill = i go to 99 endif go to 10 endif if (i .eq. 0) then buffill = eof else buffill = i endif 99 buffer(i+1) = 0 return end subroutine bufemp(buffer,fd,len) ccc bufemp - dump a buffer to a file. c *call kermcom boolean buffer(*), ch, prevch save prevch data prevch / -1 / c c define ctl statement function c ctl(ascch) = ascch .xor. o"100" c c write the packet data to the file c i = 1 10 if (i .le. len) then ch = buffer(i) if (ch .eq. quotech) then i = i + 1 ch = buffer(i) tch = ch .and. o"177" if ((ctl(tch).lt.blank).or.(ctl(tch).eq.del)) ch = ctl(ch) if(ch .eq. 0) ch = null endif c c if image transfer, do not convert things. c if(dskcset .eq. dskimag) then call putc(ch,fd) else c c convert cr/lf pair to nel (205b) c if (ch .eq. lf .and. prevch .eq. cr) then ch = nel c c just a lone cr c else if (prevch .eq. cr) then call putc(prevch,fd) endif if (ch .ne. cr) call putc(ch,fd) prevch = ch endif i = i + 1 go to 10 endif return end integer function fopen(fn,mode) ccc fopen - pretend to open a file for i/o. c c fopen just assigns a file desciptor (integer index) to c a file name. no opening of the file is really performed c since this is done automatically by iop. c *call kermcom character*10 fn logical cfe c c check for valid parameters c if (mode .lt. rd .or. mode .gt. create) then call displa(' fopen - invalid mode ',mode) call abtp("nd") endif c c find the next unused entry c do 100 i = 1, maxfile c c if unused table entry is found c if (fmode(i) .eq. closed) then fname(i) = fn fwptr(i) = 1 fnwds(i) = 0 if (mode .eq. rd) then fwshft(i) = 12 else fwshft(i) = 0 endif if (mode .eq. create) then if (cfe(fname(i))) then fmode(i) = closed fopen = error return endif fmode(i) = wr else fmode(i) = mode endif feof(i) = .false. ctdev(i) = .false. fopen = i call makefet(fname(i),fets(0,i),fetl,ciobuff(1,i),ciobufl) c$ if (nos .eq. 1) call nosetlf(fets(0,i), i) c$ endif c c if standard i/o files, connect them to the terminal. c if (fn .eq. 'stdin' .or. fn .eq. 'stdout') then c$ if (nos .eq. 1) call return (fets(0,i)) fets(1,i) = l"tt" .or. (compl(mask(12)) .and. fets(1,i)) call mtr (l"lfmp" .or. shift(13, 24) .or. shift(1, 19) + .or. locf (fets(0,i))) c$ else call xcon(fets(0,i),1) c$ endif ctdev(i) = .true. endif c c set the ascii flag and rewind the file. c if(fmode(i) .eq. rd) then call open(fets(0,i),"read") else call open(fets(0,i),"write") endif call recall(fets(0,i)) fets(0,i) = and(fets(0,i),shift(mask(44),2)) if(fmode(i) .eq. wr) fets(0,i) = or(fets(0,i),ciowt) if(fmode(i) .eq. rd) fets(0,i) = or(fets(0,i),ciord) return c c if table entry file name matches fn c else if (fname(i) .eq. fn) then call remark(' fopen - file ' // fn // ' already open.') call abtp("nd") endif 100 continue call remark(' fopen - too many files open.') call abtp("nd") return end subroutine fclose(fd) ccc fclose - remove an fd from the active list. c c fclose will remove the fd from the active list for c allocation at a later date. c *call kermcom if (fd .lt. 1 .or. fd .gt. maxfile) then call displa(' fclose - invalid fd ',fd) call abtp("nd") endif if (fmode(fd) .eq. 0) then call displa(' fclose - fd not open.',fd) return endif c c force emptying of the buffer c call fflush(fd) c c write a file mark c if(fmode(fd) .eq. wr) then call writer(fets(0,fd)) call recall(fets(0,fd)) endif fmode(fd) = closed if(ctdev(fd)) then call close(fets(0,fd),"unload") call recall(fets(0,fd)) else call close(fets(0,fd),"rewind") call recall(fets(0,fd)) endif return end subroutine fflush(fd) ccc fflush - flush an i/o buffer. c c fflush will flush the ascii string buffer for a particular c file descriptor. c *call kermcom parameter (nosibit = 36, intrcom = 42, asc128 = 22, asc256 = 23) parameter (first = 1, in = 2, out = 3, limit = 4, intwd = 5) c$ if (nos .eq. 1) boolean bpatx c$ endif c c is the fd valid? c if (fd .lt. 1 .or. fd .gt. maxfile) then call displa(' fflush - invalid file descriptor',fd) call abtp("nd") endif if (fmode(fd) .eq. 0) then call displa(' fflush - file descriptor not open',fd) call abtp("nd") endif c c if fd was opened as write, then flush to the file c if (fmode(fd) .eq. wr) then if(ctdev(fd)) then c$ if (ut2d .eq. 1) then fets(first,fd) = or(fets(first,fd),shift(1,asciiio)) c$ else fets(first,fd) = or(fets(first,fd),shift(1,intrcom)) fets(intwd,fd) = shift(1,asc256) c$ if (nos .eq. 1) fets(first,fd) = or(fets(first,fd),shift(1,nosibit)) if (fnwds(fd) .eq. 1) then bpatx = o"00004000400040004000" else bpatx = o"40004000400040004000" endif fchbuf(fnwds(fd),fd) = fchbuf(fnwds(fd),fd) .or. bpatx fnwds(fd) = fnwds(fd) + 1 fchbuf(fnwds(fd),fd) = 0 c$ endif c$ endif elseif(fd .ne. debugfd .and. dskcset .eq. dskdpc) then temp = dpctbl(0) dpctbl(0) = 0 call xtxs(fchbuf(1,fd),fnwds(fd),fchbuf(1,fd),dpctbl) if(mod(fnwds(fd),2) .eq. 0) + fchbuf(fnwds(fd) / 2 + 1,fd) = 0 dpctbl(0) = temp fnwds(fd) = findeol(fchbuf(1,fd),fnwds(fd),.false.) endif call writew(fets(0,fd),fchbuf(1,fd),fnwds(fd)) c$ if (nos .eq. 1) if ((binmode .or. rawmode) .and. ctdev(fd)) then call writer(fets(0,fd)) endif c$ endif else if (fmode(fd) .eq. rd) then call recall(fets(0,fd)) fets(in,fd) = and(fets(first,fd),o"777777") fets(out,fd) = fets(in,fd) endif c c reset buffer character count c fwptr(fd) = 1 fnwds(fd) = 0 if (fmode(fd) .eq. rd) then fwshft(fd) = 12 else fwshft(fd) = 0 endif return end integer function getc(fd,ch) ccc getc - return next character from the input stream. c c getc will return the next ascii character that was c read from the file descriptor fd. reads are buffered c with 5 characters packed to a word. o"0000" bytes c are ignored. nuls are o"4000" bytes. eof (-1) is c returned when eof is read. c *call kermcom c c is the fd valid? c if (fd .lt. 1 .or. fd .gt. maxfile) then call displa(' getc - invalid file descriptor',fd) call abtp("nd") endif if (fmode(fd) .eq. closed) then call displa(' getc - file descriptor not open',fd) call abtp("nd") endif c c check if ok to read c if ((fmode(fd).and.rd) .ne. rd) then call displa(' getc - read on write-only file ',fd) call abtp("nd") endif c c check if more data needed c 10 if (fwptr(fd) .gt. fnwds(fd)) then if (feof(fd)) then getc = eof return endif c c get a buffer worth of data c nread = getrec(fd,fchbuf(1,fd),maxwd,feof(fd)) fwptr(fd) = 1 fnwds(fd) = nread fwshft(fd) = 12 go to 10 endif c c pickup char to return and check for ignored o"0000" byte c ch = shift(fchbuf(fwptr(fd),fd),fwshft(fd)) .and. o"7777" fwshft(fd) = fwshft(fd) + 12 if (fwshft(fd) .gt. 60) then fwshft(fd) = 12 fwptr(fd) = fwptr(fd) + 1 endif c c if the front-end isn't stripping parity and we aren't using c the eigth bit for data, then strip the parity bit. also, convert c carriage returns and linefeeds which come from the keyboard into c regular end-of-lines (this only happens in binmode). c if (binmode .and. .not. rawmode) then if (parity .ne. nopar .and. ctdev(fd)) ch = ch .and. o"177" if(ctdev(fd) .and. (ch .eq. cr .or. ch .eq. lf)) ch = nel endif if (ch .eq. 0) go to 10 getc = ch return end subroutine ungetc(fd,ch) ccc ungetc - try to put a character back into the input stream. c c ungetc can only put back characters as far as the beginning c of the buffer. hopefully, this is ok, since only getword c does this with an nel which should be well into the buffer. *call kermcom c c is it ok to back up the pointer? c if (fwshft(fd) .eq. 12 .and. fwptr(fd) .eq. 1) then call displa('ungetc - cannot push character ',ch) return endif c c back up the pointer c if (fwshft(fd) .eq. 12) then fwshft(fd) = 60 fwptr(fd) = fwptr(fd) - 1 else fwshft(fd) = fwshft(fd) - 12 endif fchbuf(fwptr(fd),fd) = (fchbuf(fwptr(fd),fd) .and. shift( + o"7777",60-fwshft(fd))) .or. shift(ch,60-fwshft(fd)) feof(fd) = .false. return end integer function getword(fd,str,maxlen) ccc getword - get a word from an input stream. c c getword considers a word to be delimited by blanks. c it will return the length of the word as its value. c *call kermcom integer str(maxlen) len = 0 c c skip leading white spaces c 10 if (getc(fd,ch) .eq. eof) then getword = eof return else if (ch .eq. nel) then getword = 0 return endif if (ch .eq. blank .or. ch .eq. tab) go to 10 c c found the first character, so keep going c 20 if (len .lt. maxlen) then len = len + 1 str(len) = ch endif ch = getc(fd,ch) if (ch .ne. eof .and. ch .ne. blank .and. ch .ne. tab .and. + ch .ne. nel) go to 20 c c save eols for next getword c if (ch .eq. nel) call ungetc(fd,ch) str(len+1) = 0 getword = len return end subroutine putc(tch,fd) ccc putc - put a character into an output stream c c putc outputs a character with the parity bit set to the c proper parity if the output file is conversational. c the five types of parity are defined for each character c in a table. c *call kermcom integer chparty(128) data (chparty(i),i=1,38) / + o"40000200020040004000", o"02010001020100010001", c nul soh + o"02020002020200020002", o"00030203020300030003", c stx etx + o"02040004020400040004", o"00050205020500050005", c eot enq + o"00060206020600060006", o"02070007020700070007", c ack bel + o"02100010021000100010", o"00110211021100110011", c bs ht + o"00120212021200120012", o"02130013021300130013", c lf vt + o"00140214021400140014", o"02150015021500150015", c ff cr + o"02160016021600160016", o"00170217021700170017", c so si + o"02200020022000200020", o"00210221022100210021", c dle dc1 + o"00220222022200220022", o"02230023022300230023", c dc2 dc3 + o"00240224022400240024", o"02250025022500250025", c dc4 nak + o"02260026022600260026", o"00270227022700270027", c syn etb + o"00300230023000300030", o"02310031023100310031", c can em + o"02320032023200320032", o"00330233023300330033", c sub esc + o"02340034023400340034", o"00350235023500350035", c fs gs + o"00360236023600360036", o"02370037023700370037", c rs us + o"02400040024000400040", o"00410241024100410041", c ! + o"00420242024200420042", o"02430043024300430043", c " pound + o"00440244024400440044", o"02450045024500450045" / c $ percent data (chparty(i),i=39,76) / + o"02460046024600460046", o"00470247024700470047", c & ' + o"00500250025000500050", o"02510051025100510051", c ( ) + o"02520052025200520052", o"00530253025300530053", c * + + o"02540054025400540054", o"00550255025500550055", c , - + o"00560256025600560056", o"02570057025700570057", c . / + o"00600260026000600060", o"02610061026100610061", c 0 1 + o"02620062026200620062", o"00630263026300630063", c 2 3 + o"02640064026400640064", o"00650265026500650065", c 4 5 + o"00660266026600660066", o"02670067026700670067", c 6 7 + o"02700070027000700070", o"00710271027100710071", c 8 9 + o"00720272027200720072", o"02730073027300730073", c : ; + o"00740274027400740074", o"02750075027500750075", c < = + o"02760076027600760076", o"00770277027700770077", c > ? + o"03000100030001000100", o"01010301030101010101", c @ a + o"01020302030201020102", o"03030103030301030103", c b c + o"01040304030401040104", o"03050105030501050105", c d e + o"03060106030601060106", o"01070307030701070107", c f g + o"01100310031001100110", o"03110111031101110111", c h i + o"03120112031201120112", o"01130313031301130113" / c j k data (chparty(i),i=77,114) / + o"03140114031401140114", o"01150315031501150115", c l m + o"01160316031601160116", o"03170117031701170117", c n o + o"01200320032001200120", o"03210121032101210121", c p q + o"03220122032201220122", o"01230323032301230123", c r s + o"03240124032401240124", o"01250325032501250125", c t u + o"01260326032601260126", o"03270127032701270127", c v w + o"03300130033001300130", o"01310331033101310131", c x y + o"01320332033201320132", o"03330133033301330133", c z [ + o"01340334033401340134", o"03350135033501350135", c \ ] + o"03360136033601360136", o"01370337033701370137", c ^ underscore + o"01400340034001400140", o"03410141034101410141", c grave accent a + o"03420142034201420142", o"01430343034301430143", c b c + o"03440144034401440144", o"01450345034501450145", c d e + o"01460346034601460146", o"03470147034701470147", c f g + o"03500150035001500150", o"01510351035101510151", c h i + o"01520352035201520152", o"03530153035301530153", c j k + o"01540354035401540154", o"03550155035501550155", c l m + o"03560156035601560156", o"01570357035701570157", c n o + o"03600160036001600160", o"01610361036101610161" / data (chparty(i),i=115,128) / c p q + o"01620362036201620162", o"03630163036301630163", c r s + o"01640364036401640164", o"03650165036501650165", c t u + o"03660166036601660166", o"01670367036701670167", c v w + o"01700370037001700170", o"03710171037101710171", c x y + o"03720172037201720172", o"01730373037301730173", c z left brace + o"03740174037401740174", o"01750375037501750175", c bar right brace + o"01760376037601760176", o"03770177037701770177" / c tilde del c c is the fd valid? c if (fd .lt. 1 .or. fd .gt. maxfile) then call displa(' putc - invalid file descriptor',fd) call abtp("nd") endif if (fmode(fd) .eq. closed) then call displa(' putc - file descriptor not open',fd) call abtp("nd") endif c c is it ok to write on this stream? c if ((fmode(fd).and.wr) .ne. wr) then call displa(' putc - write on read-only file ',fd) call abtp("nd") endif c c add another character to the output buffer c ch = tch 10 if (ctdev(fd)) then if (ch .eq. nel .and. .not. rawmode) ch = cr if (ch .ge. 0 .and. ch .lt. 128) + ch = shift(chparty(ch+1),parity*12) .and. o"7777" endif if (fwshft(fd) .eq. 0) then if (fnwds(fd) .eq. maxwd) then call fflush(fd) endif fwshft(fd) = 48 fnwds(fd) = fnwds(fd) + 1 fchbuf(fnwds(fd),fd) = 0 else fwshft(fd) = fwshft(fd) - 12 endif c c if this is an mass storage device (disk), and we have a nel c character, flush the line into the cio buffer. the standard cdc c line terminator is already present thanks to the above code c pre-zeroing the target word before anything is put in it. c however, don't flush if we need the nel character in the c line (e.g. ut 812 ascii and disk image format). c if(.not.ctdev(fd) .and. tch.eq.nel .and. dskcset.ne.dskut8 .and. + dskcset.ne.dskimag) then call fflush(fd) return endif c$ if (nos .eq. 1) c c preset transparent output for the terminal if first word of buffer c if (fnwds(fd) .eq. 1 .and. fwshft(fd) .eq. 48) then if (fmode(fd) .eq. wr .and. ctdev(fd)) then fchbuf(fnwds(fd),fd) = shift(o"0007",48) fwshft(fd) = 36 endif endif if (ctdev(fd)) ch = ch .or. o"4000" c$ endif fchbuf(fnwds(fd),fd) = fchbuf(fnwds(fd),fd) .or. + shift(and(ch,o"7777"),fwshft(fd)) if (tch .eq. nel .and. (ch.and.o"0177") .eq. cr) then ch = lf go to 10 endif if (tch .eq. nel .and. ctdev(fd)) call fflush(fd) return end subroutine fread(fd,buf,nwd) ccc fread - read some words from a file. c *call kermcom integer buf(nwd) c c is the fd valid? c if (fd .lt. 1 .or. fd .gt. maxfile) then call displa(' fread - invalid file descriptor',fd) call abtp("nd") endif if (fmode(fd) .eq. closed) then call displa(' fread - file descriptor not open',fd) call abtp("nd") endif c c check if ok to read c if ((fmode(fd).and.rd) .ne. rd) then call displa(' fread - read on write-only file ',fd) call abtp("nd") endif c c transfer a cio buffer full at a time until done c istart = 1 nleft = nwd 10 nrd = nleft if (nrd .gt. ciobufl-1) then nrd = ciobufl-1 endif call readw(fets(0,fd),buf(istart),nrd) istart = istart + nrd nleft = nleft - nrd if (nleft .gt. 0) goto 10 return end subroutine fwrite(fd,buf,nwd) ccc fwrite - write some words to a file. c *call kermcom c c is the fd valid? c if (fd .lt. 1 .or. fd .gt. maxfile) then call displa(' fwrite - invalid fd ',fd) call abtp("nd") endif if (fmode(fd) .eq. closed) then call displa(' fwrite - fd not open.',fd) return endif c c is it ok to write on this stream? c if ((fmode(fd).and.wr) .ne. wr) then call displa(' fwrite - write on read-only file ',fd) call abtp("nd") endif c c write the words to the file c call writew(fets(0,fd),buf,nwd) return end subroutine putstr(fd,str) ccc putstr - output a string to an output stream. c c putstr will add characters from the null terminated character c buffer str to the specified output stream. c *call kermcom integer str(*) c c is the fd valid? c if (fd .lt. 1 .or. fd .gt. maxfile) then call displa(' putc - invalid fd ',fd) call abtp("nd") endif if (fmode(fd) .eq. 0) then call displa(' putc - fd not open.',fd) return endif c c is it ok to write on this stream? c if ((fmode(fd).and.wr) .ne. wr) then call displa(' putc - write on read-only file ',fd) call abtp("nd") endif c c put chars in the output buffer c i = 1 10 if (str(i) .ne. 0) then c c is it a valid character? c c if ((str(i).and.mask(48)) .ne. 0) then c call displa(' putstr - invalid ascii byte ',str(i)) c call abort c endif call putc(str(i),fd) i = i + 1 go to 10 endif return end subroutine putint(fd,int,minwid) ccc putint - output an integer. c *call kermcom integer string(21) width = 0 if (int .lt. 0) then call putc(asc('-'),fd) width = 1 endif val = iabs(int) ascii0 = asc('0') nch = 0 10 nch = nch + 1 string(nch) = mod(val,10) + ascii0 val = val / 10 if (val .ne. 0 .and. nch .lt. 20) go to 10 width = width + nch c c now output the digits c 20 call putc(string(nch),fd) nch = nch - 1 if (nch .gt. 0) go to 20 30 if (width .lt. minwid) then call putc(blank,fd) width = width + 1 go to 30 endif return end subroutine putday(fd,mm,dd,yy) ccc output day of week. c *call kermcom izlr(iyr,m,idy)=mod((13*(m+10-(m+10)/13*12)-1)/5+idy+77 1 +5*(iyr+(m-14)/12-(iyr+(m-14)/12)/100*100)/4 2 +(iyr+(m-14)/12)/400-(iyr+(m-14)/12)/100*2,7)+1 wkday = izlr(yy,mm,dd) if (wkday .eq. 1) then call fprintf(fd,'^sunday') else if (wkday .eq. 2) then call fprintf(fd,'^monday') else if (wkday .eq. 3) then call fprintf(fd,'^tuesday') else if (wkday .eq. 4) then call fprintf(fd,'^wednesday') else if (wkday .eq. 5) then call fprintf(fd,'^thursday') else if (wkday .eq. 6) then call fprintf(fd,'^friday') else call fprintf(fd,'^saturday') endif return end subroutine putmnth(fd,mm) ccc putmnth - output the month name. c *call kermcom if (mm .eq. 1) then call fprintf(fd,'^january',0) else if (mm .eq. 2) then call fprintf(fd,'^february',0) else if (mm .eq. 3) then call fprintf(fd,'^march',0) else if (mm .eq. 4) then call fprintf(fd,'^april',0) else if (mm .eq. 5) then call fprintf(fd,'^may',0) else if (mm .eq. 6) then call fprintf(fd,'^june',0) else if (mm .eq. 7) then call fprintf(fd,'^july',0) else if (mm .eq. 8) then call fprintf(fd,'^august',0) else if (mm .eq. 9) then call fprintf(fd,'^september',0) else if (mm .eq. 10) then call fprintf(fd,'^october',0) else if (mm .eq. 11) then call fprintf(fd,'^november',0) else if (mm .eq. 12) then call fprintf(fd,'^december',0) else call fprintf(fd,'putmnth - no such month as @d\n',mm) endif return end subroutine fprintf(fd,fmt,i1,i2,i3,i4) ccc fprintf - poor attempt at formatted ascii output. c c conversion is similar to fprintf used in c. supported c conversions are @d (integer), @c (ascii character), @s (ascii c string buffer). a \n will map to a newline, a \t will c will map to a tab, a \0 will terminate the format scanning. c a \ followed by any other character will cause that character c to be output. the default output case will be lowercase. c a ^ followed by a letter will cause that character to be output c as uppercase. a @d conversion may now specify a minimum field c width as @d (i.e. @10d) in which the number will be blank c padded to the right to use up characters. c *call kermcom character*(*) fmt c c is the fd valid? c if (fd .lt. 1 .or. fd .gt. maxfile) then call displa(' fprintf - invalid fd ',fd) call abtp("nd") endif if (fmode(fd) .eq. closed) then call displa(' fprintf - fd not open.',fd) return endif c c is it ok to write on this stream? c if ((fmode(fd).and.wr) .ne. wr) then call displa(' fprintf - write on read-only file ',fd) call abtp("nd") endif c c now call the real fprintf workhorse c call doprnt(fd,0,1,fmt,i1,i2,i3,i4) return end subroutine sprintf(str,fmt,i1,i2,i3,i4) ccc sprintf - poor attempt at doing internal formatted i/o. c c sprintf is the same as fprintf except that it writes to c and ascii string buffer instead. c *call kermcom character*(*) fmt boolean str(*) c c call the real sprintf workhorse c call doprnt(0,str,2,fmt,i1,i2,i3,i4) return end subroutine doprnt(fd,strng,ptyp,fmt,i1,i2,i3,i4) ccc doprnt - workhorse for formatted ascii i/o. c c conversion is similar to fprintf used in c. supported c conversions are @d (integer), @c (ascii character), @s (ascii c string buffer). a \n will map to a newline, a \t will c will map to a tab, a \0 will terminate the format scanning. c a \ followed by any other character will cause that character c to be output. the default output case will be lowercase. c a ^ followed by a letter will cause that character to be output c as uppercase. a @d conversion may now specify a minimum field c width as @d (i.e. @10d) in which the number will be blank c padded to the right to use up characters. c *call kermcom character*(*) fmt boolean str(21), strng(*) character*1 ch c c check for file or string write c if (ptyp .ne. 1 .and. ptyp .ne. 2) then call displa(' doprnt - invalid write function',ptyp) call abtp("nd") endif c c output the formatted string c iptr = 1 optr = 1 fptr = 1 fmtlen = len(fmt) 10 if (fptr .le. fmtlen) then ch = fmt(fptr:fptr) if (ch .ne. '\' .and. ch .ne. '@' .and. ch .ne. '^') then if (ptyp .eq. 1) then call putc(asc(ch),fd) else strng(optr) = asc(ch) optr = optr + 1 endif c c is it a quote or special sequence character? c else if (ch .eq. '\') then fptr = fptr+1 ch = fmt(fptr:fptr) if (ch .eq. 'n' .and. ptyp .eq. 1) then call putc(nel,fd) else if (ch .eq. 't' .and. ptyp .eq. 1) then call putc(tab,fd) else if (ch .eq. '0') then if (ptyp .eq. 2) strng(optr) = 0 return else if (ch .eq. 'n') then strng(optr) = nel optr = optr + 1 else if (ch .eq. 't') then strng(optr) = tab optr = optr + 1 else if (ptyp .eq. 1) then call putc(asc(ch),fd) else strng(optr) = asc(ch) optr = optr + 1 endif endif c c is it an uppercase mapping? c else if (ch .eq. '^') then fptr = fptr + 1 ch = fmt(fptr:fptr) if (ch .ge. 'a' .and. ch .le. 'z') then ach = asc(ch)-32 else ach = asc(ch) endif if (ptyp .eq. 1) then call putc(ach,fd) else strng(optr) = ach optr = optr + 1 endif c c must be a conversion (@) c else intwdth = 1 fptr = fptr + 1 ch = fmt(fptr:fptr) c c is it an integer value format spec? c 20 if (ch .eq. 'd') then if (iptr .eq. 1) then ach = i1 else if (iptr .eq. 2) then ach = i2 else if (iptr .eq. 3) then ach = i3 else ach = i4 endif if (ptyp .eq. 1) then call putint(fd,ach,intwdth) else tlen = itos(ach,strng(optr),intwdth) optr = optr + tlen endif iptr = iptr + 1 c c is it a character value output spec? c else if (ch .eq. 'c') then if (iptr .eq. 1) then ach = i1 else if (iptr .eq. 2) then ach = i2 else if (iptr .eq. 3) then ach = i3 else ach = i4 endif if (ptyp .eq. 1) then call putc(ach,fd) else strng(optr) = ach optr = optr + 1 endif iptr = iptr + 1 c c is it a string value output spec? c else if (ch .eq. 's') then if (iptr .eq. 1) then if (ptyp .eq. 1) then call putstr(fd,i1) else call strcpy(i1,strng(optr)) optr = optr + slen(i1) endif else if (iptr .eq. 2) then if (ptyp .eq. 1) then call putstr(fd,i2) else call strcpy(i2,strng(optr)) optr = optr + slen(i2) endif else if (iptr .eq. 3) then if (ptyp .eq. 1) then call putstr(fd,i3) else call strcpy(i3,strng(optr)) optr = optr + slen(i3) endif else if (ptyp .eq. 1) then call putstr(fd,i4) else call strcpy(i4,strng(optr)) optr = optr + slen(i4) endif endif iptr = iptr + 1 c c is it a field width specifier? c else if (ch .ge. '0' .and. ch .le. '9') then sptr = 0 30 sptr = sptr + 1 str(sptr) = asc(ch) fptr = fptr + 1 ch = fmt(fptr:fptr) if (ch .ge. '0' .and. ch .le. '9') go to 30 str(sptr+1) = 0 intwdth = ctoi(str) go to 20 c c unknown conversion so output the @ and conversion char c else if (ptyp .eq. 1) then call putc(asc('@'),fd) call putc(asc(ch),fd) else strng(optr) = asc('@') strng(optr+1) = asc(ch) optr = optr + 2 endif endif endif fptr = fptr + 1 go to 10 endif if (ptyp .eq. 2) strng(optr) = 0 return end subroutine stty(mode,value) ccc stty - set a terminal mode. c *call kermcom character*(*) mode integer value c$ if (nos .eq. 1) integer nositm(5), nosttm(2), nosfull, noshalf, + noszero, nosodd, noseven, nosnone c c for nos (initiate *rawmode*): c set pw=0,ci=0,li=0,pg=n,ubl=15,ubz=200,eb=cr,fa=y,cp=0,lk=y c data nositm / o"00164043400040544000", o"40554000404540004030", + o"40174031400241014001", o"40674001410740004040", + o"40010000000000000000" / c c for nos (terminate *rawmode*): c set fa=n,cp=1,lk=n c data nosttm / o"00164067400041074001", o"40404000000000000000" / c c for nos (full/half duplex): c data nosfull / o"00164061400100000000" / data noshalf / o"00164061400000000000" / c c for nos (parity: zero, odd, even, none) c data noszero / o"00164062400000000000" / data nosodd / o"00164062400100000000" / data noseven / o"00164062400200000000" / data nosnone / o"00164062400300000000" / c c$ endif c c is it setting duplex? c if (mode .eq. 'duplex') then if (value .eq. fulldup) then c$ if (ut2d .eq. 1) call bellc(l"full",0,0) c$ endif c$ if(uariz .eq. 1) call echoplx('on') c$ endif c$ if(nos .eq. 1) call writew(fets(0,stdout),nosfull,1) call writer(fets(0,stdout)) if (debug .ne. 0) then call fprintf(debugfd, '^stty - full duplex.\n') endif c$ endif duplex = fulldup else if (value .eq. halfdup) then c$ if (ut2d .eq. 1) call bellc(l"half",0,0) c$ endif c$ if(uariz .eq. 1) call echoplx('off') c$ endif c$ if(nos .eq. 1) call writew(fets(0,stdout),noshalf,1) call writer(fets(0,stdout)) if (debug .ne. 0) then call fprintf(debugfd, '^stty - half duplex.\n') endif c$ endif duplex = halfdup else call displa(' stty - invalid duplex ',value) call abtp("nd") endif c c is it setting parity? c else if (mode .eq. 'parity') then if (value .eq. nopar .or. value .eq. evepar .or. + value .eq. oddpar .or. value .eq. mrkpar .or. + value .eq. spcpar) then parity = value c$ if (nos .eq. 1) if (debug .ne. 0) then call fprintf(debugfd, '^stty - parity switch.\n') endif if (parity .eq. nopar) then call writew(fets(0,stdout),nosnone,1) call writer(fets(0,stdout)) else if (parity .eq. evepar) then call writew(fets(0,stdout),noseven,1) call writer(fets(0,stdout)) else if (parity .eq. oddpar) then call writew(fets(0,stdout),nosodd,1) call writer(fets(0,stdout)) else if (parity .eq. mrkpar) then call writew(fets(0,stdout),noszero,1) call writer(fets(0,stdout)) else if (parity .eq. spcpar) then call writew(fets(0,stdout),noszero,1) call writer(fets(0,stdout)) endif c$ endif else call displa(' stty - invalid parity ',value) call abtp("nd") endif c c is it setting binary (no translation) i/o? c else if (mode .eq. 'binary') then binmode = (value .eq. on) do 100 i = 1,maxfile if (fmode(i) .ne. closed) then if (ctdev(i)) then if (binmode) then fets(0,i) = or(fets(0,i),cioodd) else fets(0,i) = and(fets(0,i),.not.cioodd) endif endif endif 100 continue c$ if(nos .eq. 1) if (binmode) then call writew(fets(0,stdout),nositm, 5) call writer(fets(0,stdout)) if (debug .ne. 0) then call fprintf(debugfd, '^stty - binary.\n') endif else call writew(fets(0,stdout),nosttm, 2) call writer(fets(0,stdout)) if (debug .ne. 0) then call fprintf(debugfd, '^stty - normal.\n') endif endif c$ endif c c is it setting transparent (raw) i/o? c else if (mode .eq. 'raw') then if (value .eq. 0) then rawmode = .false. else rawmode = .true. endif else call displa(' stty - invalid mode ',bool(mode)) call abtp("nd") endif return end integer function gtty(mode) ccc gtty - get a tty mode. c *call kermcom character*(*) mode c c is it duplex they're looking for? c if (mode .eq. 'duplex') then gtty = duplex c c is it parity they're looking for? c else if (mode .eq. 'parity') then gtty = parity else call displa(' gtty - invalid mode ',bool(mode)) call abtp("nd") endif return end subroutine as2dpc(astr,dstr) ccc as2dpc - translate an ascii string buffer to dpc char string. c c ascii string is terminated by a zero byte. c c *call kermcom boolean astr(*) character dstr*(*) integer clen c c i = 1 clen = len(dstr) dstr = ' ' 10 if (astr(i) .ne. 0 .and. i .le. clen) then if (astr(i) .gt. 127) then call movech(dpctbl(blank),9,dstr,i - 1,1) else call movech(dpctbl(astr(i)),9,dstr,i - 1,1) endif i = i + 1 go to 10 endif c return end integer function asc(dpch) ccc asc - convert a dpc character to lower case ascii. c c *call kermcom character*1 dpch c c asc = lascii(ichar(dpch)) c return end subroutine dpc2as(dstr,astr,nwords) c c translate string of display code characters to uppercase ascii. c string is nwords characters (words) long. c c *call kermcom character*(*) dstr boolean astr(nwords) c c do 1 i=1,nwords astr(i) = uascii((ichar(dstr(i:i)))) 1 continue c c set ascii end-of-string-buffer c astr(nwords+1) = 0 c return end integer function ctoi(astr) ccc ctoi - convert character buffer to integer. c c ctoi converts the number using base 10 as a default. c a suffix of h will convert using base 16 and a suffix c of o will convert using base 8. default suffix is c d. c *call kermcom parameter (dig0=48, dig7=55, dig9=57, biga=65, bigb=66, bigd=68) parameter (bigf=70, bigh=72, bigo=79, leta=97, letb=98, letd=100) parameter (letf=102, leth=104, leto=111) integer astr(*) base = 0 ptr = 0 c c find last valid digit c 10 ptr = ptr + 1 if (astr(ptr) .ne. 0) go to 10 ptr = ptr - 1 if (astr(ptr) .eq. leto .or. astr(ptr) .eq. bigo .or. + astr(ptr) .eq. letb .or. astr(ptr) .eq. bigb .or. + astr(ptr) .eq. leth .or. astr(ptr) .eq. bigh) then eod = ptr - 1 else eod = ptr ptr = ptr + 1 endif c c try to figure out the base c if (astr(ptr) .eq. 0) then base = 10 else if (astr(ptr) .eq. leto .or. astr(ptr) .eq. bigo .or. + astr(ptr) .eq. letb .or. astr(ptr) .eq. bigb) then base = 8 else if (astr(ptr) .eq. leth .or. astr(ptr) .eq. bigh) then base = 16 endif c c if didn't find a base c if (base .eq. 0) then call fprintf(stdout,'ctoi - invalid base @c\n',astr(ptr),0,0,0) ctoi = 0 return endif c c add up the digits c total = 0 isneg = 1 do 100 i = 1,eod ch = astr(i) if (ch .eq. minus) then isneg = -1 go to 100 endif if (base .eq. 10) then if (ch .lt. dig0 .or. ch .gt. dig9) then call fprintf(stdout,'ctoi - invalid decimal digit @c\n', + ch,0,0,0) ctoi = 0 return else ch = ch - dig0 endif else if (base .eq. 8) then if (ch .lt. dig0 .or. ch .gt. dig7) then call fprintf(stdout,'ctoi - invalid octal digit @c\n', + ch,0,0,0) ctoi = 0 return else ch = ch - dig0 endif else if (base .eq. 16) then if (ch .ge. dig0 .and. ch .le. dig9) then ch = ch - dig0 else if (ch .ge. leta .and. ch .le. letf) then ch = 10 + ch - leta else if (ch .ge. biga .and. ch .le. bigf) then ch = 10 + ch - biga else call fprintf(stdout,'ctoi - invalid hex digit @c\n', + ch,0,0,0) ctoi = 0 return endif endif total = total*base + ch 100 continue ctoi = total * isneg return end integer function itos(int,str,minwid) ccc itos - convert an integer to string format. c *call kermcom integer str(*) width = 0 if (int .lt. 0) then width = 1 str(width) = asc('-') endif val = iabs(int) ascii0 = asc('0') 10 width = width + 1 str(width) = mod(val,10) + ascii0 val = val / 10 if (val .ne. 0) go to 10 str(width+1) = 0 c c now reverse the digits c iptr = 1 endptr = width if (str(iptr) .eq. asc('-')) iptr = iptr + 1 20 if (iptr .lt. endptr) then tch = str(iptr) str(iptr) = str(endptr) str(endptr) = tch iptr = iptr + 1 endptr = endptr - 1 go to 20 endif itos = width return end subroutine getemsg(strng) ccc getemsg - get an error message string for the current error. c *call kermcom integer direc(8,2) integer packnam(9,0:6) data direc / 115, 101, 110, 100, 4*0, c s e n d + 114, 101, 99, 101, 105, 118, 101, 0 / c r e c e i v e data packnam / 85, 78, 75, 78, 79, 87, 78, 2*0, c u n k n o w n + 73, 110, 105, 116, 5*0, c i n i t + 70, 105, 108, 101, 110, 97, 109, 101, 0, c f i l e n a m e + 68, 97, 116, 97, 5*0, c d a t a + 69, 79, 70, 6*0, c e o f + 66, 114, 101, 97, 107, 4*0, c b r e a k + 83, 101, 114, 118, 101, 114, 3*0 / c s e r v e r if ((abortyp.and.initerr) .ne. 0) then ptyp = 1 else if ((abortyp.and.filerr) .ne. 0) then ptyp = 2 else if ((abortyp.and.dataerr) .ne. 0) then ptyp = 3 else if ((abortyp.and.eoferr) .ne. 0) then ptyp = 4 else if ((abortyp.and.brkerr) .ne. 0) then ptyp = 5 else if ((abortyp.and.srvcmd) .ne. 0) then ptyp = 6 else ptyp = 0 endif dtyp = shift(abortyp.and.o"300",-6) if ((abortyp.and.toomany) .ne. 0) then call sprintf(strng,'^cannot @s @s packet',direc(1, + dtyp),packnam(1,ptyp),0,0) else if ((abortyp.and.invalid) .ne. 0) then call sprintf(strng, + '^received an invalid packet while trying to @s @s packet', + direc(1,dtyp),packnam(1,ptyp),0,0) else if ((abortyp.and.seqerr) .ne. 0) then call sprintf(strng, + '^packet sequence error while trying to @s @s packet', + direc(1,dtyp),packnam(1,ptyp),0,0) else if ((abortyp.and.lclfile) .ne. 0) then call sprintf(strng,'^file is already local',0,0,0,0) else if ((abortyp.and.notlcl) .ne. 0) then call sprintf(strng,'^file is not local',0,0,0,0) else if ((abortyp.and.invfn) .ne. 0) then call sprintf(strng,'^invalid filename',0,0,0,0) else if ((abortyp.and.srvcmd) .ne. 0) then call sprintf(strng,'^unimplemented server command',0,0,0,0) endif return end integer function creat(fn) ccc creat - open a file for writing packet data to. c c creat will try to create a file to write to. if it c already exists, then it will fail. c *call kermcom character*10 filenam c c get the dpc version of the filename c call as2dpc(fn,filenam) call filchk(filenam) creat = fopen(filenam,create) return end subroutine getnow(mm,dd,yy,hr,min,sec) ccc get the current date and time. c *call kermcom character*10 date, time, string string = date() offset = ichar('0') c$ if (ut2d .eq. 1) dd = (ichar(string(2:2))-offset)*10 + ichar(string(3:3))-offset mm = -1 if (string(5:7) .eq. 'jan') then mm = 1 else if (string(5:7) .eq. 'feb') then mm = 2 else if (string(5:7) .eq. 'mar') then mm = 3 else if (string(5:7) .eq. 'apr') then mm = 4 else if (string(5:7) .eq. 'may') then mm = 5 else if (string(5:7) .eq. 'jun') then mm = 6 else if (string(5:7) .eq. 'jul') then mm = 7 else if (string(5:7) .eq. 'aug') then mm = 8 else if (string(5:7) .eq. 'sep') then mm = 9 else if (string(5:7) .eq. 'oct') then mm = 10 else if (string(5:7) .eq. 'nov') then mm = 11 else if (string(5:7) .eq. 'dec') then mm = 12 endif yy = (ichar(string(9:9))-offset)*10 + ichar(string(10:10))-offset c$ endif c$ if (nos .eq. 1) yy = (ichar(string(2:2))-offset)*10 + ichar(string(3:3))-offset mm = (ichar(string(5:5))-offset)*10 + ichar(string(6:6))-offset dd = (ichar(string(8:8))-offset)*10 + ichar(string(9:9))-offset c$ endif c$ if (nosbe .eq. 1) dd = (ichar(string(5:5))-offset)*10 + ichar(string(6:6))-offset mm = (ichar(string(2:2))-offset)*10 + ichar(string(3:3))-offset yy = (ichar(string(8:8))-offset)*10 + ichar(string(9:9))-offset c$ endif yy = yy + 1900 string = time() hr = (ichar(string(2:2))-offset)*10 + ichar(string(3:3))-offset min = (ichar(string(5:5))-offset)*10 + ichar(string(6:6))-offset sec = (ichar(string(8:8))-offset)*10 + ichar(string(9:9))-offset return end subroutine filchk(fn) ccc filchk - check and fix filename validity. c c check validity of filename. invalid characters are dropped c and the filename is truncated at 7 characters. if there c is still not a valid filename (all characters were bad) then c use file kermdat. c *call kermcom boolean ch character *(*) fn integer ptr,length c ptr = 0 length = len(fn) do 2 i=1,7 1 ptr = ptr + 1 if (ptr .gt. length) go to 3 ch = ichar(fn(ptr:ptr)) if (ch .lt. 1 .or. ch .gt. 36) go to 1 fn(i:i)=fn(ptr:ptr) 2 continue i = 8 c 3 if (length .gt. 7) then do 4 j=i,length fn(j:j) = ' ' 4 continue endif c c use our magic file if no valid characters in the file name. c this can happen as some micros allow things like '&' for c a file name. note that nos allows a digit in the first c character of an lfn while scope and nos/be do not. c c$ if(ut2d .eq. 1 .or. nosbe .eq. 1 .or. scope .eq. 1) if(ichar(fn(1:1)) .lt. 1 .or. ichar(fn(1:1)) .gt. 26) + fn = 'kermdat' c$ else if(ichar(fn(1:1)) .lt. 1 .or. ichar(fn(1:1)) .gt. 36) + fn = 'kermdat' c$ endif return end subroutine rdparam(pdata) ccc rdparam - get the packet parameters from the other kermit. c *call kermcom boolean pdata(*) integer params(11) equivalence (params,spksiz) c c define ctl and unchar statement functions c ctl(ascch) = ascch .xor. o"100" unchar(ascch) = ascch - blank c c cycle through the list of parameters until the end-of-list c is found (a 0 byte). c i = 1 10 if (pdata(i) .ne. 0) then c c is it the pad character? c if (i .eq. 4) then params(i) = ctl(pdata(i)) if (params(i) .eq. 0) params(i) = null c c is it the quote character? c else if (i .eq. 6) then params(i) = pdata(i) else if (unchar(pdata(i)) .ne. 0) then params(i) = unchar(pdata(i)) endif endif i = i + 1 go to 10 endif return end subroutine remove(fn) ccc remove - remove a file from the local file list. c *call kermcom boolean fn(*) character*10 lfn c c quit if nothing useful in the file name array. c if(fn(1) .eq. 0) return c c convert the file name to display code. c call as2dpc(fn,lfn) c c get rid of the file. c call retfile(lfn) return end subroutine strcpy(s1,s2) ccc strcpy - copy one ascii string to another c *call kermcom boolean s1(*),s2(*) i1 = 1 10 s2(i1) = s1(i1) if (s1(i1) .ne. 0) then i1 = i1 + 1 go to 10 endif return end integer function slen(str) ccc slen - return the length of a zero terminated ascii string buffer. c *call kermcom boolean str(*) i = 0 10 if (str(i+1) .ne. 0) then i = i + 1 go to 10 endif slen = i return end integer function sndpar(pdata) ccc sndpar - set up parameters to send to other kermit. c *call kermcom boolean pdata(*) c c define ctl and tochar statement functions c ctl(ascch) = ascch .xor. o"100" tochar(ascch) = ascch + blank c c send what we want c pdata(1) = tochar(packsiz) pdata(2) = tochar(timeout) pdata(3) = tochar(npad) pdata(4) = ctl(padch) pdata(5) = tochar(eolch) pdata(6) = quotech pdata(7) = 0 c c return length of how many things we want to set c sndpar = 6 c c other values are set by default to not operate c return end subroutine sleep(seconds) cc sleep - use periodic recall to delay things. c c entry seconds = integer number of seconds to sleep. c c exit indicated number of seconds has elapsed. c *call kermcom do 100 i=1,seconds call delay(1000) 100 continue return end subroutine delay(msec) cc delay - delay for a few milliseconds. c c entry msec = delay time in milliseconds. c c exit time has elapsed. c c notes works for scope, ut2d, and nos/be systems. nos users must c change the computation to account for the difference c in data returned by rtime macro. c *call kermcom c c use real time clock to control delay period. c call rtime(rtcl) rtcl = and(rtcl,compl(mask(24))) 10 call rtime(rtcl1) rtcl1 = and(rtcl1,compl(mask(24))) c c convert from seconds/4096 to milliseconds. c if((rtcl1-rtcl)/4.096 .gt. msec) return c c sleep for 100 milliseconds. c call recall(0) go to 10 end subroutine echoplx(ecmode) *** echoplx - set echoplex mode for 2550 front end. * * depends on u of arizona modifications to cci, plus a u of * arizona pp routine 'uui'. this subroutine is only called * from stty if uariz is defined. * * entry ecmode = 'on' or 'off' to enable or disable echoplex. * * exit uui called to change echoplex mode. *call kermcom c c don't compile if not university of arizona c c$ if (uariz .eq. 1) boolean echofnc, echooff, echoon, uuiwd character*(3) ecmode parameter (echofnc=o"10",echooff=0,echoon=1) if(ecmode .eq. 'on') then uuiwd = or(shift(echoon,12),echofnc) elseif(ecmode .eq. 'off') then uuiwd = or(shift(echooff,12),echofnc) else call remark(' kermit - invalid echoplex option.') call abtp("nd") endif call mtr(l"uui","rcl",locf(uuiwd)) * nudge 2550 into processing the reconfiguration message * sent by the uui call, so echo gets fully reset, even if * next kermit operation is a read, not a write. call putc(null,stdout) call fflush(stdout) c$ endif return end integer function getrec(fd,wsa,wsal,eofflag) cc getrec - get a record from a file. c c nread = getrec(fd,wsa,wsal,eofflag) c c entry fd = file descriptor. c wsal = length of wsa. c c exit wsa contains data record. c nread = number of words actually placed in wsa c eofflag = .true. if eof hit (iff nread .eq. 0). c c notes performs display to ascii conversion if needed. *call kermcom parameter (intrcom = 42, asc128 = 22, asc256 = 23) parameter (first = 1, in = 2, out = 3, limit = 4, intwd = 5) boolean status, wsa(wsal) logical eofflag eofflag = .false. c c start read if possible, and determine disk character set c if not in raw data mode. c 1 if(.not. ctdev(fd) .and. and(fets(0,fd),o"1") .eq. o"1") then if(fets(in,fd) .eq. fets(out,fd) .and. + and(fets(0,fd),o"20") .eq. 0) then call read(fets(0,fd)) if(.not. rawmode) then cset = xscs(fets(0,fd)) if(cset .eq. 0) go to 1 if (cset .eq. -1) then dskcset = dsknos8 c$ if (ut2d .eq. 1) c must set nos bit for screwy coded read routines fets(first,fd) = fets(first,fd) + .or.shift(1,nosbit) c$ endif elseif(cset .eq. -2) then dskcset = dskut8 c$ if (ut2d .eq. 1) c must clear nos bit for screwy coded read routines fets(first,fd) = and(fets(first,fd), + .not.shift(1,nosbit)) c$ endif endif if(cset .lt. 0) then c$ if (ut2d .eq. 1) c these are needed for strange coded read routines. fets(first,fd) = fets(first,fd).or.shift(1,asciiio) c$ endif else dskcset = dskdpc c$ if (ut2d .eq. 1) fets(first,fd) = and(fets(first,fd), + .not.shift(1,asciiio)) c$ endif endif endif endif endif c c process terminal devices. c if(ctdev(fd)) then c$ if (ut2d .eq. 1) then fets(first,fd) = or(fets(first,fd),shift(1,asciiio)) c$ else fets(first,fd) = or(fets(first,fd),shift(1,intrcom)) fets(intwd,fd) = shift(1,asc128) if(binmode .or. rawmode) fets(intwd,fd) = shift(1,asc256) c$ endif c$ if (nos .eq. 1) c$ if (noslvl .ge. 602) c c wait for input checking for timeout on read c if (binmode .or. rawmode) then nosdlay = stimout * 1000 else nosdlay = rdelay endif do 10 irdl = 1, nosdlay, 24 if (nosctab().ne.0) goto 11 call noswait 10 continue if (binmode .or. rawmode) then call remark(' kermit - read timeout....') endif c$ else if (rdelay .gt. 0) call delay(rdelay) c$ endif 11 continue c$ else if (rdelay .gt. 0) call delay(rdelay) c$ endif call readc(fets(0,fd),wsa,wsal,status) if(status .eq. 0) then nread = wsal elseif(status .lt. 0) then c$ if (nos .eq. 1) nread = 0 c c give poor user another prompt c if ((.not. rawmode) .and. (.not. binmode)) then call memstat call fprintf(stdout,'^kermit-170>',0,0,0,0) call fflush(stdout) call writer(fets(0,stdout)) call read(fets(0,fd)) endif goto 1 c$ else nread = 0 eofflag = .true. c$ endif else nread = status - locf(wsa) fets(0,fd) = or(and(fets(0,fd),shift(mask(44),2)),ciord) if(nread .le. 0) go to 1 endif c$ if (nos .eq. 1) if (nread .gt. 0) call conbuff(wsa, nread, eofflag, status) c$ endif getrec = nread if(nread .gt. 0) getrec = findeol(wsa,nread,.not. binmode) else c c process mass storage (disk) files. c if(rawmode) then call readw(fets(0,fd),wsa,wsal,status) elseif((dskcset.and.dskasci) .ne. 0) then call readc(fets(0,fd),wsa,wsal,status) else call readc(fets(0,fd),wsa(wsal / 2 + 1),wsal / 2, status) if(status .ge. 0) then call edl(wsa,wsa(wsal / 2 + 1),wsal / 2,status) endif endif c c process mass storage (disk) file status return. c if(status .eq. 0) then getrec = findeol(wsa,wsal,.not. rawmode) elseif(status .gt. 0) then getrec = findeol(wsa,status - locf(wsa),.not. rawmode) fets(0,fd) = or(and(fets(0,fd),shift(mask(44),2)),ciord) if(getrec .le. 0) go to 1 elseif(status .eq. -1) then getrec = 0 fets(0,fd) = or(and(fets(0,fd),shift(mask(44),2)),ciord) c$ if (ut2d .eq. 1) then eofflag = .true. c$ else go to 1 c$ endif else getrec = 0 eofflag = .true. endif endif return end integer function findeol(wsa,wsal,addnel) cc findeol - find eol byte in working buffer. c c len = findeol(wsa,wsal,addnel) c c entry wsa = line image. c wsal = length of wsa. c addnel = .true. if a nel should be stuffed in buffer. c c exit len = length of data line in words. *call kermcom boolean wsa(wsal) logical addnel c c if the line length is zero, return zero length. c if(wsal .le. 0) then findeol = 0 return endif c c find eol, and stick nel in if needed. c do 10 i = 1, wsal if((and(wsa(i),o"7777") .eq. 0) .or. + (and(wsa(i),o"7777") .eq. nel)) then if(addnel .and. (dskcset.ne.dskut8)) wsa(i) = or(wsa(i),nel) findeol = i return endif 10 continue if(addnel) wsa(wsal) = or(and(wsa(wsal),mask(48)),nel) findeol = wsal return end subroutine edl(ascbuf,dpcbuf,dpcbufl,status) cc edl - expand display code line. c c call edl(ascbuf,dpcbuf,dpcbufl,status) c c entry dpcbuf = display code line image. c dpcbufl = dimensioned size of dpcbuf. c status = readc status. c c exit ascbuf = ascii line. c status = lwa + 1 of data converted, iff status was c non-zero on entry to edl. c c notes edl must not be called with negative status values. *call kermcom boolean ascbuf(*), dpcbuf(dpcbufl), dpcch, status, tempdpc c c determine number of words in buffer (worst case). c wc = dpcbufl if(status .gt. 0) wc = status - locf(dpcbuf) if(wc .le. 0) then status = locf(ascbuf) return endif c c now scan for zero byte. c do 10 i = 1, wc if(and(dpcbuf(i),o"7777") .eq. 0) go to 1 10 continue c c no eol was found, so we force one in the last word. c i = wc dpcbuf(i) = and(dpcbuf(i),mask(48)) c c at this point, 'i' contains the position of the eol word. c 1 eolwd = i ascbuf(1) = 0 if(eolwd .eq. 1 .and. dpcbuf(eolwd) .eq. 0) return if(eolwd .gt. 1 .and. dpcbuf(eolwd) .eq. 0 .and. + and(dpcbuf(eolwd - 1),o"77") .eq. 0) eolwd = eolwd - 1 c c now we convert everything up to the eol word, but not the eol word c itself, as we do not want to 'convert' the line terminator. c wc = 0 if(eolwd .gt. 1) then call xsxt(dpcbuf,eolwd - 1,ascbuf,uascii) wc = 2 * (eolwd - 1) endif c c now convert the eol word. code can handle overlapping buffers. c wc = wc + 1 tempdpc = dpcbuf(eolwd) ascbuf(wc) = 0 ascbuf(wc + 1) = 0 do 20 i = 0, 9 tempdpc = shift(tempdpc,6) dpcch = and(tempdpc,o"77") tempdpc = and(tempdpc,mask(54)) if(tempdpc .eq. 0 .and. dpcch .eq. 0) then if(status .gt. 0) status = locf(ascbuf(wc + i / 5)) + 1 return endif ascbuf(wc + i / 5) = or(ascbuf(wc + i / 5), + shift(uascii(dpcch),60 - 12 * (mod(i,5) + 1))) 20 continue if(status .gt. 0) status = locf(ascbuf(wc + 1)) + 1 return end ident makefet entry makefet sst syscom b1 makefet title makefet - make a file environment table. comment make a file environment table. makefet space 4,10 ** makefet - make a file environment table. * * call makefet(lfn,fet,fetl,ciobuf,ciobufl) * * entry (lfn) = is the character*7 file name. * (fet) = an array to receive the fet. * (fetl) = length of fet in words (minimum of 5). * (ciobuf) = an array to be used as the cio buffer. * (ciobufl) = the length of ciobuf. * * exit fet built. makefet subr entry/exit sb1 1 always sa2 a1+b1 sb6 x2 (b6) = fet address sa2 a2+b1 sa3 x2 (x3) = fet length sa2 a2+b1 sx6 x2 (x6) = fwa of cio buffer sa2 a2+b1 sa2 x2 (x2) = buffer length ix7 x6+x2 (x7) = limit pointer sa6 b6+2 set in and out sa6 a6+b1 sa7 a6+b1 set limit sx7 x3-5 (x7) = fet length - 5 sb7 x7 lx7 18 bx6 x6+x7 add (fet length - 5) to first sa6 b6+b1 set first mx7 0 makefet1 gt b7,b0,makefet2 if no more words to set sa7 a7+b1 sb7 b7-b1 eq makefet1 loop till done makefet2 sb7 b1 length of transfer rj =xmfs> move lfn into fet sa1 b6-b1 rj =xbtz> convert blanks to 00b sx1 b1 add complete bit to lfn bx6 x6+x1 sa6 a1 eq makefetx return end *if def,nosbe ident cfe entry cfe syscom b1 cfe title cfe - check files existance. comment check files existance. cfe space 4,10 ** cfe - check files existance. * * logical cfe, result * * result = cfe(lfn) * * entry (lfn) = is the character*7 file name. * * exit (result) = .true. if file exists. * (result) = .false. otherwise. cfe subr entry/exit sb1 1 always sb6 cfea sb7 b1 rj =xmfs> move lfn into filinfo block sa1 cfea rj =xbtz> convert blanks to 00b sx1 4 block length lx1 12 bx6 x6+x1 sa6 a1 mx7 0 clear rest of block sa7 a6+b1 sa7 a7+b1 sa7 a7+b1 sa7 a7+b1 filinfo cfea check on file mx6 0 assume no file (.false.) mx7 12 sa1 cfea+1 bx7 x7*x1 (x7) = device code if file exists, or 0 zr x7,cfex if no file mx6 -1 set file found (.true.) eq cfex return cfea vfd 42/**,6/4,12/0 filinfo block bssz 4 end *endif *if -def,nosbe ident cfe entry cfe sst syscom b1 cfe title cfe - check files existance. comment check files existance. cfe space 4,10 ** cfe - check files existance. * * logical cfe, result * * result = cfe(lfn) * * entry (lfn) = is the character*7 file name. * * exit (result) = .true. if file exists. * (result) = .false. otherwise. cfe subr entry/exit sb1 1 always sb6 cfea sb7 b1 rj =xmfs> move lfn into filinfo block sa1 cfea rj =xbtz> convert blanks to 00b sx1 b1 set complete bx6 x6+x1 sa6 a1 mx7 0 clear rest of block sa7 a6+b1 sa7 a7+b1 sa7 a7+b1 sa7 a7+b1 status cfea check on file mx6 0 assume no file (.false.) mx7 11 lx7 12 sa1 cfea bx7 x7*x1 (x7) = 0 if file doesn't exist zr x7,cfex if no file mx6 -1 set file found (.true.) eq cfex return cfea bssz 1 fake fet end *endif subroutine conbuff (buf, wc, eofflag, status) *call,kermcom c$ if (nos .eq. 1) boolean buf(1), nosbuf(maxwd) logical eofflag, conbug data conbug / .false. / c check for special *eof* flag. if (wc .eq. 1 .and. buf(1) .eq. shift(r"^<",48)) then wc = 0 eofflag = .true. return endif c copy the buffer first savewc = wc do 1 i = 1, wc 1 nosbuf(i) = buf(i) if (debug .ne. 0 .and. conbug) then call fprintf(debugfd, 'conbuff called.\n',0,0,0,0) endif ips = 0 ipw = 1 ops = 60 opw = 1 buf(opw) = 0 c c now scan for zero byte. c do 2 i = 1, wc if(and(nosbuf(i),o"7777") .eq. 0) go to 3 2 continue c c no eol was found, so we force one in the last word. c i = wc nosbuf(i) = and(nosbuf(i),mask(48)) c c at this point, 'i' contains the position of the eol word. c 3 eolwd = i if(eolwd .eq. 1 .and. nosbuf(eolwd) .eq. 0) return c c check for the famous 66-bit end-of-line!!! c if(eolwd .gt. 1 .and. nosbuf(eolwd) .eq. 0 .and. + and(nosbuf(eolwd - 1),o"77") .eq. 0) eolwd = eolwd - 1 c calculate the character position of the last *real* character! do 4 j = 6, 54, 6 if ((compl(mask(60-j)) .and. nosbuf(eolwd)) .ne. 0) then lps = 72 - j goto 5 endif 4 continue lps = 6 c c now convert the characters! c 5 nose = 0 lch = 0 if (debug .ne. 0 .and. conbug) then call fprintf(debugfd,' conbuff - wc @d\n', wc,0,0,0) call fprintf(debugfd,' conbuff - el @d\n', eolwd,0,0,0) call fprintf(debugfd,' conbuff - ls @d\n', lps,0,0,0) endif 10 ips = ips + 6 if (ips .eq. 66) then ips = 6 ipw = ipw + 1 endif if (debug .ne. 0 .and. conbug) then call fprintf(debugfd,' conbuff - is @d\n', ips,0,0,0) call fprintf(debugfd,' conbuff - iw @d\n', ipw,0,0,0) endif if (ipw .eq. eolwd .and. ips .ge. lps) then if (.not.rawmode) then ch = nel lch = nel goto 40 else goto 50 endif endif ich = and(shift(nosbuf(ipw), ips), o"77") if (debug .ne. 0 .and. conbug) then call fprintf(debugfd,' conbuff - ich @d\n', ich,0,0,0) endif if (nose .eq. 0) then if (ich .eq. r"@") then nose = ich else if (ich .eq. r"^") then nose = ich else if (ich .ge. r"a" .and. ich .le. r"z") then if (.not.(binmode .or. rawmode)) then ch = lascii(ich) else ch = uascii(ich) endif else ch = uascii(ich) endif else if (nose .eq. r"^") then nose = 0 if (ich .ge. r"a" .and. ich .le. r"z") then ch = lascii(ich) else if (ich .ge. r"0" .and. ich .le. r"4") then ch = ich + o"140" else if (ich .ge. r"5" .and. ich .le. r";") then ch = ich - o"40" if (ch .eq. 0) ch = nul else ch = nul endif else if (nose .eq. r"@") then nose = 0 if (ich .eq. r"a") then ch = lascii(r"@") else if (ich .eq. r"b") then ch = lascii(r"^") else if (ich .eq. r"d") then ch = lascii(r":") else if (ich .eq. r"g") then ch = o"140" else if (ich .eq. r"h") then ch = cr else if (ich .eq. r"i") then ch = lf else ch = nul endif endif c c process this character. c if (nose .ne. 0) then goto 10 else if (ch .lt. 0) then goto 10 else if (ch .eq. lf .and. .not. rawmode) then goto 10 else if (ch .eq. cr .and. .not. rawmode) then ch = nel else if (ch .eq. nul .and. .not. rawmode) then goto 10 endif c c really process the character. c 40 if (debug .ne. 0 .and. conbug) then call fprintf(debugfd,' conbuff - ich @d\n', ich,0,0,0) call fprintf(debugfd,' conbuff - ch @d\n', ch,0,0,0) call fprintf(debugfd,' conbuff - ch @c\n', ch,0,0,0) endif c c put it in the buffer c if (ops .eq. 0) then ops = 48 opw = opw + 1 buf(opw) = 0 else ops = ops - 12 endif buf(opw) = buf(opw) .or. shift(ch,ops) if (lch .eq. 0) goto 10 c we are now done. 50 wc = opw if (debug .ne. 0 .and. conbug) then call fprintf(debugfd, ' conbuff exited.\n',0,0,0,0) endif c$ endif return end