!********************************
!*  emas-2900  fep  itp server  *
!*   file: x25_xxx3as/xxx3y         *
!* NB: NOT same source as 2900       *
!********************************
!! stack size = 500
!*
#options

%control 1
%include "deimosperm"

%begin

      %conststring (13)vsn = "xxx...3g "
#datestring

      !!   no of data bytes in a short block  

      %constinteger small block max = 115;        ! 128-4-6-4
      %constinteger big block max = 127;          ! for P=128/128 calls
      %constinteger big 256 len   = 254;          ! < 256

      %constintegername no of big == k'120040';  ! no free big buffs
      %constintegername no of small == k'120042';! no free small buffs
      %owninteger critical = 15;        ! switch off o/p level



      %recordformat itpf((%byte res, %bytearray a(1:128) %or %string (128) s))

      %recordformat lev3f(%bytearray reserved(0:4), %record (itpf) itp)

      %recordformat ts29f(%bytearray reserved(0:5), %record (itpf) itp)

      %recordformat mef(%Integer buff no, len, %c
        %byteinteger owner, type, (%record (lev3f)lev3 %or %c
         %record (ts29f)ts29 %or %bytearray params(0:231) %or %c
         %integer kick to go, from flag, spare, %bytearray a(0:240)))

      %recordformat m2900f(%Integer buff no, len, %byteinteger owner, type, %c
        %integer stream, sub ident, %c
         p2a, p2b, p3a, p3b, p4a, p4b, p5a, p5b, p6a, p6b, trf buff)

      %recordformat m2900bf(%Integer buff no, len, %byteinteger owner, type, %c
        %integer stream, sub ident, %c
         %byteintegerarray b(0:19))

      %recordformat m2900if(%Integer buff no, len, %byteinteger owner, type, %c
        %integer stream, sub ident, p2a, p2b, %string (15) int, %integer trf buff)

      %recordformat m2900cf(%Integer buff no, len, %byteinteger owner, type, %c
         %integer stream, sub ident, %integerarray pa(0:9))


      %recordformat maf(%Integer buff no, mlen, %byteinteger owner, %c
        mtype, %bytearray reserved(0:5), %bytearray a(0:240))


      %recordformat pe(%byteinteger ser, reply, %c
       (%integer a, b, (%integer c %or %byte c1, c2) %or %byte fn, a2, %c
         (%Integer buff no, %byte gate port, task port %or %c
         %string (3) facility)))


      %recordformat qf(%record (mef) %name e)

      !********************************************************
      !*  formats of tables, ie stream descriptors, tcps etc  *
      !********************************************************
      %recordformat con desf(%Integer hold, %c
        %integer state, stream, %byteinteger o state, out go, %c
        in cnt, tcp, seq bits, pmt n, mode, hold f, abortf, %c
        imode, kick, sp1, %c
        %integer trig, i pos, opos, o lim, o trig, p lim, %c
        in lim, out lim, o posx, %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, tsf, tcpn, term, %c
         size, max, P256, spare,  %record (qf) outq)
      !************************************************************
      !*  upper level (itp&rje) handler messages to gate
      !************************************************************
      %include "b_ygatecalls"

      !**************************************************************
      !*         buffer manager calls   (from and to)               *
      !**************************************************************
!      %constinteger buffer here = 0
      !********** to buffer manager ***********
      %constinteger request buffer = 0
      %constinteger release buffer = 1
      !**************************************************************
      !*             calls to 2900 link handler                     *
      !**************************************************************
      %constinteger send data = 0
      %constinteger low level control = 1
      %constinteger here i am = 2
      %constinteger transfer request = 3

      !**************************************************************
      !*               replies from 2900 link handler                 *
      !****************************************************************
      %constinteger  interf addr = 0
      %constinteger do input = 1
      %constinteger do output = 2
      %constinteger message = 3
      %constinteger mainframe up = 4
      %constinteger mainframe down = 5
      !****************************************************************

      !********** various service numbers *************
      %constinteger gate ser = 24
      %constinteger buffer manager = 17
      %constinteger link handler = 18

      %constbyteintegername change out zero == k'160310'
      %constinteger t3 ser = 21

      %constinteger comm bit = k'1'
      %constinteger accept char = k'002'
      %constinteger acfy = k'010';     ! peter calls it rxfy
      %constinteger xopl = k'020';     ! x operable - latched
!      %constinteger xop  = k'040';     ! x operable
      %constinteger ready = k'200'
      !************************************************************
      !*                   tcp  states                            *
      !************************************************************
!        %constinteger not allocated = 0
      %constinteger connected = 1
      %constinteger disconnecting tcp = 2
      !******  tcp_ostate states  (permission to send)  *****
      %constinteger idle = 0
      %constinteger busy = 1
      !***********************************************************
      !*               2900  states                               *
      !***********************************************************
      %own %integer host state = 0;      ! holds 2900 state
      %constinteger down = 0
      %constinteger up = 1
      !****************** comms control states ********************
!      %constinteger unused = 0
      %constinteger disconnecting = 1
      %constinteger connecting = 2
      %constinteger suspending = 4
      %constinteger aborting = 5
      %constinteger enabling = 7
!      %constinteger enabled = 8

      !**************************************************************
      !*            console states                                  *
      !**************************************************************
      %constinteger not allocated = 0
      %constinteger name sent = 1;      ! hello has been received
      %constinteger pass sent = 2;      ! 'name' has been received
      %constinteger logging on = 3
      %constinteger logged on = 4;      ! 2970 has accepted it
      %constinteger input enabled = 5
      %constinteger awaiting int = 6
      %constinteger logging off = 7;    ! 2970 is getting rid of it

      !!  ostate  states

      !! %constinteger idle = 0
      %constinteger enabld = 1
      %constinteger out p = 2;          ! output req 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 welcome = 10
!     %constinteger send login reply = 8;    ! logon successful
!     %constinteger send login fails 1 = 9;   ! 9-17

      %constinteger send emas down = 18
      %constinteger Send int = 19
      %constinteger send kill transmit = 20
      %constinteger send pad params = 21

      %constinteger last itp reason = 21

      %constinteger get op block = 23
      %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 do enable facility(%string (11) address)
      %routinespec handle clock
      %routinespec get o block
      %routinespec to gate(%integer fn, %record (mef) %name mes, %c
        %integer flag)
      %routinespec to 2900(%integer fn, buff no)
      %routinespec get buffer(%integer reason)
      %routinespec free buff no(%integer buff no)
      %routinespec free buffer(%record (mef) %name mes)
      %routinespec from gate
      %routinespec from 2900
      %routinespec from buffer manager(%record (pe) %name p2)
      %integerfnspec analyse itp message(%record (mef) %name mes)
      %routinespec retrieve(%record (con desf) %name d)
      %routinespec lose consoles(%integer x)
      %routinespec move(%integer le, from, to)
      %routinespec read from am1
      %routinespec write to am1
      %routinespec kick 2900 message(%record (mef) %name log)
      %routinespec tidy message streams
      %routinespec read message from am1
      %routinespec write message to am1
      %routinespec mon mes(%record (mef) %name mes)
      %routinespec mon p(%record (pe) %name p)
      !******************************************************
      %ownrecord (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 fixed = 20;            ! 1st available stream

      %constinteger max calls = 60;        ! only XXX, so can be greater than 2900
      %constinteger tcp limit = max calls;  ! Total number of virtual circuits!!!
      %ownrecord (tcpf) %array tcpa(0:tcp limit)
      %ownstring(21) %array tnames(0:tcp limit)


         %constinteger con lim = max calls;      ! number of active terminals
      %ownrecord (con desf) %array con desa(-2:con lim)

      %constinteger max tts = 49;      ! ie 0 to 48


      %owninteger fep name = 0;         ! will contain EMAS name (distinct letter)
      %owninteger mon = 0;              ! monitoring flag

      %owninteger bh = 0;               ! no of buffers held by Task
      %owninteger held = 0;             ! no of conversations held for buffer shortage
       %owninteger theld = 0;           ! Total no held ever

      %owninteger lose op = 0;         ! discard output for erte
      %constintegername users == k'120014'; ! no of users in buff seg  (my seg 5)
      %owninteger messflag = 0

      %integer i, n
      %ownstring (127) str

      %ownstring (1) snil = ""

      %constinteger header len = 0
      %recordformat hold bufff(%record (hold bufff) %name link, %integer buff no)
      %ownrecord (holdbufff) %array hba(0:100)
      %ownrecord (holdbufff) %name free hold
      !**********************************************
      !*      initialisation                        *
      !**********************************************

      change out zero = t3 ser

      poff(p);            ! wait for instructions
      fep name = p_fn;    ! get fep name, ie emas-A, emas-B etc

      first d == con desa(0)
      %cycle i = con lim, -1, 1
         push(free des, con desa(i))
         con desa(i)_stream = i
      %repeat

      n = 0
      %cycle i = 1, 1, tcp limit
         tcp == tcpa(i)
         tcp_tcpn = i
      %repeat
      d2 == con desa(-2)
      d2_stream = -2
      d3 == con desa(-1)
      d3_stream = -1

      %cycle i = 100, -1, 2
        hba(i-1)_link == hba(i)
      %repeat
      free hold == hba(1)

      printstring(vsn)
      printstring(datestring); newline

      i = map virt(buffer manager, 6, 5);   ! stack seg to my 5
      users = 0

      p_c = 8
      to 2900(here i am, 0)
      p_c = 9
      to 2900(here i am, 0)

      tcp == tcpa(0);                 ! dummy for below
        do enable facility("XXX")
       do enable facility("TS29")
      alarm(50)
      !**********************************************
      !*           main loop                        *
      !**********************************************
      %cycle
         p_ser = 0;  poff(p)

         %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 %start
             from buffer manager(p)
         %finish %else %if p_reply = 0 %then handle clock
      %repeat

      !*************************************************
      !*           routines to do the work             *
      !*************************************************

      %routine octal(%integer n)
         %integer i
         %cycle i = 15, -3, 0
            printsymbol((n>>i)&7+'0')
         %repeat
         space
      %end

      %routine crunch(%integer n, extra)
         %integer i
         %cycle i = 1, 1, 15
            printstring("xxx: Bad buffer ***** dump fep ********")
            write(n, 1); spaces(2); octal(extra); newline
         %repeat
         %cycle
            p_ser = 0; poff(p)
         %repeat
      %end

      %routine to gate(%integer fn, %record (mef) %name mes, %c
         %integer flag)
         %if fn = put output %or fn = control data %start
            %if tcp_state # connected %start; ! throw away
                free buffer(mes);  %return
            %finish

            %unless k'1000'<= mes_buff no <= k'7776' %then %c
                crunch(1,mes_buff no); ! had it
            tcp_size = tcp_size+1
            tcp_max = tcp_size %if tcp_size>tcp_max
            d_out go = d_out go-1
            %if d_out go > 250 %then d_out go = 0;  ! not negative

            %if mon = -1 %start
               select output(1)
               printstring("To Tcp ");  mon mes(mes)
            %finish
         %finish

         p_ser = gate ser; p_reply = own id
         p_fn = fn; p_gate port = tcp_port
         %if mes == null %then p_buff no = 0 %else p_buff no = mes_buff no
         p_a2 = flag
         p_task port = tcp_tcpn
         %if mon # 0 %start
            select output(1);  spaces(5)
            printstring("xxx: to gate:");      mon p(p)
            select output(0)
         %finish
        bh = bh-1 %unless p_buff no = 0
         pon(p)
      %end

      %routine to 2900(%integer fn, buff no)
         p_ser = link handler; p_reply = own id
         p_fn = fn; p_buff no = buff no
         %if buff no # 0 %start
            bh = bh-1
            %if buff no < k'1000' %or buff no > k'7776' %then crunch(2,buff no)
         %finish
         %if fn = Transfer Request %start
            %if p_c < 8 %or p_c > 180 %then crunch(3,p_c);  ! nb: DEPENDANT on max calls
            %if 10 <= p_c <= 19 %then crunch(4,p_c)
         %finish
         pon(p)
      %end

      %routine get buffer(%integer reason)
         %record (pe) p
         %integer type
      %record (holdbufff) %name hb
      !*******************************************************
      !*    hold a pool, so can call buffer here immedialtely*
      !*         otherwise hold the activity until it arrives*
      !*******************************************************

         %if reason = get big op block %then type=0 %else type=1
         p_c2 = reason
         p_a2 = d_stream
         %if buffer pool == null %or type=0 %start;  ! have to ask for it
            p_ser = buffer manager; p_reply = own id
            p_fn = request buffer
            p_c1 = type;                     ! either size
            pon(p)
         %else
            hb == buffer pool
            buffer pool == hb_link
            p_buff no = hb_buff no
            hb_link == free hold
            free hold == hb
            no of buff = noof buff-1;  from buffer manager(p)
            bh = bh-1
         %finish
      %end

       %routine free short buff(%integer buff no)
          %record (holdbufff) %name hb
          %if buff no < k'1000' %or buff no > k'7776' %then crunch(5,buff no)
          %if no of buff > 10 %or no of small < 20 %then free buff no(buff no) %and %return
                 ! send it back if we hold too many or there is a shortage
            hb == free hold; free hold == hb_link
            hb_buff no = buff no
            hb_link == buffer pool
            buffer pool == hb
            no of buff = no of buff+1
       %end

      %routine free buffer(%record (mef) %name mes)
         %record (pe) p

         %if mes_buff no < k'1000' %or mes_buff no > k'7777' %or %c
            mes_owner # own id %then crunch(6, mes_owner)

         %if mes_type = 0 %start
            p_ser = buffer manager; p_reply = own id
            !! queue it if it is a short buffer
            p_fn = release buffer; p_buff no = mes_buff no
            bh = bh-1
            pon(p)
         %else
            !! short buffer, so queue it
            free short buff(mes_buff no)
         %finish
      %end
%routine bpush(%record (qf) %name q, %integer buff no)
   %record (hold bufff) %name bf
   bf == free hold
   free hold == bf_link
   bf_buff no = buff no
   push(q, bf)
%end

%integerfn bpop(%record (qf) %name q)
   %record (hold bufff) %name bf
   %integer x
   bf == pop(q)
   %result = 0 %if bf == null;   ! none left in q
   x = bf_buff no
   bf_link == free hold
   free hold == bf
   %result = x
%end

     %record (mef) %map map(%integer buff no)
        ! buff no is already in r0 - where its wanted
        %result == null %if buff no = 0
        *mov_#8,1;     ! desired vm seg no *2 ie 4*2
        *mov_#k'2006',2; ! lenght of segment
        *iot
        %result == record(k'100000');   ! map to base of seg 4
     %end

     %record (mef) %map map0(%integer buff no)
        ! buff no is already in r0 - where its wanted
        %result == null %if buff no = 0
        *mov_#0,1;     ! desired vm seg no *2 ie 0*2
        *mov_#k'2006',2; ! lenght of segment
        *iot
        %result == record(k'000000');   ! map to base of seg 0
     %end

      %routine free buff no(%integer buff no)
           ! not mapped, so send it straight back
         %record (pe) p
         %return %if buff no = 0;          ! rest of code is very loose on this
         %if buff no < k'1000' %or buff no > k'7776' %then crunch(7, buff no)
         p_ser = buffer manager; p_reply = id
         p_fn = release buffer
         p_buff no = buff no
         pon(p)
         bh = bh-1
      %end



      %routine handle clock
         %owninteger last
         %integer i
         %if int # 0 %start
         %if 'M' <= int <= 'P' %start
            mon = int-'O'
         %finish
         %if int='A' %then messflag=1-messflag;   !turn messages on & off
         %if int = '?' %start;   ! $$ mon
            write(no of buff, 4)
            printstring(", bh ="); write(bh, 1)
            printstring(", held ="); write(held, 1)
            printstring(", tot h ="); write(theld, 1); newline
            printstring("term      qu  mq held  no held  index  sta  goah ")
            printstring("ost  opos  olim   Ip-Lock
")
            %cycle i = 1, 1, tcp limit
               tcp == tcpa(i)
               %if tcp_state = connected %start
                   write(tcp_tcpn, 3)
                  %if tcp_tsf = 0 %then printstring(" X ") %else %c
                    printstring(" T ")
                  printstring(tnames(i))
                  write(tcp_size, 3);  write(tcp_max, 3)
                  write(tcp_held, 3); write(tcp_h no, 5)
                  write(tcp_con state ind, 4)
                  %if tcp_con state ind # 0 %start
                     d == con desa(tcp_con state ind)
junk label:
                     write(d_state, 1)
                     write(d_outgo, 1)
                     write(d_ostate, 1); write(d_opos, 1); write(d_olim, 1)
                     space
                     %if d_kick = 0 %then printsymbol('0') %else printsymbol('L')
                   %finish
                   newline
                   tcp_max = 0
               %finish
            %repeat
         %finish
         %if int = 'C' %start
            select output(1)
            close output
            printstring("Done
")
         %finish

         int = 0
         %finish

         alarm(25)
         %if held # 0 %and no of small > critical %and no of big > critical %start
            last = last+1; last = 1 %if last > conlim
            i = last
            %cycle
               tcp == tcpa(i)
               %if tcp_held # 0 %start
                  held = held-1; tcp_held = 0
                  %if tcp_con state ind # 0 %start
                     d == con desa(tcp_con state ind)
                     %if d_o state > enabld %then get o block %and %return
                  %finish
               %finish
               i = i+1; i=1 %if i > conlim
               %exit %if i = last
           %repeat
           held = 0
        %finish
     %end

      %string (127) %fn unpack(%record (mef) %name mes, %integer no)
         %integer i, l
         %unless mes == null %or mes_len<=0 %or no<=0 %start
            l = 0
            %while no>1 %cycle
               l=l+mes_params(l)+1
               no = no-1
            %repeat
            %result = string(addr(mes_params(l)))
         %finish %else %result = ""
      %end

      %routine pack(%record(mef) %name mes, %string (*) %name s)
         string(addr(mes_params(mes_len))) = s
         mes_len = mes_len+length(s)+1
      %end

       %routine handle x3 inmode(%record (mef) %name mes, %string (*) %name x)
            %record (maf) %name m
            d == con desa(tcp_con state ind)
            %if tcp_con state ind = 0 %or d_state = not allocated %start
               free buffer(mes);           ! free it
            %else
%if mon < 0 %start
    write(tcp_con state ind, 1); write(d_state, 1); newline
%finish
               str = x;                      ! 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
            %finish
            to gate(enable input, null, 1);    ! ack buffer to gate
       %end

      %routine get o block

         !! this routine determines whether it is worth asking for
         !! a big buffer to put itp output in, otherwise gets small

         !! nb: 1st transfer is always a small buffer (not done here)

         %integer x
         %return %if d_state = awaiting int
         x = d_o lim-d_o pos
         %if x<0 %then x=x+d_out lim
         %if x>small block max %and no of big>20 %then %c
           get buffer(get big op block) %else %c
           get buffer(get op block)
      %end

      %routine do enable facility(%string (11) address)
        %record (mef) %name mes
            p_ser = buffer manager; p_reply = id
            p_fn = request buffer
            ponoff(p)
            p_ser = gate ser; p_reply = own id
            p_fn = enable facility; p_a2 = 1
            mes == map(p_buff no)
            string(addr(mes_params)) = address
            pon(p)
      %end


      %routine from gate
         %record (mef) %name mes
         %record (tcpf) %name targ
         %integer fn, flag, type, x, q, stream, buff no
         %switch fns(connect:Control Data)
         %string (63) calling
         %string (23) qual

         fn = p_fn
         tcpn = p_task port
         tcp == tcpa(tcpn)
         buff no = p_buff no
         mes == map(buff no)
         %unless mes == null %start
            bh = bh+1
            mes_owner = own id;       ! mark it as mine
         %finish
         %if mon # 0 %start
            select output(1); spaces(5)
            printstring("xxx: from gate:")
            mon p(p)
            select output(0)
         %finish

         ->fns(fn)

fns(Connect):
         tcp == null
         %cycle tcpn = tcp limit, -1, 1
            targ == tcpa(tcpn)
               %if targ_state = not allocated %then tcp == targ
         %repeat
         %if tcp == null %start
                                        !  Full up
reject it:
            tcp == tcpa(0)
            tcp_port = p_gate port;          ! for 'to gate' call only
            to gate(Disconnect, null, x'f0');  ! Full up
            free buffer(mes)
            %return
         %finish

         d == pop(free des);     ! find a descriptor
         -> reject it %if d == null; ! run out

         tcp_state = connected
         tcp_port = p_gate port

         qual = unpack(mes, 1);     ! celled address
         %if qual -> qual.("TS").qual %then tcp_tsf = 1 %else tcp_tsf = 0

         qual = unpack(mes, 3);     ! real qual of service this time
         %if qual -> calling.("P=256/256").str %then %c
           tcp_p256 = 1 %else tcp_p256 = 0

         calling = unpack(mes, 2)

         %if messflag=1 %start
            printstring("       xxx: ")
            printstring(calling)
           printstring(" connected
")
         %finish

         tcp_max = 0; tcp_size = 0; tcp_held = 0;          ! for monitoring
         %if charno(calling, 2) = '.' %start
            %unless calling -> ("2.").calling %then x = 0
         %finish
         %if length(calling)>20 %then length(calling) = 20
         tnames(tcp_tcpn) = calling

         mes_len = 0
         pack(mes, snil)
         pack(mes, qual)
         pack(mes, snil)
         to gate(accept call, mes, 0)

            stream = d_stream;       ! hold the stream
            d = 0;                   ! zero the record
            d_stream = stream
            d_tcp = tcp_tcpn
            tcp_con state ind = stream

            d_state = name sent;        ! if down, goes to logging off whe sent

            %if host state = down %start
               get buffer(send emas down)
               %return
            %finish
            get buffer(send pad params)

            get buffer(send name prompt)
            users = users+1
            d_hold = 0
            get buffer(store user name)

         %return

fns(input here):

         %if mon = -1 %start
            select output(1)
            printstring("From Tcp ");      mon mes(mes)
         %finish

         flag = -1;                   ! enable input if zero length packet
         %if mes_len > 0 %start

            mes_lev3_reserved(0) = 1;          ! missing gah count
            flag = analyse itp message(mes)
            %if flag > 0 %then %return
        %finish
        free buff no(buff no)
        to gate(enable input, null, 1) %if flag < 0
                                            ! flag > 0  - going to 2900
                                            ! flag = 0  - free, but no ack
                                            ! flag < 0  - may be freed
         %return

fns(enable output):
         tcp_size = tcp_size-p_a2
         tcp_size = 0 %if tcp_size > 250;   ! byte quantity !
         %return %if tcp_con state ind = 0
         d == con desa(tcp_con state ind)
         x = d_out go
         d_out go = d_out go+p_a2 %unless x > 2
         %if x = 0 %and d_ostate > enabld %start
            %if no of small < critical %or no of big < critical %start
               tcp_held = 1; held = held+1; theld = theld+1
            %finish %else get o block
                            ! global control for buffer management
                            !     output is held in EMAS if buffers are low
         %finish
         %return

fns(Expedited):                         ! int: etc
      %unless tcp_con state ind = 0 %start
         d == con desa(tcp_con state ind)
junk label2:
         %if d_state = input enabled %start
            get buffer(Send int)
            d_state = awaiting int
         %finish
      %finish
      free buff no(buff no) %unless buff no = 0
      %return

fns(Disconnect):                    ! Call has been cleared
         flag = p_a2;                   ! pickup reason for close

         free buffer(mes) %unless mes == null
         %if messflag=1 %start
            printstring("       t");  write(tcp_tcpn, 1)
            printstring(" connection ")
              printstring("cleared")
            write(flag, 1)
            write(tcp_max, 1); newline
         %finish
         lose consoles(-1)
         to gate(disconnect, null, 1) %unless tcp_state = disconnecting tcp
         tcp_state = not allocated
         tcp_max = 0
         %return

fns(Reset):
      printstring("X:Reset rec'd
")
      %unless mes == null %start
         mon mes(mes)
         free buffer(mes)
      %finish
      to gate(Disconnect, null, 1)
      tcp_state = disconnecting tcp
      %return

fns(Control Data):
            %if mon < 0 %start
               printstring("XXX:Control data in:")
               mon mes(mes)
            %finish
            mes_lev3_itp_res = mes_len
            handle x3 inmode(mes, mes_lev3_itp_s)
      %end


      %integerfn analyse itp message(%record (mef) %name mes)

         %record (itpf) %name itp, itp2
         %integer cnsl, index, stream, len, q, x, res, reason
         %record (maf) %name m
         %record (m2900if) %name mi
        %record (ts29f) %name ts29
         %string (16) int mes

         %switch console state(idle:logging off)

         %if tcp_tsf = 0 %then itp == mes_lev3_itp %else %c
                               itp == mes_ts29_itp %and mes_len = mes_len-1
         x = itp_res;                  ! hold it for ts29 in mode
         itp_res = mes_len;             ! nb: overwrites last byte of header
         %if itp_res>60 %then itp_res=60; ! ***** NOTE *******
                                        ! ******* NOTE *****************

         %if tcp_tsf # 0 %and x = 128 %start;  ! ts29 & control data
            handle x3 inmode(mes, itp_s)
            %result = 2;                     ! chuck buffer, no ack
       %finish

         %unless tcp_con state ind = 0 %start
            d == con desa(tcp_con state ind)
junk label compiler error:
            ->console state(d_state)
         %finish

console state(not allocated):           ! eg no descriptor

                        ! this can happen legitimately if stuff is rec'd after
                        ! the invitation to clear has been sent (send disconnect)
                        ! but before the other end reacts (or ignores it)
           %result = -1

console state(name sent):               ! user name arrived ?

            %if d_hold = 0 %start;       ! no buffer to put name into !!
               to gate(disconnect, null, x'fd'); ! so get rid of conn
               tcp_state = disconnecting tcp
               %result = -1
            %finish

            d_state = pass sent
            str = itp_s;           ! copied for big buffer version
            %if length(str) > 2 %then length(str) = length(str)-1
            %if charno(str,length(str))=13 %then length(str) = %c
            length(str)-1
            %if length(str) > 20 %then length(str) = 20
            m == map(d_hold);          ! map onto buffer with 'calling'
            string(addr(m_a(m_mlen))) = str
            m_mlen = m_mlen+length(str)+1
            get buffer(put echo off);   ! switch the echo off &
            get buffer(send pass prompt); ! prompt for password
         %result = -1;                  ! de-alloctae block (mes)

console state(pass sent):               ! password arrived ??

            str = itp_s;               ! copy it out of the way (big buffer vsn)
            get buffer(send nl);        ! send out a newline
            get buffer(put echo on);      ! put echo back on
            m == map(d_hold);           ! get saved block
            !! check that it has switched buffers??
            %if length(str) > 2 %then length(str) = length(str)-1
            %if charno(str,length(str))=13 %then length(str)= %c
             length(str)-1

            index = d_stream<<1+fixed
            x = m_mlen
            %if x+length(str) > 60 %then %c
              length(str) = 60-x
                                            ! ****************************
                                            ! *    NOTE - restriction    *
                                            ! *           on length      *
                                            ! ****************************
            string(addr(m_a(x))) = str; ! put in password
            x = x+length(str)
            m_a(0) = x

            d_state = logging on
            d_hold = 0;               ! block has gone to 2900

            kick 2900 message(m);       ! nb: disturbs 'd'
            p_c = index;             ! param for 'here i am'
            to 2900(here i am, 0)
            p_c = index+1;           ! param for 'here i am'
            to 2900(here i am, 0)

         %result = -1

console state(awaiting int):
            reason = 0
create int:
            d_state = input enabled
            %if itp_res > 16 %then itp_res = 16
            int mes = itp_s;                 ! copy it out of the way

            len = length(int mes);       ! check for cr, nl  & nl
            len = len-1;                ! delete the cr
            %if len <= 0 %then res = -1 %else %start;  ! invalid
               length(int mes) = len
   
               mi == mes;                        ! re-use 'mes'
               mi_stream = (d_stream<<1)+fixed;  mi_sub ident = 0
               mi_p2a = -1;  mi_p2b = -1;  ! set up params
               mi_int = int mes;                 ! copy string accross
               mi_trf buff = 0
               to 2900(send data, mi_buff no)
               to gate(enable input, null, 1); ! horrible - flag 'res' too complicated
               res = 2;                     ! don't deallocate buffer
            %finish

            %if reason = 0 %and %c
               d_o state > enabld %and d_out go >0 %then get o block
            %result = res

console state(logging on):              ! go ahead only?
console state(logged on):               ! still no input
      %result = -1

console state(input enabled):           ! input messages and ints


            mes_kick to go = 1;         ! for now, always kick the process
            mes_from flag = 12;         ! start of data
            %if tcp_tsf # 0 %then move(mes_len, addr(mes)+13, addr(mes)+12)

                         ! NB:  All output from the DX11 MUST start on an even
                         !      boundary, so it will be necesssary to MOVE ts29
                         !      data up a byte

            ! take a ctrl+c and turn it into an INT:C

            x = itp_a(1)
            %if x < 32 %and d_imode = 0 %start;  ! is a ctrl char&not binary
               %if x = 3 %or x= 20 %or x=1 %or x=11 %start;   ! ctrl+c,t,a or k
                  itp_a(1) = x+'A'-1;     ! int:C,T,A or K
                  itp_res = 2;            ! length = 2 (C+nl)
                  reason = 1
                  -> create int
               %finish
            %finish

            %if d_kick = 0 %start
               d_kick = 1
               p_c = d_stream<<1+fixed;    ! emas stream no
               to 2900(Transfer Request, mes_buff no); ! send it in
            %else
               bpush(d_inp q, mes_buff no); ! cant send it, so q it
            %finish
            %result = 2



console state(logging off):             ! message is out, just disconnect
         get buffer(send disconnect)

get rid of it:
         %result = -1
      %end



      %routine free transient
        %if %not d_hold = 0   %then free buff no(d_hold)  %and d_hold =0
        %while %not d_inp q_e == null %cycle
           free buff no(bpop(d_inp q))
        %repeat
      %end

      %ROUTINE High Level Control Message(%integer stream, p2b, p3b)
         d == con desa((stream-fixed)>>1)
         tcp == tcpa(d_tcp) %unless stream < fixed;   ! control streams
         %if stream = 8 %then d == d2
         %if stream = 9 %then d == d3

         %if mon # 0 %start
            select output(1)
            printstring("High m, str, p2b, p3b:")
            write(stream, 1); write(p2b, 1); write(p3b, 1); newline
            select output(0)
         %finish
         !*********************************
         !* high level message
         !********************************
         %if stream&1 = 0 %and stream > 2 %start;        ! input high level
          ! ignore for now (wrap around check eventually ?)
         %else
            !************************
            !*  output  stream      *
            !************************
            %if stream = 9 %start

               !! update of pointer on message stream
               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 = p2b
               d_o trig = p3b

               %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 d_hold # 0 %then free buff no(d_hold) %and d_hold = 0

                     %if d_tcp = 0 %then -> gb;     ! compiler problem
                     %if no of small < critical %c
                               %or no of big < critical %start
                        tcp_held = 1; held = held+1; theld = theld+1
                     %else
gb:                     get o block
                     %finish
                  %finish
               %finish

               !! check whether immediate trig reply is needed

               %if d_o trig >= 0 %start;    ! maybe
                  get buffer(send trig reply) %if d_opos = d_olim %or %c
                    (d_opos<d_olim %and %not d_opos<d_otrig<=d_olim) %c
                     %or %c
                    (d_opos>d_olim %and d_olim<=d_otrig<=d_opos)
               %finish

            %finish
         %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, buff no
         %integer type, p2b, pf, p2a, p3b
         %switch link fns(interf addr:mainframe down)

         buff no = p_buff no
         %if mon < 0 %start
            select output(1)
            printstring("From Dx: ty, bu:")
            write(p_fn, 1); write(p_buff no, 1); newline
            select output(0)
         %finish

         %if p_a&x'8000' # 0 %start;   ! Bit significance for new HLCM !
            stream = p_a&x'7fff'
            p2b = p_b; p3b = p_c
            High Level Control Message(stream, p2b, p3b)
            %return
         %finish

         m2900 == map(buff no);  m2900b == m2900
         %if p_fn = message  %start
            stream = m2900_stream;               ! get first stream no
            m2900_owner = own id
         %else
            %if p_fn > message %then ->link fns(p_fn)
            stream = p_c
         %finish
         d == con desa((stream-fixed)>>1)
         tcp == tcpa(d_tcp) %unless stream < fixed;   ! control streams
         -> link fns(p_fn)


link fns(interf addr):               ! interface addr from eam5
         %return


link fns(do output):         ! -> 11/34
         bh = bh+1
         %if stream = 9 %then read message from am1 %else %c
           read from am1
!         ->d mon
         %return

link fns(do input):      ! -> 2900
         bh = bh+1
         %if stream = 8 %then write message to am1 %else %c
           write to am1
         %return

link fns(mainframe up):
link fns(mainframe down):
tidy:    tidy message streams
         %cycle i = 0, 1, con lim
            d == con desa(i)
            %if d_state # not allocated %and d_tcp = 0 %then %c
              retrieve(d) %else %start
               %if not allocated < d_state < logging off %start
                  free transient
                  tcp == tcpa(d_tcp)
                  to gate(Disconnect, null, x'f2')
                  tcp_state = Disconnecting TCP
                  tcp_con state ind = 0;       ! no more to console descr.
                  retrieve(d);                 ! and get it back
                                               ! wait for disconnect response
               %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 = 8 %then d == d2
         %if stream = 9 %then d == d3
         bh = bh+1

         p2a = swab(m2900_p2a); p2b = swab(m2900_p2b)
         p3b = swab(m2900_p3b)

         type = 0
         sub ident = m2900_sub ident
         state = m2900b_b(0); mode = m2900b_b(1)
            %if mon < 0 %start
               select output(1)
               printstring("mess:s,su,st,2b,3b:")
               write(stream, 1); write(sub ident, 1); write(state, 1)
               write(p2b, 1); write(p3b, 1)
               newline
               select output(0)
            %finish


         %if sub ident = 0 %start
            %if d_o state = not allocated %start;   ! cross over?
               printstring("xxx:mess "); write(stream, 1);  write(sub ident, 1)
               write(state, 1)
               printstring(" NO DESC
")
            %finish %else %start
               High Level Control Message(stream, p2b, p3b)
            %finish
            free short buff(buff no)
            %return
         %finish

      ! low level
            %if stream < 10 %start
               %if state = connecting %start
                  !! initial logon stream connected
                  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 = p2b; d_o pos = 0; d_o lim = 0; d_o posx=0
                     printstring("logon stream enabled
")
                     HOST STATE = UP
                  %finish

                  %if state = disconnecting %start
                     host state = down
                     printstring("logon stream disconnected
")
                  tidy message streams
                  %finish
               %finish
            %else

            ! ******************************************
            !      u s e r    s t r e a m 
            ! ******************************************

               %if d_state = not allocated %start
                  -> send reply
               %finish

               %if state = enabling %and stream&1 = 0 %and d_tcp = 0 %c
                 %then type = 1
                 ! connecting, input stream, +console lost -> send chop

               %if state = enabling %start;   ! 1st intersting condition
                  %if stream&1 = 0 %start
                     d_state = input enabled
                     %if d_tcp = 0 %start;   ! gone away
                         type = 1
                     %else
                        d_in lim = p2b
                        d_i pos = p3b
                        d_imode = mode >> 4;   ! find out binary
                     %finish
                  %else

                     d_out lim = p2b;  d_o state = enabld
                     d_o pos = 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
                     type = 2;          ! send out 'invitation to clear'
                  %finish

               %finish %else %if state = aborting %or state = suspending %start
                  %if stream&1 # 0 %start;     ! output side
                      d_o state = idle;       ! stop transfers
                     d_abortf = state;                 ! remember type
                     %if d_hold # 0 %then free buff no(d_hold) %and d_hold=0
                  %finish
               %finish
            %finish
            m2900_p2a = 0;  m2900_p2b = 0
send reply:
            m2900_trf buff = 0;                 ! for safety
            to 2900(low level control, buff no)
            %if type # 0 %start
               %if type = 1 %then get buffer(send the chop) %else %c
                 get buffer(send disconnect)
            %finish
         %end;   ! of from 2900

      %routine fill(%record (mef) %name mes, %integer no)
         %integer n, pt, max
        %record (itpf) %name itp

         %constbyteintegerarray pts(1:last itp reason) =
           100, 10, 19, 26, 33, 39, 40, 45, 45, 45(8),
         45, 65, 75, 81
           !! pt to itp mess

         %ownbyteintegerarray itp message(1:139) =
         8, 2, k'146', 5, 'U', 's', 'e', 'r', ':',;  ! name prompt
         8, 0, k'246', 5, 'P', 'a', 's', 's', ':',;  ! pass prompt
         5, 1, 2, 3, 2, 2, 1,;                           ! echo on
         5, 3, 2, 3, 2, 2, 0,;                           ! echo off
         5, 0, 2, 2, 13, nl,;                        ! nl
         0,;                                         ! not used
         3, 5, 0, 1, 1,;                                ! i disconnect
         0, 0, 0, 16, 13, nl, '*', '*', ' ', 'E', 'M', 'A', 'S', ' ',
            'D', 'o', 'w', 'n', 13, nl,;             ! emas down
          0, 0, 0, 6, 13, nl, 'I', 'n', 't', ':',;      ! send Int:
          0, 0, 0, 2, 13, nl,;                       ! nl

          0(3), 15, 2, 2, 1, 3, 126, 7, 1, 9, 0, 10, 80,

                       12, 0, 13, 4,;                  ! sensible pad parameters
          0(3), 36, 'C', 'o', 'n', 'n', 'e', 'c', 't', 'e', 'd', ' ',
          't', 'o', ' ', 'E', 'd', 'i', 'n', 'b', 'u', 'r', 'g', 'h',
          '.', 'E', 'M', 'A', 'S', '-', 'A', 13, nl,
          'U', 's', 'e', 'r', ':';                     ! new user prompt


         pt = pts(no)

         %if tcp_tsf = 0 %then itp == mes_lev3_itp  %else %c
                               itp == mes_ts29_itp
         itp_s = string(addr(itp message(pt+3)))
         mes_len = length(itp_s)
         itp_res = 0;    ! for ts29

         %if no = 1 %then charno(itp_s, 29) = fep name; ! put in distinct letter

      %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
         %integer k

         !  N B
         !      Total length of addr, name and password must not exceed
         !      small block max
         !      Password is truncated if this is so

         %if d_state # name sent %start
           printstring("xxx:mun fails")
           write(d_state, 1); newline
           free buffer(logr);  %return
        %finish
         logr_a(1) = 1
         logr_a(2) = 0
         logr_a(3) = d_stream<<1+fixed

         k = tcpa(d_tcp)_tcpn
         string(addr(logr_a(4))) = tnames(k)
         logr_mlen = logr_a(4) +4+1
         d_hold = logr_buff no
      %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 p2)
         %integer reason, type, call ty, buff no, max trf, max len, e stream, mx
         %record (m2900f) %name m2900
          %record (mef) %name mes
         %record (m2900if) %name mi
         %conststring (1) the chop = "Y"

         bh = bh+1
         reason = p2_c2;                 ! get reason for calling
         buff no = p2_buff no
         mes == map(buff no)

         ! ******* check buffer first

         %if buff no # mes_buff no %start; ! corrupted on arival (?)
            printstring("XXX:BAD BUFFER:"); octal(mes_buff no); newline
            buff no = buff no-5; ! previous buffer
            mes == map(buff no); ! map to it for debugging
            crunch(11, buff no)
         %finish

         mes_owner = own id
         n = p2_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(n, 1); write(reason, 1)
            write(d_stream, 1); write(d_state, 1)
            printstring(", b:"); write(buff no, 1)
            newline; select output(0)
         %finish

         %if d_state = not allocated %start
            printstring("XXX:Not all!"); write(d_tcp, 1)
            write(reason, 1); newline
            -> free
         %finish
         %if reason = store user name %then move user name(mes) %andc
           %return
         tcp == tcpa(d_tcp)

         %if reason <= last itp reason %start
            %if d_tcp # 0 %start;   ! tcp = 0 - connection is lost
               fill(mes, reason);    ! insert the message

               call ty = put output
               %if 3<=reason<=4 %or reason = 7 %or %c
                 reason = send pad params %then call ty = Control data

               %if tcp_tsf # 0 %start
                  %if call ty = control data %start
                     call ty = put output
                     mes_ts29_itp_res = 128;   ! assert ts29 control byte
                  %finish
                 mes_len = mes_len+1;      ! additional byte in ts29
               %finish
               to gate(call ty, mes, 0)
               %if reason = send emas down %then d_state = logging off %and %c
                 get buffer(send disconnect)
            %else
free:          free buff no(buff no)
            %finish

            %if reason = send disconnect %start
               retrieve(d)
           %finish
         %else

            E stream = d_stream<<1 +fixed +reason&1
            %if d_stream < 0 %then E stream = 10+d_stream; ! control stream

            %if reason=get op block %or reason=get big op block %start
               %if d_o state = idle %then -> free; ! kill o/p done
               %if d_stream < 0 %then mes_len = 64 %else %start
                  max len = d_o lim-d_o pos;  ! difference between pointers
                  %if max len = 0 %then printstring("XXX:Zero trf?
")                  %and -> free
                  %if tcp_P256 = 0 %then mx = 127 %else mx = 255
                  %if max len > mx %or max len < 0 %then max len = mx
                  %if reason = get op block %and max len > 100 %then max len = 100
                                      ! Control stream is always 64
                                      ! User streams, its either the actual
                                      !      length or 127 whichever the smaller
                                      !      < 0 means wrapped over the end
                  mes_len = max len
               %finish
               %if mon<0 %start
                  select output(1)
                  printstring("req: o pos, o len, max,go:"); write(d_o pos, 1)
                  write(d_o lim, 1); write(mes_len, 1); write(d_out lim, 1)
                  write(d_out go, 1); newline
                  select output(0)
               %finish
               p_c = E stream;        ! pass emas strema no
               to 2900(Transfer Request, buff no)
                                      ! the buffer carries the max transfer 
                                      ! length for the DX11 to act on.
                                      !   xxx = 128
                                      !   Ts29= 127

                                      ! Control buffer = 64
               %return
            %finish

            !! message to 2900 reason
            m2900 == mes
            m2900_sub ident = x'0a00';    ! = swab(10)
            m2900_trf buff = 0;       ! for safety

            m2900_stream = E stream

            m2900_p2b = 0;  m2900_p2a = 0

            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, buff no)
         %finish
      %end


      %routine retrieve(%record (con desf) %name d)
         %record (tcpf) %name tcp

         %return %if d_state = not allocated
         %if d_tcp # 0 %start;   ! tcp=0 - connection is lost
            tcp == tcpa(d_tcp)
            tcp_con state ind = 0;      ! only one user in XXX
         %finish

        free transient

        d_state = not allocated
        d_kick = 0
        users = users-1 %unless users<0

         push(free des, d)
      %end


      !! r o u t i n e   lose consoles(all or a specific one)

      %routine lose consoles(%integer x)
         !! throw away connected consoles
         %integer index, i, t, q

            q = tcp_con state ind

            %unless q = 0 %start
               d == con desa(q)
               d_tcp = 0;             ! no messages to the tcp now
               free transient
               %if d_state < logging off %start
                  %if input enabled <= d_state <= awaiting int %start
                     !! log off 2900
                     ! If logging-on, then wait for EMAS to connect streams
                     %if tcp_held # 0 %start;  ! was held, must release it first !
                        tcp_held = 0; held = held-1
                        get o block
                        d_out go = 1;          ! ensure it can (how horrible !)
                     %finish
                     get buffer(send the chop)
                  %else
                     %if d_state < logging on %then %c
                       retrieve(d);           ! may re-claim immediately
                  %finish
               %finishelse retrieve(d)
            %finish
            tcp_con state ind = 0;      ! break the link
      %end


      %routine move(%integer len,from,to)
      !
      ! 'Assembler Routine' to emulate EMAS MOVE.
      ! Note: 1. No action if LEN<=0
      !       2. Registers 1,2 and 3 used.
      !
      %label uploop, downloop, up, return
      !
            *mov_len,1          ;! Load the length
            *ble_return         ;! Return if less than or equal to zero
            *mov_from,2         ;! Load the FROM address
            *mov_to,3           ;! Load the TO address
            *cmp_3,2      ;!Is TO address > FROM address?
            *bgt_up      ;!Yes - Move from top down in case...
      *beq_return  ;!Move in place - Null function
      !
      !     Loop to move LEN bytes FROM -> TO
      !
downloop:   *movb_(2)+,(3)+     ;! Move the byte
            *sob_1,downloop           ;! decrement & Continue if length not exhausted       
            *br_return
      !
up:         *add_1,2
            *add_1,3
uploop:     *movb_-(2),-(3)
            *sob_1,uploop
return:
            %return
      %end ;!of Move

      %routine read from am1
                  ! This routine now indicates that a buffer with data has
                  !  actually arrived from the amdahl, there are 3 conditions

                  ! 1) Stop at a page bdry, oe end of buffer -> More to come
                  ! 2) Max length, but more to come
                  ! 3) Possibly max len, but no more to come

         %record (mef) %name mes
         %record (itpf) %name it
         %integer n, flag, sym, lim, type, t, stat, len, new pos, old pos

         mes  ==map(p_buff no)
         mes_owner = own id
         len = mes_len

         %if mes == null %or d_state = not allocated %start
            printstring("xxx:sequence?
")
            %return
         %finish
         %if mon<0 %start
            select output(1)
            printstring("Out Len:"); write(len, 1); newline
            select output(0)
         %finish

         it == mes_lev3_itp;         ! data, whichever type, is actually there
         %if tcp_tsf # 0 %start
            ! ***************** NO GO *********************************
            ! ******* must move data ******
            move(len, addr(mes)+12, addr(mes)+13)
            it == mes_ts29_itp
            mes_len = len+1; it_res = 0
         %finish

         lim = d_o lim;  old pos = d_o pos
         new pos = d_opos + len
         %if new pos-1 = d_out lim %then d_opos = 0 %else d_opos = new pos

            %if d_o pos = lim %then d_o state = enabld

            %if d_tcp = 0 %start;      ! gone away
               free buffer(mes)
            %finish %else to gate(put output, mes, 0)

            %if d_out go > 0 %and d_ostate > enabld %then %c
                get o block

            %if d_o trig > 0 %and old pos < d_o trig <= new pos %then %c
              get buffer(send trig reply)
            %end

      %routine write to am1
                  ! This routine now indicates that the amdahl has taken an
                  ! input buffer from us.
         To Gate(Enable input, null ,1)
         d_kick = 0
         %if d_inp q_e ## null %start
            d_kick = 1
            p_c = d_stream<<1+fixed
            to 2900(Transfer Request, bpop(d_inp q))
         %finish
      %end



      %routine kick 2900 message(%record (mef) %name log)

         !! this routine sends 'log' to the 2900 by inserting
         !! it in the input q for stream 8, and kicking it if
         !! necessary

         d == d2
         log_len = 64;                  ! they are all 64 now 
         log_kick to go = 1;            ! wake up director
         d_in cnt = d_in cnt+1
         %if d_kick = 0 %start
            d_kick = 1
            p_c = 10+d_stream;          ! -1 & -2 map to 9 & 8
            to 2900(Transfer Request, log_buff no)
         %else
            bpush(d_inp q, log_buff no)
         %finish
      %end


      %routine tidy message streams
         d2_o state = idle; d3_o state = idle
         d2_kick = 0
         %while %not d2_inp q_e == null %cycle
            free buff no(bpop(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

                      ! This routine now means that a buffer has actually arrived
                      ! from the amdahl, all buffers are 64 bytes in length


         %record (mef) %name m
         %integer n, sym, t, stat, lreply, stream, mode
         %record (mef) %name mes
         %integer type
         %record (itpf) %name itp

         %switch hlm(1:2)

         m == map(p_buff no)
         m_owner = own id;             ! pick up the buffer
         %if m == null %or d3_opos = d3_o lim %start
              printstring("xxx: seq2!
")
              t = 0!128; -> reply
         %finish

         d3_opos = d3_opos+64
         %if d3_opos-1 = d3_out lim %then d3_opos = 0
         type = m_a(1)
         %if mon < 0 %start
            select output(1)
            mon mes(m)
            select output(0)
         %finish

         stream = m_a(2)<<8!m_a(3)
         %unless 1 <= type <= 2 %%start
            printstring("Bad HLM, type ="); write(type, 1); newline
            -> reply
         %finish
         d == con desa((stream-fixed)>>1)
         %if d_state = not allocated %start;  ! user has disconnected etc
            printstring("xxx: Invalid logon reply
")
            free buffer(m)
            -> reply
         %finish

         -> hlm(type)

hlm(1):                                 ! Logon Reply

               lreply = m_a(5)
               str = string(addr(m_a(6)));   ! copy text out of way
               mes == m;            ! make it a network buffer
               mes_len = length(str)

               %if d_tcp # 0 %start;  ! user hasn gone away
                  tcp == tcpa(d_tcp)
                  %if tcp_tsf = 0 %then itp == mes_lev3_itp  %else %start
                      itp == mes_ts29_itp
                      mes_len = mes_len+1;     ! ts29 byte
                  %finish

                  itp_s = str;    ! copy text back in
                  %if tcp_tsf # 0 %then itp_res = 0; ! ts29 '1st' byte=data
                  to gate(put output, mes, 0)
               %finish %else free buffer(m)
               %if l reply = 0 %start
                  %if d_state = input enabled %start; ! out of sequence
                     printstring("xxx:enable before logon reply
")
                  %else
                     d_state = logged on
                  %finish
                                 ! NB: Even if the connection is lost, we cannot
                                 !     immediately retrieve 'd', as we have to
                                 !     wait until EMAS has CONNECTED the streams
                                 !     before sending in the abort message.
               %else
                  d_state = logging off
                  %if d_tcp = 0 %then retrieve(d) %else %c
                    get buffer(send disconnect);  ! immediate request to go
               %finish
         -> reply

hlm(2):                                 ! setmode out, string at m_a(5)
         %if d_tcp = 0 %start
frx:        free buffer(m); -> reply
         %finish

                                      !  XXX param settings
                                      !      - there is a dummy 255 as the
                                      !        1st byte past the length. This
                                      !        is to avoid sending itp setmodes out
                                      !      - a 254 means change the flag
                                      !        which allows ctrl+t etc to be
                                      !        changed to single char ints

         tcp == tcpa(d_tcp);          ! pickup tcp descriptor

         %if m_a(6) = 254 %start;        ! control ints switch
            d_imode = m_a(7);            ! 0=allow, 1=disallow
            -> frx
         %finish

         %if m_a(6) = 255 %start;        ! proper xxx mode set
            m_a(6) = m_a(5)-1;           ! move length down one to scrap 255
            str = string(addr(m_a(6)));      ! copy setmode out of the way
            mes == m;                      ! change the buffer to an itp one
            mes_len = length(str)+header len
            %if tcp_tsf = 0 %start
                mode = control data; itp == mes_lev3_itp
             %else
                 mode = put output; itp == mes_ts29_itp; mes_len = mes_len+1
             %finish

            itp_s = str;                     ! put the setmode back in
            length(itp_s) = 128;     ! flag control in TS29, else ignored
            to gate(mode, mes, 0);   ! send the buffer
         %finish %else FREE BUFFER(m);            ! CANT HANDLE SETMODE

reply:
         ! nothing to do here except to check if another one ready to come.

         %if d3_opos # d3_olim %start
            d == d3
            get buffer(get op block)
         %finish

     %end



      !!     w r i t e   m e s s a g e   t o    a m 1

      %routine write message to am1

         %integer n, max, am1 reply, stat

         ! allways use d2

         ! This now means that a message has gone to the amdahl,
         ! simply see if there is another to be sent

         d2_kick = 0;             ! may now send another
         %if d2_inp q_e ## null %start
            d2_kick = 1
            p_c = 10+d2_stream
            to 2900(Transfer Request, bpop(d2_inp q))
         %finish
      %end


      %routine mon mes(%record (mef) %name mes)
         %integer i, j, k, n
         %record (itpf) %name itp

         k = mes_len;  itp == mes_lev3_itp
         write(k, 1); space; space
         j = 0; %return %if k = 0
         %cycle i = 1, 1, k
                  write(itp_a(i), 1)
               j = j+1;  %if j = 25 %then j = 0 %and newline
         %repeat
         newline;  select output(0)
      %end
   
   
      %routine mon p(%record (pe)%name p)
         %integer i
         printstring(" fn ="); write(p_fn, 1)
         printstring(" G port"); write(p_gate port, 1)
         printstring(" T port"); write(p_task port, 1)
         printstring(" a2"); write(p_a2, 1)
        printstring(", b:"); write(p_buff no, 1)
         newline
      %end
   
   
%endofprogram