!  File  MOUSE:IO_F

! Device interface module for remote filestores
! using 1976/1986-style "old" protocol on 2MHz ether.

%option "-low-nocheck-nodiag"
%include "io.inc"

%systemroutinespec move(%integer bytes,%name from,to)
%externalintegerfnspec EtherAllocatePort
%externalroutinespec EtherOpenPort  (%integer Port,RemoteStation,RemotePort)
%externalroutinespec EtherTransmitBlock (%integer Port,Bytes,%name Buffer)
%externalroutinespec EtherReceiveBlock  (%integer Port,MaxBytes, -
    %integername Bytes,%Name Buffer)
%externalroutinespec EtherClosePort (%integer Port)
%externalroutinespec EtherFreePort  (%integer Port)

%externalstring(255)%fnspec translate logical name(%string(255)s)

%recordformat fsid fm (%byte port,dte,remoteport,logintoken,protocol)
%recordformat fsid list fm (%record(fsid list fm)%name next,%record(fsid fm)id)
%ownrecord(fsid list fm)%name connection list == nil

%ownstring(255) first file name = "", file name = "", file store = ""
%ownrecord(fsid fm)%name first fsid == nil, fsid == nil
%ownstring(255) packet = ""
  
{nasty back-compat stuff}
@16_35c4 %short userno
@16_3fa9 %byte lsap,rdte,rsap

%routine check for error(%bytename b,%integer s)

! Signal an event if the filestore response starting at B,
! of size S, begins with a minus sign.

%string(255)message
%bytename m
%integer code
  %returnunless b='-'
  m == length(message); m = 0
  code = b[1]-'0'; b == b[3]  
  s = s-4    {minus, code, space, NL}
  %while s>0 %and m<255 %cycle
    s = s-1; m = m+1; m[m] = b; b == b[1]
  %repeat
  %signal 3,4,code,message
%end

%routine fcomm(%integer command,%string(255)param)

! Send a command to the filestore identified by FSID,
! using the login token (user number) in FSID, and read the
! response into global string PACKET.  Used only for "simple"
! commands, i.e. those involving a single line there and back,
! no data blocks (except shorties like datetime and finfo).

%bytename p == length(param)
%integer len
  param = "xx".param
  p[1] = command
  p[2] = fsid_logintoken
  p = p+1; p[p] = nl
  ether transmit block(fsid_port,p,p[1])
  p == length(packet)
  ether receive block(fsid_port,255,len,p[1])
  p = len
  check for error(p[1],len)
%end

%routine connect to filestore(%integer fs)

! Search the list of known connections to filestore FS, and point
! global FSID at it.  If none exists, establish one, allocating a
! port for the purpose as well and adding a cell to the connection list.

%bytename p == length(packet)
%integer state=0,port,remoteport,i
%record(fsid list fm)%name cell

  %on 3 %start   {ether error}
    ether close port(port) %if state>1
    ether free port(port) %if state>0
    event_message = "Cannot connect to filestore ".filestore." ".event_message
    %signal 3,5,event_extra,event_message
  %finish

! Search connection list

  cell == connection list
  %while cell##nil %cycle
    %if cell_id_dte=fs %start
      fsid == cell_id
      lsap = fsid_port; userno = fsid_logintoken-'0'
      rsap = fsid_remote port; rdte = fs
      %return
    %finish
    cell == cell_next
  %repeat

! None found.  Grab a port and send connect request.

  port = ether allocate port; state = 1
  ether open port(port,fs,0); state = 2
  p = 1; p[1] = 2
  ether transmit block(port,p,p[1])
  ether receive block(port,255,i,p[1])
  p = i; p = p-1 %if p[p]=nl
  %signal 3,5,0,packet %unless p=1 %and p[1]>'0'
  remoteport = p[1]-'0'

! Open the connection

  ether close port(port); state = 1
  ether open port(port,fs,remoteport); state = 2

! Check out the connection (suppress possible duplicate first packets)

  p = 3; p[1] = 'M'; p[2] = '0'; p[3] = nl
  ether transmit block(port,p,p[1])
  ether receive block(port,255,i,p[1])
  p = 3; p[1] = 'G'; p[2] = '0'; p[3] = nl
  ether transmit block(port,p,p[1])
  ether receive block(port,255,i,p[1]) %until p[1]#'-'

! Record connection in list

  cell == new(cell); make global(cell); cell = 0; fsid == cell_id
  fsid_dte = fs; fsid_remoteport = remoteport
  fsid_port = port; fsid_logintoken = '0'
  cell_next == connection list; connection list == cell
  lsap = port; userno = 0
  rsap = remote port; rdte = fs
%end

%routine disconnect from filestore

! Break connection to filestore and remove cell from list.

%record(fsid list fm)%name cell,next
%bytename p == length(packet)
  p = 1; p[1] = 4
  ether transmit block(fsid_port,p,p[1])
  ether close port(fsid_port)
  ether free port(fsid_port)
  cell == connection list
  %if fsid==cell_id %start {first one: easy}
    connection list == cell_next
    dispose(cell)
    %return
  %finish
  %cycle   {scan list for cell to remove}
    next == cell_next
    %returnif next==nil  {should not happen}
    %if next_id==fsid %start
      cell_next == next_next; dispose(next)
      %return
    %finish
    cell == next
  %repeat
%end

%routine parse file name(%string(*)%name in)

! IN is a canonical file name of the form  :E:x:y
! where X is a filestore identifier and Y is the filestore-specific
! part of the file name, the :y may be absent.
! Scan IN and put Y into global variable FILE NAME (shifting its
! contents across to FIRST FILE NAME), and use X to identify the
! filestore concerned.
! Place into global variable FSID (shifting its contents into FIRST FSID)
! details of the connection identified, which will be established if necessary.
! Logical names are used to deduce filestore address and protocol variant
! from filestore name.  To distinguish these logical names from ordinary
! ones, they start with a colon.  Protocol variants are 0 and 1 for the
! 1976 and 1986 versions, respectively, e.g.:  ":B" == "015";  ":A" == "114".
! Protocol variant 2 is equivalent to 0 and denotes an inability to support
! multi-block reads (Vax brown box).

%bytename i,f,o
%integer p,n,k
  first file name = file name; file name = ""
  first fsid == fsid; fsid == nil
  i == length(in); p = 4  {past ":E:"}
  filestore = ":"         {build :X}
  f == length(filestore)
  %while p<=i %and i[p]#':' %cycle
    f = f+1; f[f] = i[p]; p = p+1
  %repeat
  p = p+1 %if p<=i %and i[p]=':'
  o == length(file name)  {build Y}
  %while p<=i %cycle
    o = o+1; o[o] = i[p]; p = p+1
  %repeat
  filestore = translate logical name(filestore)
  p = 1
  n = 0      {parse hex number, ignoring possible ':' character
  %while p<=f %cycle
    k = f[p]&127-'0'
    %if 0<=k<=9 %start
      n = n<<4+k
    %elseunless k=':'-'0'
      k = (k+'0')&95
      %if 'A'<=k<='F' %start
        n = n<<4-'A'+k+10
      %else
        n = -1; p = f
      %finish
    %finish
    p = p+1
  %repeat
  n = byte(16_3faa) %if n=0      {default established by rom bootstrap}
  %if n=0 %or n&16_37f#n %start
    event_message = "Unknown filestore ".filestore
    %signal 3,5,n,event_message
  %finish
  connect to filestore(n&127)
  fsid_protocol = n>>8
%end

%constinteger lbsize=9, bsize=1<<lbsize    {512 byte buffers}

%routine block write (%record(scbfm)%name cb,%integer pos,size,%bytename buf)

! Write one or more file blocks starting at a block boundary.
! CB contains details of the file, in particular CB_B and CB_C are port and xno.
! POS is the byte offset within the file.
! SIZE is usually, but not necessarily, a multiple of the block size,
!   but if not, it should be at the end of the file.
! BUF is where the data are to come from.
! We copy them into an auxiliary buffer in order to stick on the protocol.

%bytearray auxbuf(1:bsize+10)
%bytename b == auxbuf(1)
%integer i
  pos = pos>>lbsize              {convert to block number}
  %while size>0 %cycle
    i = size; i = bsize %if i>bsize
    %if pos=cb_d %start
      b = 'Y'
      b[1] = cb_c
      b[2] = i>>4+'0'
      b[3] = i&15+'0'
      b[4] = nl
      move(i,buf,b[5])
      ether transmit block(cb_b,i+5,b)
    %else
      cb_d = pos
      b = 'W'
      b[1] = cb_c
      b[2] = pos>>12+'0'
      b[3] = pos>>8&15+'0'
      b[4] = pos>>4&15+'0'
      b[5] = pos&15+'0'
      b[6] = ','
      b[7] = i>>4+'0'
      b[8] = i&15+'0'
      b[9] = nl
      move(i,buf,b[10])
      ether transmit block(cb_b,i+10,b)
    %finish
    size = size-i; buf == buf[i]; pos = pos+1
    ether receive block (cb_b, 255, i, b[1])
    check for error(b[1],i)
    cb_d = cb_d+1
  %repeat
%end

%routine block read (%record(scbfm)%name cb,%integer pos,size,%bytename buf)

! Read one or more file blocks starting at a block boundary.
! CB contains details of the file, in particular CB_B and CB_C are port and xno.
! POS is the offset within the file and is block-aligned.
! SIZE is the amount to be read, not necessarily a multiple of the block size.
! BUF is where the data are to go.
! The first block is read using random addressing, subsequent blocks use
! sequential addressing, with multi-block reads if appropriate.

%string(7)s
%bytename b == length(s)
%integer i,before,blocks

  %routine get block

! Read one response block (possibly of several), for multi-block reads
! this routine is called repeatedly.
! Advance global position BUF and decrement bytes-to-go counter SIZE.
! We EXPECT (but do not require) that the response takes the form
! <two-digit-length><NL><data>, and we attempt to maximise the likelihood
! of the data arriving at an even byte boundary to make the copying go faster.

  %bytearray auxbuf(1:bsize+10)
  %bytename b == auxbuf(2)
  %integer i,l
    ether receive block (cb_b, bsize+9, i, b)
    check for error(b,i)
    cb_d = cb_d+1
    l = 0
    %while b>='0' %cycle
      l = l<<4+b-'0'; i = i-1; b == b[1]
    %repeat
    b == b[1]; i = i-1   {for NL}
    i = l %if l<i        {?inconsistent length?}
    i = size %if size<i
    move(i,b,buf)
    buf == buf[i]; size = size-i
  %end

  %returnunless size>0
  %signal 9,,,"End of file" %if pos+size>cb_fl-cb_fs
  fsid == record(cb_a)
  pos = pos>>lbsize
  %if pos=cb_d %start
    b = 'X'
    b[1] = cb_c
    b[2] = nl
    i = 3
  %else
    cb_d = pos
    b = 'R'
    b[1] = cb_c
    b[2] = pos>>12+'0'
    b[3] = pos>>8&15+'0'
    b[4] = pos>>4&15+'0'
    b[5] = pos&15+'0'
    b[6] = nl
    i = 7
  %finish
  ether transmit block (cb_b, i, b)
  before = size
  get block
  %while size>0 %cycle
    %if before-size<bsize %start
      cb_fl = cb_fs+pos; %return
    %finish
    blocks = (size+bsize-1)>>lbsize; blocks = 16 %if blocks>16
    blocks = 1 %if fsid_protocol=2
    b = 'X'
    b[1] = cb_c
    %if blocks=1 %start
      b[2] = nl; i = 3
    %else
      b[2] = blocks+'0'
      b[3] = nl
      i = 4
    %finish
    ether transmit block (cb_b, i, b)
    %cycle
      before = size
      get block
      blocks = blocks-1
    %repeatuntil blocks=0 %or before-size<bsize
  %repeatuntil size=0
%end

%routine read input(%record(scbfm)%name cb,%integer pos,amount,%bytename buf)

! Read arbitrary portion of file.

%bytearray auxbuf(1:bsize)
%integer auxpos,auxamount
  %returnunless amount>0
  %if cb_c='0' %start {special file}
    %signal 9 %unless 0<=pos %and pos+amount<=cb_fl-cb_fs
    move(amount,byte(cb_fs+pos),buf)
    %return
  %finish
  auxpos = pos&\(bsize-1)
  %unless auxpos=pos %start  {beginning not block-aligned}
    auxamount = pos-auxpos+amount; auxamount = bsize %if auxamount>bsize
    block read(cb,auxpos,auxamount,auxbuf(1))
    auxamount = auxpos+bsize-pos; auxamount = amount %if auxamount>amount
    move(auxamount,auxbuf(pos-auxpos+1),buf)
    pos = pos+auxamount; buf == buf[auxamount]; amount = amount-auxamount
  %finish
  block read(cb,pos,amount,buf)
%end

%routine write output(%record(scbfm)%name cb,%integer pos,amount,%bytename buf)

! Write arbitrary portion of file, which may involve reading part-blocks.

%bytearray auxbuf(1:bsize)
%integer auxpos, auxamount, limit = cb_fl-cb_fs
  %returnunless amount>0
  auxpos = pos&\(bsize-1)
  %if pos#auxpos %start  {beginning not block-aligned}

! Read block containing beginning.  Rest of file if less than block size.

    auxamount = limit-auxpos; auxamount = bsize %if auxamount>bsize
    block read(cb,auxpos,auxamount,auxbuf(1))

! Copy part-block at beginning into appropriate part of aux buffer.

    auxamount = auxpos+bsize-pos
    auxamount = amount %if amount<auxamount
    move(auxamount,buf,auxbuf(pos-auxpos+1))

! Write back block containing beginning, adjusting high water mark if needed.

    auxamount = auxamount+pos-auxpos
    block write(cb,auxpos,auxamount,auxbuf(1))
    %if auxpos+auxamount>limit %start
      limit = auxpos+auxamount
      cb_fl = cb_fs+limit
    %finish
    amount = amount-auxamount
    %returnunless amount>0
    pos = pos+auxamount
    buf == buf[auxamount]
  %finish

! Write any whole blocks inbetween (or last block)

  %while amount>=bsize %or (amount>0 %and pos+amount+cb_fs>=cb_fl) %cycle
    block write(cb,pos,bsize,buf)
    pos = pos+amount; amount = amount-bsize; buf == buf[bsize]
    cb_fl = cb_fs+pos %if cb_fs+pos>cb_fl
  %repeat

! Now write the last part-block (not at end of file)

  %returnunless amount>0
  auxamount = cb_fl-cb_fs-pos
  auxamount = bsize %if auxamount>bsize
  block read(cb,pos,auxamount,auxbuf(1))
  move(amount,buf,auxbuf(1))
  block write(cb,pos,auxamount,auxbuf(1))
%end

%routine refresh input (%record(scbfm)%name cb)

! Fill the buffer associated with the CB.
! CB_P-CB_FS is the position in the file that is to be contained
! in the buffer, and we adjust CB_FS and CB_FL accordingly such that
! CB_BS-CB_FS is a multiple of the block size.

%integer pos = cb_p-cb_fs, offset = pos&(bsize-1),
         delta = pos-offset-(cb_bs-cb_fs), amount = bsize
  %signal 9,,,"End of file" %if cb_p>=cb_fl
  cb_l = cb_fl %andreturnif cb_c='0' {special file}
  cb_fs = cb_fs-delta
  cb_fl = cb_fl-delta
  cb_p = cb_p-delta
  amount = cb_fl-cb_bs %if cb_fl-cb_bs<bsize
  %signal 9,,amount,"End of file reached" %if amount<0
  block read(cb,pos-offset,amount,byte(cb_bs))
  cb_l = cb_bs+amount
%end

%routine flush output (%record(scbfm)%name cb,%integer k)

! Write that part of the buffer which lies between CB_BS and CB_P
! to the file, at position CB_BS-CB_FS.  Adjust high water mark if needed.
! Advance buffer along file if CB_P has reached CB_BL.

  %unless cb_p=cb_bs %start
    cb_fl = cb_p %if cb_p>cb_fl
    block write(cb,cb_bs-cb_fs,cb_p-cb_bs,byte(cb_bs))
    %if cb_p=cb_bl %start
      cb_fs = cb_fs-bsize
      cb_fl = cb_fl-bsize
      cb_p = cb_bs
    %finish
    cb_l = cb_bl
  %finish
  %unless k<0 %start
    byte(cb_p) = k; cb_p = cb_p+1
  %finish
%end

%constinteger normal='K',abnormal='H'

%routine close(%record(scbfm)%name cb,%integer com)
%bytename b == length(packet)
%integer i
  i = cb_c; cb_c = '0'
  %unless i='0' %start
    b = 3; b[1] = com; b[2] = i; b[3] = nl
    ether transmit block(cb_b,b,b[1])
    ether receive block(cb_b,255,i,b[1])
    check for error(b[1],i)
  %finish
  dispose(record(cb_bs)) %unless cb_bs=0
  dispose(cb)
%end

%routine SOP (%record(scb fm)%name cb,%integer code,p1,p2,%bytename b)
%switch sw(sopclose:sopread)
  ->sw(code) %if sopclose<=code<=sopread
  %signal 3,4,code,"Illegal SCB operation"
sw(sopflush):   flushoutput(cb,p1);       %return
sw(sopwrite):   writeoutput(cb,p1,p2,b);  %return
sw(soprefresh): refreshinput(cb);         %return
sw(sopread):    readinput(cb,p1,p2,b);    %return
sw(sopclose):   close(cb,normal);         %return
sw(sopabort):   close(cb,abnormal)
%end

%routine logout
  %if fsid_logintoken#'0' %start
    fcomm('M',"")
    fsid_logintoken = '0'
    userno = 0
  %else
    disconnect from filestore
  %finish
%end

%routine login(%string(*)%name p)
  logout %unless fsid_logintoken='0'
  fcomm('L',filename.",".p)
  fsid_logintoken = charno(packet,1)
  userno = fsid_logintoken-'0'
%end

%routine quote(%string(*)%name p)
  fcomm('Q',p)
%end

%routine pass(%string(*)%name p)
  fcomm('P',p)
%end

%integerfn gethex(%bytename b,%integername p)

! B is typically the length byte of some string.
! P is the position in that string at which a HDHEX number starts.
! Return it as result, advancing P past it and the terminator.

%integer n=0,k
  %cycle
    p = p+1; k = b[p-1]-'0'
    %result = n %if k<0
    n = n<<4+k
  %repeat
%end

%record(scb fm)%map open(%integer com,%string(*)%name originalname)

! Open the file specified in global variable FILENAME on the filestore
! connection specified by FSID, in the mode indicated by COM.  Allocate
! a control block and record the (canonical) name ORIGINALNAME in it,
! allocate a 512-byte buffer.  Record in CB_A/B/C the address of the FSID
! record being used, the ethernet port number, the file transaction number.
! Use CB_D as the next sequential block number.

%record(scb fm)%name cb
%bytename r
%integer p

  %routine read owner register  {special for 1976 filestore}
  %integer i
    %routine put(%integer k)
      byte(cb_l) = k; cb_l = cb_l+1; cb_fl = cb_l
    %end
    %routine semipartition(%integer s)
    %bytearray buf(1:bsize+10)
    %bytename b == buf(1)
    %integer i,l=0
      b = 4; b[1] = '\'; b[2] = fsid_logintoken; b[3] = s+'0'; b[4] = nl
      ether transmit block(fsid_port,b,b[1])
      ether receive block(fsid_port,bsize+10,i,b)
      %returnif b='-'       {too many partitions?}
      %while b>='0' %cycle  {skip length indicator}
        l = l<<4+b-'0'; b == b[1]; i = i-1
      %repeat
      b == b[1]; i = i-1    {skip NL}
      i = l %if l<i         {?inconsistent length?}
      %while i>0 %cycle
        %if b>' ' %start    {within a directory name}
          put(b); b == b[1]; i = i-1
        %else               {between names: scan to next one}
          put(':'); put(nl)
          %cycle
            b == b[1]; i = i-1
          %repeatuntil i<=0 %or b>' '
        %finish
      %repeat
    %end
    cb == newscb(originalname)
    cb_a = addr(fsid)
    cb_b = fsid_port
    cb_c = '0'
    cb_bs = heapget(8192); make global(record(cb_bs))
    cb_bl = cb_bs+8192
    cb_fs = cb_bs
    cb_fl = cb_bs
    cb_p = cb_bs
    cb_l = cb_bs
    semipartition(i) %for i = 0,1,15
    cb_l = cb_fl
  %end

! Main part of OPEN

  %on 3 %start
    %signal 3,3,event_extra,event_message
  %finish
  %if filename="LOCAL:" %and fsid_protocol=0 %and com='S' %start
    read owner register
    %result == cb
  %finish
  fcomm(com,filename)
  cb == newscb(originalname)
  cb_a = addr(fsid)
  cb_b = fsid_port
  cb_c = charno(packet,1)
  cb_d = 0
  cb_bs = heapget(bsize); make global(record(cb_bs)); cb_bl = cb_bs+bsize
  cb_p = cb_bs; cb_l = cb_bl; cb_fs = cb_bs; cb_fl = cb_fs
  %unless com='T' %start
    cb_l = cb_p
    r == length(packet); p = 2; p = 3 %if r[p]=','
    cb_fl = gethex(r,p)<<9; cb_fl = cb_fl-gethex(r,p)+cb_fs
  %finish
  %result == cb
%end

%routine credir
%integer c = 'V'
  c = '[' %if fsid_protocol=0
  fcomm(c,filename)
%end

%routine delete
  fcomm('D',filename)
%end

%routine info(%string(*)%name x)
%bytename r == length(packet), l == length(x), f == length(filename)
%integer p = 1, c = 'N'
  c = 'F' %and f = f-1 %if f[f]=':'
  fcomm(c,filename)
  l = gethex(r,p)
  move(l,r[p],l[1])
%end

%routine rename(%string(*)%name f2)
  parse filename(f2)
  %signal 3,4,0,"Cannot rename across filestores" %unless first fsid==fsid
  %if fsid_protocol=0 %start
    %while filename -> (":").filename %cycle; %repeat
  %finish
  fcomm('B',first filename.",".filename)
%end

%routine copy(%string(*)%name f2)
  parse filename(f2)
  %signal 3,4,0,"Cannot copy across filestores" %unless first fsid==fsid
  fcomm('O',first filename.",".filename)
%end

%routine permit(%string(*)%name p)
  fcomm('E',filename.",".p)
%end

%routine stamp(%string(*)%name d)
  fcomm('C',filename.",".d) %if fsid_protocol=0
%end

%routine time(%string(*)%name d)
%bytename r == length(packet), l == length(d)
%integer p = 1
  fcomm('G',"")
  l = gethex(r,p)
  move(l,r[p],l[1])
%end

%routine special(%record(fs)%name r)
  r_sendbuf[1] = fsid_logintoken %if r_sendbuf[1]<='0'
  ether transmit block(fsid_port,r_send,r_sendbuf)
  ether receive block(fsid_port,r_recmax,r_rec,r_recbuf)
  check for error(r_recbuf,r_rec)
%end

%routine oldfinfo(%string(*)%name x)
%bytename r == length(packet), l == length(x), f == length(filename)
%integer p = 1
  fcomm('F',filename)
  l = gethex(r,p)
  move(l,r[p],l[1])
%end

%externalrecord(scbfm)%map FOP %alias "FOP_F" -
  (%integer code,%string(*)%name file,%name x)
%switch sw(foplogout:fopoldfinfo)
%record(scbfm)%name cb == nil
%integer fpc,spc
  parse filename(file)
  ->sw(code) %if foplogout <= code <= fopoldfinfo
  %signal 3,4,code,"Unsupported file operation"
sw(foplogout): logout;      %result == nil
sw(foplogin):  login(x);    %result == nil
sw(fopquote):  quote(x);    %result == nil
sw(foppass):   pass(x);     %result == nil
sw(fopopeni):  cb == open('S',file); ->opened
sw(fopopeno):  cb == open('T',file); ->opened
sw(fopopenm):  cb == open('A',file); ->opened
sw(fopopena):  %signal 3,3,0,"Append mode not supported"
sw(fopcredir): credir;      %result == nil
sw(fopdelete): delete;      %result == nil
sw(fopinfo):   info(x);     %result == nil
sw(foprename): rename(x);   %result == nil
sw(fopcopy):   copy(x);     %result == nil
sw(foppermit): permit(x);   %result == nil
sw(fopstamp):  stamp(x);    %result == nil
sw(foptime):   time(x);     %result == nil
sw(fopspecial):special(x);  %result == nil
sw(fopoldfinfo):oldfinfo(x);%result == nil
opened:
  *lea sop,a0; *move.l a0,spc
  %if code=fopopeni %start
    *lea refresh input, a0; *move.l a0,fpc
  %else
    *lea flush output,a0; *move.l a0,fpc
  %finish
  cb_fastpc = fpc
  cb_soppc = spc
  cb_gla = a4
  %result == cb
%end