!********************************
!* emas-2900 fep itp server *
!* file: x25_xxx1s/xxx1y *
!********************************
!! stack size = 500
!*
!* nsi version - include !n! statements
!* ring version - !n! -> !n! and !r! -> {r}
!*
#if i
control x'4001'
include "b_deimosspecs"
#else
control 1
include "deimosperm"
#fi
begin
conststring (13)vsn = "xxx...1d "
#datestring
recordformat am1f(integer rxs, rxd, txs, txd)
ownrecord (am1f) name l == 1; ! addr passed by eam1
!! no of data bytes in a short block
constinteger small block max = 51; ! 64-4-6-4
constinteger big block max = 127; ! < 256 !
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((byte res, bytearray a(1:128) or string (128) s))
!n! %recordformat lev3f(%bytearray reserved(0:5), %c
!n! %record (itpf) itp)
! nb: replaces fn,sufl,st,ss,flag,uflag
recordformat lev3f(bytearray reserved(0:6), record (itpf) itp)
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))
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)))
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
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)
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)
!************************************************************
!* upper level (itp&rje) handler messages to gate
!************************************************************
include "b_ygatecalls"
!**************************************************************
!* 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
!****************************************************************
!********** various service numbers *************
constinteger gate ser = 24
constinteger buffer manager = 17
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
constinteger disconnecting tcp = 2
!****** 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 awaiting int = 6
constinteger logging off = 7; ! 2970 is getting rid of it
constinteger logging off 2 = 8; ! 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
!**********************************************************
!* 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
! %constinteger send login fails 1 = 9; ! 9-17
constinteger send emas down = 18
constinteger Send int = 19
constinteger send kill transmit = 20
constinteger send pad params = 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
routinespec mon mes(record (mef) name mes)
routinespec mon p(record (pe) name p)
!******************************************************
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
constinteger max calls = 50
constinteger tcp limit = max calls; ! increase con statea as well !!!!!!!
ownrecord (tcpf) array tcpa(0:tcp limit)
constinteger con lim = max calls; ! number of active terminals
ownrecord (con desf) array con desa(-2:con lim)
constinteger max ports = 50
! cross index from port to tcp
constinteger max tts = 49; ! ie 0 to 48
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 = 1
integer i, n
ownstring (63) str
ownstring (1) snil = ""
constinteger header len = 0
!**********************************************
!* 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
repeat
d2 == con desa(-2)
d2_stream = -2
d3 == con desa(-1)
d3_stream = -1
printstring(vsn)
#if i
printstring("new ")
#fi
printstring(datestring); newline
#if i
map hwr(3); ! map am1 to seg 3
#else
map hwr(0); ! map am1 to segment 0
#fi
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
#if ~s
p_c = 2; ! param for 'here i am'
#else
p_c = 8
#fi
to 2900(here i am, null)
#if ~s
p_c = 3; ! and claim stream 3
#else
p_c = 9
#fi
to 2900(here i am, null)
tcp == tcpa(0); ! dummy for below
p_ser = gate ser; p_reply = own id
p_fn = enable facility; p_a2 = 0
p_facility = "XXX"
pon(p)
!**********************************************
!* main loop *
!**********************************************
cycle
p_ser = 0; poff(p)
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)
write(tcp_con state ind, 4)
newline
tcp_max = 0
finish
repeat
finish
if int = 'C' start
select output(1)
close output
printstring("Done
")
finish
int = 0
finish
if p_reply = link handler start
from 2900
finish else if p_reply = gate ser start
from gate
finish else if p_reply = buffer manager then from buffer manager(p)
repeat
!*************************************************
!* routines to do the work *
!*************************************************
routine crunch
integer i
cycle i = 1, 1, 15
printstring("xxx: 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 or fn = control data start
if tcp_state # connected start ; ! throw away
free buffer(mes); return
finish
if addr(mes)&k'140000' = k'140000' then crunch; ! had it
tcp_size = tcp_size+1
tcp_max = tcp_size if tcp_size>tcp_max
d_out go = d_out go-1
if d_out go = 255 then d_out go = 0; ! not negative
if mon < 0 start
select output(1)
printstring("To Tcp "); mon mes(mes)
finish
finish
p_ser = gate ser; p_reply = own id
p_fn = fn; p_gate port = tcp_port; p_mes == mes
p_a2 = flag
p_task port = tcp_tcpn
if mon # 0 start
select output(1); spaces(5)
printstring("xxx: to gate:"); mon p(p)
select output(0)
finish
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
p_a2 = d_stream
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
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
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
return if d_state = awaiting int
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
routine from gate
record (mef) name mes
record (tcpf) name targ
integer fn, flag, type, x, q, stream
switch fns(connect:Control Data)
string (63) calling
string (23) qual
fn = p_fn
tcpn = p_task port
tcp == tcpa(tcpn)
mes == p_mes
if mon # 0 start
select output(1); spaces(5)
printstring("xxx: from gate:")
mon p(p)
select output(0)
finish
->fns(fn)
fns(Connect):
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
to gate(Disconnect, null, 17)
return
finish
tcp_state = connected; tcp_ostate = idle
tcp_port = p_gate port
tcp_node = 0; ! ??????
calling = unpack(mes, 2)
qual = unpack(mes, 3)
if messflag=1 start
printstring(" xxx: ")
printstring(calling)
printstring(" connected
")
finish
tcp_max = 0; tcp_size = 0; tcp_held = 0; ! for monitoring
mes_len = 0
pack(mes, snil)
pack(mes, qual)
pack(mes, snil)
to gate(accept call, mes, 0)
! to gate(enable input, null, 1); ! out till pre-ack gate ready
d == pop(free des)
if d == null then return ; ! reject call later !!!!!!!!!!!!
stream = d_stream; ! hold the stream
d = 0; ! zero the record
d_stream = stream
d_tcp = tcp_tcpn; d_cnsl = 0
tcp_con state ind = stream
d_state = name sent; ! if down, goes to logging off whe sent
if host state = down start
get buffer(send emas down)
return
finish
get buffer(send pad params)
get buffer(send name prompt)
users = users+1
d_hold == null
get buffer(store user name)
return
fns(input here):
if mes_len <= 0 start
free buffer(mes)
return
finish
to gate(enable input, null, 1)
if mon < 0 start
select output(1)
printstring("From Tcp "); mon mes(mes)
finish
mes_lev3_reserved(0) = 0; ! missing gah count
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
fns(enable output):
tcp_ostate = idle
tcp_size = tcp_size-1 unless tcp_size = 0
return if tcp_con state ind = 0
d == con desa(tcp_con state ind)
d_out go = d_out go+1 unless d_out go > 2
if d_out go = 1 and d_ostate > enabld start
get o block
finish
return
! ring vsn?
return ; ! handled in 'input recd'
fns(Expedited): ! int: etc
unless tcp_con state ind = 0 start
d == con desa(tcp_con state ind)
get buffer(Send int)
d_state = awaiting int
finish ; ! buffer involved ??????????????????????????????????
return
fns(Disconnect): ! Call has been cleared
flag = p_a2; ! pickup reason for close
if messflag=1 start
printstring(" t"); write(tcp_term, 1)
printstring(" connection ")
if flag = 0 then printstring("aborted") else c
printstring("closed")
write(flag, 1)
write(tcp_max, 1); newline
finish
lose consoles(-1)
to gate(disconnect, null, 1)
tcp_state = not allocated
free buffer(mes) unless mes == null
tcp_max = 0
return
fns(Reset):
printstring("Reset rec'd
")
mon mes(mes)
return
fns(Control Data):
printstring("Control data in:")
mon mes(mes)
free buffer(mes)
to gate(enable input, null, 1)
end
integerfn analyse itp message(record (mef) name mes)
record (itpf) name itp, itp2
integer cnsl, index, stream, len, q, x, res
record (maf) name m
record (m2900if) name mi
string (15) int mes
switch console state(idle:logging off 2)
itp == mes_lev3_itp
itp_res = mes_len; ! nb: overwrites last byte of header
unless tcp_con state ind = 0 start
d == con desa(tcp_con state ind)
->console state(d_state)
finish
console state(not allocated): ! eg no descriptor
printstring("oops
")
result = -1
console state(name sent): ! user name arrived ?
if addr(d_hold)&k'140000'=k'140000' then printstring("name?")and crunch
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)-1
if charno(itp_s,length(itp_s))=13 then length(itp_s) = c
length(itp_s)-1
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
result = -1; ! de-alloctae block
console state(pass sent): ! password arrived ??
if addr(d_hold)&k'140000'=k'140000' then printstring("pass?")and crunch
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)-1
if charno(itp_s,length(itp_s))=13 then length(itp_s)= c
length(itp_s)-1
index = d_stream<<1+fixed
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_state = logging on
d_hold == null
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)
result = -1
console state(awaiting int):
d_state = input enabled
int mes = itp_s; ! copy it out of the way
len = length(int mes); ! check for cr, nl & nl
len = len-1; ! delete the cr
len = 15 if len > 15
if len <= 0 then res = -1 else start ; ! invalid
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
res = 2; ! don't deallocate buffer
finish
if mon < 0 start
select output(1)
printstring("On Int:ostate & out go:"); write(d_o state, 1); write(d_out go, 1)
newline
select output(0)
finish
if d_o state > enabld and d_out go >0 then get o block
result = res
console state(logging on): ! go ahead only?
console state(logged on): ! still no input
result = -1
console state(input enabled): ! input messages and ints
if not d_in mes == null start
d_seq bits = d_seq bits+seq inc
itp2 == d_in mes_lev3_itp
d_in mes_lev3_reserved(0) = d_in mes_lev3_reserved(0)+1; ! missing gah count
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
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
#if i
l == record(addr(p_mes)&k'17777'!k'060000'); ! put in seg 3
#else
l == record(addr(p_mes)&k'17777'); ! force to seg 0
#fi
return
link fns(do output): ! -> 11/34
#if ~s
if stream = 3 then read message from am1 else c
#else
if stream = 9 then read message from am1 else c
#fi
read from am1
! ->d mon
return
link fns(do input): ! -> 2900
#if ~s
if stream = 2 then write message to am1 else c
#else
if stream = 8 then write message to am1 else c
#fi
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 ~s
if stream = 2 then d == d2
if stream = 3 then d == d3
#else
if stream = 8 then d == d2
if stream = 9 then d == d3
#fi
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 < 10 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("xxx: 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
if d_cnsl = 255 start ; ! gone away
type = 1
else
d_in lim = m2900_p2b
d_i pos = m2900_p3b
finish
else
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
d_abortf = state; ! remember type
if not d_hold == null then c
free buffer(d_hold) and d_hold == null
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
! 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 ~s
if stream = 3 start
#else
if stream = 9 start
#fi
!! update of pointer on message stream
p2b = m2900_p2b
free buffer(m2900)
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 mon < 0 start
select output(1)
printstring("o/p: go, size:")
write(d_out go, 1); write(tcp_size, 1); newline
select output(0)
finish
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
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
constbyteintegerarray pts(1:last itp reason) =
1, 10, 19, 26, 33, 39, 40, 45, 45, 45(8),
45, 64, 74, 80
!! pt to itp mess
ownbyteintegerarray itp message(1:98) =
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, 3, 2, 2, 1,; ! echo on
5, 3, 2, 3, 2, 2, 0,; ! echo off
5, 0, 2, 2, 13, nl,; ! nl
0,; ! not used
3, 5, 0, 1, 1,; ! i disconnect
18, 0, 2, 15, 13, nl, '*', '*', '2', '9', '0', '0', ' ',
'D', 'o', 'w', 'n', 13, nl,; ! emas down
0, 0, 0, 6, 13, nl, 'I', 'n', 't', ':',; ! send Int:
0, 0, 0, 2, 13, nl,; ! nl
0(3), 15, 2, 2, 1, 3,2, 7, 1, 9, 0, 10, 80,
12, 0, 13, 4; ! sensible pad parameters
pt = pts(no)
mes_lev3_itp_s = string(addr(itp message(pt+3)))
mes_len = length(mes_lev3_itp_s)
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 (3) add
! 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("xxx: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
! string(addr(logr_a(4))) = mes_bsp_itp_s
! logr_mlen = length(mes_bsp_itp_s)+5+1
! until tcp passes address
length(add) = 3
charno(add, 1) = tcpa(d_tcp)_node
charno(add, 2) = tcpa(d_tcp)_term
string(addr(logr_a(4))) = add
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, call ty
record (m2900f) name m2900
record (mef) name mes
record (m2900if) name mi
conststring (1) the chop = "Y"
reason = p_c2; ! get reason for calling
!n! n = p_gate port; ! byte quantity !
n = p_a2
if n >= 254 then n = n-256
d == con desa(n); ! get console desxcriptor
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
call ty = put output
if 3<=reason<=4 or reason = 7 or c
reason = send pad params then call ty = Control data
tcp == tcpa(d_tcp)
to gate(call ty, p_mes, 0)
if reason = send emas down then d_state = logging off 2 and c
get buffer(send disconnect)
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 ~s
if d_stream < 0 then m2900_stream = 4+d_stream
#else
if d_stream < 0 then m2900_stream = 10+d_stream
! streams 8 & 9 are internally -2 & -1
#fi
if reason = low level op transfer start
mes == d_hold
if mes == null or d_state = awaiting int 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)
tcp_con state ind = 0; ! only one user in XXX
finish
free transient
d_state = not allocated
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
q = tcp_con state ind
unless q = 0 start
d == con desa(q)
d_cnsl = 255; ! no messages to the tcp now
free transient
unless d_state >= logging off start
if input enabled <= d_state <= awaiting int 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
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("xxx: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
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
d_o pos = d_o posx; ! see comment above at type = pmt p
d_ostate = enabld
else
finish
to 2900(return control, null)
mes_len = n+header len; ! 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_out go > 0 and d_ostate > enabld then c
get o block
return
finish
if n >= len start
!! leave room for a cr/lf sequence
-> 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)))); newline; 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)
free buffer(d_in mes); d_in mes == null
return
finish
char = it_a(n)
char = nl if char = cr; ! forwarding on cr, with no lf
n = n+1
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
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("xxx: 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("xxx: 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("xxx: 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("***xxx: 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(" xxx messages lost
")
if n > 0 start
cycle sym = 0, 1, n
write(m_a(sym), 2); newline if n&15=15
repeat
newline
finish
d3_o pos = d3_o lim
-> 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
d == con desa((stream-fixed)>>1)
if d_state = not allocated start ; ! user has disconnected etc
printstring("xxx: Invalid logon reply
")
free buffer(m)
-> reply
finish
-> 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)
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
get buffer(send disconnect); ! immediate request to go
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
mes == m; ! change the buffer to an itp one
itp == mes_lev3_itp
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
FREE BUFFER(MES); ! CANT HANDLE SETMODE
->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
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 = 1, 1, k
if mon > 0 and i > 3 start ; ! 'p' and not header
n = itp_a(i)
printsymbol(n) unless n = 0 or n = 4
else
write(itp_a(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
endofprogram