!******************************** !* emas-2900 fep itp server * !* file: itps9/itps9y * !* date: 25.mar.82 * !******************************** !! stack size = 500 !* !* nsi version - include {n} statements !* ring version - {n} -> !n! and !r! -> {r} !* nsi and ring - include {z} !* Yellow book gate interface - {n} & {z} -> !n! & !z!, !x! -> {x} !* %control 1 %include "deimosperm" %begin %conststring (13)vsn = "itps...9(n)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 %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((%byteinteger cnsl, hdb1, hdb2, %c (%string (241) s %or %byteintegerarray a(0:241)) %or %c %byteintegerarray aa(0:244))) {n} %recordformat lev3f(%bytearray reserved(0:5), %c {n} %record (itpf) itp) ! nb: replaces fn,sufl,st,ss,flag,uflag !x! %recordformat lev3f(%bytearray reserved(0:7), %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)) {z} %recordformat pe(%byteinteger ser, reply, %c {z} fn, gate port, %record (mef) %name mes, (%byteinteger c1, c2 %or %c {z} %integer c)) !x! %recordformat pe(%byteinteger ser, reply, %c !x! (%integer a, b, (%integer c %or %byte c1, c2) %or %byte fn, a2, %c !x! (%record(mef)%name mes, %byte gate port, task port %or %c !x! %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 !************************************************************ {z} %constinteger enable facility = 1; ! enable the facility {z}! %constinteger disable facility = 2; ! the reverse {z} %constinteger call reply = 3; ! reply to a 'call connect' {z} %constinteger enable input = 4; ! allow a block to be read {z} %constinteger put output = 5; ! send a block of output {z} %constinteger close call = 6; ! terminate a call {z} %constinteger abort call = 7; ! abort the call {z} {z} %constinteger reject = 0; ! qualifier on above {z} !********************************************************** {z} !* messages from gate to upper level protocols {z} !********************************************************** {z} %constinteger incoming call = 2 {z} %constinteger input here = 3; ! block arrived from node {z} %constinteger output transmitted = 4; ! prepared to accept more {z} %constinteger call closed = 5; ! either end has closed down {z} %constinteger call aborted = 6; ! other end has aborted {z} !x! %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 ************* {z} %constinteger gate ser = 16 !x! %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 !****** 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 !********************************************************** !* 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 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 !x! %routinespec mon mes(%record (mef) %name mes) !x! %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 tcp limit = 28; ! increase con statea as well !!!!!!! %ownrecord (tcpf) %array tcpa(0:tcp limit) %ownbytearray con index(0:1472) %constinteger con lim = 118; ! number of active terminals %ownrecord (con desf) %array con desa(-2:con lim) %constinteger max ports = 50 %ownbyteintegerarray porta(0:max ports) ! 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 {z} %owninteger messflag=0; !w.s.c 9/4/81 tcp connect messages !x! %owninteger messflag = 1 %integer i, n %ownstring (63) str !x! %ownstring (1) snil = "" {n} %constinteger header len = 6 !r! %constinteger header len = 2 !x! %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 tcp_con state ind = n; n = n+max tts %repeat d2 == con desa(-2) d2_stream = -2 d3 == con desa(-1) d3_stream = -1 printstring(vsn) 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 {z} to gate(enable facility, null, 18) !x! p_ser = gate ser; p_reply = own id !x! p_fn = enable facility; p_a2 = 0; p_facility = "ITP" !x! 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) newline tcp_max = 0 %finish %repeat %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("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 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 ! %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 {z} p_c2 = flag !x! p_a2 = flag !x! p_task port = tcp_tcpn !x! %if mon # 0 %start !x! select output(1); spaces(5) !x! printstring("itp: to gate:"); {x} mon p(p) !x! select output(0) !x! %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 {z} p_gate port = d_stream !x! 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 !x! %string (127) %fn unpack(%record (mef) %name mes, %integer no) !x! %integer i, l !x! %unless mes == null %or mes_len<=0 %or no<=0 %start !x! l = 0 !x! %while no>1 %cycle !x! l=l+mes_params(l)+1 !x! no = no-1 !x! %repeat !x! %result = string(addr(mes_params(l))) !x! %finish %else %result = "" !x! %end !x! %routine pack(%record(mef) %name mes, %string (*) %name s) !x! string(addr(mes_params(mes_len))) = s !x! mes_len = mes_len+length(s)+1 !x! %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 %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 {z} %switch fns(incoming call:call aborted) !x! %switch fns(connect:Datagram Reply) !x! %string (63) calling !x! %string (9) qual fn = p_fn {z} tcpn = porta(p_gate port) !x! tcpn = p_task port tcp == tcpa(tcpn) mes == p_mes !x! %if mon # 0 %start !x! select output(1); spaces(5) !x! printstring("itp: from gate:") !x! mon p(p) !x! select output(0) !x! %finish ->fns(fn) {z} fns(incoming call): !x! 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 {z} flag = reject {z} to gate(call reply, null, flag) !x! to gate(Disconnect, null, 17) %return %finish {z} tcp_term = p_c2 tcp_state = connected; tcp_ostate = idle {z} tcp_node = p_mes_lev3_reserved(4); ! really mes_nsl_sn - but hi a compiler fault! {z} porta(p_gate port) = tcp_tcpn; ! fill in port no - tcp no index tcp_port = p_gate port {z} flag = p_c1; ! pick upp fl & rl {z} x = flag&x'70'; ! pick up fl {z} %if x>x'20' %then x = x'20'; ! limit to 2 {z} flag = (flag&x'f')!x !x! tcp_node = 0; ! ?????? !x! calling = unpack(mes, 2) !x! qual = unpack(mes, 3) %if messflag=1 %start {z} printstring(" itp: t") {z} write(p_c2, 1) !x! printstring(" itp: ") !x! printstring(calling) printstring(" connected ") %finish tcp_max = 0; ! for monitoring tcp_size = 0; tcp_held = 0; tcp_h no = 0 {z} to gate(call reply, null, flag) !x! mes_len = 0 !x! pack(mes, snil) !x! pack(mes, qual) !x! pack(mes, snil) !x! to gate(accept call, mes, 0) !x!! to gate(enable input, null, 1); ! out till pre-ack gate ready %return !x! fns(expedited): ! int message (i hope) fns(input here): %if mes_len <= 3 %start free buffer(mes) %return %finish to gate(enable input, null, 1) !x! %if mon < 0 %start !x! select output(1) !x! printstring("ii "); !x! mon mes(mes) !x! %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 {z} fns(output transmitted): !x! fns(enable output): tcp_ostate = idle %unless tcp_outq_e == null %start tcp_size = tcp_size-1 to gate(put output, pop(tcp_outq), 0) %finish %if tcp_held # 0 %and tcp_size<5 %start !! consoles are held & q is now redduced 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: %finish %return {z} fns(call closed): ! ring vsn? %return; ! handled in 'input recd' {z} fns(call aborted): ! either way, all is lost !x! fns(Disconnect): ! Call has been cleared {z} type = abort call; ! nb: cpmatibility with x25 vsn {z} flag = 1 !x! flag = p_a2; ! pickup reason for close %while %not tcp_outq_e == null %cycle free buffer(pop(tcp_outq)) %repeat %if messflag=1 %start printstring(" t"); write(tcp_term, 1) printstring(" connection ") %if flag = 0 %then printstring("aborted") %else %c printstring("closed") !x! write(flag, 1) write(tcp_max, 1); newline %finish lose consoles(-1) tcp_state = not allocated {z} to gate(type, null, 0) !x! to gate(disconnect, null, 1) 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 %if host state = down %start get buffer(send emas down) %result = -1 %finish get buffer(send name prompt) users = users+1 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 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 d_seq bits = x'c0' 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) %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 %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 %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 %if d_cnsl = 255 %start; ! gone away type = 1 %else d_in lim = m2900_p2b d_i pos = m2900_p3b get buffer(send go ahead); get buffer(send go ahead) get buffer(send go ahead) %finish %else %if d_out lim # 0 %start %if d_abortf = aborting %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 d_abortf = state; ! remember type get buffer(send kill transmit) %if state = aborting %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 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_oposd_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 %constbyteintegerarray pts(1:last itp reason) = 1, 10, 19, 25, 31, 37, 38, 42, 42, 42(8), 42, 61, 65, 69 !! pt to itp mess %ownbyteintegerarray itp message(1:74) = 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 pt = pts(no) string(addr(mes_lev3_itp_aa(0))) = string(addr(itp message(pt))) mes_len = mes_lev3_itp_aa(0)+header len+1; ! nsi+cnsl no %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("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 ! 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 charno(add, 3) = d_cnsl string(addr(logr_a(4))) = add.mes_lev3_itp_s 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 {n} n = p_gate port; ! byte quantity ! !x! 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 p_mes_lev3_itp_cnsl = d_cnsl tcp == tcpa(d_tcp) 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 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 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 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 %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 %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 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) -> 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 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 !x! %routine mon mes(%record (mef) %name mes) !x! %integer i, j, k, n !x! %record (itpf) %name itp !x! k = mes_len; itp == mes_lev3_itp !x! write(k, 1); space; space !x! j = 0 !x! %cycle i = 0, 1, k-1 !x! %if mon > 0 %and i > 3 %start; ! 'p' and not header !x! n = itp_aa(i) !x! printsymbol(n) %unless n = 0 %or n = 4 !x! %else !x! write(itp_aa(i), 1) !x! j = j+1; %if j = 25 %then j = 0 %and newline !x! %finish !x! %repeat !x! newline; select output(0) !x! %end !x! !x! !x! %routine mon p(%record (pe)%name p) !x! %integer i !x! printstring(" fn ="); write(p_fn, 1) !x! printstring(" gate port"); write(p_gate port, 1) !x! printstring(" task port"); write(p_task port, 1) !x! printstring(" a2"); write(p_a2, 1) !x! %if %not p_mes == null %start !x! newline; spaces(5) !x! write(p_mes_len, 3) !x! %cycle i = 1, 1, 25 !x! write(p_mes_params(i), 2) !x! %repeat !x! %finish !x! newline !x! %end !x! !x! %endofprogram