!********************************
!* emas-2900 fep ts29 server *
!* file: fepi_ts29s *
!********************************
!! stack size = 500
!*
!
! prep options
!
! k - kent
! i - new imp compiler
! s - use streams 8 & 9 as control streams to coexist with itp hdlr
! b - use kent booking server
!
#if i
control x'4001'
include "b_deimosspecs"
#else
control 1
include "deimosperm"
#fi
!
begin
!
conststring (13) vsn= "ts29...1a "
#datestring
recordformat am1f(integer rxs, rxd, txs, txd)
!
ownrecord (am1f) name l == 1; ! addr passed by eam1
!
#if k
constinteger small block len = 128
#else
constinteger small block len= 64
#fi
constinteger small block max= small block len - 11
!
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 dstart, bytearray reserved(0:6), (bytearray data(0:240) orbyte type))
!
recordformat mef(record (mef) name link, byteinteger len, type, (record (itpf) itp orbytearray params(0:231)))
!
recordformat m2900f(record (mef) name l, byteinteger len, type, integer stream, sub ident, p2a, p2b, p3a, p3b, p4a, p4b,
p5a, p5b, p6a, p6b)
!
recordformat m2900bf(record (mef) name l, byteinteger len, type, integer stream, sub ident, byteintegerarray b(0:19))
!
recordformat m2900if(record (mef) name l, byteinteger len, type, integer stream, sub ident, p2a, p2b, string (15) int)
!
recordformat m2900cf(record (mef) name l, byteinteger len, type, integer stream, sub ident, integerarray pa(0:9))
!
!
recordformat maf(record (mef) name l, byteinteger mlen, mtype, byteintegerarray a(0:240))
!
!
recordformat pe(byteinteger ser, reply, (integer a, b, (integer c orbyte c1, c2) or c
byte fn, a2, (record (mef) name mes, byte ts port, task port orstring (3) facility)))
!
!
recordformat qf(record (mef) name e)
!
!********************************************************
!* formats of tables, ie stream descriptors, tcps etc *
!********************************************************
recordformat con desf(record (mef) name out buf, { buffer for output}
record (mef) name in buf, { buffer for input}
integer dindex, { internal console number - index to con desa array}
o lim, o pos, otrig, oposx, {posn within buffer}
i lim, i pos, prompt ipos, p lim,
out lim, in lim, {cyclic buffer limits}
out go, {may be negative}
byte pushed, {last data input}
datatype, {0 -> normal}
int char,
cons no, {as on TCP}
bits, {status bits-see below}
nstate, {state of network connection}
mode, {0=>iso,2=>bin}
port, {ts port number}
(string (7) tcp name, user or
record (qf) inp q, {data for control strm}
integer in cnt, in buf pos, out mess len))
!
!
include "tsbsp_tscodes"
!
!**************************************************************
!* 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 k
constinteger ts ser = 16
#else
constinteger ts ser= 24
#fi
#if b
constinteger host bk ser = 25
#fi
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'
!***********************************************************
!* 2900 states *
!***********************************************************
owninteger 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 fixed= 10; ! 1st available stream
!**************************************************************
!* network states *
!**************************************************************
constinteger closed= 0
constinteger sent name= 1
constinteger sent pass= 2
constinteger connected= 3
constinteger resetting= 4
constinteger closing= 5
constinteger sent disc = 6
!
!
! status bits stored in 'bits'
constinteger allocated= 1
constinteger is connected= 2
constinteger os connected= 4
constinteger is enabled= 8
constinteger os enabled= 16
constinteger output pending= 32
constinteger prompt pending= 64
!
!******************************************
!* 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 send disconnect= 6
!
constinteger send emas down= 7
#if b
constinteger send busy = 8
constinteger send pad params= 9
#else
constinteger send pad params= 8
#fi
!
constinteger last itp reason= send pad params
!
constinteger init facility = 19
!
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 int = 26
constinteger get big op block= 27
constinteger kick message stream= 28
!**************************************************************
string (8)fnspec itos(integer i)
routinespec puthex(integer d)
routinespec dump(record (con desf) name d)
routinespec from clock
routinespec crunch
routinespec to ts(integer fn, record (mef) name mes, integer flag)
routinespec to 2900(integer fn, record (m2900f) name m2900)
routinespec get buffer(integer reason)
routinespec free buffer(record (mef) name mes)
string (127) fnspec unpack(record (mef) name mes, integer no)
routinespec pack(record (mef) name mes, string (*) name s)
routinespec get o block
record (condesf) mapspec new slot
routinespec from ts
routinespec ucase(string (*) name s)
routinespec set address(string (*) name a)
string (*) mapspec cleanup(record (mef) name mes, integer max)
routinespec append(record (maf) name m, string (*) name s)
routinespec setup logon request(record (maf) name logr, string (*) name pass)
routinespec handle control data(record (mef) name mes)
routinespec qdatain(record (mef) name mes)
routinespec free transient
routinespec from 2900
routinespec fill(record (mef) name mes, integer no)
routinespec from buffer manager(record (pe) name p)
routinespec close connection
routinespec retrieve(record (con desf) name d)
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 translate(record (maf) name m, integer strt)
routinespec write message to am1
routinespec mon mes(record (mef) name mes)
routinespec mon p(record (pe) name p)
#if b
routinespec from bk
#fi
!******************************************************
ownrecord (pe) p
ownrecord (con desf) name d
ownrecord (con desf) name control d
ownrecord (qf) name buffer pool
owninteger no of buff= 0
!
constinteger max cons= 2
!
constinteger initial out go = 1
ownrecord (con desf) array con desa(-1:max cons)
!
!-1 is used for the control streams 2 and 3 (or 8 and 9) for the rest
!con desa(i) corresponds to streams fixed+i<<1 and fixed+i<<1+1
!
owninteger slot scan = 0; !used in allocation of console slots
owninteger tp; !used in translation of setmodes
ownbytearrayname t; !ditto
!
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 (1) snull= ""
!
!**********************************************
!* initialisation *
!**********************************************
!
change out zero = t3 ser
!
control d == con desa(-1)
!
printstring(vsn)
#if k
printstring("Kent ")
#fi
#if b
printstring("(bk) ")
#fi
#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)_dindex = i for i = -1, 1, max cons
!
#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)
!
control d_bits = allocated
d == control d; !must have d set for get buffer call
get buffer(init facility);!enable "ts29"
!**********************************************
!* main loop *
!**********************************************
alarm(100)
cycle
p_ser = 0; poff(p)
!
!
if p_reply=0 start
from clock
finishelseif p_reply=link handler start
from 2900
finishelseif p_reply=ts ser start
from ts
#if b
finishelseif p_reply = host bk ser start
from bk
#fi
finishelseif p_reply=buffer manager then from buffer manager(p)
repeat
!
!*************************************************
!* routines to do the work *
!*************************************************
!
string (8)fn itos(integer i)
!-----------------------------
bytearray c(0:7)
string (8)s
integer k, sign
k=0
sign = 1
if i<0 start
i = -i; sign = -1
finish
cycle
c(k)=i-i//10*10+'0'; i=i//10
k=k+1
repeatuntil i=0
if sign < 0 then c(k) = '-' and k = k+1
length(s)=k
for i=1,1,k cycle
charno(s,i)=c(k-i)
repeat
result =s
end
!
routine puthex(integer d)
!-------------------------------------------------
!
integer i;
byteinteger s;
!
printsymbol(' ');
cycle i = 12,-4,0;
s = (d>>i)&x'f';
if s>9 then s = s-'0'+'a'-10;
printsymbol(s+'0');
repeat ;
end ;
!
routine dump(record (con desf) name d)
!----------------------------------------
integer i, n, add
conststring (5) array bitstr(0:6) = "allc ","isc ","osc ","ise ", "ose ",
"outp ","prp "
conststring (5) array nstatestr(0:6)="clsd ","name ","pass ","conn ",
"rst ","disc ","sntd "
!
if d_bits&allocated = 0 then return
write(d_dindex,3)
printsymbol(':')
printstring(nstatestr(d_nstate))
for i=0, 1, 6 cycle
if (d_bits >> i) & 1 #0 then printstring(bitstr(i))
repeat
!
if d_dindex>=0 start
printstring(d_tcpname); space; printstring(d_user)
finish
newline
n = 0
add = addr(d)
for i=1, 1, 26 cycle
if n>=16 then newline and n=0
put hex(integer(add))
n=n+1
add = add+2
repeat
newlines(2)
end
!
routine from clock
!-------------------------------
integer n, i
if host state = down start ; !see if any consoles to throw off
n = 0
for i=0, 1, max cons cycle
if n > 3 then exit ; !never discard more than 3 per clock tick
d == con desa(i)
if d_bits & allocated # 0 start
if d_nstate = closed start
retrieve(d)
finishelse if d_nstate # closing and d_nstate # sent disc start
free transient
get buffer(send emas down)
get buffer(send disconnect)
n = n+1
finish
finish
repeat
finish
!
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
select output(1)
write(no of buff, 4); write(users,1); newline
for i = -1, 1, max cons cycle
dump(con desa(i))
repeat
close output
printstring("Done"); newline
finish
if int='C' start
select output(1)
close output
printstring("Done
")
finish
!
int = 0
finish
alarm(100)
end
!
routine crunch
!-------------------------------
!--------------
printstring("ts29: Bad buffer ***** dump fep ********
")
*=k'104001'; ! emt wait
end
!
routine to ts(integer fn, record (mef) name mes, integer flag)
!-------------------------------
!
unless mes==null start
if (addr(mes)&k'160000'#k'100000' and addr(mes)&k'160000'#k'120000') orc
addr(mes)&k'77'#0 then crunch
finish
!
if fn=put output start
if mon<0 start
select output(1)
printstring("To Tcp "); mon mes(mes)
finish
finish
!
p_ser = ts ser; p_reply = own id
p_fn = fn; p_ts port = d_port; p_mes == mes
p_a2 = flag
p_task port = d_dindex
if mon#0 start
select output(1); spaces(5)
printstring("ts29: to ts:"); 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 immediately*
!* 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_dindex
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 = no of buff-1; from buffer manager(p)
finish
end
!
routine free buffer(record (mef) name mes)
!-------------------------------
record (pe) p
!
if (addr(mes)&k'160000'#k'100000' and addr(mes)&k'160000'#k'120000') orc
addr(mes)&k'77'#0 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 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)))
finishelseresult = ""
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
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 get buffer(get big op block) c
else get buffer(get op block)
end
!
record (condesf) map new slot
!------------------------------
integer i
i = slot scan
cycle
slot scan = slot scan+1
if slot scan>max cons then slot scan = 0
d == con desa(slot scan)
if d_bits=0 then d_bits=allocated and result == d
repeatuntil slot scan=i
result ==null
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
d==con desa(index)
index=index*2 + fixed
if p_fn=logon reply start
if p_a2=bkaccept start ; !send logon request to the host
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_nstate=closed start
retrieve(d)
else
d_bits = d_bits&(¬(isconnected!osconnected)); !they never were really connected
get buffer(send busy)
get buffer(send disconnect)
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; !user name in m_a(4) onwards, as string
kick 2900 message(m); !NB corrupts d
finish
!
end
#fi
!
routine from ts
!-------------------------------
record (mef) name mes
integer fn, cno, int char
ownstring (4) mes emas="emas"
ownstring (21) mes no free console slots="No free console slots"
ownstring (5) quality="W=1/1"
switch fns(connect:reset)
string (63) called
!
fn = p_fn
mes == p_mes
if mon<0 start
selectoutput(1)
printstring("From ts:")
monp(p)
if fn=connect or fn=input here then mon mes(mes)
selectoutput(0)
finish
!
unless connect<=fn<=reset start
printstring("ts29:Illegal fn from tsbsp"); write(fn,1); newline
unless mes==null then free buffer(mes)
return
finish
!
if fn#connect start ; !verify state and port numbers
cno = p_task port
if 0<=cno<=maxcons start
d == con desa(cno)
if d_nstate=closed or d_bits&allocated=0 start
printstring("ts29:illegal message from tsbsp")
err:
write(fn, 1); write(p_ts port, 1); write(d_bits, 1); newline
unless mes==null then free buffer(mes)
return
finish
else
printstring("ts29:illegal console number from tsbsp");
write(cno, 1); ->err
finish
finish
!
->fns(fn)
!
fns(connect):
called = unpack(mes, 2)
d == new slot
if d==null start ; !no free slots
mes_len = 0
pack(mes, mes emas)
pack(mes, mes no free console slots)
d == control d; !use this one as it hasn't a network connection
d_port = p_ts port
to ts(disconnect, mes, ts err busy)
return
finish
cno = d_dindex
users = users + 1
d_port = p_ts port
set address(called); !decypher tcp name and console number from address
!and store into d
mes_len = 0
pack(mes, mes emas)
pack(mes, quality); !quality = W=1/1 only 1 input buffer
pack(mes, snull)
to ts(accept call, mes, 0)
d_pushed = 1; !initialise state of data stream in
d_out go = initial out go
if host state=down start
d_nstate = connected
get buffer(send emas down)
get buffer(send disconnect)
return
finish
get buffer(send pad params)
get buffer(send name prompt); !normal logon attempt - send User: prompt
d_nstate = sent name
return
!
fns(input here):
to ts(enable input, null, 1)
unless d_nstate<=connected then free buffer(mes) andreturn
!
if d_pushed#0 start ; !last data was pushed
if mes_len=0 start
printstring("ts29:no data type byte from ")
printstring(d_tcpname); write(d_consno,1); newline
else
d_data type = mes_itp_type
finish
mes_itp_dstart = 1
else
mes_itp_dstart = 0
finish
d_pushed=p_a2
if d_datatype=0 then qdatain(mes) else handle control data(mes)
return
!
fns(disconnect):
unless mes==null then free buffer(mes)
if d_nstate=closing start ; !stream now closed
if d_bits&(isconnected+osconnected)=0 then retrieve(d)
else
to ts(disconnect, null, 1)
if d_bits&(isconnected+osconnected)=0 start
retrieve(d)
else
d_intchar = 'Y'
get buffer(send int)
finish
finish
d_nstate = closed
return
!
fns(enable output):
if d_nstate>connected thenreturn
if d_out go<=0 start ; !output blocked
d_out go = d_out go+p_a2
if d_out go>0 and d_bits&(prompt pending!output pending)#0 then get o block
return
finish
d_out go = d_out go+p_a2
return
!
fns(expedited data):
if mes==null start
int char = p_a2
else
int char = mes_params(0)
free buffer(mes)
finish
if int char=0 then intchar = 'A'
if d_nstate>connected or d_bits&isconnected=0 thenreturn
d_int char = int char
get buffer(send int)
return
!
fns(reset):
unless mes==null then free buffer(mes)
if d_nstate=closing thenreturn
if d_nstate=sent disc start
to ts(disconnect, null, tserr reset)
free transient
d_nstate = closing
return
finish
if d_nstate=resetting start
d_nstate = connected
else
to ts(reset, null, 1)
d_intchar = 'C'; !send int C to emas if nstate ok
if d_nstate=connected then get buffer(send int)
finish
d_pushed = 1
if d_out go<=0 start ; ! output was blocked
if d_bits&osenabled#0 then get o block
finish
d_out go = initial out go
return
!
end
!
!
routine ucase(string (*) name s)
!-------------------------------
integer i
for i = 1, 1, length(s) cycle
if 'a'<=charno(s, i)<='z' then charno(s, i) = charno(s, i)-'a'+'A'
repeat
end
!
routine set address(string (*) name a)
!-------------------------------
!takes a ts address probably of the form tcpxyz/ts29/n where
!n is the console number in hex (single digit) This form is checked
!and if ok the tcpname and console number are stored in the console
!descriptor
string (63) addr, add2
integer c
ucase(a)
if a->addr.("/TS29/").add2 start
if length(add2)=1 start ; !console number in hex
c = charno(add2, 1)
if '0'<=c<='9' then c = c-'0' elseif 'A'<=c<='F' then c = c-'A'+10 else c = 0
else
c=0
finish
!remove initial address fields separated by /
while addr->add2.("/").addr cycle ; repeat
if length(addr)>7 then length(addr) = 7
d_tcp name = addr
d_consno = c
else
d_tcp name = "ANON"
d_consno = d_dindex; !keeps them unique
finish
end
!
string (*) map cleanup(record (mef) name mes, integer max)
!-------------------------------------------------
!mes is a data buffer from the network. trailing cr lf are removed
!and a string pointer is returned (corrupting the byte before the data
!as the length)
integer ds, l
ds = mes_itp_dstart
l = mes_len-ds
if l>0 and mes_itp_data(ds+l-1)=13 then l = l-1; !remove trailing cr
if l>max then l=max
mes_itp_data(ds-1) = l; !make it look like a string
result == string(addr(mes_itp_data(ds-1)))
end
!
routine append(record (maf) name m, string (*) name s)
!-------------------------------
!append s to the buffer m which is destined for the 2900
!
integer x
x = m_mlen
string(addr(m_a(x))) = s
m_mlen = x+length(s)+1
end
!
routine setup logon request(record (maf) name logr, string (*) name pass)
!--------------------------------------------------------------------------
!
!have got buffer to store logon request info in
!
logr_a(1) = 1
logr_a(2) = 0
logr_a(3) = d_dindex<<1+fixed
string(addr(logr_a(4))) = d_tcp name."::".itos(d_consno).":"."emas"
!blank field above is for the terminal speed
logr_mlen = logr_a(4)+4+1
append(logr, d_user)
append(logr, pass)
logr_a(0) = logr_mlen-1
end
!
routine handle control data(record (mef) name mes)
!----------------------------------------------------
free buffer(mes)
end
!
routine qdatain(record (mef) name mes)
!-------------------------------
!handle buffer of data
integer index, l, i
string (8) pass
!
if d_nstate=connected start ; !normal input data
if mes_itp_dstart>=mes_len start ; !empty buffer
free buffer(mes)
return
finish
if d_in buf==null start
d_inbuf == mes
if d_bits&isenabled#0 then get buffer(low level ip transfer)
else
!see if new buffer can be copied into existing one
l = d_inbuf_len
if mes_len+l <240 start
for i = mes_itp_dstart, 1, mes_len-1 cycle
d_inbuf_itp_data(l) = mes_itp_data(i)
l = l+1
repeat
free buffer(mes)
d_inbuf_len = l
else
printstring("ts29:Extra input!!")
free buffer(mes)
finish
finish
return
finish
if d_nstate=sent name start ; !this should be the user name
d_nstate = sent pass
get buffer(put echo off)
get buffer(send pass prompt)
d_user = cleanup(mes, 7)
return
finish
if d_nstate=sent pass start
pass = cleanup(mes, 8); !copy password out of buffer
d_nstate = connected
get buffer(send nl)
get buffer(put echo on)
d_bits=d_bits!(isconnected!osconnected)
setup logon request(mes, pass)
#if b
p_mes == mes
to bk(d_dindex, can i logon)
#else
index = d_dindex<<1+fixed
p_c = index
to 2900(here i am, null); !tell am1 handler about new stream
p_c = index+1
to 2900(here i am, null);
kick2900 message(mes); !NB corrupts d
#fi
return
finish
end
!
routine free transient
!-------------------------------
ifnot d_in buf==null then free buffer(d_in buf) and d_in buf == null
ifnot d_out buf==null start
free buffer(d_out buf); d_out buf == 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
!
integer stream, sub ident, state, trig, mode, i
integer type, p2b
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
if stream>=fixed then d == con desa((stream-fixed)>>1) else d == control d
->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, max cons
d == con desa(i)
d_bits = d_bits & allocated; !clear all the other bits
repeat
host state = down
users = 0
return
!
!
link fns(message):
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
control d_bits=control d_bits ! (isconnected+osconnected)
!! initial logon stream connected
host state = up
printstring("logon stream connected
")
users = 0
else
if state=enabling start
printstring("ts29:logon stream enabled ")
if stream&1=0 start
d_bits = d_bits!isenabled
printstring("(input)"); newline
else
d_bits = d_bits!osenabled
d_outlim = m2900_p2b
printstring("(output)"); newline
finish
finish
!
if state=disconnecting start
control d_bits = allocated; !clear all bits but allocated
host state = down
printstring("logon stream disconnected
")
tidy message streams
finish
finish
else
!
if d_bits&allocated=0 start
printstring("ts29:attempt to access unallocated stream")
write(stream, 1); write(d_nstate, 1); write(d_bits, 6); newline
->send reply
finish
!
if state=enabling start ; ! 1st interesting condition
if stream&1=0 start ; !enable input stream
d_bits=d_bits!isenabled
if d_nstate=closed start
type=1; !abort the stream
else
d_in lim=m2900_p2b
d_i pos=m2900_p3b
unless d_inbuf==null then get buffer(low level ip transfer)
finish
else ; !enable output stream
d_bits=d_bits!osenabled
d_outlim=m2900_p2b
d_o pos=m2900_p3b
d_mode = mode>>4; ! 0-iso,x'20'-bin,x'30'-cont
finish
finishelseif state=disconnecting start
if stream&1=0 start ; !disconnect input stream
d_bits=d_bits&(¬(isconnected+isenabled))
else ; !disconnect output
d_bits=d_bits&(¬(osconnected+osenabled))
finish
if d_bits&(osconnected+isconnected)=0 start
close connection
!
finish
!
finishelseif state=aborting or state=suspending start ; !stop streams
if stream&1=0 start
d_bits=d_bits&(¬isenabled)
if state=aborting start
unless d_inbuf==null then free buffer(d_inbuf) andc
d_inbuf==null
to ts(reset, null, 0)
d_nstate=resetting
d_out go = initial out go
finish
else
d_bits=d_bits&(¬(osenabled+output pending+prompt pending))
unless d_outbuf==null then free buffer(d_outbuf) andc
d_outbuf==null
finish
finish
finish
m2900_p2a = 0; m2900_p2b = 0
send reply:
to 2900(low level control, m2900)
if type#0 then d_int char='Y' and get buffer(send int); !chop the stream
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
!the input is at the trigger position ie no type ahead discernible now
!get the prompt
d_p lim = m2900_p2b
d_prompt i pos=d_ipos; !remember current value so can check
!there's been no type ahead when the
!prompt is read
if d_bits&(prompt pending+output pending+osenabled)=osenabled start
d_outbuf==m2900; !save the buffer
d_bits=d_bits!prompt pending
get buffer(low level op transfer)
return
finish
d_bits=d_bits!prompt pending
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 orc
(d_opos<d_olim andnot d_opos<d_otrig<=d_olim) orc
(d_opos>d_olim and d_olim<=d_otrig<=d_opos)
finish
!
d_bits=d_bits&(¬prompt pending); !discard prompt
if d_bits&output pending=0 and d_opos#d_olim start
d_bits=d_bits!output pending
if mon<0 start
select output(1)
printstring("o/p: go, size:")
write(d_out go, 1); newline
select output(0)
finish
if d_out go>0 start ; ! allowed to send
ifnot d_out buf==null start
free buffer(m2900)
else
d_out buf == m2900
finish
!
get buffer(low level op transfer)
return
finish
finish
free buffer(m2900)
finish
finish
end
!
routine fill(record (mef) name mes, integer no)
!-------------------------------
integer i, pt
!
ownbyteintegerarray pts(1:last itp reason)
!
!the itp messages have a length followed by the ts29 data type byte followed
!by the data. The pts array is initialised on the first call to index the
!messages.
#if b
ownbyteintegerarray itp message(1:106) =
#else
ownbyteintegerarray itp message(1:65) =
#fi
6,0,'U','s','e','r',':',; !name prompt
6,0,'P','a','s','s',':',; !password prompt
4,128,2,2,1,; !echo on
4,128,2,2,0,; !echo off
3,0,13,nl,; !newline
2,128,1,; !disconnect (invitation to clear)
16,0,13,nl,'*','*','2','9','0','0',' ',
'D','o','w','n',13,nl,; !**2900 Down
#if b
40,0,13,nl,'*','*','*','S','o','r','r','y',' ',; !Sorry no free consoles
't','h','e','r','e',' ','a','r','e',' ','n','o',' ',
'f','r','e','e',' ','c','o','n','s','o','l','e','s',13,nl,
#fi
16,128,2,2,1,; !pad params- echo on
3,2,; !forward on cr
7,1,; !transmit Interrupt on break
9,0,; !no pad after cr
10,80,; !line fold after 80
12,0,; !flow control off
13,4; !lf inserted after echoed cr
!
if pts(1)=0 start ; ! initialise pts array
pt=1
for i=1,1,last itp reason cycle
pts(i)=pt
pt=pt+itp message(pt)+1
repeat
finish
pt = pts(no)
!
string(addr(mes_itp_reserved(6)))=string(addr(itp message(pt)))
mes_len=itp message(pt)
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
!
reason = p_c2; ! get reason for calling
n = p_a2
if n>=254 then n = n-256
d == con desa(n); ! get console descriptor
if mon<0 start
select output(1); printstring("from buff:")
write(p_ts port, 1); write(n, 1); write(reason, 1)
write(d_dindex, 1); write(d_nstate, 1)
newline; select output(0)
finish
!
if d_bits&allocated=0 then free buffer(p_mes) and return
!
if reason=init facility start
string(addr(p_mes_params(0)))="TS29"
to ts(enable facility, p_mes, 1)
return
finish
!
if reason<=last itp reason start
if sent name<=d_nstate<=connected or d_nstate=resetting start
fill(p_mes, reason); ! insert the message
!
to ts(put output, p_mes, 1); !always push the data
d_out go=d_out go-1
if reason=send disconnect then d_nstate=sent disc
else
free buffer(p_mes)
finish
!
else
!
if reason=get op block or reason=get big op block start
if d_bits&osenabled=0 then free buffer(p_mes) and return
unless d_out buf==null then free buffer(d_out buf)
d_out buf == p_mes
get buffer(low level op transfer)
return
finish
!
!! message to 2900 reason
m2900 == p_mes
m2900_stream = d_dindex<<1+fixed+reason&1
m2900_sub ident = 10
!
#if ~s
if d_dindex<0 then m2900_stream = 2+(reason&1)
#else
if d_dindex < 0 then m2900_stream = 8+(reason&1)
#fi
!
if reason=low level op transfer start
mes == d_out buf
if mes==null then free buffer(p_mes) and return
! kill op done, so ignore tran request
mes_itp_dstart=1; !start of data index
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 int start
mi == m2900; mi_sub ident = 0; type = send data
mi_p2a = -1; mi_p2b = -1
length(mi_int) = 1
charno(mi_int, 1) = d_int char
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 close connection
!------------------------
switch st(closed:sent disc)
free transient
->st(d_nstate)
st(closed):
retrieve(d)
return
st(sent pass):
st(sent name):
st(connected):
get buffer(send disconnect)
return
st(resetting):
st(sent disc):
to ts(disconnect, null, tserr crash)
d_nstate = closing
return
st(closing):
end
!
routine retrieve(record (con desf) name d)
!-------------------------------
!
if d_bits&allocated=0 start
printstring("ts29:attempt to free deallocated slot")
write(d_dindex, 1); newline
return
finish
free transient
!
d_bits=0
#if b
to bk(d_dindex, logged off); !tell booking server task
#fi
users = users-1
if users<0 start
printstring("ts29:users count negative")
newline
users = 0
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, prompt, t, stat, len
!
mes == d_out buf
!
if mes==null or d_bits&osenabled=0 start
printstring("ts29:sequence?
")
p_c1 = 0!128; to 2900(return control, null)
return
finish
!
d_out buf == null
!
if mes_type=0 then len = bigblockmax-2 else len = small block max-2
it == mes_itp
n = it_dstart
flag = 0
!
if d_bits&output pending#0 start
lim = d_o lim; prompt=0
else
lim = d_p lim; prompt=1
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
exitif 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_out buf == mes; it_dstart = n
return
finish
!
if sym=nl and d_mode=0 start
it_data(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_data(n) = sym
n = n+1
!
if d_o pos=d_o trig start ; ! send trigger message
get buffer(send trig reply)
finish
!
if d_o pos=lim start
d_bits=d_bits&(¬output pending)
!
reply:
p_c1 = 0!128; ! eam1 to reject last char
!
to 2900(return control, null)
mes_len = n
it_type = 0; !not control data
!
if d_nstate#connected and d_nstate#resetting start
free buffer(mes)
else
if prompt#0 start
!! this is actually a prompt - not output
d_o pos = d_o posx; ! see comment above at type = pmt p
d_bits=d_bits&(¬prompt pending)
if d_prompt ipos#d_ipos start ; !type ahead
free buffer(mes); !discard the prompt
else
to ts(put output, mes, 1); !pushed
d_out go = d_out go-1
finish
else
if d_mode=3 start ; !set mode
it_type = n-1; !make it look like string
translate(mes, 8); !m_a(8) == mes_itp_type
!translate accesses the buffer as maf
finish
to ts(put output, mes, 1)
d_out go = d_out go-1
finish
finish
!
if d_out go>0 and d_bits&(prompt pending!output pending)#0 thenc
get o block
return
finish
!
if n>=len start
!! leave room for a cr/lf sequence
->reply
finish
!
!
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
constinteger cr= 13
!
mes == d_in buf
if d_bits&isenabled=0 or mes==null start
p_c1 = 0; ! terminate
->am1 rep; ! reply to am1 hanmdler
finish
!
it == mes_itp
n = it_dstart
max = mes_len
if mon<0 start
select output(1); printstring("inp:")
it_data(n-1)=max-n
printstring(string(addr(it_data(n-1)))); 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
it_dstart = n
am1 rep:
to 2900(return control, null)
return
finish
!
if l_txs&ready#0 thenexit
repeat
!
if n>=max start
p_c1 = 4; ! condition y
to 2900(return control, null)
free buffer(d_in buf); d_in buf == null
return
finish
!
!
char = it_data(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 == control d
if (d_out buf==null and d_inp q_e==null) or d_incnt>5 then get buffer(kick message stream)
push(d_inp q, log)
d_in cnt = d_in cnt+1
end
!
routine tidy message streams
!-------------------------------
control d_bits=allocated
whilenot control d_inp q_e==null cycle
free buffer(pop(control d_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
string (40) str
!
switch hlm(1:2)
!
! control d is always used
m == control d_out buf; control d_outbuf == null
if m==null or control d_opos=control d_o lim start
printstring("ts29: seq2!
")
t = 0!128; ->reply
finish
!
!! (cater for partial block rec'd)
n = control d_o posx
if n=0 then control d_out mess len = 0
!
cycle
cycle
stat = l_rxs
exitif stat&(ready!xopl)#0
repeat
!
if stat&xopl#0 start ; ! xop gone down
t = 64; ! send unsuccessfull
printstring("ts29: 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("ts29: parity
")
->skip
finish
finish
!
if stat&comm bit#0 start
t = 2!128
skip:
control d_o posx = n; control d_out buf == m
reply:
p_c1 = t; ! long block+accept last
to 2900(return control, null)
return
finish
!
if control d_o pos=control d_out lim then control d_o pos = -1
if control d_o pos=control d_o lim then ->badm
!
control d_o pos = control d_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
control d_out mess len = m_a(0); ! max = 256
unless 5<control d_out mess len<=small block len-18 start
! nb: SMALL buffer is used
badm:
printstring("***ts29: message fails -")
write(control d_out mess len, 1); write(control d_o pos, 1); write(control d_out lim, 1)
write(control d_o lim, 1); write(type, 1); write(n, 1)
printstring(" ts29 messages lost
")
if n>0 start
cycle sym = 0, 1, n
write(m_a(sym), 2); newline if n&15=15
repeat
newline
finish
control d_o pos = control d_o lim
->reply
finish
!
else
if n=control d_out mess len then ->exit3; ! Got the whole message
finish
!
l_rxs = l_rxs!accept char; ! accept the last char
!
repeat
!
exit3:
control d_o posx = 0; ! full message taken
t = 0!128; ! normal+accept last
!
if control d_o pos#control d_o lim start ; ! Another message waiting
d == control d
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)
!
->hlm(type)
!
hlm(1):
! Logon Reply
lreply = m_a(5)
if d_bits&allocated=0 start
printstring("ts29:Invalid logon reply")
dump(d)
free buffer(m)
->reply
finish
if d_nstate=closed start
if lreply#0 then retrieve(d); !logon failed anyway
!successful logon is trapped
!when the streams are enabled
free buffer(m)
->reply
finish
!
str = string(addr(m_a(6))); ! copy text out of way
mes == m; ! make it a network buffer
mes_len = length(str)+1
string(addr(mes_itp_type)) = str
mes_itp_type = 0
to ts(put output, mes, 1)
d_out go = d_out go-1
if l reply#0 start
d_bits = d_bits&(¬(isconnected!osconnected))
get buffer(send disconnect); ! immediate request to go
finish
->reply
!
hlm(2):
! setmode out, string at m_a(5)
translate(m, 5); !convert to ts29 form
if connected<=d_nstate<=resetting start
to ts(put output, m, 1)
d_out go = d_out go-1
else
free buffer(m)
finish
->reply; ! give control back to am1h
!
end
!*******************************************************************
! code to translate setmodes (more or less)
!*******************************************************************
!
routine stuff(integer code, val)
!---------------------------------
!insert code and val into setmode array
!the array name t and pointer tp are %owns
t(tp)=code
t(tp+1)=val
tp=tp+2
end
!
routine settabs(record (maf) name m, integer mp)
!---------------------------------------------------
integer i, code
code = 54; !code for first tab posn
for i=1, 1, 7 cycle
stuff(code, m_a(mp))
mp = mp+1
code = code+1
repeat
end
!
integerfn superset(integer base)
!---------------------------------
!base is the address of the first of 16 bytes making up the full rawmode
!bit map. The superset of ts29 data forwarding options is constructed and
!returned as the function value.
!the ts29 options are defined by the arrays below which are slightly
!compressed versions of the bitmaps of the ts29 options
!start and end are the positions of the non-zero bytes of the
!compressed bitmaps, the index corresponds to the ts29 option bit
!the sections of the bitmaps are stored one after the other in mask
!
constbytearray start(0:7) = 6, 1, 0, 2, 0, 1, 0, 4
constbytearray end(0:7) = 15,1, 3, 15,0, 1, 3, 15
constbytearray mask(0:46) = c
16_ff, 16_03, 16_fe, 16_ff, 16_ff, 16_07, 16_fe, 16_ff, 16_ff, 16_07,;!A-Z a-z 0-9
16_20, ;! CR
16_e0, 16_00, 16_00, 16_08, ;!ESC BEL ENQ ACK
16_04, 16_01, 0(11), 16_80, ;!DEL CAN DC2
16_18, ;!ETX EOT
16_1e, ;!HT LF VT FF
16_07, 16_c1, 16_fb, 16_f6, ;!other controls
16_ff, 16_ff, 16_00, 16_fc, 16_01, 16_00, 16_00, 16_f8, 16_01, 16_00,
16_00, 16_78 ;!everything else
!
integer bit, l, i, j, bits
bit = 1; !individual ts29 option - gets shifted left
bits = 0; !actual ts29 option
l = 0; !for indexing into mask array
for i = 0, 1, 7 cycle
for j = start(i), 1, end(i) cycle ; !next ts29 option
if byteinteger(base+j) & mask(l) # 0 then bits = bits ! bit
l = l+1
repeat
bit = bit<<1
repeat
result = bits
end
routine translate(record (maf) name m, integer strt)
!----------------------------------------
!translate itp setmode starting at m_a(strt) to ts29
record (mef) name mes
integer mp, max, code, word, val
constinteger copy = 0
constinteger ignore = 1
constinteger copyinv = 2
constinteger tabs = 3
constinteger grout = 4
constinteger tty = 5
constinteger video = 6
constinteger bulk = 7
constinteger stop = 8
!
constinteger maxcode = 23
!
ownbytearray action(0:maxcode)=stop,copy,copy,copy,ignore,ignore,
ignore,copy,copy,copyinv,tabs,grout,ignore,tty,copy,video,stop,
copy,ignore,ignore,stop,copyinv,bulk,video
!
ownbytearray tcode(0:maxcode)=0,2,51,10,0,0,
0,16,17,15,22,10,0,0,9,52,0,
5,0,0,0,53,0,52
!
switch operation(copy:stop)
byteintegerarray tt(0:50)
tp = 1; !setup %owns to access tt array, tt(0) will hold the length
!so that string copy can be used to copy back into m
t == tt
mp = strt+1; !start of data part of itp setmode
max = m_a(strt)+strt
while mp<max cycle
code = m_a(mp)
if code<=maxcode start
val = m_a(mp+1)
mp = mp+2; !default increment
->operation(action(code))
!
operation(ignore):
continue
!
operation(copy):
cpy:
stuff(tcode(code), val)
continue
!
operation(copyinv):
if val#0 then val = 0 else val = 1
->cpy
!
operation(tabs):
settabs(m, mp-1); !start of tab vector
mp = mp+6
continue
!
operation(grout):; !graphical output
if val#0 then val = 0 else val = 80; !default line len??
->cpy
!
operation(tty):
stuff(10, 80); !line len => graph mode off
stuff(15, 1); !line editing on
continue
!
operation(video):
if val#0 then val = 2
->cpy
!
operation(stop):
exit
!
operation(bulk):
!
!bulk setmode, mp has been incremented by 2 already so mp-1 addresses
!the first byte of the parameters
!
word = m_a(mp-1); !byte 1 bits
if word&2=0 then val = 1 else val = 0
stuff(2, val)
!
if word&4#0 then m_a(mp+3)=0; !line len=0=>graph output
!
if word&16=0 then val = 1 else val = 0
stuff(15, val); !editing disabled
!
word = m_a(mp); !byte 2
!
val=word&1; !flow control on/off
stuff(5, val)
!
if word&8=0 then val = 0 else val = 2; !video mode
stuff(52, val)
!
if word&32=0 then val = 1 else val = 0; !hw tabs
stuff(53, val)
!
!if rawmode bit set then construct superset of bit map with ts29 data
!forwarding char options else just forward on CR
if (word&64)#0 then val=superset(addr(m_a(mp+17))) else val=2
stuff(3, val)
!
stuff(51, m_a(mp+4)); !page len
stuff(10, m_a(mp+3)); !line len
stuff(16, m_a(mp+15)); !DEL char
stuff(17, m_a(mp+16)); !CAN char
settabs(m, mp+6)
stuff(9, m_a(mp+1)); !cr pads
exit
finish
repeat
mes == m; !convert to ts29 format
mes_itp_dstart=1
mes_itp_type=128
!use string copy to move the data
tt(0) = tp-1
string(addr(mes_itp_data(1)))=string(addr(tt(0)))
mes_itp_data(1) = 2; !overwrite len with 'set pad params'
mes_len = tp+1
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, am1 reply, stat
!
! always use control d
am1 reply = 4; ! "condition y"
!
cycle
!
m == control d_in buf
if m==null then m == pop(control d_inp q) and control d_in cnt = control d_in cnt-1
!
if m==null thenexit
!! terminate with "normal" (shouldnt happen)
!
n = control d_in buf pos; ! start of block - control d_in buf pos = 0
!
cycle
cycle
stat = l_rxs
!
if stat&xopl#0 start
control d_in buf == m; ! retain buffer for retry
am1 reply = 64; ->am1 rep
finish
!
if stat&ready#0 start
!! l i m i t sent
am1 reply = 2; ! long block
control d_in buf pos = n
control d_in buf == m; ! retain for later
->am1 rep
finish
!
if l_txs&ready#0 thenexit
repeat
!
!
if n>m_a(0) start
free buffer(m)
control d_in buf == null; control d_in buf pos = 0
!
if control d_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_itp
write(k, 1); space; space
j = 7
write(itp_type,1)
cycle i = 1, 1, k-1
n = itp_data(i)
if 32<=n<=127 start
printsymbol(n); j = j+1
else
printsymbol('¬'); write(n,3); j=j+4
finish
if j>80 then newline and j=0
repeat
newline; select output(0)
end
!
!
routine mon p(record (pe) name p)
!-------------------------------
integer i
printstring(" fn ="); write(p_fn, 1)
printstring(" ts port"); write(p_ts port, 1)
printstring(" task port"); write(p_task port, 1)
printstring(" a2"); write(p_a2, 1)
ifnot 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