home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
kermit.columbia.edu
/
kermit.columbia.edu.tar
/
kermit.columbia.edu
/
archives
/
hp1000.zip
/
k6subs.ftn
< prev
next >
Wrap
Text File
|
2011-08-10
|
27KB
|
672 lines
subroutine SetTrap(SyRv) ,<881219.1353>
>Set Fortran Trapping
implicit none
! K6SUBS contains routines which are specific to RTE-6. This
! revision operates with KERMIT revision 1.99 or later.
! This routine is actually system-independent. It is included in the
! system-dependent outines only because it contains conditionally-
! compiled code. If the user MUST use this KERMIT on a C.83 system,
! having this routine here will reduce the installation time greatly.
! BE SURE TO RE-INDEX the appropriate library file!
include kercom.ftni,NOLIST !Defines "SysRev"
integer*2 SyRv
external FtnTrap
if (SysRev .ge. 2440) then !Fortran trapping desired?
if (SyRv .ge. 2440) then !Yes - is it available?
call Ftrap(FtnTrap) !Yes - use it
else
call tpFm('You must set "SysRev" (in KERCOM) <_')
call tpFm(' 2440, then recompile/relink KxSubs!')
call quit
endif
endif
return
end
subroutine restore(lu) ,<881219.1353>
>6/Restore LU's
implicit none
include kercom.ftni,NOLIST
include kercnf.ftni,NOLIST
integer*2 lu,cnf(CnfSiz)
logical*2 fMux
integer*2 timv,ctrg,c17s,c30c,c30s,c33c,c33s,c34c,c34s
equivalence (fMux,Cnf(fMx)), (timv,Cnf(tim)), (ctrg,Cnf(trg))
equivalence (c17s,Cnf(v17))
equivalence (c30c,Cnf(c30)), (c33c,Cnf(c33)), (c34c,Cnf(c34))
equivalence (c30s,Cnf(s30)), (c33s,Cnf(s33)), (c34s,Cnf(s34))
! This routine differs from its RTE-A counterpart in that IDM00
! has a CN45 request to kill the DC1 trigger character, which would
! need to be restored. The DVM00 trigger handling is part of the
! DDV05 device-driver, which is restored (if needed) when we do the
! CN33 to restore the driver-responses configuration.
if (lu .eq. L) then !Use which configuration array?
call MoveWords(LocCnf,cnf,CnfSiz)
else
call MoveWords(RemCnf,cnf,CnfSiz)
endif
call Set_timeout(lu,timv,fMux) !Restore original timeout
if (.not. fMux) return !Not mux? Nothing left to do
c At this point, we will restore ONLY those parameters we have altered
c as a result of KERMIT's normal operations.
if (c30c .ne. c30s) then
call control(lu,3000b,c30s) !restore char format
endif
if (c33c .ne. c33s) then
call control(lu,3300b,c33s) !restore configuration
endif
if (c34c .ne. c34s) then
call control(lu,3400b,c34s)
endif
if (.not. btest(cnf,0) ) then !D mux?
call control(lu,3700b,173400b) !No: allow echo/edit; end on CR
else ! --> Need not yet established!
call control(lu,1700b,c17s) !Yes: restore terminator
endif
return
end
subroutine enable(lu,imux) ,<881219.1353>
>6/Enable int-scheduling
implicit none
integer*2 lu,imux
! This routine differs from its RTE-A counterpart in that IDM00
! muxt keep up with the names of the interrupt-scheduled programs
! and DVM00 doesn't.
if (.not. btest(imux,0) ) then !B/C mux?
call control(lu,3700b,173400b) !cn37: set read type
endif
call control(lu,2000b,0) !cn20: enable interrupts
return
end
subroutine disable(lu,imux) ,<881219.1353>
>6/Disable int-scheduling
implicit none
integer*2 lu,imux
! This routine differs from its RTE-A counterpart in that IDM00
! uses CN23 to disable interrupts, whereas DVM00 should agree with
! the RTE-6 "D" mux driver in using a CN21 to do the same job.
call control(lu,2100b,0) !cn21: disable interrupts
return
end
subroutine set_timeout(lu,val,imux) ,<881219.1353>
>6/Set LU timeout value
implicit none
integer*2 lu,val,imux
! This routine differs from its RTE-A counterpart in that IDM00
! has two flavors of timeout ("user" and "system") where DVM00 has
! only one.
if (val .lt. 0) return !Don't set negative time-outs
call control(lu,2200b,val) !cn22: set time-out
return
end
subroutine KillEnqAck ,<881219.1353>
>6/Disable ENQ/ACK
implicit none
include kercom.ftni,NOLIST
include kercnf.ftni,NOLIST
! This routine differs from its RTE-A counterpart in that IDM00
! has a CN45 request to clear the trigger-character, whereas DVM00
! uses DDV05 to perform triggering, and we bypass that anyway.
if ( btest(iRmx,0) ) then !D-mux?
if ( btest(r34c,0) ) then !XON/XOFF enabled?
r34c = 5 !Yes - add CPU<-->CPU protocol
else
r34c = 4 !else change to CPU<-->CPU proto
endif
call control (R,3400b,r34c)
r33c = 100000b !Turn on FIFO mode
else
if ( btest(r30c,7) ) then !Is Enq/Ack on now?
r30c = ibclr(r30c,7) !Yes - turn it off
call control(R,3000b,r30c)
endif
r33c = 22501B !Bypass dev-drvr/type-ahead on
endif
call control(R,3300b,r33c)
! If we are really modifying the local configuration, we must track
! the changes to the local array, or RESTORE won't work correctly!
if (R .eq. L) call MoveWords(RemCnf,LocCnf,CnfSiz)
return
end
Subroutine cPrep ,<881219.1353>
>6/Prepare for Connect
implicit none
include kercom.ftni,NOLIST !Defines L and R
include kercnf.ftni,NOLIST
include kconcw.ftni,NOLIST
! This routine differs from its RTE-A counterpart in the function-
! codes it sets for IDM00 (12040B/C) vs. DVM00 (12792B/C), and for
! ID*00 (12005) vs. DVA05 (12966).
call disable(L) !Kill local interrupt scheduling
Ltx=L $ Lrx=L $ Rtx=R $ Rrx=R !Prepare XLUEX hi control words
term = 1200b !(B/C mux terminate rcv buffer)
dstat = 600b !Dynamic status request code
! Prepare the local LU for connect - allows 12966 and 2 Mux types
if ( fLmx ) then !Local on a mux?
if ( fLcm ) then !Yes - if B or C mux...
Lrc = 3300b !transparent + save t-a data
L33c = iand(L33c,17b) .or. 22600b !Turn on type-ahead
call control(L,3300b,L33c)
call control(L,3600b,1) !Set read length
call control(L,3700b,4000b) !Terminate on count only
call control(L,term,0) !Terminate all buffers
call control(L,term,0) !Terminate all buffers again
call control(L,term,0) !Terminate all buffers once more
else
Lrc = 100b !D mux uses only binary
L33c = 100000b !Turn on FIFO mode
call control(L,3300b,L33c)
endif
call control(L,2600b,1) !Flush card
else
Lrc = 100b !binary
endif
Ltc = 2000b !transparent
! Prepare the remote LU for connect - allows for 2 mux types only
if ( fRcm ) then !Prepping a B/C mux port?
Rrc = 3300b !transparent + save t-a data
Rtc = 3300b !transparent
R33c = (R33c.and.17b) + 22600b !cn33: read reconfig off
call control(R,3300b,R33c)
call control(R,3600b,254) !cn36: set read len (254 bytes)
call control(R,3700b,4000b) !cn37: terminate on count only
call control(R,term,0) !terminate all buffers
call control(R,term,0) !terminate all buffers again
call control(R,term,0) !terminate all buffers once more
call sleep(10) !allow .1 sec settling time
else
Rrc = 100b !D-mux is simple: just binary
Rtc = 2000b !...still simple: transparent
endif
if ( fLmx ) call control(L,2600b,1) !Flush local if on a mux
call control(R,2600b,1) !Flush remote
return
end
integer*2 function GetPak() ,<881219.1353>
>6/Read a packet
implicit none
include kercom.ftni,NOLIST
include kercnf.ftni,NOLIST !To define iRmx
integer*2 buf(128),xr(2),cw
equivalence (buf,RecPkt),(xr(2),cw)
! This routine differs from its RTE-A equivalent in that we must
! bypass DD*00 and suppress a trigger in the read call under RTE-A.
if ( btest(iRmx,0) ) then !D-mux?
cw = 0 !Yes - set for normal ASCII
else
cw = 3000b !B/C: transparent, keep t-a data
endif
xr = R !Set remote lu into control word
call xluex(1,xr,buf,-254) !Read a buffer
call abreg(GetPak,rlen) !Get the received length
return
end
subroutine PutPak(len) ,<881219.1353>
>6/Send a packet
implicit none
include kercom.ftni,NOLIST
include kercnf.ftni,NOLIST !Defines iRmx
integer*2 len,xl(2),cw,PakBuf
equivalence (xl(2),cw),(Packet,PakBuf)
data cw /2000b/ !transparent
! This routine differs from its RTE-A counterpart in that we must
! bypass DD*00 and suppress handshake under RTE-A.
xl = R !Get the remote LU
call control(R,2600b,1) !Flush card before sending
call xluex(2,xl,PakBuf,-len)
return
end
subroutine GetMux(LU,CnfArr) ,<881219.1353>
>6/Get MUX info
implicit none
! This routine fills the Loc or Rem CNF array for the given LU.
! If it uses the new serial drivers, we can ask the driver what kind of
! card the LU is connected to; if it doesn't, we will look in the DVP
! of the LU to see what we can learn.
!
! The value placed in fLmx or fRmx tells KERMIT what kind of LU it is:
! Bit 15: set if LU supports KERMIT protocol as follows
! RTE-A: 12040 mux only
! RTE-6: 12792 mux (or 12966 using DVW00 - see note below)
! Bit 0: set if LU is on a D MUX
! Bit 1: set if LU is on the A400 OBIO
!
! NOTE: This version of KERMIT doesn't actually support the 12966/DVW00
! combination. It is supported by KERMIT-CX as part of CONNECT,
! which is a terminal-emulation program by ICT. If KERMIT-RTE
! does things which you would like to see in KERMIT-CX, ask Don
! Wright (at ICT) to add the appropriate code.
$alias /datc/ = '$DATC', NoAllocate
$alias opsy = '.OPSY', direct
$alias xla = '.XLA', direct
$alias xluex, NoAbort
include kercnf.ftni,NOLIST
include kercom.ftni,NOLIST
integer*2 LU,CnfArr(CnfSiz)
integer*2 xl(2),cw,j,a,b,z,datc,eqta,eqxa
integer*2 LuTru,AddressOf,IxGet,opsy,xla,sc,eqx
integer*2 naRd,naCn
parameter (naRd = 100001b)
parameter (naCn = 100003b)
logical*2 xftty
common /datc/ datc
equivalence (xl(2),cw)
integer*2 Cnf(CnfSiz)
logical*2 fmxc
integer*2 imxc,syuc,timc,trgc,v17c
integer*2 c30c,c33c,c34c,s30c,s33c,s34c
equivalence (fmxc,imxc,Cnf(fmx)),(syuc,Cnf(syu))
equivalence (timc,Cnf(tim)),(trgc,Cnf(trg)),(v17c,Cnf(v17))
equivalence (c30c,Cnf(c30)),(c33c,Cnf(c33)),(c34c,Cnf(c34))
equivalence (s30c,Cnf(s30)),(s33c,Cnf(s33)),(s34c,Cnf(s34))
! The following are equivalences to cfg (in kercnf.ftni)
character*6 pnam,snam
character*4 dnam,inam
integer*2 drev,dvt6,dvad,irev,frev
integer*2 cn17,cn22,cn30,cn31,cn33,cn34,dv20
equivalence (dnam, cfg(1)),(drev, cfg(4)),(dvt6, cfg(5))
equivalence (dvad, cfg(6)),(inam, cfg(7)),(irev,cfg(10))
equivalence (frev,cfg(11)),(pnam,cfg(12)),(snam,cfg(15))
equivalence (cn17,cfg(18)),(cn22,cfg(19)),(cn30,cfg(20))
equivalence (cn31,cfg(21)),(cn33,cfg(22)),(cn34,cfg(23))
! cfg words 24-31 are currently (rev 4.1) spares
equivalence (dv20,cfg(32))
!Statement function:
sc(j) = ixget(j) .and. 77b !Get/isolate a select-code
eqx(j) = ixget(j+8) .and. 377b !Get/isolate the EQTX size
! This routine differs from its RTE-A counterpart in that the
! determination of the interface type is different.
j = opsy() !Get the operating-system type
if (j .ne. -17) then
call tpFm('Aborting - not set up for this system!')
call exec(6)
endif
Cnf = 0
Call MoveWords(Cnf,Cnf(2),CnfSiz-1) !Clear the configuration array
syuc = LuTru(LU) !Get system LU
xl = syuc .or. 100000b !Set session override for XLUEX
imxc = 0 !Preset to 'not a mux'
if (xla(datc) .lt. 2440) then !timeout bit moved at rev 2440
rtoBit = 7
else
rtoBit = 0
endif
if ( xftty(xl) ) then !If interactive...
cw = 60600b !see if we can do SSR
call xluex(naCn,xl,-2,*10) !No-abort special dynamic status
call abreg(a,b) !Get the return flag
if (b .ne. 123456b) goto 10 !Not SSR compatible
cw = 3700b !Prepare for the SSR
call xluex(naRd,xl,cfg,32,*30) !Do the SSR
if (dnam .eq. 'DV80') then !Remains to be seen what happens
imxc = 100001b
rtoBit = 1 !just a guess...
endif
if (imxc .eq. 0) goto 20 !Not a mux? Just return to caller
v17c = cn17 !Get current terminator
timc = cn22 !Current time-out value
c30c = cn30 !Current CN30 value
c33c = cn33 !Current CN33 value
c34c = cn34 !Current CN34 value
endif
goto 20
! We come here if the LU is interactive but the driver won't do SSR.
! We decide it is a MUX LU if there are 3 or more EQTs using the
! same select-code (Don Wright: thanks for that idea!). We must also
! eliminate DVV00 LUs, so each of the LUs using the same select-code
! must also have an EQT-extension of more than 13 words. Sad to say,
! once DVM00 is happy with the EQTX size, it clears that word, so we
! must also allow the EQTX size to be zero!
10 call exec(13,LU,a,b) !Get the EQT4 value in "b"
b = b .and. 77b !Isolate the select-code
eqta = IxGet(1650b) + 3 !Point to 1st EQT4 word
a = 0 !Clear the loop counter
do j = 1,IxGet(1651b) !Loop through the EQT table
if (sc(eqta) .eq. b) then !Same select-code?
z = eqx(eqta) !Get the EQT-extension size
if (z.gt.13 .or. z.eq.0)
> a = a + 1
endif
eqta = eqta + 15 !Bump to next EQT4
end do
if (a .lt. 3) goto 20 !probably not a mux
imxc = 100000b !Flag as KERMIT-useable
eqta = IxGet(1652b) + syuc - 1 !Find my DRT entry
eqta = IxGet(eqta) .and. 377b !Find my EQT-number
eqta = IxGet(1650b) + (eqta-1)*15 !Find my EQT entry
timc = abs(IxGet(eqta+13)) !Get current timeout value
eqxa = IxGet(eqta+12) !Get my EQT-extension address
c30c = IxGet(eqxa + 4) !Get the current CN30 value
c33c = IxGet(eqxa + 5) !Get the current CN33 value
if (iand(c33c,177760b) .eq. 0) then !any cn33 configuration set up?
c33c = c33c .or. 52500b !No - set power-on defaults
endif
!Note: the cn34 parameter isn't needed with 12792B/C muxes
20 call MoveWords(c30c,s30c,3) !Copy current values to saves
call MoveWords(cnf,CnfArr,CnfSiz) !Copy config back to caller
return
30 call tpFm('Aborting: SSR-compatible driver rejected the SSR')
call quit
end
subroutine LogOff ,<881219.1353>
>6/Log the server off
implicit none
include kercom.ftni,NOLIST !Needed for system
integer*2 sess,Eqt,EqTypA,EqTyp,junk,err,ime(3)
integer*2 LuTru,LuSes,LogLu,ixget
integer*2 drt,eqta
character*6 me
equivalence (me,ime)
! This routine differs from its RTE-A counterpart in that the jobs
! performed by the log-off program are completely different under
! RTE-A and under RTE-6. Further, CLGOF doesn't exist for RTE-6!
sess = LuTru( L ) !Get our true terminal LU#
! Trace down the EQT entry for this session - we will be modifying
! the device type so that it doesn't look interactive.
drt=ixget(1652b) $ eqta=ixget(1650b)!Locate system tables
Eqt = ixget(drt+sess-1) .and. 377b !Get our EQT#
EqTypA = (Eqt - 1) * 15 + eqta + 4 !Locate device-type word
junk = ixget(EqTypA) !Get current device-type word
EqTyp = junk .and. 37400b !Isolate current device-type
junk = junk .or. 37400b !Turn us into an instrument...
call ixPut(EqTypA,junk) !...now!
call clgof(sess,1,err) !Log us off now
junk = ixget(EqTypA) .xor. 37400b .or. EqTyp
call ixPut(EqTypA,junk) !Restore device-type word
call pname(ime) !Who am I
call ShootProg(me,'8') !Commit suicide
end
subroutine clgof(sess,dum1,dum2) ,<881219.1353>
>6/Perform programmatic log-off
implicit none
! CLGOF logs the session indicated by SESS off.
!
! This routine differs from the versions submitted to the CSL by
! Don Wright and Bill Donze in that the shutdown of any programs
! running in the session is performed here, and not in LGOFF (as
! it would otherwise be). If the caller of this routine has
! a) DeTACHed from the session and
! b) set the device-type of the user's terminal to a non-
! interactive type
! then it is possible to perform a completely "silent" log-off
! (i.e., no messages will be emitted to the user's terminal).
! BE SURE TO RESTORE THE TERMINAL'S DEVICE TYPE!
!
! Note -- this code was obtained originally by disassembling the
! appropriate code from RTE-A (of all things) to find out what
! operations were done by CLGOF there. I reasoned that I could
! perform similar operations under RTE-6, and a look at LGOFF
! verified the methods used here.
integer*2 sess !Formal parameters
integer*2 dum1,dum2 !(for RTE-A compatibility)
integer*2 lgof,lgcl,dscs !External stuff
$alias /lgof/ = '$LGOF', NoAllocate
$alias xla = '.XLA', direct
common /lgof/ lgof
common /LogOffInfo/ scba,sessn,idad
integer*2 xla,LUSes,LogLU,LUTru,TrimLen,GetMySons
integer*2 scba,sessn,idad
integer*2 junk,temp,p1,p2,p3 !Local stuff
integer*2 myses,cclas,prog(3),ime(3)
logical*2 fses
character*5 pgnam,me
equivalence (pgnam,prog),(me,ime)
! The RTE-A equivalent to this code is furnished by the system.
myses = LuTru(LogLu(junk)) !Get my session#
call pname(ime)
sessn = sess !...and passed session#
if (sessn .eq. myses) call dtach !Get out of LGOFF's way
lgcl = xla(lgof) !Get LGOFF's class#
if (lgcl .eq. 0) return !Session not available
lgcl = lgcl .or. 20000b !Set 'no deallocate' bit
scba = LuSes(sessn) !Get the SCB address
if (scba .eq. 0) return !No such session? Just return!
! The following loop terminates all programs running in the given
! session except:
! My caller (in case we didn't actually detach...)
! D.RTR/SMP (special cases - they clean themselves up)
p2 = 0 !Initialize for program-search
do while (GetMySons(prog,p2,fses) .ne. 0)
if (pgnam .eq. 'D.RTR') goto 10
if (pgnam .eq. 'SMP') goto 10
if (pgnam .eq. me) goto 10
if ( fses ) then !Normal program in session?
call ShootProg(pgnam,'8')
else
call ShootProg(pgnam,'1') !A "system utility"
endif
10 end do
cclas = 0 !Insure we allocate a class#
call exec(18,0,0,0,0,0,cclas) !Write to new comm class
! Tell LGOFF to log off the given session
call exec(100024b,0,cclas,1,sessn+20000b,scba,lgcl,*999)
! Get messages from LGOFF until LGOFF is done.
20 call exec(100025b,cclas+20000b,junk,0,p1,p2,p3,*999)
if (p3 .ne. 1) goto 20 !Must be class read or write/read
if (p2 .gt. 0) goto 20 !Ignore class-writes/-controls
call clrq(2,cclas) !Release the class#
999 return
end
integer*2 function GetMySons(pgnam,idno,fses) ,<881219.1353>
>6/Find Session Programs
implicit none
integer*2 pgnam(3),idno !My parameters
logical*2 fses
integer*2 ixget !Externals
common /LogOffInfo/ scb,sessn,idad
integer*2 scb,sessn,idad
integer*2 keywd,temp !Local stuff
! The RTE-A equivalent to this code is furnished by the system.
keywd = ixget(1657b) !Get ID-segment table pointer
GetMySons = 0 !Prepare for pessimistic result
fses = .true. !Assume program is in session
10 idad = ixget(keywd + idno) !Get an ID-segment address
if (idad .eq. 0) return !End of ID-segment table - done
idno = idno + 1 !Prep for next iteration
temp = ixget(idad + 14) !Get the ID-segment status
if (.not. btest(temp,4) ) then !If this is a long ID-segment
temp = ixget(idad+32) !Get the SCB pointer from it
if (scb .eq. temp) then !If it matches the target
pgnam = ixget(idad+12) !...get progname (1st word)
pgnam(2) = ixget(idad+13) !...get progname (2nd word)
pgnam(3) = ixget(idad+14) .and. 177400b .or. 40b
GetMySons = 1 !Flag success
temp = ixget(idad+31) .and. 377b
fSes = temp .eq. sessn !Flag program in session
return
endif
endif
goto 10
end
subroutine ShootProg(name,how) ,<881219.1353>
>6/Quietly kill a program
implicit none
character*(*) name,how
integer*2 buf(7),TrimLen,p
character*13 cBuf
equivalence (buf,cbuf)
! The RTE-A equivalent to this routine is furnished by RTE-A
p = TrimLen(name)
cbuf = 'OF,' // name(:p) // ',' // how // ',NP'
call messs(buf,13)
return
end
integer*2 function WhoLockedLu(LU)
>, 92084-1Y013 REV 2718 870506 <ps>
implicit none
! This source was obtained via disassembly of the system routine of the
! same name. As of the 4.1 system revision, the original system routine
! caused its caller to be non-transportable; this is fixed here:
! The original WhoLockedLu used "AddressOf($RNTB)" via an alias to
! obtain the true address of the Resource Number table.
! By going one level indirect using "XLA($$RTB)" also via an alias
! to retrieve this address, the code becomes transportable.
$alias /rntb/ = '$$RTB', NoAllocate
$alias xla = '.XLA', direct
integer*2 rntb
common /rntb/ rntb
integer*2 LU
integer*2 drt,lumax,drt3,LockWord,LockerRN,LockerIDNo
integer*2 IxGet,IDNumberToAdd,xla !<ps>
WhoLockedLu = 0 !Preset return value
drt = ixget(1652b) !Locate the Device Reference Table
lumax = ixget(1653b) !...and the size of it
if (LU .gt. lumax) return !Return if illegal LU
drt3 = drt + lumax*2 !Locate DRT part 3
LockWord = IxGet( ((LU-1)/2)+drt3 ) !Get word with lock for this lu
if (iand(LU,1) .ne. 0) then !Upper or lower byte?
LockerRN = ibits(LockWord,8,8) !Odd LU uses upper byte
else
LockerRN = ibits(LockWord,0,8) !Even LU uses lower byte
endif
if (LockerRN .eq. 0) return !Quit if not locked
LockerIDNo = ixget(xla(rntb) + LockerRn) .and. 377b
WhoLockedLu = IDNumberToAdd(LockerIDNo)
return
end
subroutine IDAddToName(idaddr,PrgName,lu)
>, 92084-1Y013 REV 2718 870506 <ps>
implicit none
! The source for this routine was obtained via disassembly of the system
! routine of the same name. As of the 4.1 system revision, this routine
! did not provide the ID-segment's session info; it is fixed here!
integer*2 idaddr,PrgName(*),lu,IxGet
PrgName(1) = IxGet(idaddr+12)
PrgName(2) = IxGet(idaddr+13)
PrgName(3) = IxGet(idaddr+14) .and. 177400b .or. 40b
lu = IxGet(idaddr+31) .and. 377b !870506-ps
return
end