!********************************
!* emas-2900 fep itp server *
!* file: itps9/itps9y *
!* date: 25.mar.82 *
!********************************
!! stack size = 500
!*
!* code options
!* a = additions
!* b = kent booking server code
!* n = ercc nsi
!* r = ring
!* k = kent
!* e = ercc
!* x = transport service
#if (k&e)!(x&n)!(x&r)!(r&n)!(k&n)!~(x!r!n)!~(k!e)
#report "Options incompatible"
#abort
#fi
!*
control 1
include "deimosperm"
begin
#datestring
#timestring
conststring (13)vsn = "itps...9(x)h"
recordformat am1f(integer rxs, rxd, txs, txd)
ownrecord (am1f) name l == 1; ! addr passed by eam1
!! no of data bytes in a short block
#if ~k
constinteger small block max = 51; ! 64-4-6-4
constinteger big block max = 127; ! < 256 !
#else
constinteger small block max = 110; ! 128-4-6-4
constinteger big block max = 220; ! < 256 !
#fi
constintegername no of big == k'100112'; ! no of free buffs
constintegername no of small == k'100114'
owninteger critical = 15; ! switch off o/p level
recordformat itpf((byteinteger cnsl, hdb1, hdb2, c
(string (241) s or byteintegerarray a(0:241)) or c
byteintegerarray aa(0:244)))
#if r&e
recordformat lev3f(bytesrray reserved(0:7), integer uflag,
record (itpf) itp)
#fi
#if n
recordformat lev3f(bytearray reserved(0:5), c
record (itpf) itp)
#fi
! nb: replaces fn,sufl,st,ss,flag,uflag
#if x!(k&r)
recordformat lev3f(bytearray reserved(0:7), record (itpf) itp)
#fi
recordformat mef(record (mef) name link, c
byteinteger len, type, (record (lev3f)lev3 or c
bytearray params(0:231)))
recordformat m2900f(record (mef) name l, byteinteger len, type, c
integer stream, sub ident, c
p2a, p2b, p3a, p3b, p4a, p4b, p5a, p5b, p6a, p6b)
recordformat m2900bf(record (mef) name l, byteinteger len, type, c
integer stream, sub ident, c
byteintegerarray b(0:19))
recordformat m2900if(record (mef) name l, byteinteger len, type, c
integer stream, sub ident, p2a, p2b, string (15) int)
recordformat m2900cf(record (mef) name l, byteinteger len, type, c
integer stream, sub ident, integerarray pa(0:9))
recordformat maf(record (mef) name l, byteinteger mlen, c
mtype, byteintegerarray a(0:240))
#if ~x
recordformat pe(byteinteger ser, reply, c
fn, gate port, record (mef) name mes, (byteinteger c1, c2 or c
integer c))
#else
recordformat pe(byteinteger ser, reply, c
(integer a, b, (integer c or byte c1, c2) or byte fn, a2, c
(record (mef)name mes, byte gate port, task port or c
string (3) facility)))
#fi
recordformat qf(record (mef) name e)
!********************************************************
!* formats of tables, ie stream descriptors, tcps etc *
!********************************************************
recordformat con desf(record (mef) name hold, c
integer state, stream, byteinteger o state, out go, c
in cnt, tcp, cnsl, seq bits, pmt n, mode, hold f, abortf, c
#if k
gahs wanted, gahs sent,
#fi
integer trig, i pos, opos, o lim, o trig, p lim, c
in lim, out lim, o posx, (record (mef) name in mes or c
record (qf) inp q))
recordformat cons statef(record (con desf) name con des)
#if ~k
#if a
recordformat tcpf(integer state, con state ind, c
held, h ind, h no, byteinteger port, ostate, tcpn, node, term, c
size, max, en in,en in count, record (qf) outq)
#else
recordformat tcpf(integer state, con state ind, c
held, h ind, h no, byteinteger port, ostate, tcpn, node, term, c
size, max, record (qf) outq)
#fi
#else
#if ~a
recordformat tcpf(integer state, con state ind, c
held, h ind, h no, byteinteger port, ostate, tcpn, node, term, c
size, max, string (8) name, record (qf) outq)
#else
recordformat tcpf(integer state, con state ind, c
held, h ind, h no, byteinteger port, ostate, tcpn, node, term, c
size, max, en in,en in count, string (8) name, record (qf) outq)
#fi
#fi
!************************************************************
!* upper level (itp&rje) handler messages to gate
!************************************************************
#if ~x
constinteger enable facility = 1; ! enable the facility
! %constinteger disable facility = 2; ! the reverse
constinteger call reply = 3; ! reply to a 'call connect'
constinteger enable input = 4; ! allow a block to be read
constinteger put output = 5; ! send a block of output
constinteger close call = 6; ! terminate a call
constinteger abort call = 7; ! abort the call
constinteger reject = 0; ! qualifier on above
!**********************************************************
!* messages from gate to upper level protocols
!**********************************************************
constinteger incoming call = 2
constinteger input here = 3; ! block arrived from node
constinteger output transmitted = 4; ! prepared to accept more
constinteger call closed = 5; ! either end has closed down
constinteger call aborted = 6; ! other end has aborted
#else
#if k
include "tsbsp_tscodes"
#else
include "b_ygatecalls"
#fi
#fi
!**************************************************************
!* buffer manager calls (from and to) *
!**************************************************************
! %constinteger buffer here = 0
!********** to buffer manager ***********
constinteger request buffer = 0
constinteger release buffer = 1
!**************************************************************
!* calls to 2900 link handler *
!**************************************************************
constinteger send data = 0
constinteger low level control = 1
constinteger here i am = 2
constinteger return control = 3
!**************************************************************
!* replies from 2900 link handler *
!****************************************************************
constinteger interf addr = 0
constinteger do input = 1
constinteger do output = 2
constinteger message = 3
constinteger mainframe up = 4
constinteger mainframe down = 5
!****************************************************************
#if b
! booking server messages
constinteger logged off = 1
constinteger can i logon = 2
!from booking server
constinteger logon reply = 1
constinteger force off = 2
!flag values for logon reply
constinteger bkaccept = 2
constinteger bkreject = 1
#fi
!********** various service numbers *************
#if ~x!k
constinteger gate ser = 16
#else
constinteger gate ser = 24
#fi
constinteger buffer manager = 17
#if b
constinteger host bk ser = 25
#fi
constinteger link handler = 18
constbyteintegername change out zero == k'160310'
constinteger t3 ser = 21
constinteger comm bit = k'1'
constinteger accept char = k'002'
constinteger acfy = k'010'; ! peter calls it rxfy
constinteger xopl = k'020'; ! x operable - latched
! %constinteger xop = k'040'; ! x operable
constinteger ready = k'200'
!************************************************************
!* tcp states *
!************************************************************
! %constinteger not allocated = 0
constinteger connected = 1
#if x
constinteger tcp disc = 2
#fi
!****** tcp_ostate states (permission to send) *****
constinteger idle = 0
constinteger busy = 1
!***********************************************************
!* 2900 states *
!***********************************************************
own integer host state = 0; ! holds 2900 state
constinteger down = 0
constinteger up = 1
!****************** comms control states ********************
! %constinteger unused = 0
constinteger disconnecting = 1
constinteger connecting = 2
constinteger suspending = 4
constinteger aborting = 5
constinteger enabling = 7
! %constinteger enabled = 8
constinteger fixed = 10; ! 1st available stream
!**************************************************************
!* console states *
!**************************************************************
constinteger not allocated = 0
constinteger name sent = 1; ! hello has been received
constinteger pass sent = 2; ! 'name' has been received
constinteger logging on = 3
constinteger logged on = 4; ! 2970 has accepted it
constinteger input enabled = 5
constinteger logging off = 6; ! 2970 is getting rid of it
constinteger logging off 2 = 7; ! waiting to send it
!! ostate states
!! %constinteger idle = 0
constinteger enabld = 1
constinteger out p = 2; ! output req pending
constinteger pmt p = 4; ! prompt request pending
!bit values to indicate if input/output aborted in d_abortf
constinteger input aborted = 1
constinteger output aborted = 2
!**********************************************************
!* itp header bytes definitions *
!**********************************************************
constinteger text = 0; ! in itp_hdb1
constinteger bin b = 1
constinteger control = 1
constinteger go ahead = 2; ! in itp_hdb1
constinteger hello = 8
constinteger i disconnect = 4
constinteger terminated = 2; ! in itp_hdb2
constinteger prompt = 4
! %constinteger text marker = 8
constinteger seq no valid = 32
! %constinteger seq no bits = x'c0'
constinteger seq inc = x'40'
constinteger intm = 1; ! hdb2 - control message
constinteger set mode = 2
! %constinteger kill transmit = 8
! %constinteger kill receive = 4
!******************************************
!* reasons for waiting for a buffer *
!******************************************
constinteger send name prompt = 1
constinteger send pass prompt = 2
constinteger put echo on =3, put echo off = 4, send nl = 5
constinteger store user name = 6
constinteger send disconnect = 7
! %constinteger send login reply = 8; ! logon successful
#if b
constinteger send busy = 9
#fi
constinteger send kill receive = 17
constinteger send emas down = 18
constinteger send go ahead = 19
constinteger send kill transmit = 20
constinteger send text marker = 21
constinteger last itp reason = 21
constinteger low level ip transfer = 22
constinteger low level op transfer = 23
constinteger get op block = 24
constinteger send trig reply = 25; ! must be odd (output trigger)
constinteger send the chop = 26; ! send an "int y" to 2900
constinteger get big op block = 27
constinteger kick message stream = 28
!**************************************************************
routinespec to gate(integer fn, record (mef) name mes, c
integer flag)
routinespec to 2900(integer fn, record (m2900f) name m2900)
routinespec get buffer(integer reason)
routinespec free buffer(record (mef) name mes)
routinespec from gate
routinespec from 2900
routinespec from buffer manager(record (pe) name p)
integerfnspec analyse itp message(record (mef) name mes)
routinespec retrieve(record (con desf) name d)
routinespec lose consoles(integer x)
routinespec read from am1
routinespec write to am1
routinespec kick 2900 message(record (maf) name log)
routinespec tidy message streams
routinespec read message from am1
routinespec write message to am1
#if x
routinespec mon mes(record (mef) name mes)
routinespec mon p(record (pe) name p)
#fi
#if a
routinespec from clock
routinespec restart output
routinespec get o block
#fi
#if b
routinespec from bk
#fi
!******************************************************
record (pe) p
ownrecord (tcpf) name tcp
owninteger tcpn
ownrecord (con desf) name d
ownrecord (qf) free des; ! holds free descriptors
ownrecord (con desf) name first d; ! for dumping only
ownrecord (con desf) name d2, d3
ownrecord (qf) name buffer pool
owninteger no of buff = 0
#if ~k
constinteger tcp limit = 28; ! increase con statea as well !!!!!!!
#else
constinteger tcp limit = 25; ! increase con statea as well !!!!!!!
#fi
ownrecord (tcpf) array tcpa(0:tcp limit)
#if ~k
ownbytearray con index(0:1472)
#else
ownbytearray con index(0:857)
#fi
#if ~k
constinteger con lim = 118; ! number of active terminals
#else
constinteger con lim = 64; ! number of active terminals
#fi
ownrecord (con desf) array con desa(-2:con lim)
constinteger max ports = 50
ownbyteintegerarray porta(0:max ports)
! cross index from port to tcp
#if k
constinteger max tts = 33; ! ie 0 to 32
#else
constinteger max tts = 49; ! ie 0 to 48
#fi
owninteger mon = 0; ! monitoring flag
owninteger lose op = 0; ! discard output for erte
constintegername users == k'100014'; ! no of users in buffer seg
owninteger messflag=0; !w.s.c 9/4/81 tcp connect messages off
integer i, n
ownstring (63) str
#if x
ownstring (1) snil = ""
#fi
#if n
constinteger header len = 6
#else
#if r&e
constinteger header len = 2
#else
constinteger header len = 0
#fi
#fi
!**********************************************
!* initialisation *
!**********************************************
change out zero = t3 ser
first d == con desa(0)
cycle i = con lim, -1, 0
push(free des, con desa(i))
repeat
n = 0
cycle i = 1, 1, tcp limit
tcp == tcpa(i)
tcp_tcpn = i
tcp_con state ind = n; n = n+max tts
repeat
d2 == con desa(-2)
d2_stream = -2
d3 == con desa(-1)
d3_stream = -1
#if k
str=vsn."Kent "
#else
str=vsn."ERCC "
#fi
#if b
str=str."(bk)"
#fi
#if x
str=str."ts "
#else
#if r
str=str."ring "
#else
str=str."nsi "
#fi
#fi
printstring(str.datestring)
newline
map hwr(0); ! map am1 to segment 0
i = map virt(buffer manager, 5, 4); ! map buff man stack to seg 4
i = map virt(buffer manager, 6, 5); ! and second seg
users = 0
con desa(i)_stream = i for i = 0, 1, con lim
p_c = 2; ! param for 'here i am'
to 2900(here i am, null)
p_c = 3; ! and claim stream 3
to 2900(here i am, null)
tcp == tcpa(0); ! dummy for below
#if ~x
to gate(enable facility, null, 18)
#else
p_ser = gate ser; p_reply = own id
p_fn = enable facility; p_a2 = 0; p_facility = "ITP"
pon(p)
#fi
#if a
alarm(100)
#fi
!**********************************************
!* main loop *
!**********************************************
cycle
p_ser = 0; poff(p)
#if a
if p_reply=0 then from clock and continue
#else
if int # 0 start
if 'M' <= int <= 'P' start
mon = int-'O'
finish
if int='A' then messflag=1; !turn messages on
if int='B' then messflag=0; !turn off
if int = '?' start ; ! $$ mon
write(no of buff, 4); newline
printstring("term qu mq held no held
")
cycle i = 1, 1, tcp limit
tcp == tcpa(i)
if tcp_state = connected start
write(tcp_term, 3)
write(tcp_size, 3); write(tcp_max, 3)
write(tcp_held, 3); write(tcp_h no, 5)
newline
tcp_max = 0
finish
repeat
finish
int = 0
finish
#fi
if p_reply = link handler start
from 2900
finish else if p_reply = gate ser start
from gate
#if b
finish else if p_reply = host bk ser start
from bk
#fi
finish else if p_reply = buffer manager then from buffer manager(p)
repeat
!*************************************************
!* routines to do the work *
!*************************************************
#if a
routine restart output
integer x, q
x = tcp_h ind
cycle
x = x+1
if x >= max tts then x = 0
q = con index(x+tcp_con state ind)
unless q = 0 start ; ! console active
d == con desa(q)
if d_hold f # 0 start ; ! and held
d_hold f = 0; tcp_held = tcp_held-1
get o block
#if ~k ! x
if tcp_size > 0 then c
tcp_h ind = x and ->got it
!! if q is still non-zero, release only 1
#else
tcp_h ind=x; ->got it
#fi
finish
finish
repeat until x = tcp_h ind
tcp_held = 0; ! didn't find any!
got it:
end
routine from clock
integer i
if int # 0 start
if 'M' <= int <= 'P' start
mon = int-'O'
finish
if int='A' then messflag=1; !turn messages on
if int='B' then messflag=0; !turn off
if int = '?' start ; ! $$ mon
write(no of buff, 4)
newline
printstring("term qu mq held no held en_in")
newline
cycle i = 1, 1, tcp limit
tcp == tcpa(i)
if tcp_state = connected start
#if k
printstring(tcp_name)
#else
write(tcp_term, 3)
#fi
write(tcp_size, 3)
write(tcp_max, 2)
write(tcp_held, 3)
write(tcp_h no, 2)
#if a
write(tcp_en in,1); !input blocked if #0
#fi
newline
tcp_max = 0
finish
repeat
finish
int = 0
finish
for i=1,1,tcp limit cycle
tcp==tcpa(i)
if tcp_state#connected then continue
if tcp_en in > 0 start
tcp_en in count=tcp_en in count + 1
if tcp_en in count > 10 start
printstring("itps: ")
#if k
printstring(tcp_name)
#else
printstring("TCP")
write(tcp_term, 3)
#fi
printstring(" appears to be stuck, should it be reloaded?")
newline
tcp_en in count=0
finish
else
if tcp_en in count>0 then tcp_en in count=tcp_en in count - 1
finish
if tcp_held#0 and tcp_size=0 andc
no of small>=critical start
restart output
printstring("Output restarted ")
#if k
printstring(tcp_name)
#fi
newline
exit
finish
repeat
alarm(100)
end
#fi
#if k
string (8)fn itos(integer i)
bytearray c(0:7)
string (8)s
integer k
k=0
if i<0 start
c(0)='-'; k=1; i=-i
finish
cycle
c(k)=i-i//10*10+'0'; i=i//10
k=k+1
repeatuntil i=0
length(s)=k
for i=1,1,k cycle
charno(s,i)=c(k-i)
repeat
result =s
end
#fi
routine crunch
integer i
cycle i = 1, 1, 15
printstring("itps: Bad buffer ***** dump fep ********
")
repeat
*=k'104001'; ! emt wait
end
routine to gate(integer fn, record (mef) name mes, c
integer flag)
if fn = put output start ; ! queue these as necessary
if tcp_state # connected start ; ! throw away
free buffer(mes); return
finish
if addr(mes)&k'140000' = k'140000' then crunch; ! had it
#if ~k ! x
if tcp_ostate # idle start
push(tcp_outq, mes)
tcp_size = tcp_size+1
tcp_max = tcp_size if tcp_size>tcp_max
return
finish
tcp_ostate = busy
#else
tcp_size = tcp_size + 1
tcp_max = tcp_size if tcp_size>tcp_max
#fi
! %if mon # 0 %start
! select output(1)
! printstring("io ");! mon mes(mes)
! %finish
finish
p_ser = gate ser; p_reply = own id
p_fn = fn; p_gate port = tcp_port; p_mes == mes
#if ~x
p_c2 = flag
#else
p_a2 = flag
p_task port = tcp_tcpn
if mon # 0 start
select output(1); spaces(5)
printstring("itp: to gate:"); mon p(p)
select output(0)
finish
#fi
pon(p)
end
routine to 2900(integer fn, record (m2900f) name m2900)
p_ser = link handler; p_reply = own id
p_fn = fn; p_mes == m2900
pon(p)
end
routine get buffer(integer reason)
record (pe) p
integer type
!*******************************************************
!* hold a pool, so can call buffer here immedialtely*
!* otherwise hold the activity until it arrives*
!*******************************************************
if reason = get big op block then type=0 else type=1
p_c2 = reason
#if ~x
p_gate port = d_stream
#else
p_a2 = d_stream
#fi
if buffer pool == null or type=0 start ; ! have to ask for it
p_ser = buffer manager; p_reply = own id
p_fn = request buffer
p_c1 = type; ! either size
pon(p)
else
p_mes == buffer pool; buffer pool == p_mes_link
p_mes_link == null
no of buff = noof buff-1; from buffer manager(p)
finish
end
routine free buffer(record (mef) name mes)
record (pe) p
if addr(mes)&k'140000' = k'140000' then crunch
if mes_type=0 or no of buff>10 or no of small < 15 start
p_ser = buffer manager; p_reply = own id
!! queue it if it is a short buffer
p_fn = release buffer; p_mes == mes
pon(p)
else
!! short buffer, so queue it
mes_link == buffer pool; buffer pool == mes
no of buff = no of buff+1
finish
end
#if x
string (127) fn unpack(record (mef) name mes, integer no)
integer i, l
unless mes == null or mes_len<=0 or no<=0 start
l = 0
while no>1 cycle
l=l+mes_params(l)+1
no = no-1
repeat
result = string(addr(mes_params(l)))
finish else result = ""
end
routine pack(record (mef) name mes, string (*) name s)
string(addr(mes_params(mes_len))) = s
mes_len = mes_len+length(s)+1
end
#fi
routine get o block
!! this routine determines whether it is worth asking for
!! a big buffer to put itp output in, otherwise gets small
!! nb: 1st transfer is always a small buffer (not done here)
integer x
x = d_o lim-d_o pos
if x<0 then x=x+d_out lim
if x>small block max and no of big>15 then c
get buffer(get big op block) else c
get buffer(get op block)
end
#if b
routine to bk(integer stream, fn); !to booking server
!---------------------------------
p_ser=host bk ser; p_reply=own id
p_fn=fn; p_c=stream
pon(p)
end
routine from bk
!-------------- message from booking server
! either reply to can i logon or a throw off
record (maf) name m
integer index
m==p_mes
index=p_c; !stream number
unless 0<=index<=con lim start
printstring("itps:illegal stream no. from HY")
write(index, 2)
newline
free buffer(p_mes)
return
finish
d==con desa(index)
tcp==tcpa(d_tcp)
index=index*2 + fixed
if p_fn=logon reply start
#if x
if p_a2=bkaccept start ; !send logon request to the host
#else
if p_gate port=bkaccept start
#fi
kick 2900 message(m); !NB corrupts d
p_c=index
to 2900(here i am, null);!tell am1 handler
p_c=index+1
to 2900(here i am, null)
else ; !logon request rejected
free buffer(p_mes)
if d_cnsl=255 start
retrieve(d)
else
get buffer(send busy)
d_state=logging off
finish
finish
else ; !force a logoff
m_a(1)=6; !code for force off
m_a(2)=0
m_a(3)=index
m_a(0)=m_a(4)+4
kick 2900 message(m); !NB corrupts d
finish
end
#fi
routine from gate
record (mef) name mes
record (tcpf) name targ
integer fn, flag, type, x, q
#if k&~x
bytearrayname tsparams
integer i, l, k
#fi
#if ~x
switch fns(incoming call:call aborted)
#else
switch fns(connect:Datagram Reply)
string (63) calling
string (9) qual
#fi
fn = p_fn
#if ~x
tcpn = porta(p_gate port)
#else
tcpn = p_task port
#fi
tcp == tcpa(tcpn)
mes == p_mes
#if x
if mon # 0 start
select output(1); spaces(5)
printstring("itp: from gate:")
mon p(p)
select output(0)
finish
#fi
->fns(fn)
#if ~x
fns(incoming call):
#else
fns(Connect):
#fi
tcp == null
cycle tcpn = tcp limit, -1, 1
targ == tcpa(tcpn)
if targ_state = not allocated then tcp == targ
repeat
if tcp == null start
! 2900 down or full up
tcp == tcpa(0)
tcp_port = p_gate port; ! for 'to gate' call only
#if ~x
flag = reject
to gate(call reply, null, flag)
#else
to gate(Disconnect, null, 17)
free buffer(mes)
#fi
return
finish
#if ~x
tcp_term = p_c1
#fi
tcp_state = connected; tcp_ostate = idle
#if ~x
#if k
tcp_node=0
#else
tcp_node = p_mes_lev3_reserved(4); ! really mes_nsl_sn - but hi a compiler fault!
#fi
porta(p_gate port) = tcp_tcpn; ! fill in port no - tcp no index
#fi
tcp_port = p_gate port
#if ~x
#if n
flag = p_c1; ! pick upp fl & rl
x = flag&x'70'; ! pick up fl
if x>x'20' then x = x'20'; ! limit to 2
flag = (flag&x'f')!x
#else
flag = 1
#fi
#else
tcp_node = 0; ! ??????
calling = unpack(mes, 2)
#if k
tcp_name<-calling
#fi
qual = unpack(mes, 3)
#fi
#if k&~x
tsparams==p_mes_lev3_itp_a
if p_mes_len>8 and tsparams(5)=128 and tsparams(6)=16 andc
tsparams(8)>=132 start
l=tsparams(8)&63; if l>8 then l=8
length(tcp_name)=l
k=-1; !to control byte swapping
for i=1,1,l cycle
charno(tcp_name,i)=tsparams(7+i+k)
k=-k
repeat
else
tcp_name="T".itos(tcp_term)
finish
#fi
if messflag=1 start
#if ~x
#if k
printstring(" itp: "); printstring(tcp_name)
#else
printstring(" itp: t")
write(p_c2, 1)
#fi
#else
printstring(" itp: ")
printstring(calling)
#fi
printstring(" connected
")
finish
tcp_max = 0; ! for monitoring
tcp_size = 0; tcp_held = 0; tcp_h no = 0
#if ~x
to gate(call reply, null, flag)
#else
mes_len = 0
pack(mes, snil)
pack(mes, qual)
pack(mes, snil)
to gate(accept call, mes, 0)
#fi
return
#if x
fns(expedited data): ! int message (i hope)
#fi
fns(input here):
mes_len = mes_len - header len
if mes_len <= 3 start
free buffer(mes)
#if x
!see if data is pushed, if so treat as close request
if p_a2#0 start
to gate(disconnect, null, 0)
tcp_state = tcp disc
finish
#fi
return
finish
#if a
if tcp_size < 5 then to gate(enable input, null, 1) elsec
tcp_en in = tcp_en in + 1
#else
to gate(enable input, null, 1)
#fi
#if x
if mon < 0 start
select output(1)
printstring("ii "); mon mes(mes)
finish
#fi
#if ~k
mes_lev3_reserved(0) = 0; ! missing gah count
#fi
flag = analyse itp message(mes)
if flag < 0 then free buffer(mes)
! flag > 0 - going to 2900
! flag = 0 - used internally
! flag < 0 - may be freed
return
#if ~x
fns(output transmitted):
#else
fns(enable output):
#fi
#if ~k ! x
tcp_ostate = idle
unless tcp_outq_e == null start
tcp_size = tcp_size-1
to gate(put output, pop(tcp_outq), 0)
finish
#else
tcp_size = tcp_size -1
#fi
if tcp_held # 0 and tcp_size<5 start
!! consoles are held & q is now redduced
#if a
restart output
#else
x = tcp_h ind
cycle
x = x+1
if x >= max tts then x = 0
q = con index(x+tcp_con state ind)
unless q = 0 start ; ! console active
d == con desa(q)
if d_hold f # 0 start ; ! and held
d_hold f = 0; tcp_held = tcp_held-1
get o block
if tcp_size > 0 then c
tcp_h ind = x and -> got it
!! if q is still non-zero, release only 1
finish
finish
repeat until x = tcp_h ind
tcp_held = 0; ! didn't find any!
got it:
#fi
finish
#if a
if tcp_en in > 0 and tcp_size < 5 start
to gate(enable input, null, 1)
tcp_en in = tcp_en in - 1
finish
#fi
return
#if ~x
fns(call closed):
#if r
flag = 0
type = close call
-> kill it
#else
return ; ! handled in 'input recd'
#fi
#fi
#if ~x
fns(call aborted): ! either way, all is lost
#else
fns(Disconnect): ! Call has been cleared
unless p_mes==null then free buffer(p_mes)
#fi
#if ~x
flag = 1
type = abort call; ! nb: cpmatibility with x25 vsn
kill it:
#else
flag = p_a2; ! pickup reason for close
#fi
if messflag=1 start
#if k
printstring(" itp:"); printstring(tcp_name)
#else
printstring(" t"); write(tcp_term, 1)
#fi
printstring(" connection ")
#if x
if (tcp_state = tcp disc and flag = 1) or flag = 0 start
printstring("closed")
finishelsestart
printstring("aborted"); write(flag, 1)
finish
#else
if flag # 0 then printstring("aborted") else c
printstring("closed")
#fi
write(tcp_max, 1); newline
finish
lose consoles(-1)
#if ~x
to gate(type, null, 0)
#else
if tcp_state#tcp disc then to gate(disconnect, null, 1)
#fi
tcp_state = not allocated
x = 0
while not tcp_outq_e == null cycle
free buffer(pop(tcp_outq))
x = x+1
if x&7 = 7 then set prio(1)
!! force a reschedule, to avoid overload
repeat ; ! flush any queued items
end
integerfn analyse itp message(record (mef) name mes)
record (itpf) name itp, itp2
integer cnsl, index, stream, len, q, x
record (maf) name m
record (m2900if) name mi
string (15) int mes
switch console state(idle:logging off 2)
itp == mes_lev3_itp
cnsl = itp_cnsl
if cnsl >= max tts start
printstring("itps: cnsl no too high, tcp,cnsl:")
write(tcp_term, 1); write(cnsl, 1)
newline
-> get rid of it
finish
index = cnsl+tcp_con state ind
q = con index(index)
unless q = 0 start
d == con desa(q)
if cnsl#d_cnsl or d_tcp#tcp_tcpn start
printstring("itps: console mismatch (warning)
")
-> get rid of it
finish
if itp_hdb1&i disconnect # 0 start
!! console ctrl+d
lose consoles(cnsl)
-> get rid of it
finish
if itp_hdb1&go ahead# 0 start ; ! 'simple' goahead
d_out go = d_out go+1
if d_out go > 4 then d_out go = 4
if d_out go = 1 and d_ostate &out p # 0 start
if tcp_size >= 4 or no of small < critical start
d_hold f = 1; tcp_held = tcp_held+1; tcp_h no=tcp_h no+1
finish else get o block
finish
finish
->console state(d_state)
finish
console state(not allocated): ! eg no descriptor
if itp_hdb1&hello # 0 start ; ! sent hello
d == pop(free des)
if d == null then -> get rid of it
stream = d_stream; ! hold the stream
con index(index) = stream
d = 0; ! zero the record
d_stream = stream
d_tcp = tcpn; d_cnsl = cnsl
d_out go = 1 if itp_hdb1&go ahead # 0
d_state = name sent; ! if down, goes to logging off whe sent
users = users+1
if host state = down start
get buffer(send emas down)
result = -1
finish
get buffer(send name prompt)
d_hold == mes
get buffer(store user name)
result = 2; ! buffer retained
finish
result = -1; ! no further
console state(name sent): ! user name arrived ?
if itp_hdb1&control = 0 start ; ! is a text message
d_state = pass sent
get buffer(put echo off); ! switch echo off
get buffer(send pass prompt); ! send pass:
if length(itp_s) > 2 then length(itp_s) = length(itp_s)-2
if length(itp_s) > 20 then length(itp_s) = 20
m == d_hold; ! pickup buffer with 'address'
string(addr(m_a(m_mlen))) = itp_s
m_mlen = m_mlen+length(itp_s)+1
finish
result = -1; ! de-alloctae block
console state(pass sent): ! password arrived ??
if itp_hdb1&control = 0 start ; ! ia a text message
d_out go = d_out go-1
get buffer(send nl); ! send out a newline
get buffer(put echo on); ! put echo back on
m == d_hold
!! check that it has switched buffers??
if length(itp_s) > 2 then length(itp_s) = length(itp_s)-2; ! delete the cr/lf
#if k
!convert password to upper case
for x=1, 1, length(itp_s) cycle
if 'a'<=charno(itp_s, x)<='z' thenc
charno(itp_s, x)=charno(itp_s, x)-'a'+'A'
repeat
#fi
x = m_mlen
if x+length(itp_s) > small block max then c
length(itp_s) = small block max-x
string(addr(m_a(x))) = itp_s; ! put in password
x = x+length(itp_s)
m_a(0) = x
d_hold == null
d_seq bits = x'c0'
d_state = logging on
#if b
p_mes==m
to bk(d_stream, can i logon)
#else
index = d_stream<<1+fixed
kick 2900 message(m); ! nb: disturbs 'd'
p_c = index; ! param for 'here i am'
to 2900(here i am, null)
p_c = index+1; ! param for 'here i am'
to 2900(here i am, null)
#fi
finish
result = -1
console state(logging on): ! go ahead only?
console state(logged on): ! still no input
result = -1
console state(input enabled): ! input messages and ints
!! check for a text message
if itp_hdb1&control = 0 start ; ! text
#if k
d_gahs sent=d_gahs sent-1
if d_gahs sent<0 start
printstring("itps:too much input!!");
write(tcp_term,3); write(d_cnsl,3); newline
d_gahs sent=0
finish
#fi
if not d_in mes == null start
d_seq bits = d_seq bits+seq inc
itp2 == d_in mes_lev3_itp
#if ~k
d_in mes_lev3_reserved(0) = d_in mes_lev3_reserved(0)+1; ! missing gah count
#fi
unless length(itp_s)+length(itp2_s)>240 then c
itp2_s = itp2_s.itp_s
result = -1; ! chuck the buffer
finish
get buffer(low level ip transfer); ! signal to 2900 input here
d_in mes == mes
mes_lev3_reserved(1) = 0; ! pos in block flag = 0
result = 2
finish
!! check for an "int" messgae
if itp_hdb2&intm # 0 start ; ! int message
int mes = itp_s; ! copy it out of the way
len = length(int mes); ! check for cr, nl & nl
if charno(int mes, len-1) = 13 then len = len-2
if charno(int mes, len) = nl then len = len-1
len = 15 if len > 15
result = -1 if len <= 0; ! invalid int
length(int mes) = len
mi == mes; ! re-use 'mes'
mi_stream = (d_stream<<1)+fixed; mi_sub ident = 0
mi_p2a = -1; mi_p2b = -1; ! set up params
mi_int = int mes; ! copy string accross
to 2900(send data, mi); ! send to am1h
result = 2; ! don't deallocate buffer
finish
if itp_hdb2&set mode # 0 start ; ! setmode in
str = itp_s; ! copy to global string
m == mes; ! change to 'to 2900' type
m_a(1) = 2; ! type = set mode
m_a(2) = 0; ! top half of stream
m_a(3) = d_stream<<1+fixed; ! rest of stream
string(addr(m_a(4))) = str; ! copy setmode back in
m_a(0) = length(str)+4; ! put in total length
kick 2900 message(m); ! put in q for 2900
result = 2; ! dont free buffer
finish
result = -1
console state(logging off): ! message is out, just disconnect
d_state = logging off 2
get buffer(send disconnect)
result = -1
get rid of it:
console state(logging off 2): ! ignore
result = -1
end
routine free transient
if not d_in mes == null then free buffer(d_in mes) and c
d_in mes == null
if not d_hold == null start
free buffer(d_hold); d_hold == null
finish
end
!! r o u t i n e from 2900
!! all messages from the 2900 come to this routine
routine from 2900
record (m2900f) name m2900
record (m2900bf) name m2900b
record (m2900cf) name m2900c
record (mef) name mes
integer stream, sub ident, state, trig, l reply, mode, i
integer type, p2b, pf
switch link fns(interf addr:mainframe down)
m2900 == p_mes; m2900b == m2900
if p_fn = message start
stream = m2900_stream; ! get first stream no
else
if p_fn > message then ->link fns(p_fn)
stream = p_c
finish
d == con desa((stream-fixed)>>1)
tcp == tcpa(d_tcp)
-> link fns(p_fn)
link fns(interf addr): ! interface addr from eam5
l == record(addr(p_mes)&k'17777'); ! force to seg 0
return
link fns(do output): ! -> 11/34
if stream = 3 then read message from am1 else c
read from am1
! ->d mon
return
link fns(do input): ! -> 2900
if stream = 2 then write message to am1 else c
write to am1
!d mon: %if mon #0 %start
! select output(1);! printsymbol('t')
! write(p_fn, 1);! write(stream, 1);! newline;! select output(0)
! %finish
return
link fns(mainframe up):
printstring("emas-2900 up
")
-> tidy
link fns(mainframe down):
printstring("Emas Down
")
tidy: tidy message streams
cycle i = 0, 1, con lim
d == con desa(i)
if d_state # not allocated and d_cnsl=255 then c
retrieve(d) else start
if not allocated < d_state < logging off start
free transient
get buffer(send emas down)
d_state = logging off
finish
finish
if i&3 = 3 then set prio(1); ! force re-schedule
repeat
host state = down
users = -1
return
link fns(message):
if stream = 2 then d == d2
if stream = 3 then d == d3
type = 0
sub ident = m2900_sub ident
state = m2900b_b(1); mode = m2900b_b(0)
if mon < 0 start
select output(1)
printstring("mess:")
write(stream, 1); write(sub ident, 1); write(state, 1)
write(m2900_p2b, 1); write(m2900_p3b, 1)
newline
select output(0)
finish
if sub ident # 0 start ; ! low level
if stream <= 3 start
if state = connecting start
!! initial logon stream connected
host state = up
printstring("logon stream connected
")
users = 0
else
if state = enabling start
d_o state = enabld
d_state = logged on; ! not quite right, but?
d_out lim = m2900_p2b; d_o pos = 0; d_o lim = 0; d_o posx=0
printstring("logon stream enabled
")
finish
if state = disconnecting start
host state = down
printstring("logon stream disconnected
")
tidy message streams
finish
finish
else
if d_state = not allocated start
if stream&1=0 start ; ! monitor input str only
printstring("itps: not allocated problem")
write(state, 1); newline
finish
-> send reply
finish
if state = enabling start ; ! 1st intersting condition
if stream&1 = 0 start
d_state = input enabled
d_seq bits = x'c0'
if d_cnsl = 255 start ; ! gone away
type = 1
else
d_in lim = m2900_p2b
d_i pos = m2900_p3b
#if ~k
get buffer(send go ahead); get buffer(send go ahead)
#else
d_gahs wanted=3
d_gahs sent=0
#fi
get buffer(send go ahead)
finish
else
if d_out lim # 0 start
if d_abortf & output aborted #0 start
!! an 'aborting' has been done
get buffer(send text marker)
d_out go = d_out go-1
finish
finish
d_out lim = m2900_p2b; d_o state = enabld
d_o pos = m2900_p3b; d_o lim = 0; d_p lim = 0
d_mode = mode>>4; ! 0-iso,x'20'-bin,x'30'-cont
finish
finish else if state = disconnecting start
if stream&1 = 0 then d_in lim = 0 else start
d_out lim = 0
d_o state = idle
finish
if d_in lim = 0 and d_out lim = 0 start
! both disconnected
d_state = logging off
get buffer(send disconnect)
finish
finish else if state = aborting or state = suspending start
if stream&1 # 0 start ; ! output side
d_o state = idle; ! stop transfers
if state = aborting start
d_abortf = d_abortf ! output aborted
get buffer(send kill transmit)
else
d_abortf = d_abortf & (¬output aborted)
finish
if not d_hold == null then c
free buffer(d_hold) and d_hold == null
else ; !input has been aborted
if state = aborting start
d_abortf = d_abortf ! input aborted
get buffer(send kill receive)
else
d_abortf = d_abortf & (¬input aborted)
finish
finish
finish
finish
m2900_p2a = 0; m2900_p2b = 0
send reply:
to 2900(low level control, m2900)
if type # 0 then get buffer(send the chop)
return
finish
!*********************************
!* high level message
!********************************
if stream&1 = 0 and stream > 2 start ; ! input high level
trig = m2900_p3b
if d_i pos = trig start
d_p lim = m2900_p2b
i = d_o state
d_o state = i!pmt p
d_pmt n = d_seq bits!terminated!prompt!seq no valid
! hold for use later
if i = enabld start
d_hold == m2900; ! retain buffer
get buffer(low level op transfer)
return
finish
finish
free buffer(m2900); ! past that position already
else
!************************
!* output stream *
!************************
if stream = 3 start
!! update of pointer on message stream
p2b = m2900_p2b
free buffer(m2900)
if mon < 0 start
write(d_olim, 2); write(d_opos, 2); write(p2b, 2); write(d_out lim, 2); newline
finish
get buffer(get op block) if d_o lim = d_o pos
d_o lim = p2b
else
!! request output message
! %integer output pos, trig pos
d_o lim = m2900_p2b
d_o trig = m2900_p3b
m2900_p3a = k'050505'; ! diagnostic purposes
!! check whether immediate trig reply is needed
if d_o trig >= 0 start ; ! maybe
get buffer(send trig reply) if d_opos = d_olim or c
(d_opos<d_olim and not d_opos<d_otrig<=d_olim) c
or c
(d_opos>d_olim and d_olim<=d_otrig<=d_opos)
finish
d_o state = d_o state&(¬pmt p); ! discard prompt
if d_o state&out p = 0 and d_opos # d_olim start
d_ostate = d_ostate!outp
if d_out go > 0 start ; ! allowed to send
if not d_hold == null start
free buffer(m2900)
else
d_hold == m2900
finish
if tcp_size>=4 or no of small < critical start
d_hold f = 1; tcp_held = tcp_held+1
tcp_h no = tcp_h no+1
free buffer(d_hold); d_hold == null
else
get buffer(low level op transfer)
finish
return
finish
finish
free buffer(m2900)
finish
finish
end
routine fill(record (mef) name mes, integer no)
integer n, pt, max
#if k
integer p, l
#fi
#if ~b
constbyteintegerarray pts(1:last itp reason) =
1, 10, 19, 25, 31, 37, 38, 42, 42, 42(7), 75,
42, 61, 65, 69
#else
constbyteintegerarray pts(1:last itp reason) =
1, 10, 19, 25, 31, 37, 38, 42, 75, 42(7), 118,
42, 61, 65, 69
#fi
!! pt to itp mess
#if ~b
ownbyteintegerarray itp message(1:78) =
#else
ownbyteintegerarray itp message(1:121) =
#fi
8, 2, k'146', 5, 'U', 's', 'e', 'r', ':',; ! name prompt
8, 0, k'246', 5, 'P', 'a', 's', 's', ':',; ! pass prompt
5, 1, 2, 2, 1, 1,; ! echo on
5, 3, 2, 2, 1, 0,; ! echo off+go ahead
5, 0, 2, 2, 13, nl,; ! nl
0,; ! not used
3, 5, 0, 0,; ! i disconnect
18, 0, 2, 15, 13, nl, '*', '*', '2', '9', '0', '0', ' ',
'D', 'o', 'w', 'n', 13, nl,; ! emas down
3, 3, 0, 0,; ! go ahead
3, 1, 8, 0,; ! kill transmit
5, 0, 10, 2, 13, nl,; ! nl+text marker
#if ~b
3, 1, 4, 0; !kill receive
#else
42,0,2,39,13,nl,'*','*','*','S','o','r','r','y',' ',
't','h','e','r','e',' ','a','r','e',' ','n','o',' ',
'f','r','e','e',' ','c','o','n','s','o','l','e','s',13,nl,
3, 1, 4, 0; !kill receive
#fi
pt = pts(no)
string(addr(mes_lev3_itp_aa(0))) = string(addr(itp message(pt)))
#if k
if no = send go ahead start
l = itp message(pt); !length of gah
p = l+1
d_gahs sent=d_gahs sent+1; !always send one, loop below for any more
while d_gahs sent<d_gahs wanted cycle
if p>100 start
printstring("itps:too many gahs!!")
write(tcp_term,3); write(d_cnsl,3)
write(d_gahs sent,3); write(d_gahs wanted,3); newline
exit
finish
string(addr(mes_lev3_itp_aa(p))) = string(addr(itp message(pt)))
mes_lev3_itp_aa(p) = d_cnsl; !overwrite str len with cnsl
p = p + l+1; !depends on length of gah
d_gahs sent=d_gahs sent+1
repeat
mes_len = p+header len
else
mes_len = mes_lev3_itp_aa(0)+header len+1; ! nsi+cnsl no
finish
#else
mes_len = mes_lev3_itp_aa(0)+header len+1; ! nsi+cnsl no
#fi
end
!! r o u t i n e move user name (from big to small buffer)
routine move user name(record (maf) name logr)
record (mef) name mes
string (24) add
string (24) name s
integer la
! N B
! Total length of addr, name and password must not exceed
! small block max
! Password is truncated if this is so
if d_state # name sent start
printstring("itp:mun fails")
write(d_state, 1); newline
free buffer(logr); return
finish
mes == d_hold
logr_a(1) = 1
logr_a(2) = 0
logr_a(3) = d_stream<<1+fixed
#if ~k
! until tcp passes address
length(add) = 3
charno(add, 1) = tcpa(d_tcp)_node
charno(add, 2) = tcpa(d_tcp)_term
charno(add, 3) = d_cnsl
string(addr(logr_a(4))) = add.mes_lev3_itp_s
#else
add=tcp_name."::".itos(d_cnsl); !field for terminal speed blank
s==mes_lev3_itp_s
while length(s)>0 and 0<=charno(s,length(s))<=31 cycle
length(s)=length(s)-1
repeat
string(addr(logr_a(4)))= add.":".s
#fi
logr_mlen = logr_a(4) + 4 + 1
free buffer(mes)
d_hold == logr
end
!! r o u t i n e from buffer manager
!! all requests for buffers come back through here
routine from buffer manager(record (pe) name p)
integer reason, type
record (m2900f) name m2900
record (mef) name mes
record (m2900if) name mi
conststring (1) the chop = "Y"
reason = p_c2; ! get reason for calling
#if ~x
n = p_gate port; ! byte quantity !
#else
n = p_a2
#fi
if n >= 254 then n = n-256
d == con desa(n); ! get console descriptor
tcp == tcpa(d_tcp);!in case it's needed
if mon < 0 start
select output(1); printstring("from buff:")
write(p_gate port, 1); write(n, 1); write(reason, 1)
write(d_stream, 1); write(d_state, 1)
newline; select output(0)
finish
if d_state = not allocated then -> free
if reason = store user name then move user name(p_mes) andc
return
if reason <= last itp reason start
if d_cnsl # 255 start ; ! cnsl = 255 - disconnected
fill(p_mes, reason); ! insert the message
p_mes_lev3_itp_cnsl = d_cnsl
to gate(put output, p_mes, 0)
if reason = send emas down then d_state = logging off
else
free: free buffer(p_mes)
finish
if reason = send disconnect start
retrieve(d)
finish
else
if reason=get op block or reason=get big op block start
if d_o state = idle then -> free; ! kill o/p done
unless d_hold==null then free buffer(d_hold)
d_hold == p_mes
get buffer(low level op transfer)
return
finish
!! message to 2900 reason
m2900 == p_mes
m2900_stream = d_stream<<1+fixed+reason&1
m2900_sub ident = 10
if d_stream < 0 then m2900_stream = 4+d_stream
if reason = low level op transfer start
mes == d_hold
if mes == null then -> free
! kill op done, so ignore tran request
length(mes_lev3_itp_s) = 1
m2900_p2a = k'400'; ! = swab(1)
m2900_p2b = swab(d_o pos)
else
m2900_p2b = 0; m2900_p2a = 0
finish
type = low level control
if reason = send trig reply start
m2900_sub ident = 0
m2900_p5a = 0; m2900_p5b = swab(d_opos)
type = send data
d_o trig = -1
finish
if reason = send the chop start
mi == m2900; mi_sub ident = 0; type = send data
mi_p2a = -1; mi_p2b = -1
mi_int = the chop
finish
if mon < 0 start
select output(1)
printstring("trf:")
write(m2900_stream, 1); write(m2900_sub ident, 1)
write(swab(m2900_p2a), 1); write(swab(m2900_p2b), 1)
write(d_o lim, 4); write(d_p lim, 1)
newline; select output(0)
finish
to 2900(type, m2900)
finish
end
routine retrieve(record (con desf) name d)
record (tcpf) name tcp
return if d_state = not allocated
if d_cnsl # 255 start ; ! cnsl = 255 - disconnected
tcp == tcpa(d_tcp)
con index(d_cnsl+tcp_con state ind) = 0
finish
free transient
d_state = not allocated
#if b
to bk(d_stream, logged off); !tell booking server task
#fi
users = users-1 unless users<0
push(free des, d)
end
!! r o u t i n e lose consoles(all or a specific one)
routine lose consoles(integer x)
!! throw away connected consoles
integer index, i, t, q
index = tcp_con state ind
if x < 0 then t = max tts-1 and x = 0 c
else t = x
cycle i = x, 1, t
q = con index(i+index)
d == con desa(q)
con index(i+index) = 0
unless q = 0 start
if d_state=not allocated start
printstring("itps:attempt to discard free console")
write(tcp_tcpn,3); write(q,3)
newline
continue
finish
d_cnsl = 255; ! no messages to the tcp now
free transient
unless d_state >= logging off start
if d_state = input enabled start
!! log off 2900
!! nb: **** the case of "logged on" is not catered for
get buffer(send the chop)
else
unless d_state >= logging on then c
retrieve(d); ! may re-claim immediately
finish
finishelseif d_state=logging off then retrieve(d)
finish
set prio(1) if i&15 = 15; ! don't do too many at once
repeat
end
routine read from am1
!! itp server has control of the link
record (mef) name mes
record (itpf) name it
integer n, flag, sym, lim, type, t, stat, len
mes == d_hold
if mes == null or d_state = not allocated start
printstring("itp:sequence?
")
p_c1 = 0!128; to 2900(return control, null)
return
finish
d_hold == null
if mes_type=0 then len=bigblockmax-2 else c
len = small block max-2
it == mes_lev3_itp
n = it_a(0)
flag = 0
if d_ostate&out p # 0 start
lim = d_o lim; type = out p
else
lim = d_p lim; type = pmt p
d_o posx = d_o pos if n = 1
!! hold beginning of prompt (temporarily) in oposx
!! in case it spans the end of buffer
finish
cycle
cycle
stat = l_rxs
exit if stat&(ready!xopl) # 0
repeat
if stat&xopl # 0 start ; ! xop gone down
t = 64; -> skip; ! send unsuccessfull
finish
sym = l_rxd; ! read the char
if l_rxs&acfy # 0 start ; ! failed to read
sym = l_rxd; ! read it again
if l_rxs&acfy # 0 start ; ! hard failure - parity
t = 3; -> skip
finish
finish
if stat&comm bit # 0 start
t = 2!128
skip:
p_c1 = t; ! long block+accept last
to 2900(return control, null)
d_hold == mes; it_a(0) = n
return
finish
if sym = nl and d_mode = 0 start
it_a(n) = 13; n = n+1; ! plant cr
finish
if d_o pos = d_out lim then d_opos = -1
d_o pos = d_o pos+1
it_a(n) = sym
if d_o pos = d_o trig start ; ! send trigger message
get buffer(send trig reply)
finish
if d_o pos = lim start
it_hdb2 = terminated
d_ostate = d_ostate&(¬out p)
reply:
p_c1 = 0!128; ! eam1 to reject last char
if type = pmt p start
!! this is actually a prompt - not output
it_hdb2 = d_pmt n; ! at time of request
d_o pos = d_o posx; ! see comment above at type = pmt p
d_ostate = enabld
else
d_out go = d_out go-1 unless lose op # 0 or d_mode = 3
finish
to 2900(return control, null)
it_cnsl = d_cnsl; it_hdb1 = text
if d_mode = 2 start ; ! binary
it_hdb2 = it_hdb2!bin b
else
if d_mode = 3 start ; ! set mode
it_hdb1 = control; it_hdb2 = set mode
finish
finish
it_a(0) = n; ! itp length
mes_len = n+header len+1+3; ! nsi+cnsl+itp+no of chars
if d_cnsl = 255 start ; ! gone away
free buffer(mes)
else
if type # out p or lose op = 0 then c
to gate(put output, mes, 0) else c
free buffer(mes)
finish
if (d_ostate > enabld and d_out go > 0 ) or c
d_ostate = pmt p!enabld then get o block
return
finish
if n >= len start
!! leave room for a cr/lf sequence
it_hdb2 = 0
-> reply
finish
n = n+1
l_rxs = l_rxs!accept char; ! accept the last char
repeat
end
routine write to am1
record (mef) name mes
record (itpf) name it
integer n, max, char, stat, gah
constinteger cr = 13
mes == d_in mes
if d_state # input enabled or mes == null start
p_c1 = 0; ! terminate
->am1 rep; ! reply to am1 hanmdler
finish
it == mes_lev3_itp
n = mes_lev3_reserved(1)+1; ! pos in buffer, when buffer split
max = it_a(0)
if mon < 0 start
select output(1); printstring("inp:")
printstring(string(addr(it_a(0)))); select output(0)
finish
cycle
cycle
stat = l_rxs
if stat&xopl # 0 then p_c1 = 64 and ->am1 rep
if stat&ready # 0 start
!! l i m i t sent
p_c1 = 2; ! long block
mes_lev3_reserved(1) = n-1
am1 rep: to 2900(return control, null)
return
finish
if l_txs&ready # 0 then exit
repeat
if n > max start
p_c1 = 4; ! condition y
to 2900(return control, null)
gah = mes_lev3_reserved(0)
free buffer(d_in mes); d_in mes == null
d_seq bits = d_seq bits+seq inc
#if k
get buffer(send go ahead)
#else
if gah > 3 start
printstring("itps: gah ="); write(gah, 1)
!! nasty !
newline
gah = 2
finish
get buffer(send go ahead) and gah = gah-1 c
while gah >= 0
#fi
return
finish
cycle
char = it_a(n)
n = n+1
exit if char # cr or it_hdb2&bin b # 0
repeat
l_txd = char
if d_i pos = d_in lim then d_i pos = -1
d_i pos = d_i pos+1
repeat
end
routine kick 2900 message(record (maf) name log)
!! this routine sends 'log' to the 2900 by inserting
!! it in the input q for stream 4, and kicking it if
!! necessary
d == d2
if (d_hold == null and d_inp q_e == null) or d_incnt>5 then c
get buffer(kick message stream)
push(d_inp q, log)
d_in cnt = d_in cnt+1
end
routine tidy message streams
d2_o state = idle; d3_o state = idle
while not d2_inp q_e == null cycle
free buffer(pop(d2_inp q))
repeat
end
!! r e a d m e s s a g e f r o m a m 1
routine read message from am1
record (maf) name m
integer n, sym, t, stat, lreply, stream, index
record (mef) name mes
integer type
record (itpf) name itp
switch hlm(1:2)
! d3 is allways used
m == d3_hold; d3_hold == null
if m == null or d3_opos = d3_o lim start
printstring("itp: seq2!
")
t = 0!128; -> reply
finish
!! (cater for partial block rec'd)
n = d3_o posx
if n = 0 then d3_in cnt = 0
cycle
cycle
stat = l_rxs
exit if stat&(ready!xopl) # 0
repeat
if stat&xopl # 0 start ; ! xop gone down
t = 64; ! send unsuccessfull
printstring("itps: xop d
")
-> skip
finish
sym = l_rxd; ! read the char
if l_rxs&acfy # 0 start ; ! failed to read
sym = l_rxd; ! read it again
if l_rxs&acfy # 0 start ; ! hard failure - parity
t = 3
printstring("itps: parity
")
-> skip
finish
finish
if stat&comm bit # 0 start
t = 2!128
skip:
d3_o posx = n; d3_hold == m
reply:
p_c1 = t; ! long block+accept last
to 2900(return control, null)
return
finish
if d3_o pos = d3_out lim then d3_o pos = -1
if d3_o pos = d3_o lim then -> badm
d3_o pos = d3_o pos+1
if mon < 0 start
select output(1)
printsymbol('i'); write(n, 2); write(sym, 2); space
printsymbol(sym) if sym > 32; newline
select output(0)
finish
m_a(n) = sym; n = n+1
if n = 1 start ; ! Got the total length
d3_in cnt = m_a(0); ! max = 256
unless 5 < d3_in cnt <= 64-18 start
! nb: SMALL buffer is used
badm: printstring("***itps: message fails -")
write(d3_in cnt, 1); write(d3_o pos, 1); write(d3_out lim, 1)
write(d3_o lim, 1); write(type, 1); write(n, 1)
printstring(" itp messages lost
")
if n > 0 start
cycle sym = 0, 1, n
write(m_a(sym), 2); newline if sym&15=15
repeat
newline
finish
d3_o pos = d3_o lim
freebuffer(m)
-> reply
finish
else
if n = d3_in cnt then -> exit3; ! Got the whole message
finish
l_rxs = l_rxs!accept char; ! accept the last char
repeat
exit3:
d3_o posx = 0; ! full message taken
t = 0!128; ! normal+accept last
if d3_o pos # d3_o lim start ; ! Another message waiting
d == d3
get buffer(get op block)
finish
type = m_a(1); ! max = 256
! ? x = (8+m_a(4))&x'fffe'
stream = m_a(2)<<8!m_a(3)
m_m len = n
unless 1 <= type <= 2 then ->badm
index=(stream-fixed)>>1
unless 0<=index<=con lim then ->badm
d==con desa(index)
-> hlm(type)
hlm(1): ! Logon Reply
lreply = m_a(5)
str = string(addr(m_a(6))); ! copy text out of way
mes == m; ! make it a network buffer
mes_len = length(str)+4 +header len
mes_lev3_itp_cnsl = d_cnsl
mes_lev3_itp_hdb1 = 0
mes_lev3_itp_hdb2 = 2
mes_lev3_itp_s = str; ! copy text back in
tcp == tcpa(d_tcp)
to gate(put output, mes, 0)
d_out go = d_out go-1
if l reply = 0 start
d_state = logged on
else
d_state = logging off
retrieve(d) if d_cnsl = 255
finish
-> reply
hlm(2): ! setmode out, string at m_a(5)
if d_cnsl = 255 start
free buffer(m); -> reply
finish
str = string(addr(m_a(5))); ! copy setmode out of the way
#if k
!see if rawmode mask being used
if charno(str,1)=22 start
if charno(str,3) & 64 # 0 then d_gahs wanted=20 else d_gahs wanted=3
if d_gahs wanted>d_gahs sent then get buffer(send go ahead)
finish
#fi
mes == m; ! change the buffer to an itp one
itp == mes_lev3_itp
itp_cnsl = d_cnsl
itp_hdb1 = control; itp_hdb2 = set mode
itp_s = str; ! put the setmode back in
mes_len = length(str)+4+header len; ! hdr+string+string length
tcp == tcpa(d_tcp); ! map to tcp description
to gate(put output, mes, 0); ! send the buffer
->reply; ! give control back to am1h
end
!! w r i t e m e s s a g e t o a m 1
routine write message to am1
record (maf) name m
integer n, max, am1 reply, stat
! allways use d2
am1 reply = 4; ! "condition y"
cycle
m == d2_hold
if m == null then m == pop(d2_inp q) and d2_in cnt = d2_in cnt-1
if m == null then exit
!! terminate with "normal" (shouldnt happen)
n = d2_o posx; ! start of block - d2_o posx = 0
cycle
cycle
stat = l_rxs
if stat&xopl#0 start
d2_hold == m; ! retain buffer for retry
am1 reply = 64; d2_hold f = n; ->am1 rep
finish
if stat&ready # 0 start
!! l i m i t sent
am1 reply = 2; ! long block
d2_o posx = n; d2_o pos = max
d2_hold == m; ! retain for later
-> am1 rep
finish
if l_txs&ready # 0 then exit
repeat
if n > m_a(0) start
free buffer(m)
d2_hold == null; d2_o posx = 0; d2_hold f = 0
if d2_inp q_e == null then ->am1 rep
exit
finish
if mon < 0 start
select output(1)
printsymbol('o'); write(n, 2); write(m_a(n), 2); space
printsymbol(m_a(n)) if m_a(n) > 32; newline
select output(0)
finish
l_txd = m_a(n); n=n+1
repeat
repeat
am1 rep:
p_c1 = am1 reply
to 2900(return control, null)
end
#if x
routine mon mes(record (mef) name mes)
integer i, j, k, n
record (itpf) name itp
k = mes_len; itp == mes_lev3_itp
write(k, 1); space; space
j = 0
cycle i = 0, 1, k-1
if mon > 0 and i > 3 start ; ! 'p' and not header
n = itp_aa(i)
printsymbol(n) unless n = 0 or n = 4
else
write(itp_aa(i), 1)
j = j+1; if j = 25 then j = 0 and newline
finish
repeat
newline; select output(0)
end
routine mon p(record (pe)name p)
integer i
printstring(" fn ="); write(p_fn, 1)
printstring(" gate port"); write(p_gate port, 1)
printstring(" task port"); write(p_task port, 1)
printstring(" a2"); write(p_a2, 1)
if not p_mes == null start
newline; spaces(5)
write(p_mes_len, 3)
cycle i = 1, 1, 25
write(p_mes_params(i), 2)
repeat
finish
newline
end
#fi
endofprogram