! New dictionary package (name manager)

! This module manages process-local tables for both logical names
! and command symbols.  There is also a global mode, in which 
! requests are passed to another process for handling there.

! The tables themselves are linear linked lists hung off
! a hash table.  Each entry is a pair of heap strings.
! Although nothing is sorted, procedures are available
! for scanning the whole table "in order", so that every
! entry is visited.  To guarantee the proper operation of
! this scanning scheme, no entries should be added or
! removed during the scan.

%option "-nons-nodiag"
%include "nmouse.inc"
%systemintegerfnspec stringdiff(%string(255)s,t)

%constinteger hashmax=31  {2^n-1}
%recordformat entry fm(%record(entry fm)%name next,
                       %string(*)%name key,info)
%recordformat table fm(%record(entry fm)%namearray list(0:hashmax))

%integerfn hash(%string(*)%name s)
%bytename b==length(s)
%integer i=b,n=0
  %cycle
    %exitif i=0
    n = (n>>4&1+n<<1) {5 bit field rotated left 1} !! b[i]
    i = i-1
  %repeat
  %result = n&hashmax
%end

%record(entry fm)%map find(%string(*)%name key,%record(entry fm)%name e)
! Locate the cell containing KEY in the list E, NIL if not there.
  %cycle
    %exitif e==nil %or stringdiff(e_key,key)=0
    e == e_next
  %repeat
  %result == e
%end

%routine define(%string(255)%name key,info,%record(table fm)%name table)
! Add an entry for (KEY,INFO) into TABLE.
! Or, if INFO="", delete entry for (KEY,*) from TABLE.
%integer h
%record(entry fm)%name l,e
  h = hash(key)
  l == table_list(h)
  e == find(key,l)
  %if e==nil %start   {Not there - add a new cell}
    %returnif info="" {unless request was to delete}
    e == new(e); e_next == l
    e_key == newstring(key); e_info == newstring(info)
    table_list(h) == e
  %elseif info=""     {it's there and we want to get rid of it}
    dispose(e_info); dispose(e_key)
    %if e==l %then table_list(h) == e_next %elsestart
      l == l_next %while l_next##e
      l_next == e_next
      dispose(e)
    %finish
  %elseunless e_info=info  {it's there and we want to change it}
    dispose(e_info); e_info == newstring(info)
  %finish
%end

%predicate translated(%string(255)%name key,info,%record(table fm)%name table)
! If (KEY,*) is in TABLE, copy * into INFO and return TRUE.
! Otherwise leave INFO unchanged and return FALSE.
%integer h
%record(entry fm)%name e
  h = hash(key)
  e == find(key,table_list(h))
  info = e_info %andtrueunless e==nil
  %false
%end

%routine next(%string(*)%name key,info,%record(table fm)%name table)
! If (KEY,*) is in TABLE, return in (KEY,INFO) whatever is in the
! next entry in the table.  Otherwise, or if there are no more entries,
! return ("","").  If KEY="" to start with, return the first entry.
%integer h
%record(entry fm)%name e
  %if key="" %start
    h = 0; e == nil
  %else
    h = hash(key); e == find(key,table_list(h))
  %finish
  e == e_next %unless e==nil       {next entry on same list, if any}
  %unless e==nil %start            {yes, there it is}
    key = e_key; info = e_info
    %return
  %finish
  %while h<hashmax %cycle
    h = h+1; e == table_list(h)    {onto next list}
    %unless e==nil %start          {first element}
      key = e_key; info = e_info
      %return
    %finish
  %repeat
  key = ""; info = ""              {no more}
%end

%ownrecord(table fm)%name -
  logical name table == nil,
  command symbol table == nil

! User interface starts here
! NB Case standardisation is the responsibiliy of the caller

%externalroutine define local logical name(%string(255)key,info)
%record(table fm)%name l == logical name table
  %if l==nil %start
    l == new(l)
    l = 0
    logical name table == l
  %finish
  define(key,info,l)
%end

%externalroutine define local command symbol(%string(255)key,info)
%record(table fm)%name c == command symbol table
  %if c==nil %start
    c == new(c); c = 0; command symbol table == c
  %finish
  define(key,info,c)
%end

%externalpredicate translated local logical name(%string(*)%name s)
  %falseif logical name table==nil
  %trueif translated(s,s,logical name table)
  %false
%end

%externalpredicate translated local command symbol(%string(*)%name s)
  %falseif command symbol table==nil
  %trueif translated(s,s,command symbol table)
  %false
%end

%externalroutine next local logical name(%string(*)%name key,info)
  %if logical name table==nil %start
    key = ""; info = ""
  %else
    next(key,info,logical name table)
  %finish
%end

%externalroutine next local command symbol(%string(*)%name key,info)
  %if command symbol table==nil %start
    key = ""; info = ""
  %else
    next(key,info,command symbol table)
  %finish
%end

%conststring mbx name = "Name manager"
%ownrecord(mailbox fm)%name -
  name manager requests == nil,
  name manager replies
%recordformat f(%integer op,%string(255)key,info)

%routine call name manager(%integername op,%string(*)%name key,info)
! Passes a request to the name manager process and waits for reply
%record(message fm)%name me
%record(f)%name r
  me == get message buffer
  r == record(addr(me_data))
  r_op = op; r_key = key; r_info = info
  %if name manager requests==nil %start
    name manager requests == lookup mailbox(mbx name)
    name manager replies == create mailbox("",create semaphore("",0))
  %finish
  me_reply == name manager replies
  send message(me,name manager requests)
  me == receive message(name manager replies)
  r == record(addr(me_data))
  key = r_key; info = r_info; op = r_op
  put message buffer(me)
%end

%externalroutine define global logical name(%string(255)key,info)
%integer n=1
  call name manager(n,key,info)
%end

%externalroutine define global command symbol(%string(255)key,info)
%integer n=2
  call name manager(n,key,info)
%end

%externalpredicate translated global logical name(%string(*)%name s)
%integer n=3
  call name manager(n,s,s)
  %trueunless n=0; %false
%end

%externalpredicate translated global command symbol(%string(*)%name s)
%integer n=4
  call name manager(n,s,s)
  %trueunless n=0; %false
%end

%externalroutine next global logical name(%string(*)%name key,info)
%integer n=5
  call name manager(n,key,info)
%end

%externalroutine next global command symbol(%string(*)%name key,info)
%integer n=6
  call name manager(n,key,info)
%end

%externalpredicate translated logical name(%string(*)%name s)
  %trueif translated local logical name(s)
  %trueif translated global logical name(s)
  %false
%end

%externalpredicate translated command symbol(%string(*)%name s)
  %trueif translated local command symbol(s)
  %trueif translated global command symbol(s)
  %false
%end

%externalstring(255)%fn translate logical name(%string(255)key)
  %result = key %if translated logical name(key)
  %result = key
%end

%externalstring(255)%fn translate command symbol(%string(255)key)
  %result = key %if translated command symbol(key)
  %result = key
%end

%externalinteger default name mode = 'G'

%externalroutine define logical name(%string(255)k,e)
  %if default name mode & 95 = 'L' -
  %then define local logical name(k,e) -
  %else define global logical name(k,e)
%end

%externalroutine define command symbol(%string(255)k,e)
  %if default name mode & 95 = 'L' -
  %then define local command symbol(k,e) -
  %else define global command symbol(k,e)
%end

%externalroutine STANDARDISE FILENAME (%string(*)%name name)

! NB:
! "The separator" means ':'.
! Defaulting "" to ":N" has been discontinued,
! Defaulting ":" to ":T" has been left in for now.
! Rules:
! Names begining with the separator are deemed already standardised.
! Names which have a leading (or sole) component which is a logical
! name are subject to substitution of that logical name up to a maximum
! iteration limit.
! Once logical name translation fails, a default prefix is applied.
! That prefix is the current directory in the case of one-component
! names, or the current filestore in the case of multi-component names.
! If the name (whether single or multi component) begins with '^', we
! apply a shortened prefix, consisting of the current directory with
! one trailing components removed for every '^' removeable from the
! front of the name.

%string(1)colon=":"
%string(3)coloncolon="::"
%string(255)prefix,fore,aft
%integer lives=9
%bytename p==length(prefix),f==length(fore),n==length(name)

%predicate resolves(%string(*)%name source,match,fore,aft)
  %trueif source -> fore.(match).aft
  %false
%end

  %routine check for colon colon
! EFTP-compatibility:
! Names of the form ::zz are turned into :F:zz,
! names of the form x::y are turned into :F:x:y.
    %if resolves(name,coloncolon,fore,aft) %start
      %if fore="" %start
        name = ":F:".aft
      %else
        name = ":F:".fore.":".aft
      %finish
    %finish
  %end

  %predicate starts(%integer k)
! True iff NAME starts with character K.
    %falseif n=0; %trueif n[1]=k; %false
  %end

  %routine shorten prefix
! Strip a trailing component off string PREFIX.
! If (vax) it ends in *.x] turn it into *]
! If (vax) it ends in *[x] (no dot in the []), turn it into *[x.-]
! If it ends in *x:y: or *x:y turn it into *x:
  %integer vax
    %if p[p]=']' %start
      vax = p
      %cycle
        vax = vax-1
        %if p[vax]='[' %start
          p[p] ='.'; p[p+1] = '-'; p[p+2] = ']'; vax = p+2
          %exit
        %finish
        %if p[vax]='.' %start
          p[vax] = ']'
          %exit
        %finish
      %repeatuntil vax=0 %or p[vax]=':'
      p = vax
    %else
      p = 1 %if p=0
      p = p-1 %until p=0 %or p[p]=':'
    %finish
  %end

  %routine apply prefix
! NAME = PREFIX.NAME, but make sure one (if needed)
! and no more than one colon gets put inbetween.
    %returnif p=0
    %if ':'#p[p]#']' %start
      p = p+1; p[p] = ':'
    %finish
    name = substring(name,2,n) %while n>1 %and n[1]=':'
    name = prefix.name
  %end

  %signal 3,3,,"Null file name" %if n=0
  %if n[1]=':' %start
    name = ":T" %if n=1
    %returnunless n[2]=':'
  %finish
  check for colon colon
  %while lives>0 %andnot starts(':') %cycle
    lives = lives-1
    %if starts('^') %start
      prefix = translate logical name(".")
      %cycle
        name = substring(name,2,n)
        shorten prefix
      %repeatuntilnot starts('^')
      apply prefix
      check for colon colon
    %finish
    %if resolves(name,colon,fore,aft) %start
      %if translated logical name(fore) %start
        name = aft; prefix = fore
      %else
        prefix = "Current_Filestore"
        prefix = "^" %unless translated logical name(prefix)
      %finish
    %elseunless translated logical name(name)
      prefix = translate logical name(".")
    %finish
    apply prefix
    check for colon colon
  %repeat
  %unless n>1 %and n[1]=':' %start
    name = "Standardise file name fails: ".name
    %signal 3,3,,name
  %finish
%end

! Name manager process starts here

%begin
%record(mailbox fm)%name mbx
%record(message fm)%name m
%record(f)%name r
%switch s(1:6)

  mbx == create mailbox(mbx name,create semaphore("",0))
  become process(15000)
  default name mode = 'L'

  define logical name(":a","114")
  define logical name(":b","015")
  define logical name(":c","01B")
  define logical name(":d","135")
  define logical name(":m","044")
  define logical name(":v","272")

  define logical name("a",":f:a")
  define logical name("b",":f:b")
  define logical name("c",":f:c")
  define logical name("d",":f:d")
  define logical name("m",":f:m")
  define logical name("v",":f:v")

  define logical name(".",cliparam)

  %cycle
    m == receive message(mbx); r == record(addr(m_data))
    ->s(r_op) %if 1<=r_op<=6
    r_op = -1; ->end
s(1): define local logical name(r_key,r_info);   ->end
s(2): define local command symbol(r_key,r_info); ->end
s(3): r_info = r_key
      r_op = 0 %unless translated local logical name(r_info); ->end
s(4): r_info = r_key
      r_op = 0 %unless translatedlocal command symbol(r_info); ->end
s(5): next local logical name(r_key,r_info); ->end
s(6): next local command symbol(r_key,r_info)
end:
    send message(m,m_reply)
  %repeat
%end