!  File  NMOUSE:2MEGP

! 2MHz Ether process for "new" Mouse, RWT Aug 1988,
! adapted from GDMR's version for "interim" Mouse, Dec 1987....

%option "-nons-low-nocheck-nodiag-noline"
%option "-nolist"
%include "mouse.inc"
%include "2meg.inc"
%begin

! This handler runs the station in "raw" mode.  It speaks the "standard"
! protocol (type 01/81), providing a port-like interface, and in addition
! allows the use of other protocol-types (for IP, ARP and the like).

{L{ %include "GDMR_H:Lights.Inc"
{L{ %constinteger lights type           = 16_80
{L{ %constinteger lights sending        = 16_40
{L{ %constinteger lights outbound       = 16_20
{L{ %constinteger lights old outbound   = 16_10
{L{ %constinteger lights old reTX       = 16_04 {16_08
{L{ %constinteger lights inbound        = 16_20
{L{ %constinteger lights old inbound    = 16_10
{L{ %constinteger lights clear          = 16_F8

%ownrecord(interrupt handler fm) interrupt handler = 0  {* First %own ! *} 

%constinteger ether packet size = 768-14;  ! Excludes header

%constinteger RX buffers            = 16;  ! 2^n ??
%constinteger reTX lives            = 6
%constinteger old protocol slots    = 48
%constinteger first station         = 16_10
%constinteger last station          = 16_7F
%constinteger last registered       = 16

%constinteger overall size = 14000
%constinteger  subpro size = 2000

! Ether station definitions

@16_7FFFC %readonly %volatile %byte status %or %writeonly %byte command
@16_7FFFD %byte data, *, control

%constinteger DTX = 16_30
%constinteger RDY = 16_10
%constinteger STX = 16_20
%constinteger ETX = 16_0B
%constinteger ACK = 16_C0
%constinteger ESA = 16_05
%constinteger SSA = 16_07
%constinteger RAW = 16_02

%constinteger int bit = 7, int mask = 1 << int bit
%constinteger rst bit = 6, rst mask = 1 << rst bit
%constinteger td  bit = 3, td  mask = 1 << td  bit
%constinteger rd  bit = 2, rd  mask = 1 << rd  bit
%constinteger rc  bit = 1, rc  mask = 1 << rc  bit
%constinteger rcd bit = 0, rcd mask = 1 << rcd bit

%constinteger interrupt level = 4
! SR values:
%constinteger interrupts off  = interrupt level<<8
%constinteger interrupts on   = 0
%constinteger supervisor mode = 16_2000

! Statistics

%ownrecord(ether stats fm)stats

%routine inc(%integername x)
  x = x+1
%end

%routine disaster(%string(255)which)
%integer i
   i = or to SR(16_700)
   newline; printstring("Unexpected event in 2MHz ";which;" handler:")
   newline; printstring(poa_message)
   write(poa_event, 1; poa_sub, 1);  space;  phex(poa_extra)
   printstring(" near PC ");  phex(poa_event PC)
   newline
   %for i = 0, 1, 15 %cycle
      phex(poa_event regs(i));  space
      newline %if i & 7 = 7
   %repeat
   semaphore wait(nil)
%end

! Buffer pool management

! We use a common format for request messages and ether buffers.
! However, we keep a pool of buffers to be filled by the receive
! interrupt handler.  The process which first fields incoming
! packets either puts them straight back into the receive pool
! (when it doesn't know what else to do with them), or it sends
! them on to the user (if there were pending read requests), in
! which case the read request buffer gets put back into the pool,
! or (when there are no read requests pending, but are likely to
! materialise "soon") the packet is saved in a pending queue. In
! this case the receive pool is replenished by a fresh buffer
! from the system pool.  Correspondingly, when read requests are
! satisfied by pending packets, the packets are sent to the user
! and the requests are returned to the system pool.

%recordformat ether header fm(%byte ds, dp, %integer dz,
                              %byte ss, sp, %integer sz,
                              %byte type, seq)

%constinteger old data type = 16_01
%constinteger old ACK  type = 16_81

%ownrecord(queue fm)RX buffer pool
%ownrecord(queue fm)inbound queue
%ownrecord(semaphore fm)%name inbound packet arrived == nil
%owninteger buffers remaining   { for information only }

%routine to RX pool(%record(ether buffer fm)%name buffer)
   move to SR(interrupts off)
      %if buffers remaining < stats_buffer low water -
      %then stats_buffer low water = buffers remaining
      buffers remaining = buffers remaining + 1
      enqueue(buffer_system part_header,RX buffer pool)
   move to SR(interrupts on)
%end

%record(ether buffer fm)%map from RX pool
! Careful: this one is called by the interrupt handler
%record(ether buffer fm)%name b
   b == dequeue(RX buffer pool)
   %unless b == nil %start
      b_offset = def offset
      buffers remaining = buffers remaining-1
   %finish
   %result == b
%end

%record(ether buffer fm)%map from system pool
%record(*)%name b
   b == acquire message buffer
   %result == b
%end

%routine to system pool(%record(ether buffer fm)%name buffer)
   return message buffer(buffer_system part)
%end

%routine setup RX buffer pool
%integer i
   setup queue(inbound queue)
   setup queue(RX buffer pool)
   buffers remaining = 0
   to RX pool(from system pool) %for i = 1, 1, RX buffers
   buffers remaining = RX buffers
   stats = 0
   stats_buffer low water = RX buffers
%end

%routine complete request(%record(ether buffer fm)%name r,%integer status)
  r_status = status
  send message(r_system part,r_system part_reply)
%end

%routine complete read request(%record(ether buffer fm)%name packet,request)
%record(ether header fm)%name header
   header == record(addr(packet_data(packet_offset-14)))
   packet_ra = header_ss;  packet_rp = header_sp
   packet_la = header_ds;  packet_lp = header_dp
   packet_type = header_type
   packet_code = request_code
   packet_tag = request_tag
   packet_context = request_context
   packet_system part_reply == request_system part_reply
   complete request(packet,ether success)
%end

%ownbytename TX buffer == nil
%owninteger TX bytes = 0
%ownrecord(semaphore fm)%name TX done == nil

%routine put data char(%registerinteger x)
  %cycle; %repeatuntil status&td mask#0
  data = x
%end

%routine put control char(%registerinteger x)
  %cycle; %repeatuntil status&td mask#0
  control = x
%end

%routine put control pair(%registerinteger x)
  put control char(x)
  x = 0; put data char(x)
%end

%routine skip data char
  %cycle; %repeatuntil status&rd mask#0
  d0 = data
%end

! Interrupt handler

%routine setup station handler
   %owninteger pending DTX = -1
   %ownrecord(ether buffer fm)%name RX buffer == nil
   %label interrupt

   interrupt handler_pc = addr(interrupt)
   add interrupt handler(interrupt level)
   move to SR(supervisor mode)
      command = rst mask;          ! Ints off, reset the station
      command = 0;                 ! Ints still off, un-reset
      put control char(RAW)
      put control char(ESA)
      command = rc mask ! rd mask; ! Enable receive interrupts
   move to SR(interrupts on)
   %cycle
      %returnunless stats_this station = 0
   %repeat

interrupt:

%register(a1)%bytename b
   *temp d0-d1/a0-a1

! The interupt handler proper.  We enable interrupts for received data
! and control characters (cleared by reading the appropriate register).
! The following may be received:
!     DTX: something has arrived from the wire
!     STX: the packet we asked for is coming up next
!     ETX: our packet has just finished (this won't cause an interrupt
!          as we're in a busy-wait loop at the time reading the packet)
!     RDY: the station is ready for our (TX) packet
!     ACK: can be ignored!
!     SSA: the station address is coming up next.
! Since we're in "raw" mode the "port" part of these will always be zero.
! Note, however, that it will be present and must be explicitly handled.
! If it's anything we don't recognise we log it and ignore it.  We have
! reasonable control over the receipt of everything except DTX, which
! is driven by packets arriving off the wire.  Since we're only geared
! up to handle one receive buffer at a time we tally the "extra" DTXs
! for future processing.
!
! Note: data is transferred in a busy-wait loop in the interrupt handler.
! This should result in less overhead than interrupt-per-character would.
! Any data interrupts are assumed to be caused by the station misbehaving:
! the character is read (to clear the condition) and thrown away.

! First off, read the status register to see if the interrupt was for us.
! If it wasn't we just return; if it was we fetch the control character
! (or read and throw away the data character).

   d0 = status
   return from interrupt %if d0&int mask=0  {station not interrupting =>}
   %if d0&rc mask=0 %start       {not control (i.e. data) char: discard}
     d1 = data
{}   rompstr("2MHz: spurious  "); romphex2(d1); rompsym(nl)
     return from interrupt
   %finish

! Next, read the control character and act upon it.

   d1 = control
   -> DTX arrived %if d1=dtx
   -> STX arrived %if d1=stx
   -> RDY arrived %if d1=rdy
   -> ACK arrived %if d1=ack
   -> SSA arrived %if d1=ssa
{} rompstr("2MHz: spurious ^"); romphex2(d1); rompsym(nl)
   inc(stats_unrecognised control)
   return from interrupt

DTX arrived:

! A packet has arrived in the station.
! Claim a buffer, ready to be filled with the packet when
! we ask for it by sending a RDY.
! If no buffer is available, tell the station to throw
! the packet away by sending an ACK.
! When DTX's pile up we simply count them - we only ask for
! one packet at a time.

   skip data char                { throw away port byte
   pending DTX = pending DTX+1   { Bump pending tally
   %if pending DTX#0 %start      { One pending already
      inc(stats_pended DTX)      { Tally it
      return from interrupt      { Must wait meantime
   %finish
   RX buffer == from RX pool
   %if RX buffer == nil %start   { No buffers left
      put control pair(ACK)
   %else
      put control pair(RDY)
   %finish
   return from interrupt

STX arrived:

! The STX has arrived.  Data frame will be arriving next.
! Read it in and tally it.  When the ETX arrives put the buffer on
! the arrived queue and signal the inbound handler's semaphore.

   skip data char
   b == rx buffer_data(rx buffer_offset)  { Start of data part
   D1 = -14                        { Header offset and initial byte count
   %cycle
      %exitif status&rcmask#0      { Control ->
      %continueif status&rdmask=0  { No data yet
      b[d1] = data                 { Read the character
      d1 = d1+1                    { Bump tally
   %repeat                         { Round for the next one
   RX buffer_bytes = d1            { Note packet size
   d0 = control                    { Must have been the ETX??
   enqueue(RX buffer_system part_header,inbound queue) { Link us in
   int signal semaphore(inbound packet arrived)
   pending DTX = pending DTX-1     { Note packet has been done
%option "-nott"
   %if pending DTX<0 %start        { No more packets waiting in station
      RX buffer == nil
   %else
      RX buffer == from RX pool
      %if RX buffer == nil %start
        inc(stats_packets dropped)
        put control pair(ACK)      { ask station to throw it away
      %else
        put control pair(RDY)      { ask station to let us have it
      %finish
   %finish
   return from interrupt

RDY arrived:

! This must have been in response to our DTX.  The TX buffer address
! and length will already have been set up, so all we have to do is
! hand it on to the station, bracketed by STX/ETX.  Since we're in raw
! mode the packet must be at least 14 bytes long, so we don't have to
! worry about dealing with awkward empty ones....

   skip data char
   put control pair(STX)
   d0 = TX bytes-1      { Number of bytes to send (adjusted for DBRA)
   b == TX buffer       { First byte to go
txloop:
      %cycle; %repeatuntil status&tdmask#0
      *move.b (B)+, data
   *dbra D0, txloop
   put control char(ETX)
   int signal semaphore(TX done)
   return from interrupt

ACK arrived:

! This is just in to keep the host/station protocol the same for raw
! mode as it is for cooked mode.  We just read the port byte and
! ignore it all....

   skip data char
   return from interrupt

SSA arrived:

! The next data character will be the station address

   %cycle; %repeatuntil status&rdmask#0
   stats_this station = data
   return from interrupt

   *nop {?!}
%end

! Inbound packet handler

%recordformat icb fm(%integer active,
                     %record(queue fm)pending packets, pending reads)

%ownrecord(icb fm)%array icbs(2 : last registered) = 0(*)
%ownrecord(semaphore fm)%name icb semaphore == nil

%routinespec old inbound handler(%record(ether buffer fm)%name buffer)

%routine inbound handler
%record(ether buffer fm)%name buffer
%record(ether header fm)%name header
%record(icb fm)%name icb
%record(ether buffer fm)%name rr
   %on 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 %start
      disaster("inbound")
   %finish
{{ printstring("Inbound handler: ");  write(free store, 0);  newline
   %cycle
      %cycle
{L{      lights and B(\ lights inbound)
         semaphore wait(inbound packet arrived)
{L{      lights or B(lights inbound)
         move to SR(interrupts off)
            buffer == dequeue(inbound queue)
         move to SR(interrupts on)
         %exitif buffer_bytes < 0                 {"runt"} -
             %or buffer_bytes > ether packet size {or outsize packet}
         stats_inbound bytes = stats_inbound bytes + buffer_bytes
         inc(stats_inbound packets)
         header == record(addr(buffer_data(buffer_offset-14)))
         %if 0 # header_ds # stats_this station %start
            ! Not for us
            to RX pool(buffer)
            inc(stats_dud destinations)
         %else %if header_type = old data type %c
               %or header_type = old ACK type
            ! Hand the buffer to the old protocol handler.  Let it
            ! free the buffer when it's finished
            old inbound handler(buffer)
         %else %if 2 <= header_type <= last registered
            semaphore wait(icb semaphore)
            icb == icbs(header_type)
            signal semaphore(icb semaphore) %andexitif icb_active = 0
            rr == dequeue(icb_pending reads)
            %if rr == nil %start
               ! Nothing waiting, so put it on the end of the list
               ! and replenish the pool with a new buffer
               enqueue(buffer_system part_header,icb_pending packets)
               to RX pool(from system pool)
            %else
               ! There's a read request already waiting, so complete it
               complete read request(buffer, rr)
               to RX pool(rr)
            %finish
            signal semaphore(icb semaphore)
         %finishelseexit
      %repeat
      to RX pool(buffer)
      inc(stats_dud types)
   %repeat
%end

! Outbound packet handler

%ownrecord(semaphore fm)%name outbound semaphore == nil

%routine outbound packet handler(%record(ether header fm)%name header,
                                 %record(ether buffer fm)%name buffer)
{L{lights or A(lights outbound)
   inc(stats_outbound packets)
   ! Grab semaphore, set up parameters for the transfer
   semaphore wait(outbound semaphore)
   %if buffer == nil %start  {Header-only transfer (as in ACK)}
      TX buffer == header_ds
      TX bytes = 14
   %else
      TX buffer == buffer_data(buffer_offset-14)
      move(14,header,TX buffer)
      TX bytes = buffer_bytes+14
      stats_outbound bytes = stats_outbound bytes+buffer_bytes
   %finish
   ! Kick the station
{L{lights or A(lights sending)
   move to SR(interrupts off ! supervisor mode)
      put control pair(DTX)
   move to SR(interrupts on)
   semaphore wait(TX done)
{L{lights and A(\lights sending)
   signal semaphore(outbound semaphore)
{L{lights and A(\ lights outbound)
%end

! Old-style protocol handler.

! Protocol control blocks are accessed in one of two ways: from the user side
! they are accessed directly by indexing into the table, while from the ether
! side they are accessed indirectly via a table of chained blocks, one slot 
! for each remote address.  "Port 0" is slightly special-cased to set up the
! destination station and port and to register the existence of a recipient.
! Mostly it is just the same as the VC ports.

%recordformat old protocol fm(%record(old protocol fm)%name next,
                              %record(ether header fm) header,
                              %integer reTX lives, next reTX, reTX interval,
                              %integer last seq, last address,
                              %record(queue fm) pending packets,
                                                pending reads, pending writes)

%ownrecord(old protocol fm)%array opcb(0 : old protocol slots) = 0(*)
%ownrecord(old protocol fm)%namearray opsl(first station - 1 : last station) == nil(*)

%ownrecord(semaphore fm)%name old protocol semaphore == nil

%owninteger timestamp = 0

%record(old protocol fm)%map find inbound opcb(%record(ether header fm)%name h)
%record(old protocol fm)%name p
   %result == nil %unless first station <= h_ss <= last station
   p == opsl(h_ss)
   %while p ## nil %cycle
      ! Do source/destination ports match?  Source address for each
      ! pcb is implied by the list it's on.
      %result == p %if p_header_dp = h_sp %and p_header_sp = h_dp
      p == p_next
   %repeat
   %result == nil
%end

%routine do old write(%record(old protocol fm)%name p, %integer setup)
%record(ether buffer fm)%name r
{L{lights or A(lights old outbound)
   %if setup # 0 %start
      p_reTX lives = reTX lives
      p_reTX interval = 1
      p_next reTX = timestamp + 3
   %finish
   r == p_pending writes_forward
   %if p == opcb(0) %start
      ! Port 0, copy in ds and dp
      p_header_ds = r_ra
      p_header_dp = r_rp
   %finish
   outbound packet handler(p_header,r)
   inc(stats_old outbound packets)
{L{lights and A(\ lights old outbound)
%end

%routine old inbound handler(%record(ether buffer fm)%name buffer)
%ownrecord(ether header fm) ACK = 0
%record(ether buffer fm)%name req
%record(ether header fm)%name header
%record(old protocol fm)%name p
   %on 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 %start
      disaster("old inbound")
   %finish
{L{lights or B(lights old inbound)
   header == record(addr(buffer_data(buffer_offset-14)))
   ->ignore broadcast %if header_ds = 0
   semaphore wait(old protocol semaphore)
   %if header_dp = 0 %then p == opsl(first station - 1) %c
                     %else p == find inbound opcb(header)
   %if p ## nil %start
      ! Connection is known.  Is this inbound data or an ACK for
      ! something we've sent?
      %if header_type = old data type %start
         ! Data packet has arrived
         inc(stats_old inbound packets)
         ! First ACK the packet.
         !ACK = 0
         %unless header_ss = stats_this station %start
            ACK_ss = stats_this station;  ! Filled in by station anyway...
            ACK_sp = header_dp
            ACK_ds = header_ss
            ACK_dp = header_sp
            ACK_type = old ACK type
            ACK_seq = header_seq
            outbound packet handler(ACK, nil)
         %finish
         ! Now if this packet's sequence number is new then we forward
         ! the data to the user or queue the buffer if there isn't
         ! a pending read.
         %if header_seq # p_last seq %c
               %or header_ss # p_last address %start
            p_last seq = header_seq
            p_last address = header_ss
            req == dequeue(p_pending reads)
            %if req == nil %start
               ! No user-request waiting, so put this on the pending queue
               ! and replenish the pool.
               enqueue(buffer_system part_header,p_pending packets)
               to RX pool(from system pool)
            %else
               ! There's a user request waiting, so complete it,
               ! and then grab a new buffer to return to the pool.
               complete read request(buffer, req)
               to RX pool(req)
            %finish
            signal semaphore(old protocol semaphore)
{L{         lights and B(\ lights old inbound)
            %return
         %finish
      %else %if header_type = old ACK type
         ! ACK packet has arrived
         %if header_seq = p_header_seq %c
               %and header_ss = p_header_ds %start
            ! It's an ACK for the last thing we sent.  First bump our
            ! send sequence number (avoiding 0, as cooked stations
            ! treat it as special).
            p_header_seq = (p_header_seq + 1) & 255
            p_header_seq = 1 %if p_header_seq = 0
            ! Now complete the first request on the pending write
            ! queue.
            req == dequeue(p_pending writes)
            %if req ## nil %start
               %if req_code = ether old write read %start
                  req_timeout = timestamp + req_timeout + 3 %if req_timeout>0
                  %if queue empty(p_pending packets) %start
                     enqueue(req_system part_header,p_pending reads)
                  %else
                     to system pool(buffer)
                     buffer == dequeue(p_pending packets)
                     complete read request(buffer,req)
                     buffer == req
                  %finish
               %else
                  complete request(req,ether success)
               %finish
               %unless queue empty(p_pending writes) %start;  ! Kick next
                  do old write(p, 1)
               %finish
            %finish {else spurious ack}
         %finish {else unexpected ack}
      %finish {else something bogus on queue}
   %else
      ! Else ignore it
      inc(stats_old inbound no takers)
   %finish
   signal semaphore(old protocol semaphore)
ignore broadcast:
   to RX pool(buffer)
{L{lights and B(\ lights old inbound)
%end
         
%routine old ether request(%record(ether buffer fm)%name m)
%record(old protocol fm)%name p, q
%record(ether buffer fm)%name pw
%record(ether buffer fm)%name RX buffer
%integer i, j

   %routine unlink pcb
      i = p_header_ds
      %if first station <= i <= last station %start
         %if opsl(i) == p %start
            ! We're the first on the chain
            opsl(i) == p_next
         %else
            ! We're not first in the chain, so follow it down...
            q == opsl(i)
            q == q_next %while q_next ## nil %and q_next ## p
            %if q == nil %start
               printstring("Slow PCB ");  write(m_context, 0)
               printstring(" not in chain for ");  phex2(i)
               newline
            %else
               q_next == p_next
            %finish
         %finish
      %elseunless i=0
         printstring("Dud ether address ");  phex2(i)
         printstring(" in slow PCB ");  write(m_context, 0)
         newline
      %finish
   %end

   %routine clobber pcb
      ! First off, get rid of any pending RX buffers.
      %cycle
         RX buffer == dequeue(p_pending packets)
         %exitif RX buffer == nil
         to system pool(RX buffer)
      %repeat
      ! Pending read and write requests next...  Complete these
      ! in the order in which they were queued, in case it matters
      ! to the caller.
      %cycle
         pw == dequeue(p_pending reads)
         %exitif pw == nil
         complete request(pw,ether operation aborted)
      %repeat
      %cycle
         pw == dequeue(p_pending writes)
         %exitif pw == nil
         complete request(pw,ether operation aborted)
      %repeat
   %end

   %if m_code = ether old define %start
      inc(stats_old defines)
      %if m_ra < first station -
      %or m_ra > last station  -
      %or m_ra = stats_this station %start
         complete request(m,ether dud destination)
      %else
         semaphore wait(old protocol semaphore)
         m_context = 0
         %for i = 1, 1, old protocol slots %cycle
            p == opcb(i)
            m_context = i %and %exit %if p_header_type = 0
         %repeat
         %if m_context = 0 %start   {all slots used up}
            complete request(m,ether no free slots)
         %else
            p = 0
            ! Build set of local port numbers in use
            j = 0
            q == opsl(m_ra)
            %while q ## nil %cycle
               j = j ! (1 << q_header_sp)
               q == q_next
            %repeat
            ! Find the lowest free local port
            m_lp = 0
            %for i = 1, 1, 31 %cycle
               %if j & (1 << i) = 0 %start
                  ! Found one free
                  p_header_sp = i
                  m_lp = i
                  %exit
               %finish
            %repeat
            %if m_lp = 0 %start     {no port number left}
               p = 0
               complete request(m,ether no free slots)
            %else
               p_next == opsl(m_ra); opsl(m_ra) == p
               p_header_ss = stats_this station
               p_header_ds = m_ra
               p_header_dp = m_rp
               p_header_type = old data type
               p_header_seq = (system elapsed time // 10)&255
               p_last seq = -1
               complete request(m,ether success)
            %finish
         %finish
         signal semaphore(old protocol semaphore)
      %finish
   %else %if m_code = ether old redefine
      inc(stats_old redefines)
      %unless 0 < m_context <= old protocol slots %start
         complete request(m,ether dud context)
      %else
         p == opcb(m_context)
         %if p_header_type = 0 %start
            complete request(m,ether dud context)
         %else
            ! Change the port number of our peer.
            ! Reset our send and receive sequence numbers.
            semaphore wait(old protocol semaphore)
            clobber pcb
            p_header_dp = m_rp
            p_header_seq = (system elapsed time // 10)&255 
            p_last seq = -1
            signal semaphore(old protocol semaphore)
            complete request(m,ether success)
         %finish
      %finish
   %else %if m_code = ether old undefine
      inc(stats_old undefines)
      %unless 0 < m_context <= old protocol slots %start
         complete request(m,ether dud context)
      %else
         p == opcb(m_context)
         %if p_header_type = 0 %start
            complete request(m,ether dud context)
         %else
            semaphore wait(old protocol semaphore)
            clobber pcb
            unlink pcb
            p = 0
            signal semaphore(old protocol semaphore)
            complete request(m,ether success)
         %finish
      %finish
   %else %if m_code = ether old read
      inc(stats_old reads)
      m_timeout = m_timeout + timestamp %if m_timeout > 0
      %unless 0 <= m_context <= old protocol slots %start
         complete request(m,ether dud context)
      %else
         p == opcb(m_context)
         %if p_header_type = 0 %start
            complete request(m,ether dud context)
         %else
            ! There are two possible cases here: either there is a
            ! packet waiting for someone to read it, or there are
            ! no packets waiting and instead a queue of (zero or more)
            ! read requests waiting.
            semaphore wait(old protocol semaphore)
            RX buffer == dequeue(p_pending packets)
            %if RX buffer == nil %start
               ! No pending packets.  Enqueue our read on the end of
               ! the wait queue.
               enqueue(m_system part_header,p_pending reads)
            %else
               ! A packet awaits a reader.  By implication, there
               ! will be no read requests pending.....
               complete read request(RX buffer, m)
               to system pool(m)
            %finish
            signal semaphore(old protocol semaphore)
            %return
         %finish
      %finish
   %else %if m_code = ether old write %or m_code = ether old write read
      inc(stats_old writes)
      %unless 0 <= m_context <= old protocol slots %start
         complete request(m,ether dud context)
      %else %unless 0 < m_bytes <= ether packet size -
      %and min offset <= m_offset -
      %and m_offset+m_bytes <= max offset+1
         complete request(m,ether operation undefined)
      %else
         p == opcb(m_context)
         %if p_header_type = 0 %start
            complete request(m,ether dud context)
         %else
            semaphore wait(old protocol semaphore)
            %if m_code = ether old write read %start
               %unless queue empty(p_pending writes) -
               %and queue empty(p_pending reads) %start
                  signal semaphore(old protocol semaphore)
                  complete request(m,ether dud context)
                  %return
               %finish
               %whilenot queue empty(p_pending packets) %cycle
                  inc(stats_pendings discarded)
                  to system pool(dequeue(p_pending packets))
               %repeat
            %finish
            j = 1; j = 0 %if queue empty(p_pending writes)
            enqueue(m_system part_header,p_pending writes)
            do old write(p, 1) %if j = 0   {Kick if this is the only one}
            signal semaphore(old protocol semaphore)
            ! Inbound process will complete it...
         %finish
      %finish
   %else %if m_code = ether old register0
      inc(stats_old defines)
      %if opsl(first station - 1) == nil %start
         ! Not yet defined
         semaphore wait(old protocol semaphore)
         p == opcb(0)
         p = 0
         p_header_ss = stats_this station
         p_header_type = old data type
         p_header_seq = (system elapsed time // 10)&255
         p_header_seq = 1 %if p_header_seq = 0;  ! Avoid 0!!
         p_last seq = -1
         ! ds & dp filled in on per-TX basis
         opsl(first station - 1) == p
         signal semaphore(old protocol semaphore)
         complete request(m,ether success)
      %else
         ! Already registered
         complete request(m,ether operation undefined)
      %finish
   %else %if m_code = ether old unregister0
      inc(stats_old undefines)
      semaphore wait(old protocol semaphore)
      %if opsl(first station - 1) == nil %start
         complete request(m,ether operation undefined)
      %else
         opsl(first station - 1) == nil
         p == opcb(0)
         clobber pcb
         p = 0
         complete request(m,ether success)
      %finish
      signal semaphore(old protocol semaphore)
   %else
      complete request(m,ether operation undefined)
   %finish
%end

%routine timeout handler
%ownrecord(semaphore fm)%name clock semaphore
%record(old protocol fm)%name p
%record(ether buffer fm)%name r, head
%integer i
   %on 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 %start
      disaster("timeout")
   %finish
   clock semaphore == create semaphore("",0)
{{ printstring("Timeout handler: ");  write(free store, 0);  newline
   submit regular timer request(clock semaphore,0,100)
   %cycle
      semaphore wait(clock semaphore)
      timestamp = timestamp+1
      semaphore wait(clock semaphore)
      timestamp = timestamp+1
{{printstring("Tick")
      ! Each time we are wakened we scan the pcb table looking for
      ! user timeouts and retransmit timeouts expiring.
      semaphore wait(old protocol semaphore)
      %for i = 0, 1, old protocol slots %cycle
         p == opcb(i)
         %if P_header_type # 0 %start
            ! In use.  First retransmit any pending write requests.
            %if (%not queue empty(p_pending writes)) -
                 %and p_next reTX <= timestamp %start
               ! First pending write's timeout has expired.
               p_reTX lives = p_reTX lives - 1
               %if p_reTX lives <= 0 %start
                  ! Not ACKed, return an error to user.
                  inc(stats_old ACK timeouts)
                  r == dequeue(p_pending writes);  ! Unlink it
                  complete request(r,ether write timeout)
                  ! Transmit the next on the queue, if any
                  ! for all the good it'll do...
                  do old write(p, 1) %unless queue empty(p_pending writes)
               %else
                  inc(stats_old retransmits)
                  p_reTX interval = p_reTX interval << 1
                  p_next reTX = timestamp + p_reTX interval
{L{          !    lights or A(lights old reTX)
                  do old write(p, 0)
{L{          !    lights and A(\ lights old reTX)
               %finish
            %finish
            ! Now check for expired read timeouts.
            ! Cycle through the whole list taking each request off
            ! the front and putting it back on the end unless we
            ! send it back to the user.
            head == nil;   !remember which request was at the front
            %cycle
               r == dequeue(p_pending reads)
               %exitif r == head  {back round to front (or empty)}
               head == r %if head == nil  {establish front}
               %if 0 < r_timeout <= timestamp %start
                  ! This one's specified timeout has expired.
                  ! Send back an error message
                  inc(stats_old user timeouts)
                  head == nil %if head == r  {if this was front, zap}
                  complete request(r,ether read timeout)
               %else
                  ! No timeout specified, or not expired yet.
                  enqueue(r_system part_header,p_pending reads)
               %finish
            %repeat
            %unless r == nil %start  {put front back on front}
               requeue(r_system part_header,p_pending reads)
            %finish
         %finish
      %repeat
      opcb(0)_last seq = -1 %if timestamp & 63 = 0;  ! Nasty frig for cooked stations
      signal semaphore(old protocol semaphore)
   %repeat
%end

! General protocol handler

%routine ether request(%record(ether buffer fm)%name m)
%record(ether buffer fm)%name RX
%record(ether buffer fm)%name r
%record(icb fm)%name icb
%record(ether header fm) header
   %unless 2 <= m_type <= last registered %start
      complete request(m,ether dud context)
   %finish
   icb == icbs(m_type)
   %if m_code = ether read %start
      %if icb_active = 0 %start
         complete request(m,ether dud context)
         %return
      %finish
      semaphore wait(icb semaphore)
      RX == dequeue(icb_pending packets)
      %if RX == nil %start
         ! Nothing waiting, we'll have to queue
         enqueue(m_system part_header,icb_pending reads)
      %else
         ! Take the first pending packet
         complete read request(RX, m)
         to system pool(m)
      %finish
      signal semaphore(icb semaphore)
   %else %if m_code = ether write
      %if icb_active = 0 %start
         complete request(m,ether dud context)
         %return
      %finish
      %unless 0 < m_bytes <= ether packet size -
      %and min offset <= m_offset -
      %and m_offset+m_bytes <= max offset+1 %start
         complete request(m,ether operation undefined)
         %return
      %finish
      header_ds = m_ra
      header_dp = 255
      header_dz = 0
      header_ss = stats_this station
      header_sp = 255
      header_sz = 0
      header_type = m_type
      header_seq = 255
      %if m_ra = stats_this station %start  {Loopback}
         move(14,header,m_data(m_offset-14))
         move to SR(interrupts off)
            r == from RX pool
         move to SR(interrupts on)
         complete request(m,ether success) %if r == nil
         r_code = m_code
         r_tag = m_tag
         r_context = m_context
         r_system part_reply == m_system part_reply
         move to SR(interrupts off)
            enqueue(m_system part_header,inbound queue)
         move to SR(interrupts on)
         signal semaphore(inbound packet arrived)
         complete request(r,ether success)
      %else
         outbound packet handler(header, m)
         complete request(m,ether success)
      %finish
   %else %if m_code = ether register
      %if icb_active # 0 %start
         complete request(m,ether dud context)
         %return
      %finish
      icb_active = 1
      complete request(m,ether success)
   %else %if m_code = ether unregister
      %if icb_active = 0 %start
         complete request(m,ether dud context)
         %return
      %finish
      semaphore wait(icb semaphore)
      ! Release all pending packets
      %cycle
         RX == dequeue(icb_pending packets)
         %exitif RX == nil
         to RX pool(RX)
      %repeat
      ! Return any pending read requests in the order they were queued
      %cycle
         r == dequeue(icb_pending reads)
         %exitif r == nil
         complete request(r,ether operation aborted)
      %repeat
      ! Mark inactive and release the icb
      icb_active = 0
      signal semaphore(icb semaphore)
      ! Finally send the request back with a success code
      complete request(m,ether success)
   %else
      complete request(m,ether operation undefined)
   %finish
%end

! Main program -- fields user requests

%record(process fm)%name p
%record(mailbox fm)%name mailbox == nil
%record(ether buffer fm)%name m
%label start inbound, start timeout
   %on 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 %start
      disaster("request")
   %finish
   mailbox                == create mailbox(ether mailbox name,
                             create semaphore("",0))
   become process(overall size)
   inbound packet arrived == create semaphore("",0)
   TX done                == create semaphore("",0)
   icb semaphore          == create semaphore("",1)
   old protocol semaphore == create semaphore("",1)
   outbound semaphore     == create semaphore("",1)
   setup RX buffer pool
   setup station handler
   p == create subprocess(subprosize, addr(start inbound),"Inbound")
   p == create subprocess(subprosize, addr(start timeout),"Timeout")
{{rompstr("2MHz ether address: "); romphex2(stats_this station); rompsym(nl)
{L{lights and B(\ lights clear)
{L{lights and A(\ lights clear)
   %cycle
      m == record(addr(receive message(mailbox)))
      %if m_code & ether old operation # 0 %start
{L{      lights or B(lights type)
         old ether request(m)
{L{      lights and B(\ lights type)
      %else %if m_code & ether operation # 0
{L{      lights or A(lights type)
         ether request(m)
{L{      lights and A(\ lights type)
      %else %if m_code = ether stats
         m_offset = def offset
         move(sizeof(stats),stats,m_data(def offset))
         complete request(m,ether success)
      %else %if m_code = ether station
         m_context = stats_this station
         complete request(m,ether success)
      %else
         complete request(m,ether operation undefined)
      %finish
   %repeat

start inbound:  inbound handler
start timeout:  timeout handler

%end %of %program