!  File  NMOUSE:IO_F

! FCB interface module for 1976/86 style filestores on 2MHz ether

%option "-low-nocheck-nodiag"
%include "mouse.inc"
%include "2meg.inc"

%ownrecord(ether buffer fm)%name req == nil
%ownbytename b == nil

%routine get buffer(%integer context)
! Acquire a message buffer if we haven't got one already,
! point REQ at it and B at the data part.
%owninteger tag=0
  req == acquire packet buffer %if req==nil
  req_context = context
  tag = tag+1; req_tag = tag
  req_status = 0; req_timeout = 100
  req_ra = 0; req_rp = 0; req_lp = 0
  req_bytes = 0; req_offset = def offset
  b == req_data(req_offset)
%end

%routine put buffer
! Return the ether message buffer we have been using back to
! the system pool, if we haven't done so already.
  %returnif req==nil
  discard packet buffer(req)
  req == nil
  b == nil
%end

%routine show
%integer n
  b == req_data(req_offset)
  space
  phex2(req_context)
  n = req_bytes
  write(n,1); %returnif n<=0
  space
  %while n>0 %cycle
    printsymbol(b); %exitif b=nl; b == b[1]
  %repeat
%end

%routine indirect request(%integer code)
! Send the request message REQ to the filestore multiplexor, and wait
! for the reply.  Point REQ at it (the reply may or may not come in
! the same message buffer) and B at the data part.  Check for errors.
%ownrecord(mailbox fm)%name server==nil,punter
  req_code = code
  %if server==nil %start
    server == lookup mailbox("Filestore_Multiplexor")
    punter == create mailbox("",create semaphore("",0))
  %finish
  req_system part_reply == punter
{{printstring("IndReq -> "); phex2(req_code); show
  send message(req_system part,server)
  req == record(addr(receive message(punter)))
{{printstring("IndReq <- "); phex2(req_status); show
  b == req_data(req_offset)
  %signal 3,5,req_code,ether errors(req_status) %if req_status<0
%end

%routine direct request(%integer code)
! Send the request message REQ to the ether driver, and wait
! for the reply.  Point REQ at it (the reply may or may not come in
! the same message buffer) and B at the data part.  Check for errors.
  req_code = code
{{printstring("DirReq -> "); phex2(req_code); show
  ether request(req)
  req == ether reply
{{printstring("DirReq <- "); phex2(req_status); show
  b == req_data(req_offset)
  %signal 3,5,req_code,ether errors(req_status) %if req_status<0
%end

%systemintegerfnspec stringdiff(%string(255)a,b)

%owninteger fs num = 0
%ownstring(255) -
 file name = "",
 filestore = ""
  
%routine check for error response
! Signal an event if the filestore response begins with a minus sign.
! In this case, the response looks like:
! ['-'],[error code digit],[space],[error message],[NL].
! We use the [space] byte for the length of the error message string.
  %returnunless b='-'
  b[2] = req_bytes-4    {minus, code, space, NL}
  %signal 3,4,b[1]-'0',string(addr(b[2]))
%end

%routine command(%integer com,%string(255)param)
! Send a command to the filestore connected through CONTEXT,
! consisting of command letter COM, reference byte (i.e. user
! or transaction number) REF, the contents of PARAM (usually a
! filename), and NL.  Then read the response, checking for error.
%bytename p == length(param)
  get buffer(fs num)
  b = com; b[1] = '*'; b[1] = '0' %if com='L'; move(p,p[1],b[2])
  b[p+2] = nl; req_bytes = p+3
  indirect request(ether old write read)
  check for error response
%end

%routine parse file name(%string(*)%name in)
! IN is a canonical file name of the form  :F:x:y
! where X is a filestore identifier and Y is the filestore-specific
! part of the file name, the :y may be absent.
! Put X and Y into the global variables FILESTORE and FILENAME.
! Set global variable FS NUM to the filestore's ether address plus
! the protocol type (0/1/2)<<8.
! 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 as follows:
! 0: 1976 style (as used by B and C)
! 1: 1986 style (as used by A and D)
! 2: 1976 without multi-block read capability (as used by Vax)
! Example logical names are  :B==015, :A==114, and :V==272.
%string(255)number
%integer k,p,n
%bytename f
  p = 1
  n = 0
  f == length(number)
  file name = ""
  fs num = 0
  filestore = substring(in,4,length(in))  {take off the ":F:"}
  filename = "" %unless filestore -> filestore.(":").filename
  number = translate logical name(":".filestore)
  %while p<=f %cycle   {read hex number, ignoring possible ':' character
    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  {force error
      %finish
    %finish
    p = p+1
  %repeat
  %if n=0 %or n&16_37f#n %start
    event_message = "Unknown filestore ".filestore
    %signal 3,5,n,event_message
  %finish
  fs num = n
%end

%integerfn gethex
! B points at an HDHEX number.  Return that number as result,
! advancing B past it and its terminator.
%integer n=0,k
  %cycle
    b == b[1]; k = b[-1]-'0'
    %result = n %if k<0
    n = n<<4+k
  %repeat
%end

%integerfn copy out(%bytename dest,%integer max,offset)
! B points at the beginning of a successful filestore response,
! i.e. at the HDHEX length of a data block.  Copy this data block,
! ignoring the first OFFSET bytes, but copy at most MAX bytes.
! Result is number of bytes actually copied.
%integer amount
  amount = gethex-offset
  amount = max %if max<amount
  move(amount,b[offset],dest)
  %result = amount
%end

%routine put(%integer k)
! Put character K into the REQ buffer at B, advancing B and counting K.
  b = k; b == b[1]; req_bytes = req_bytes+1
%end

%routine puthex(%integer n)
! Put HDHEX number N to the buffer
  puthex(n>>4) %and n = n&15 %if n>32; put(n+'0')
%end

%routine tup(%integer k)
! Put character K into REQ *backwards*, used to contruct the
! filestore protocol header on the front of data already in
! the buffer, without having to move the bulk of the data.
  b == b[-1]; b = k; req_bytes = req_bytes+1
%end

%routine xehtup(%integer n)
! Put HDHEX number N into the buffer *backwards*
  tup(n&15) %and n = n>>4 %while n>32
  tup(n+'0')
%end

%routine file read (%record(fcb fm)%name cb,%integer pos,amount,%bytename buf)
! Read arbitrary portion of file described by CB to BUF.
%integer block = pos>>9, last = (pos+amount-1)>>9, offset = pos&511, blocks, i
  %returnif amount<=0
  %signal 9,,,"End of file" %if pos+amount>cb_fl-cb_fs
  %while amount>0 %cycle
    blocks = last-block+1      {number of blocks left to read
    blocks = 16 %if blocks>16  {limit on multi-block read size per go
    blocks = 1 %if cb_b&16_300=16_200 {multi-block reads not supported}
    get buffer(cb_b)
    %if block=cb_d %start      {in sequence: go for multi-block readsq
      put('X'); put(cb_c)
      put(blocks+'0') %if blocks>1
    %else                      {otherwise use single-block random read
      put('R'); put(cb_c); puthex(block)
      blocks = 1
    %finish
    put(nl); direct request(ether old write read)
    %cycle
      check for error response
      block = block+1; cb_d = block
      i = copy out(buf,amount,offset)
      offset = 0
      buf == buf[i]; amount = amount-i
      blocks = blocks-1; %exitif blocks=0
      get buffer(cb_b)
      direct request(ether old read)
    %repeat
  %repeat
%end

%routine file write (%record(fcb fm)%name cb,%integer pos,amount,%bytename buf)
! Write an arbitrary portion of file CB from BUF.  This may involve reading
! from the file where part-blocks are involved.
%integer block = pos>>9, last = (pos+amount-1)>>9, offset = pos&511, i,j,k
  %returnif amount<=0
! Arrange for BLOCK to reach LAST only if the last block of the transfer is
! a part-block which needs to be read.  So if the current transfer involves
! extending the file or if the end of the transfer is block-aligned, force
! LAST to an unreachable value.
  last = last+1 %if pos+amount>=cb_fl-cb_fs %or (pos+amount)&511=0
  %unless offset=0 %start  {Start of transfer is not block-aligned
    get buffer(cb_b)
    put('R'); put(cb_c); puthex(block); put(nl)
    direct request(ether old write read)
    check for error response
    i = gethex       {B now points at start of data
    j = 512-offset   {amount to copy
    j = amount %if amount<j  {transfer fits entirely into first block
    move(j,buf,b[offset])
    i = j+offset     {amount to write back to file (usually 512)
    k = pos-offset+i
    cb_fl = cb_fs+k %if cb_fl<cb_fs+k      {maintain high water mark
    i = cb_fl-pos+offset %if k<cb_fl-cb_fs {can you work out what this does?
    i = 512 %if i>512
    req_bytes = i
    tup(nl); xehtup(i)
    tup(','); xehtup(block)
    tup(cb_c); tup('W')
    req_offset = addr(b)-addr(req_data(def offset))
    req_context = cb_c
    direct request(ether old write read)
    check for error response
    block = block+1; cb_d = block
    pos = pos+j; buf == buf[j]; amount = amount-j
  %finish
  cb_fl = cb_fs+pos+amount %if cb_fl<cb_fs+pos+amount
  %cycle                              {do the straightforward blocks
    %returnif amount=0
    %exitif block=last
    get buffer(cb_b)
    i = 512; i = amount %if amount<i  {last block incomplete
    %if block=cb_d %start             {in sequence
      put('Y'); put(cb_c); put('0')
    %else
      put('W'); put(cb_c); puthex(block)
      put(',')
    %finish
    puthex(i); put(nl)
    move(i,buf,b)
    req_bytes = req_bytes+i
    direct request(ether old write read)
    check for error response
    buf == buf[i]; amount = amount-i
    block = block+1; cb_d = block
  %repeat
  get buffer(cb_b)            {now deal with final part-block
  put('R'); put(cb_c)
  puthex(block); put(nl)
  direct request(ether old write read)
  check for error response
  i = gethex
  move(amount,buf,b)
  tup(nl); xehtup(i)
  tup(cb_c); tup('W')
  req_offset = addr(b)-addr(req_data(def offset))
  req_context = cb_b
  direct request(ether old write read)
  check for error response
  cb_d = -1
%end

%routine refresh input(%record(fcb fm)%name cb)
! get that part of the file containing position CB_P-CB_FS
! into the FCB buffer
%integer pos,amount,delta
  %signal 9,,,"End of file" %if cb_p>=cb_fl
  pos = (cb_p-cb_fs)&-512     {pos of start of relevant block
  amount = cb_fl-cb_fs-pos    {amount left in file
  amount = 512 %if amount>512 {at most the buffer size
  delta = cb_fs+pos-cb_bs     {scroll amount
  cb_fs = cb_fs-delta
  cb_fl = cb_fl-delta
  cb_p = cb_p-delta
  file read(cb,pos,amount,byte(cb_bs))
  cb_l = cb_bl; cb_l = cb_fl %if cb_fl<cb_l
%end

%routine flush output(%record(fcb fm)%name cb,%integer k)
! write the portion from CB_BS to CB_P into the file,
! advance the buffer along the file if appropriate.
  file write(cb,cb_bs-cb_fs,cb_p-cb_bs,byte(cb_bs)) %if cb_bs<cb_p<=cb_bl
  %if cb_p=cb_bl %start
    cb_fs = cb_fs-512
    cb_fl = cb_fl-512
    cb_p = cb_bs
  %finish
  cb_l = cb_bl
  %unless k<0 %start
    byte(cb_p) = k ; cb_p = cb_p+1
  %finish
%end

%routine close(%record(fcbfm)%name cb,%integer com)
%integer i
  i = cb_c; cb_c = '/'
  %if i>='0' %start
    get buffer(cb_b)
    req_code = ether old write read
    b = com; b[1] = i; b[2] = nl; req_bytes = 3
    direct request(ether old write read)
    put buffer
  %finish
  dispose(record(cb_bs)) %unless cb_bs=0
  dispose(cb)
%end

%routine SOP (%record(fcb fm)%name cb,%integer code,p1,p2,%bytename b)
%switch sw(cbopclose:cbopread)
  ->sw(code) %if cbopclose<=code<=cbopread
  %signal 3,4,code,"Illegal FCB operation"
sw(cbopflush):   flushoutput(cb,p1);       %return
sw(cbopwrite):   filewrite(cb,p1,p2,b);    %return
sw(cboprefresh): refreshinput(cb);         %return
sw(cbopread):    fileread(cb,p1,p2,b);     %return
sw(cbopclose):   close(cb,'K');            %return
sw(cbopabort):   close(cb,'H')
%end

%record(fcb fm)%map open(%integer mode,%string(*)%name originalname)
! Open the file specified in global variable FILENAME on the filestore
! specified by FS NUM, in the mode indicated by MODE.  Allocate
! a control block and record the (canonical) name ORIGINALNAME in it,
! allocate a 512-byte buffer.  Record in CB_A/B/C the filestore number,
! the ether context number, and the file transaction number.
! Use CB_D as the next sequential block number.
%record(fcb fm)%name cb
%integer size,com,p

  %routine read owner register  {special for 1976 filestore}
  %integer i

    %routine semipartition(%integer s)
    %integer i

      %routine put(%integer k)
        byte(cb_fl) = k; cb_fl = cb_fl+1
      %end

      get buffer(fs num)
      b = '\'; b[1] = 0; b[2] = s+'0'; b[3] = nl
      req_bytes = 4
      indirect request(ether old write read)
      %returnif b='-'       {too many partitions?}
      i = gethex
      %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
      b == req_data(req_offset)
    %end

    cb_c = '.'
    cb_bs = heapget(8192)
    cb_bl = cb_bs+8192
    cb_fs = cb_bs
    cb_fl = cb_bs
    cb_p = cb_bs
    cb_l = cb_bs
    i = 0
    %cycle
      semipartition(i); i = i+1
    %repeatuntil b='-' %or i=16
    cb_l = cb_fl
  %end

! Main part of OPEN

  %on 3 %start
    %if com='A' %start  {openmod fails: try openout in case file not found
      com = 'T'; ->retry
    %finish
    %signal 3,3,event_extra,event_message
  %finish
  com = 'A'
  com = 'S' %if mode = fopopeni
  com = 'T' %if mode = fopopeno
  cb == newfcb(originalname)
  cb_a = fs num
  cb_b = -1
  %if stringdiff(filename,"LOCAL:")=0 %and fs num&16_300=0 %and com='S' %start
    read owner register
    %result == cb
  %finish
retry:
  command(com,filename)
  cb_b = req_context
  cb_c = b
  cb_bs = heapget(512); cb_bl = cb_bs+512
  size = 0
  %unless com='T' %start
    b == b[1]; b == b[1] %if b=','
    size = gethex<<9
    size = size-gethex
  %finish
  cb_fs = cb_bs; cb_fl = cb_fs+size
  %if com='S' %start
    cb_p = cb_bs; cb_l = cb_bs
  %elseif com='T'
    cb_p = cb_bs; cb_l = cb_bl
  %elseif mode=fopopena
    p = size&-512
    %if p=size %start
      cb_fl = cb_bs; cb_fs = cb_fl-size
      cb_p = cb_bs; cb_l = cb_bl
    %else
      cb_p = cb_fs+p
      refreshinput(cb)
      cb_p = cb_fs+size; cb_l = cb_bl
    %finish
  %else  {mode=fopopenm}
    cb_p = cb_fs
    refreshinput(cb) %unless size=0
    cb_l = cb_bl
  %finish
  %result == cb
%end

%routine logout
  command('M',"")
  define logical name("current_user","")
  define logical name("default_directory","")
%end

%routine login(%string(*)%name p)
%string(255)defdir
%bytename d == length(defdir)
%integer i
  %while filename -> (":").filename %cycle; %repeat {Trailing part only}
  logout %andreturnif filename=""
  command('L',filename.",".p)   {Try to log on}
  filestore = ":F:".filestore
  defdir = filestore.":"
  command('F',"")                 {Establish default dir}
  d = d+copy out(d[d+1],255-d,0)
  i = d
  %while i>0 %cycle
    i = i-1; d = i %if d[i+1]=' '
  %repeat
  d = d-5 %if fs num&16_300=16_200              {Vax: strip off "*.*;*"}
  d = d+1 %and d[d] = ':' %if ':'#d[d]#']'
  define logical name("default_directory",defdir)     {current=default}
  define logical name(".",defdir)
  define logical name("current_filestore",filestore)
  define logical name("current_user",filename)
%end

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

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

%routine credir
%integer c = 'V'
  c = '[' %if fs num&16_300=0
  command(c,filename)
%end

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

%routine finfo(%string(*)%name x)
! (This one is a candidate for getting rid of)
%bytename l == length(x), f == length(filename)
  command('F',filename)
  l = copy out(l[1],255,0)
%end

%routine info(%string(*)%name x)
! Do a NINFO on the file in FILENAME, but if FILENAME ends
! with a ':', then instead do a FINFO 0 on that directory.
%bytename l == length(x), f == length(filename)
%integer c = 'N'
  c = 'F' %and f = f-1 %if f[f]=':'
  command(c,filename)
  l = copy out(l[1],255,0)
%end

%routine rename(%string(*)%name f2)
%integer old fs num = fs num
%string(255)oldfilename = filename
  parse filename(f2)
  %signal 3,4,0,"Cannot rename across filestores" %unless old fsnum = fs num
  %if fs num&16_300=0 %start
    %while filename -> (":").filename %cycle; %repeat
  %finish
  command('B',oldfilename.",".filename)
%end

%routine copy(%string(*)%name f2)
%integer source num = fs num
%string(255)sourcefilename = filename
  parse filename(f2)
  %signal 3,4,0,"Cannot copy across filestores" %unless source num = fs num
  command('O',sourcefilename.",".filename)
%end

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

%routine stamp(%string(*)%name d)
  command('C',filename.",".d)
%end

%routine time(%string(*)%name d)
%bytename l == length(d)
  command('G',"")
  l = copy out(l[1],255,0)
%end

%routine special(%string(*)%name s)
! S typically begins with '[' or '^' or ']' for special
! commands NEWOWNER, NEWQUOTA, or CONTROL.  S does not contain
! a user number digit, that is supplied automatically.
! In the case of CONTROL commands, the control code immediately
! follows the ']'.
%integer code = charno(s,1)
  s = substring(s,2,length(s))
  command(code,s)
%end

%externalrecord(fcbfm)%map FOP %alias "FOP_F" -
  (%integer code,%string(*)%name file,%name x)
%switch sw(foplogout:fopoldfinfo)
%record(fcbfm)%name cb == nil
%integer fpc,spc
  parse filename(file)
  ->sw(code) %if foplogout <= code <= foptime
  %signal 3,4,code,"Unsupported file operation"
sw(foplogout):   logout;      ->end
sw(foplogin):    login(x);    ->end
sw(fopquote):    quote(x);    ->end
sw(foppass):     pass(x);     ->end
sw(fopcredir):   credir;      ->end
sw(fopdelete):   delete;      ->end
sw(fopinfo):     info(x);     ->end
sw(foprename):   rename(x);   ->end
sw(fopcopy):     copy(x);     ->end
sw(foppermit):   permit(x);   ->end
sw(fopstamp):    stamp(x);    ->end
sw(foptime):     time(x);     ->end
sw(fopspecial):  special(x);  ->end
sw(fopoldfinfo): finfo(x);    ->end
sw(fopopeni):
sw(fopopeno):
sw(fopopenm):
sw(fopopena):    cb == open(code,file)
  *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_pc = spc
  cb_gla = a4
end: %result == cb
%end