%conststring (13) vsn = "ftps....4a "
#datestring
#timestring

!********************************
!*  emas-2900  fep  ftp server  *
!*   file: ftp4as/ftp4ay     *
!*                              *
!********************************


#options
! prep versions are:-
!
!   m = Full Monitoring
!   c = Clock monitoring (needs a real time clock)
!  i = new imp compiler
!

%control 1
%include "deimosperm"



%begin


      %recordformat lev3f(%bytearray reserved(0:5), %bytearray a(0:241))

      %recordformat mef(%integer buff no, len, %c
        %byteinteger owner, type, (%record (lev3f)lev3 %or %c
         %bytearray params(0:231) %or %string (231) str %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
         (%integer p2a, p2b, p3a, p3b,p4a, p4b, p5a, p5b, p6a, p6b %or%c
         %bytearray b(0:19)))


      %recordformat maf(%integer buff no, len,  %byte owner, mtype, %c
        %integer kick to go, from flag, spare, %c
        (%bytearray m(0:242) %or %c
         %integer sp1, %byte sp2, type, %integer  ref, in ident, out ident, fail no, sp3, %c
         %string (63) address))

      %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 index, stream, permit, node, term, first, istate, %c
        o state, port, mode, kill, direction, in, to go, icount, ref, outlen, %c
        cpos, count, nc, secadd, ip busy, p256, %c
        %integer holdi, %record (qf) inp q)

      !************************************************************
      !*  upper level (itp&ftp) 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 Request Transfer = 3
      %constinteger Repeat  Transfer = 4
      %constinteger Discard Transfer = 5

      !**************************************************************
      !*               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

      %constinteger t3 ser = 21

      %constinteger ts accept = 17

      !********************* FTP Transfer Control Commands *************

      %constinteger ss = x'40';         ! Start of Data
      %constinteger cs = x'42';         ! Code Select
      %constinteger es = x'43';         ! End of Data
      %constinteger qr = x'46';         ! Quit
      %constinteger er = x'47';         ! End Acknowledge

      !******************* FTP Initialisation and Termination ***************

!     %constinteger p stop = X'00';     ! Request Termination (from p)
!     %constinteger q Stopack = X'05';  ! Acknowledge Termination (from q)

      !***********************************************************
      !*               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;        ! end of section or file
      %constinteger aborting = 5
      %constinteger enabling = 7
      %constinteger enabled = 8


      !*   s t a t e s

      %constinteger not alloc = -1
      %constinteger idle = 0
      %constinteger trying = 1;         ! awaiting network reply
      %constinteger timing = 2;         ! connection refused, waiting for clock
      %constinteger aborted = 3;         ! 2900 has gone down
      %constinteger Emas Dwn = 4;       ! Emas down, waiting for net reply
      %constinteger wait ts = 5;       ! fix Xgate YB problems
      %constinteger connect 1 = 6;      ! lev3 connected, waiting for
                                        ! 2900 connect&enable
      %constinteger connected = 7;      ! in file
      %constinteger enabld = 8;         ! 2900 has started file
      %constinteger conn lost = 9;      ! Disc before accept on incoming call
      %constinteger closing = 10;         ! close has been sent to network
      !******************************************
      !*  reasons for waiting for a buffer      *
      !******************************************
      %constinteger get op block = 24
      %constinteger send abort = 25;        ! ask emas to abort stream
      %constinteger do input connect = 27
      %constinteger connecting reply = 29;    ! keep this odd (see from buffer manager)
      %constinteger connecting reply 2 = 30
      %constinteger connecting reply failed = 31
      %constinteger connecting reply 2 failed = 32
     %constinteger get connect buffer = 33
      !**************************************************************
      %routinespec do enable facility(%string (11) address)
      %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 buffer(%record (mef) %name mes)
      %routinespec who and state
      %routinespec tell
      %routinespec from gate
      %routinespec from 2900
      %routinespec do connect
      %record (con desf) %mapspec get free des
      %routinespec from buffer manager(%record (pe) %name p2)
      %integerfnspec allocate stream(%record (con desf) %name d)
      %routinespec tidy buffers
      %routinespec retrieve(%record (con desf) %name d)
      %routinespec do repm(%integer flag)
      %routinespec clear all streams
      %routinespec Block From Amdahl(%record (mef) %name mes)
      %routinespec Process Input(%record (mef) %name mes)
      %routinespec Test More Input
      %routinespec write acknowledge
      %routinespec read message from am1(%record (mef) %name mes)
      %routinespec Move(%integer len, from, to)
      %routinespec mon mes(%record (mef) %name mes)
      !******************************************************
      %record (pe) p
      %owninteger con sub id reply = 1;   ! picks up from actual mess


      %ownrecord (con desf) %name d
      %ownrecord (con desf) %name d4, d5
      %constinteger con lim = 25;      ! number of active terminals (see fixed top)
      %ownrecord (con desf) %array con desa(0:con lim)
      %ownrecord (qf) %name free des;   ! pts to list of free con desa
      %record (qf) %name q frig
      %ownstring (73) %array adda(0:conlim)

      %constinteger fixed = 350;           ! 1st available stream
      %constinteger fixed top = 399;      ! number of 2900 streams in eam5
                                        ! was 281 !
      %recordformat hold bufff(%record (hold bufff) %name link, %integer buff no)
      %record (holdbufff) %array hba(0:100)
      %record (holdbufff) %name free hold

      !* * * * * * * * * * * * * * * * * * 
 
      %ownrecord (qf) %name buffer pool;  ! =k'142472'
      %owninteger no of buff = 0, bh = 0
      %owninteger max buff = 4;        ! max in the pool

      %owninteger mon = 0;              ! monitoring flag (set to 'O')
      %owninteger data len = 120;        ! cut down length for pss
      %owninteger spec mon = 0, special flag  = 0
      %owninteger out pos = 0
      %owninteger ftpi = 0;                 ! no of ftp packets
      %owninteger ftpo = 0

      %constinteger initial permit = 2
      %constinteger header len = 0
       %ownstring(1) snil = ""
      %ownstring (63) called, calling
      %ownstring (73) qual;             ! nb: Emas address moved through it
      %ownstring (1) disqual
      %ownstring (5) window = ""

      ! l o g g i n g   o n


      %integer i

      %conststring (7) %array ostates(-1:closing) =  "not all", 
         "ready", "asking", "timing", "aborted", "EmasDwn",  "Wait Ts",
        "chcking", "conning", "going", "ConLost", "close"


      !**********************************************
      !*      initialisation                        *
      !**********************************************

      change out zero = t3 ser


      %cycle i = con lim, -1, 2
         con desa(i)_index = i;  con desa(i)_o state = not alloc
         qfrig == con desa(i)
         qfrig_e == free des
         free des == qfrig
      %repeat

      con desa(1)_index = 1
      condesa(0)_stream = 6
      con desa(1)_stream = 7

%cycle i = 100, -1, 2
  hba(i-1)_link == hba(i)
%repeat
free hold == hba(1)
      printstring(vsn)
      printstring(" Amdahl ")
      printstring(datestring)
      newline

      map hwr(0);                      ! map am1 to segment 0
      d == con desa(0)
       d4 == d
      d5 == con desa(1)

      p_c = 6;                 ! param for 'here i am'
      to 2900(here i am, 0)
      p_c = 7
      to 2900(here i am, 0)

      do enable facility("FTP")
      do enable facility("MAIL")
      do enable facility("X");             ! NB: very special for GEAC



      alarm(500);                          ! set clock for 10 secs
      !**********************************************
      !*           main loop                        *
      !**********************************************
      %cycle
         p_ser = 0;  poff(p)

         %if int # 0 %start

         %if 'M' <= int <= 'P' %start
            mon = int-'O'
            printstring("ok
")
         %finish

         %if '1' <= int <= '7' %start
            window = "W=2/2"
            charno(window,3) = int; charno(window,5) = int
         %finish

         %if int = '?' %start
            printstring("Buff ="); write(bh, 1)
            printstring(", Pool ="); write(no of buff, 1); newline
            printstring("   FROM     port  oc istate icnt omde ifrst oprm i-bsy
")
            %cycle i = 2, 1, con lim
            d == con desa(i)
            %if d_o state # not alloc %start
               printstring("ftp:")
               who and state
               newline %if out pos > 30
               write(d_port, 1)
               write(d_nc, 1)
               write(d_istate, 1)
               write(d_icount, 1)
               write(d_mode, 1)
               write(d_first, 1)
               write(d_permit, 1)
               write(d_ip busy, 1)
               newline
            %finish
            %repeat
            newline
         %finish
         %if int = 'C' %start;          ! close output
            select output(1);           ! select it
            close output
            printstring("done
")
         %finish
         %if int = 'S' %then max buff = 4-max buff
         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 %start
           from buffer manager(p)

         %finish %else %if p_reply = 0 %start;       ! clock tick
            %cycle i = con lim, -1, 0
               d == con desa(i)
               %if d_o state = timing %start
                  d_count = d_count-1
                  %if d_count <= 0 %then d_ostate = idle %and do connect
               %finish

            %repeat
            alarm(100);      ! 2 secs
         %finish

      %repeat

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

      %routine crunch(%integer n)
         %integer i
         who and state; newline
         %cycle i = 1, 1, 10
            printstring("**** ftps failed"); write(n, 1); printstring("   - dump it ***
")
         %repeat
         *=k'104001';                ! emt wait
      %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)
   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_#10,1;     ! desired vm seg no *2 ie 5*2
        *iot
        %result == record(k'120000');   ! allow 3 code segs for now
     %end
%routine free buff no(%integer buff no)
     ! not mapped, so send it straight back
   %record (pe) p
   %unless k'6000' <= buff no <= k'7776' %then crunch(21)
   %return %if buff no = 0;          ! rest of code is very loose on this
   p_ser = buffer manager; p_reply = id
   p_fn = release buffer
   p_buff no = buff no
   pon(p)
   bh = bh-1
%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)
            mes_owner = own id
            string(addr(mes_params)) = address
            pon(p)
      %end


      %routine to gate(%integer fn, %record (mef) %name mes, %c
         %integer flag)

        %if mon < 0 %start
             select output(1); printstring("To gate:"); write(fn, 1)
             printstring(" on task port "); write(d_index, 1)
             printstring(", Gate Port"); write(d_port, 1)
            printstring(", Flag"); write(flag, 1); newline
            select output(0)
          %finish

         %if fn = put output %start;        ! queue these as necessary

            %if mon < 0 %or spec mon # 0 %start
               spec mon = 0
               select output(1)
               printstring("io ");  mon mes(mes)
            %finish
         %finish

         p_ser = gate ser; p_reply = own id
         p_fn = fn; p_gate port = d_port; p_task port = d_index
         p_a2 = flag
         %if mes == null %start
            p_buff no = 0
         %else
             p_buff no = mes_buffno
             crunch(99) %unless k'4000' <= p_buff no <= k'7777'
             bh = bh-1
         %finish
         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
         bh = bh-1 %unless buff no = 0
         %if mon < 0 %start
            select output(1)
            printstring("to 2900, fn, buff:")
            write(fn, 1); write(buff no, 1)
            %if fn = Request Transfer %start
               printstring(" Req:stream:")
               write(p_c, 1)
            %finish
            newline
            select output(0)
         %finish
         %if fn = Request Transfer %and p_c = 0 %then crunch(20)
         pon(p)
      %end

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

         %if reason = get op block %or reason = get connect buffer %c
            %then p_c1 = 0 %else p_c1 = 1
         ! ****** watch the above line ******** (big or small buffer)

         p_c2 = reason; p_a2 = d_index
         %if buffer pool == null %or p_c1 # 0 %start;  ! have to ask for it
            p_ser = buffer manager; p_reply = own id
            p_fn = request buffer
            pon(p)
         %else
            hb == buffer pool
            buffer pool == hb_link
            p_buff no = hb_buff no
            hb_link == free hold
            free hold == hb
            bh = bh-1;                  ! from buff adds one back on
            no of buff = noof buff-1;  from buffer manager(p)
         %finish
      %end

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


         %unless k'6000' <= mes_buff no <= k'7776' %then crunch(2)

         %if mes_type # 0 %or no of buff >= max buff %start
            p_ser = buffer manager; p_reply = own id
            !! queue it if it is a long buffer
            p_fn = release buffer
            p_buff no = mes_buff no
            bh = bh-1
            pon(p)
         %else
            !! long buffer, so queue it
            hb == free hold; free hold == hb_link
            hb_buff no = mes_buff no
            hb_link == buffer pool
            buffer pool == hb
            no of buff = no of buff+1
         %finish
      %end

      !! 
      %routine tell
         %string (*) %name s
         write(d_index, 2); space
         %if d_direction = 0 %start
            printstring("ftp-Q ")
            s == adda(d_index)
            printstring(s)
         %else
             printstring("ftp-P ")
            s == string(addr(adda(d_index))+1)
            printstring(s)
         %finish
         space
         out pos = length(s)
      %end

      %routine who and state
         tell
         printsymbol('(')
         printstring(ostates(d_o state))
         printstring(")  ")
      %end


      %routine fault(%integer n, state)
         printstring("Ftp:Fault:"); write(n, 1)
         who and state %unless d == null
         printstring(" Expected state:"); printstring(o states(state))
         newline
      %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




      ! r o u t i n e     f r o m    g a t e

      %routine from gate
         %record (mef) %name mes

         %integer fn, flag, strm, i, d1, d2, buff no
         %switch fns(connect:control data)

         %routine discres
            printstring(", reason ="); write(p_a2, 1)
            write(d1, 1); write(d2, 1); newline
         %end


         %if p_buff no = 0 %then mes == null %else %start
            mes == map(p_buff no); bh = bh+1
            buff no = p_buff no
            mes_owner = own id
         %finish

         fn = p_fn
         strm = p_task port
         d == con desa(strm)
         %if mon < 0 %start
            select output(1)
            printstring("From Gate, fn="); write(fn, 1)
            printstring(", G Port ="); write(p_gate port, 1)
            printstring(", T Port ="); write(p_task port, 1)
            printstring(", Flag ="); write(p_a2, 1)
            newline
            select output(0)
         %finish

         ->fns(fn)

fns(Connect):
         strm = p_gate port;      ! remember gate port no
         flag = 0;           ! reject if all else fails

      disqual = ""

      %if host state = down %start
         flag = x'fd'
         -> reply
      %finish


      d == get free des
      %if d == null %then flag = x'fe' %and -> reply


      !! construct a message to the 2900 *******
      i = allocate stream(d);    ! both streams
      d_direction = 0;                  ! 0 = incoming, 1 = outgoing
      d_holdi = buff no; buff no = 0
      d_o state = connect 1;            ! wait for confirmation
      d_nc = 0
      %if mon < 0 %start
         write(d_index, 2); printstring("Incoming Call
")
      %finish

      d_port = strm;          ! remember gate port no
      get buffer(do input connect)
      %return;                    ! Asking the 2900, so wait

reply:
         mes_str = "";                  ! don't want any params, only buffer
                              ! no descriptor, so reply now
         p_ser = gate ser; p_reply = own id
         p_fn = Disconnect; p_a2 = flag
         pon(p)
         bh = bh-1
         %return

fns(Input Here):
         %if d_o state = not alloc %start;   ! X-over (tighten up check ????)
            free buffer(mes)
            printstring("Ftps: Invalid Buffer from Gate, stream =")
            write(d_index, 1); newline
         %finish

         %if mon < 0 %start
            select output(1)
            printstring("In "); mon mes(mes)
            select output(0)
         %finish

         %if d_o state = enabld %and d_ip busy = 0 %start;  ! can go now
            Process Input(mes);                             ! so do it
         %else
            bpush(d_inp q, buff no);                        ! wait till we can
         %finish
         d_nc = d_nc+1;     ! count it
         %return

fns(Enable Output):
         i = d_permit
         d_permit = d_permit+p_a2
         %if i = 0 %and d_o state = enabld %then %c
            get buffer(get op block)
         %return

fns(Disconnect):
         %unless mes == null %start
            d1 = mes_lev3_reserved(2); d2 = mes_lev3_reserved(3)
            free buffer(mes)
         %finish
         %if strm = 0 %start;           ! disconnect before Accept !
            %cycle i = 2, 1, con lim
               d == con desa(i)
               %if p_gate port = d_port %start
                  who and state
                  printstring("Disc before acc
")
                  d_o state = conn lost; %return
               %finish
            %repeat
            printstring("Disc on unknown strm ="); write(strm, 1)
            discres; newline
            %return
got:
         %finish
         %if d_o state = closing %start
            %if mon < 0 %start
               tell;  printstring("close ack
")
            %finish

            to 2900(low level control, d_hold)
            d_o state = idle; d_hold = 0
         %else
                                   ! hold disconnect params for spoolr
            d_term = d2<<8!d1;     ! effectively swabbed for spoolr
            %if p_a2 # 139 %then d_term = 0;  ! if not 'call closed' - no info

            %if d_o state = trying %or d_o state = wait ts %start
               %if d_o state = wait ts %then to gate(Disconnect, null, 1)
               d_nc = d_nc+1; d_port = flag;   ! remember reason
               d_o state = timing;             ! try again soon
               d_count = 22;            ! after 45 secs
               %if mon < 0 %start
                  tell; printstring("ConRej"); discres
               %finish
               %return
            %finish
            %if mon # 0 %or d1 > 1 %start
               who and state
               printstring("network abort")
               discres
            %finish
            %if d_o state = not alloc %then %return; ! very nasty ***************
            %if d_o state >= connected %start

               get buffer(send abort);         ! get 2900 to abort stream
               to gate(Disconnect, null, 1);     ! reply to gate to clear port
            %finish
            %if d_o state = aborted %or d_o state = Emas Dwn %then %c
               retrieve(d) %else d_o state = idle
         %finish
         %return

fns(Accept Call):

         %if d_o state # trying %and d_o state # aborted %and d_o state # Emas Dwn %start
            tell; printstring("Invalid call reply !
")
            %return
         %finish

         %return %if d == d4;           ! not assigned

         free buffer(mes) %unless mes == null
         d_port = p_Gate Port

          %if d_o state = aborted %or d_o state = Emas Dwn %start
             !! connection established !
             to gate(Disconnect, null, 1)
             d_nc = 98
              %return
         %finish

               %if mon < 0 %start
               tell;  printstring("connected
")
            %finish
            d_permit = initial permit;         ! nsi change
            d_o state = wait ts;      ! must wait for YB accept (Xgate problems)
            d_nc = 0
            d_count = 0
         %return

fns(reset):
      free buffer(mes) %unless mes == null
      %if mon # 0 %start
         tell; printstring("Reset !
")
      %finish
chop connection:
      to gate(Disconnect, null, 1)
      %unless d_o state = wait ts %start
         d_o state = idle
         get buffer(send abort);       ! and tell 2900 call gone
      %else
         d_o state = trying
      %finish
      %return

fns(Expedited):
     tell; printstring("Expedited !
")
     -> chop connection

fns(control data):
        %if d_o state = wait ts %start
           %if mes_lev3_a(0) # ts accept %start
              printstring("ts accept? "); write(mes_lev3_a(0), 1); newline
           %else
              d_o state = connected
              get buffer(connecting reply);  ! tell EMAS to go
              get buffer(connecting reply 2); ! and second stream
           %finish
       %finish
       to gate(Enable input, null, 1)
       free buff no(buff no)
       %return

fns(*):
         crunch(3)

      %end

      %routine High Level Control Message
         %integer old nc
                                  ! These messages are now sent from dx11
                                  ! WITHOUT a small buffer, so are handled
                                  ! seperately
         d == d5;                 ! always for the outward control stream
%if mon<0 %start
select output(1)
printstring("HLM:new nc cou:")
write(p_b, 1); write(d_nc, 1); write(d_count, 1); newline
select output(0)
%finish
%if p_b&127 # 0 %start
printstring("bad hlm:"); write(p_b, 1); newline
p_b = d_count+128
%finish
         old nc = d_nc
         d_nc = p_b;             ! p_b contains m2900_p2b
         get buffer(get op block) %if old nc = d_count
                                  ! if 1st new message, then go get it
      %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 (m2900f) %name m2900b

         %integer stream, sub ident, state, mode, am1c, type, nsta, buff no
         %integer p2a, p2b, ioflag
         %switch link fns(interf addr:mainframe down)
         %switch com state(disconnecting:enabled)
         %switch com state b(disconnecting:enabled)

         %if p_a&x'8000' # 0 %then High Level Control Message %and %return

         buff no = p_buff no
         %if buff no # 0 %start
            bh = bh+1
            m2900 == map(buff no); m2900b == m2900
            m2900_owner = own id
         %finish
         %if p_fn = message %start
            stream = m2900_stream;               ! get first stream no
         %finish %else  stream = p_c

         %if stream < fixed %or stream > fixed top %then d == null %else %c
           d == con desa((stream-fixed+4)>>1)
         -> link fns(p_fn)


link fns(do output):         ! -> 11/34
                             ! this now means that a buffer has arrived from
                             ! the amdahl
         %if stream = 7 %then read message from am1(m2900) %else %c
           Block From Amdahl(m2900)
         %return

link fns(do input):      ! -> 2900
                             ! this now means that the dx11 handler has cleared a
                             ! buffer into the amdahl
         %if stream = 6 %then d == d4
         write acknowledge
         %return


link fns(mainframe down):
link fns(mainframe up):
         host state = down
         clear all streams
         %return


link fns(message):
         sub ident = m2900_sub ident
         state = m2900b_b(0);  mode = m2900b_b(1)&x'f0';  ! not swabbed any more
                          ! mode = 0 - seq, 1 - circ, 2 - seq cont
                          !      = x'10' - iso, x'20' - ebc, x'30' - bin
                         !      = x'40' - normal FTP (data phase)
                         !      = x'50' - default emas to emas FTP (data)
                         !      = x'60' - Negitiation Phase FTP
         p2a = swab(m2900_p2a);  p2b = swab(m2900_p2b)
         m2900_p2a = 0;  m2900_p2b = 0

         %if sub ident # 0 %start;      ! low level
            !******************************************
            !*    l o w   l e v e l  control message
            !******************************************

            ioflag = stream&1;     ! ioflag = 1 => 2900 o/p

            %if mon < 0 %start
               select output(1)
               printstring("from 2900 "); who and state %unless d == null
               write(stream, 2)
               write(sub ident, 2); write(state, 2); write(mode, 2)
               newline
               select output(0)
            %finish

            %if stream <= 7 %start
               %if stream = 6 %then d ==d4 %else d == d5
               ->com state b(state)
           %finish

            %if d == null %or d_o state = not alloc %or d_o state = Emas Dwn %start
               printstring("ftps: stream?")
               write(stream, 1); Fault(1, idle)
               -> control reply
            %finish


            -> com state(state)

com state(enabling):
                   -> control reply %if d_o state = idle
                  d_o state = enabld
                  %if mon < 0 %start
                     tell; printstring(" enab")
                     write(mode, 2)
                 %finish

                  %if ioflag # 0 %start

                     %if mon < 0 %then write(p2b, 1) %and printstring(" o
")
                     d_mode = mode;   ! remember type (output only, istate on input)
                     d_outlen = p2b;    ! length of output trans (for monit)
                     %if d_permit > 0 %start
                         type = get op block
                         to 2900(Low level control, buff no)
                         get buffer(type)
                         %return
                    %finish
                  %else
                     %if mode = x'40' %then nsta = 10;    ! normal Ftp data
                     %if mode = x'50' %then nsta = 5;      ! Default Emas-Emas
                     %if mode = x'60' %then nsta = 0;  ! Neg phase
                     %if d_icount = 0 %start
                        d_istate = nsta;     ! accept new state
                        %if mon < 0 %then newline
                     %else
                        %if mon < 0 %then printstring(" (nsc)
")
                     %finish
                     d_first = x'ff'
                     to 2900(low level control, buff no); ! MUST reply first
                     Test More Input;        ! pick up partial trf or new buffer
                     %return
                  %finish
                  -> control reply

com state(connecting):

                    con sub id reply = m2900_sub ident; ! retain for reply

                  %if ioflag # 0 %start;    ! output
                     d_nc = 0
                      %if d_direction # 0 %start
                        %if mon < 0 %then tell %and printstring("out conn
")
                        %if d_o state = idle %then do connect %else %c
                          fault(2, Idle)
                     %finish %else -> control reply
                   %else;          ! input
                     d_icount = 0;      ! always allow state change after conn

                      %if d_o state = connect 1 %start
                        p_gate port = d_port; ! for repm
                        do repm(1);      ! ok
                        d_o state = connected
                        d_permit = initial permit
                        ->control reply
                     %else
                        %if d_o state = Conn Lost %start
                           get buffer(send abort);   ! we had to wait to do this
                           d_o state = idle
                           -> control reply
                        %finish
                     %finish
                  %finish

                   free buff no(buff no);     ! reply is made up later
                   %return

com state(disconnecting):
                  %if aborted # d_o state # idle %and ioflag # 0 %start
   ! this must only be done on one stream !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
                     fault(4, connected) %if d_o state # connected

                     d_o state = closing
                     %unless d_hold = 0 %then free buff no(d_hold)
                                        ! more than one can be 'requested'
                     d_hold = m2900_buff no
   
                     %if mon < 0 %then tell %and printstring("Disconnecting call
")
   

                     to gate(Disconnect, null, 0)
                     %return;         ! hold reply till later
                  %finish
                  -> control reply


com state(aborting):
             %if mon < 0 %start
                tell; printstring("aborting
")
             %finish
             ->suspd

com state(suspending):
suspd:
             Fault(5, enabld) %unless d_o state = idle %or d_o state = enabld %or %c
                d_o state = connected
                                           ! Might like it tighter but must 
                                           ! watch the implication on BOTH streams
             d_o state = connected %if d_o state # idle %and ioflag = 0
                                        ! susp on output does not stop input
             d_kill = state %unless d_kill = aborting;  !remember type of call
                 ! stop transfers unless its idle anyway

control reply:
            to 2900(Low level control, buff no)
            %return
         !! ***********************************************
         !! the following are all stream 6 & 7 manipulations
         !! ************************************************

com state b(enabling):
         d_o state = enabling
         d_mode = p2b;                   ! bUFFER SIZE
         host state = up
         -> control reply

com state b(connecting):
         d_o state = connected
         d_nc = 0; d_count = 0; d_mode = 0; d_cpos = 0
         printstring("ftp: logon stream"); write(stream, 1)
         printstring(" connected
")
         string(addr(m2900_p3a)) = "X25";          ! flag x25 fep to spoolr
         %if stream = 6 %then -> clear out

com stateb(aborting):
com stateb(suspending):
com stateb(disconnecting):
         d_o state = idle
         host state = down
clear out:  tidy buffers
         clear all streams
         -> control reply

        %finish

      %end

      %routine do connect
         get buffer(get connect buffer)
      %end

      %routine do actual connect(%record (mef) %name mes)
      %ownstring (11) ef = "EMAS - ftp"

         qual = adda(d_index)
         called = string(addr(qual)+1)
         calling = string(addr(qual)+length(called)+2)

         %if mon # 0 %and d_nc = 0 %start
               printstring("Connect to:"); printstring(called)
               printstring(", from:"); printstring(calling)
               newline
         %finish
         mes_len = 0
         pack(mes, called)
         pack(mes, calling)
         pack(mes, window)
         pack(mes, ef)
         d_port = 0;      ! ensure it goes out on port 0
         to Gate(Connect, mes, 2)
         fault(6, idle) %if d_o state # idle
         d_o state = trying
      %end


      %record (con des f) %map get free des
         qfrig == free des
         %if qfrig == null %start
             printstring("ftps: out of descriptors! ****
")
             %result == null
         %finish
         free des == qfrig_e
         qfrig_e == null
         %result == qfrig
      %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 == d4
         log_sp1 = 0; log_sp2 = 0
         log_kick to go = 1
         log_len = 128;                  ! always 128 bytes now
         %if d_ip busy = 0 %start
            d_ip busy = 1
            p_c = d_stream; to 2900(Request Transfer, log_buff no)
         %else
            bpush(d_inp q, log_buff no)
            d_cpos = d_cpos+1
         %finish
      %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, strm
         %record (m2900f) %name m2900
         %record (maf) %name log
         %integer lc1, lc2, buff no
         %record (mef) %name mes, mex
         %string (3) td


         buff no = p2_buff no
         mes == map(buff no)
         mes_owner = own id

         bh = bh+1
         reason = p2_c2;                 ! get reason for calling
         strm = p2_a2
         d == con desa(strm);           ! and map to descriptor

         %if mon < 0 %start
            select output(1)
            printstring("from bm: reason, index")
            write(reason, 2); write(strm, 2); newline
            select output(0)
         %finish

         %if reason = get op block %start
            p_c = d_stream
            p_c = p_c+1 %if d_stream>7; ! on OUTPUT str, so its odd
            %if d_p256 # 0 %then mes_len = 256 %else mes_len = 128
            to 2900(Request Transfer, buff no);  ! do it NOW
            %return
         %finish


            ! Connect from Network, going to Spoolr
            ! The incoming buffer is used to hold the 'qual of service'
            ! the only required part of params (in a SHORT buffer)
            ! The incoming call buffer (LONG) is used to pass the params
            ! to Spoolr.
            !
            %if reason = do input connect %start
               fault(7, connect 1) %if d_o state # connect 1
               mex == map(d_holdi)
               called = unpack(mex, 1)
               calling = unpack(mex, 2)
               %if charno(calling, 2) = '.' %then %c
                  calling -> td.(".").calling
               qual = unpack(mex, 3)

               log == mex; d_holdi = buff no; ! swap the buffers over
               log_type = 4;         ! new type for packed strings
               log_in ident = swab(d_stream)
               log_out ident = swab(d_stream+1)
               log_ref = 0
               adda(d_index) = calling
               lc1 = length(called); lc2 = length(calling)
               %if lc1+lc2 > 128-12-3 %start
                  printstring("In Len?
")
                     printstring(calling); newline
                   length(calling) = 0
               %finish
               string(addr(log_address)+1) = called
               string(addr(log_address)+lc1+2) = calling
               length(log_address) = lc1+lc2+2
               %if mon # 0 %start
                  printstring("Incoming call from:"); printstring(calling)
                  printstring(" To "); printstring(called)
                  newline
               %finish
               log_len = 5+2+1+length(log_address)
               kick 2900 message(log)
                mes == map(buff no);    ! map back to it
               mes_str = qual;         ! save qualifiers for reply to connect
               %return
            %finish

            %if reason = get connect buffer %start
               do actual connect(mes)
               %return
            %finish

            !! message to 2900 reason
            !! note: streams 6&7 also use this mechanism
            m2900 == mes
            m2900_stream = d_stream
            m2900_p2a = 0;  m2900_p2b = 0

            type = low level control

            %if reason = send abort %start
               m2900_sub ident = 0
               m2900_p3a = 0
               m2900_p3b = 1
               type = send data
            %finish

            %if connecting reply <= reason <= connecting reply 2 failed  %start
               m2900_sub ident = con sub id reply
               %if reason >= connecting reply failed %then %c
                  m2900_p2b = x'0a00';   ! = swab(10)
               %if reason&1 = 0 %then m2900_stream = m2900_stream+1
               %if reason = connecting reply 2 failed  %and %c
                 d_nc # 99 %then retrieve(d) %else d_nc = 96
            %finish

            %if mon < 0 %start
               select output(1)
               printstring("to 2900, str, subid, p2b, buff:")
               write(m2900_stream, 1); write(m2900_sub ident, 1)
               write(m2900_p2b, 1)
               write(m2900_buff no, 1)
               newline
               select output(0)
            %finish

            to 2900(type, m2900_buff no)
      %end


      %integerfn allocate stream(%record (con desf) %name d)

         !! nb:  allocates two streams, one odd and the other even

         %integer i

         i = fixed-4+d_index<<1
         d_stream = i
         p_c = i;      ! claim the stream
         to 2900(here i am, 0)
         p_c = i+1
         to 2900(here i am, 0)
         %result = i
      %end

      %routine tidy buffers
         free buff no(bpop(d_inp q)) %while %not d_inp q_e == null
         free buff no(d_hold) %unless d_hold = 0
         d_hold = 0
         free buff no(d_holdi) %unless d_holdi = 0
         d_holdi = 0
      %end

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

          !! sever link between 2900 and descriptor   and
          !!  free the descriptor
        
           %if dd_index < 2 %start;   ! illegae
               crunch(4)
           %finish
         tidy buffers
         d_o state = not alloc; d_term = -1
         d_port = 0; d_node = 0;          ! in x25 is disconnect reason
         d_ip busy = 0
         qfrig == d
         qfrig_e == free des
         free des == qfrig
      %end



      %routine do repm(%integer flag)

         !! sends a 'call reply' to gate, nb: assumes p_gate port = port number

         %record (mef) %name mes
         %integer fn

         p_ser = gate ser; p_reply = own id
         %if flag = 0 %then fn = Disconnect %else fn = Accept Call
         p_fn = fn; p_a2 = 0
         p_task port = d_index
         crunch(97) %if d_holdi = 0
         mes == map(d_holdi); d_holdi = 0
         qual = mes_str
         %if qual -> called.("P=256/256").calling %then %c
           d_p256 = 1 %else d_p256 = 0
         mes_len = 0
         pack(mes, snil)
         pack(mes, qual)
         pack(mes, snil)
         p_buff no = mes_buff no
         %if mon < 0 %start
            select output(1)
            printstring("Call reply:"); %if flag = 0 %then printstring %c
              ("Failed") %else printstring("Ok")
            write(p_task port, 1); write(p_gate port, 1); newline
            select output(0)
         %finish
         bh = bh-1
         pon(p)
      %end

      %routine clear all streams

         !! used when emas goes down

         %integer i
         %switch sts(not alloc:closing)

         %cycle i = 2, 1, con lim
            d == con desa(i)
%if mon < 0 %and d_o state # not alloc %start
      who and state; newline
%finish
            ->sts(d_o state)

sts(connect 1):
         p_gate port = d_port
         do repm(0);                    ! reply 'reject' to connect
sts(idle):
sts(Conn Lost):
sts(timing):
            retrieve(d)
            %continue

sts(connected):
sts(enabld):
sts(Wait Ts):
sts(Closing):
            to gate(Disconnect, null, 1)
sts(trying):
            d_o state = Emas Dwn
            %continue


sts(aborted):
sts(Emas Dwn):                   ! must wait for network
sts(not alloc):
         %repeat
         host state = down
      %end


      %routine Block From Amdahl(%record (mef) %name mes)

         %if mon < 0 %start
            select output(1)
            printstring("read from amdahl:"); mon mes(mes)
            newline; select output(0)
         %finish

               ! NB:  there is NO code to handle the default emas-emas situation
               !      this would involve repacking the data & will be considered
               !      at a later date, possibly when large buffers from the 
               !      Amdahl can be used

         %if d_o state # enabld %or mes_len = 0 %start;    ! transfer has been aborted
            free buffer(mes);           ! get rid of the buffer
         %else
            to gate(put output, mes, 0)
            d_nc = d_nc+1
            d_permit = d_permit-1
            %if d_permit > 0 %then get buffer(get op block); ! what if theres no more?
         %finish
      %end

      %routine Process Input(%record (mef) %name mes)

         %record (lev3f) %name lev3
         %integer n, end, gate reply, am1 reply, sym
         %switch data state(0:13)

         am1 reply = 0;          ! "normal" reply

               ! should always go right through the block, are now only
               ! interested in the final state reached before sending
               ! the block to the Amdahl

         lev3 == mes_lev3
         end = mes_len-header len;             !$e
         gate reply = enable input;   ! allow next to gate

         n = 0;           ! always start at beginning
         d_holdi = 0;     ! if it was in use, it isn't now (see Test More Input)

         %cycle

skip:       %if n >= end %then %exit

            sym = lev3_a(n); n = n+1

            %if mon = -1 %start;    ! int = 'N'
               select output(1)
               printstring("di:"); write(d_istate, 1)
               write(n, 1)
               write(d_icount, 1); write(sym, 3)
               space %and printsymbol(sym) %if sym > 32
               newline; select output(0)
            %finish

            ->data state(d_istate)

data state(0):                          ! beginning of record (neg phase)
            d_icount = sym&63
            %if sym&128 # 0 %then d_istate = 2;  ! ie 3 - get 1stchar
            d_istate = d_istate+1
            %if d_icount = 0 %start
               %if d_istate = 3 %then -> kick
               d_istate = 0
            %finish
            -> send it

data state(1):                          ! 1st char of sub/record (neg phase)
data state(3):                          ! 1st char of last record/sub record
            d_first = sym %if d_first = x'ff'
            d_istate = d_istate+1
            -> ds4 %if d_istate = 4

data state(2):                          ! chars in block  (neg phase)
          d_icount = d_icount-1
         %if d_icount = 0 %start
            d_istate = 0
         %finish
         %if d_icount < 0 %start
           printstring("ftps: phase error
")
            -> had it;                    ! temp expedient
         %finish
         -> send it

data state(4):                          ! chars in block  (last block)
ds4:
         d_icount = d_icount-1
         %if d_icount = 0 %start
kick:
            d_o state = connected;      ! wait for new enable before sending
                                        ! the rest of the buffer (if any)
            %if mon < 0 %start
               select output(1); tell; printstring("kick
")
               select output(0)
            %finish
            d_istate = 0
            am1 reply = 1;              ! kick 2900
            %if n >= end %then %exit;   ! block fin, reply to gate
                             ! Can come here if there are two TCCs in the same
                             ! buffer, or a TCC & data together, ie
                             ! GO+ss(0)+code select  etc
            am1 reply = x'8001';      ! tell dx11 NOT to release buffer after partial trf
            d_holdi = mes_buff no;    ! remember the buffer
            d_to go = end-n;          ! and the remaining length
            mes_len = n;              ! send only the first part
            %exit;                    ! rest AFTER new enable
         %finish
         -> send it

!   * * *     Now the states for the Defaut Emas-Emas data transfer
             ! NOT implemented (yet ?)

data state(5):                          ! record/sub record count (default phase)
         crunch(15)
         %if sym = 128 %start;          ! horrible frig for dec-10 (0 len)
            sym = nl;                   ! implant a nl
            -> send it;                 ! expect a record headernext
         %finish

         d_icount = sym&63
         %if d_icount = 0 %start;       ! transfer command
            d_istate = 7
         %finish %else d_istate = d_istate+1
         -> skip;                       ! record count is not part of the data

data state(6):                          ! subsequent data chars  (default phase)
         d_icount = d_icount-1
         %if d_icount = 0 %then d_istate = 5
         -> send it

data state(7):                          ! 1st char of transfer comm (default phase)
         %if sym = es %or sym = qr %or sym = er %then %c
            d_istate = d_istate+2 %and -> send it
         %if sym # ss %and sym # cs %start; ! illegal - halt for now
            printstring("ftps:illegal tcc =")
            write(sym, 1); newline
had it:
            printstring("ptr ="); write(n, 1); printstring(" block =
")
            mon mes(mes)
            -> kick
         %finish
         d_istate = d_istate+1;         ! rubbish - so junk the last byte
         -> skip

data state(8):                          ! skip mode of transfer command
         d_istate = 5
         -> skip

data state(9):                          ! end of transfer (default phase)

         -> kick;                       ! nb: state -> 0 as expect disconnect next


!    * * *   Now the states for the non-default, full Ftp Data transfer * * *

data state(10):                         ! 1st char - length of record/sub/tcc
         %if sym = 0 %start;            ! TCC
            d_istate = 12;              ! get the next 2 chars f tcc
            d_icount = 2;               ! mainly to stop an 'enabling' changing state
            -> send it;                 ! send the first thru
         %finish

         d_icount = sym&63;             ! pickup record length
         %if d_icount # 0 %start;       ! zero-length record is valid
            %if sym&64 # 0 %start;         ! compression
               d_icount = 1;               ! only one to go
            %finish
            d_istate = d_istate+1;         ! go to 'into block' state
         %finish
         -> send it

data state(11):                         ! inside record/sub record
         d_icount = d_icount-1;         ! count it down
         %if d_icount = 0 %then d_istate = 10; ! eor, to length next
         %if d_icount < 0 %then printstring("FTPS:Non-default Phase error
")        %and -> kick
                                        ! on error, give up by kicking 2900
         -> send it

data state(12):                         ! 2nd byte of tcc
         d_istate = d_istate+1;         ! pickup 3rd byte
         d_icount = 1
         -> send it

data state(13):                         ! 3rd and last byte of tcc
         d_icount = 0
         -> kick;                       ! tell 2900

send it:
         %repeat

         mes_kick to go = am1 reply;     ! ie kick ftrans or not
                                         ! CAN send or wouldn't have come here at all
         d_ip busy = 1
         p_c = d_stream
         to 2900(Request Transfer, mes_buff no)
      %end

      %routine Test More Input
         %record (mef) %name mes
         %return %if d_o state # enabld
         %if d_ip busy # 0 %start
            %if mon < 0 %start
               printstring("f:ip busy,stm:"); write(d_stream, 1); newline
            %finish
            p_c = d_stream
            to 2900(Repeat Transfer, 0);  ! do it again
            %return;                      ! and then wait
         %finish

         %if d_holdi # 0 %start;         ! Partial transfer to complete
            mes == map(d_holdi)
            mes_owner = own id; bh = bh+1;  ! mine again
            Move(d_to go, addr(mes)+12+d_to go, addr(mes)+12)
            process Input(mes)
         %else
            %if d_inp q_e ## null %then Process Input(map(bpop(d_inp q)))
         %finish
      %end

      %routine write acknowledge
          ! Confirmation that block has gone to Amdahl
          d_ip busy = 0
          %if d_stream < 10 %start;      ! Control stream
             %if d_o state = enabld %and d_inp q_e ## null %start
                d_ip busy = 1
                p_c = d_stream
                to 2900(Request Transfer, bpop(d_inp q))
             %finish
          %else
             to gate(enable input, null, 1) %if d_holdi = 0
             Test More Input
          %finish
                      ! ack the block to GATE unless its a control stream
      %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 (mef) %name mes)

         %record (maf) %name m
         %integer buff no
         %integer type, strm
         %record (con desf) %name dx
         %switch swd(not alloc:closing)

         %switch hlm(1:4)

         d == d5;                        ! messages on stream 7
         m == mes
         buff no = m_buff no

         d_hold = 0

         type = m_type;                 ! max = 256
         %unless 1 <= type <= 4 %start
            printstring("FTP:Bad Message, type =")
            write(type, 1)
            newline
            -> reply
         %finish

         d_stream = 7;     ! someone is corrupting this !!!!!!
         strm = swab(m_in ident);   ! pick up 'our' reference
         d == con desa((strm-fixed+4)>>1) %unless type = 4

         %if mon < 0 %start
            select output(1)
            printstring("HLM, type,new ind, str")
            write(type, 1); write(d_index, 1); write(d_stream, 1)
            newline
            select output(0)
         %finish

         -> hlm(type)

hlm(1):                             ! Request for Status
         %if d == null %or d == d4 %then m_fail no = 255 %else %c
         m_fail no = d_o state
         -> move it

hlm(2):                                 ! Allocate stream - reply
         -> free it %if d == d4;    ! null !
         Fault(8, Connect 1) %if d_o state < connect 1 %and d_ostate # idle
                                        ! Would like a tighter state check but
                                        ! it isnt possible as the emas-connect
                                        ! can overtake the HLM !
         %if m_ref = 0 %start
            %if mon < 0 %then %c
               tell %and printstring("refused
")
            p_gate port = d_port; do repm(0) %unless d_o state = idle
            retrieve(d)
         %else

            d_ref = m_ref;            ! remember spoolers ref no
         %finish
free it:
         free buff no(buff no); -> reply

hlm(4):                                ! new packed string number
      ! set d_direction = 1 %if an outgoing connection to be made ??
            %if length(m_address) > 73 %or charno(m_address, 1)>63 %start
                                      ! overall length, or length of 1st packed
                                      ! string inside
               %if mon # 0 %then printstring("Length Too Long
")
               -> failed
            %finish

            %if special flag # 0 %then -> failed;   ! special for jh testing
            d == get free des
            %if d == null %start;       ! failed
failed:
                  ! flag it 
                  m_in ident = 0
                  m_out ident = 0
            %else
               i = allocate stream(d);   !  get both streams
      
               d_o state = idle
               adda(d_index) = m_address
               m_in ident = swab(d_stream)
               m_out ident = swab(d_stream+1)
               d_direction = 1
               d_ref = m_ref
            %finish
         -> move it

hlm(3):                                 ! spoolr requests deallocation
         %if d == d4 %start
            printstring("ftps:Spoolr deallocate on an idle strm, =")
            write(strm, 1); newline
            -> move it;                 ! ignore
         %finish
      %if mon < 0 %start
         who and state
         printstring(" deallocated
")
      %finish
      m_in ident = d_term;       ! pass in disconnect reason
      -> swd(d_o state)

swd(not alloc):
      crunch(5)

swd(idle):                              ! ok, so do it
      retrieve(d)
      -> move it

swd(wait ts):
        to gate(Disconnect, null, 39);     ! then fall thru
swd(timing):                            ! its trying to connect
swd(trying):                            ! Call outstanding
swd(Conn Lost):
      d_nc = 0;                         ! ensure sub-state flag is clear
                     ! retrieve the descriptor AFTER the connect reply sent
      %if d_o state = trying %or d_o state = wait ts %start
         d_o state = aborted
         d_nc = 99
                                ! set 'flag' in _nc, so that connecting reply 2
                                !  does not retrieve the descriptor
      %finish %else d_o state = idle
      dx == d;                ! remember who it is
      kick 2900 message(m);       ! sequence changed for benefit of new buff man
      d == dx;                ! and restore it
      get buffer(connecting reply failed)
      get buffer(connecting reply 2 failed)
      -> reply

swd(aborted):
swd(Emas Dwn):
         crunch(6)

swd(connect 1):
         p_gate port = d_port
         do repm(0)
         retrieve(d);                   ! and get the descriptor back
         -> move it

swd(connected):
swd(enabld):
swd(closing):
         ! send failed ( x over )
         who and state; printstring(" Deallocate error 6
")
         m_out ident = 999


move it:
         kick 2900 message(m)
reply:
         d == d5;                                  ! back to message stream
         d_count = d_count+128
         %if d_count-1 = d_mode %then d_count = 0; ! wrap-around at end f buffer
         %if d_count # d_nc %start;                ! more to come
            get buffer(get op block)
         %finish
     %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 mon mes(%record (mef) %name mes)
         %integer i, j, k, n
         %record (lev3f) %name lev3

         k = mes_len;  lev3 == mes_lev3
         write(k, 1); printstring(":  ")
         j = 0
         %cycle i = 0, 1, k-1
               write(lev3_a(i), 1)
               j = j+1;  %if j = 20 %then j = 0 %and newline
         %repeat
         newline;  select output(0)
      %end


%endofprogram