!  File  NMOUSE:IMPLIB

! Imp runtime library
! plus odds and sods

%option "-low-nons-nocheck-nodiag-nostack"
%include "mouse.inc"

%systemroutine NEWLINES (%integer n)
  n = n-1 %and printsymbol(nl) %while n>0
%end

%systemroutine SPACES (%integer n)
  n = n-1 %and printsymbol(' ') %while n>0
%end

%systemroutine PRINTLINE (%string(255)s)
  printstring(s); printsymbol(nl)
%end

%systemroutine READLINE (%string(*)%name s)
! For symmetry with PRINT LINE, the terminating NL is skipped and
! not included in the string.  Blank lines are not ignored, nor are
! leading and trailing spaces.
%integer sym
%bytename b
  b == length(s); b = 0
  %cycle
    readsymbol(sym); %exitif sym=nl
    b = b+1; b[b] = sym
  %repeat
%end

%systemstring(8)%fn ITOH (%integer n)
! Convert integer to 8-digit hex string
%integer i,k
%string(8)s=""
  %for i = 28,-4,0 %cycle
    k = n>>i&15; k = k+7 %if k>9; s = s.tostring(k+'0')
  %repeat
  %result = s
%end

%systemintegerfn HTOI (%string(255)s)
! Convert hex string to integer
%integer n=0,p=0,k
  %cycle
    p = p+1
    %result = n %if p>length(s)
    k = charno(s,p); %continueif k<=' '
    k = k-'0'
    %if k>9 %start
      k = k-32 %if k>='a'-'0'
      k = k-7 %if k-7>9
    %finish
    %result = n %unless 0<=k<=15
    n = n<<4+k
  %repeat
%end

%systemintegerfn STOI (%string(255)s)
! Convert decimal string to integer
%integer i,k
%integer sign=0, val=0
  i = 0
  %while i < length(s) %cycle
    i = i+1;  k = charno(s,i)
    %continue %if k <= ' '
    %if k = '-' %start
      sign = 1
    %else %if '0' <= k <= '9'
      val = val<<3+val+val+k-'0'
    %else
      %signal 4, 1, k, "Non-numeric character"
    %finish
  %repeat
  %result = val %if sign = 0
  %result = -val
%end

%systemstring(255)%fn ITOS (%integer v,p)
! Convert integer to decimal string
%string(255)s
%bytename l
  %routine printsymbol(%integer x)
    l = l+1; l[l] = x
  %end
  %routine spaces(%integer x)
    x = x-1 %and printsymbol(' ') %while x>0
  %end
  %routine write(%integer n,p)
  %integer q,r
    %if p>0 %start
      p = \p; printsymbol(' ') %and p = p+1 %if n>=0
    %finish
    p = -120 %if p<-120
    q = n//10; r = {rem(n,10)} d1 
    %if q=0 %start
      p = p+1 %if n<0; spaces(-1-p); printsymbol('-') %if n<0
    %else
      p = p+1 %if p<0; write(q,p)
    %finish
    printsymbol(|r|+'0')
  %end
  s = ""; l == length(s)
  write(v,p)
  %result = s
%end

%systemstring(255)%fn RTOS (%real r,%integer n,m)
%constreal pmax = 2147483647.0
%real y,z
%integer i=0,l,count=0,sign=' '
%string(255)result = ""
  sign = '-' %if r < 0
  m = 80 %if m>80
  n = 254-m %if 254-m>255
  y = |r|+0.5/10.0\m;  !modulus, rounded
  %if y > pmax %start
    count = count+1 %and y = y/10.0 %until y < 10.0
  %finish
  z = 1.0
  %cycle
    i = i+1;  z = z*10.0
  %repeat %until z > y
  l = n-i
  result = result." " %and l = l-1 %while l>0
  result = result.tostring(sign) %unless sign = ' ' %and n <= 0
  %cycle
    z = z/10.0
    l = int pt(y/z)
    y = y-l*z
    result = result.tostring(l+'0')
    i = i-1
    %exit %if i+m <= 0
    result = result."." %if i = 0
  %repeat
  result = result."@".itos(count,0) %if count # 0
  %result = result
%end

%systemstring(255)%fn RTOF (%real x, %integer n)
%real y,round
%integer count=-99,sign=0
%string(255) result=""
  %if x # 0 %start
    x = -x %and sign = 1 %if x < 0
   !Adjust X so that 1.0 <= rounded(X) < 10.0
    count = 0;  round = 0.5\n
    y = 1.0-round
    %if x < y %start;  !ie rounded(X) < 1.0
      count = count-1 %and x = x*10.0 %until x >= y
    %finish %else %start
      y = 10.0-round
      %while x >= y %cycle;  !ie rounded(X) > 10.0
        count = count+1;  x = x/10.0
      %repeat
    %finish
    x = -x %if sign # 0
  %finish
  result = rtos(x,1,n)
  result = result."@".itos(count,0)
  %result = result
%end

%systemrealfn STOR (%string(255)Input)
%integer Sign = 0, Sym, Pos = 1
%real Value, Exp

   %routine Next
      Pos = Pos + 1
      %if Pos > Length (Input) %start
         Sym = 0
      %else
         Sym = Char No (Input, Pos)
      %finish
   %end

   Sym = Char No (Input, Pos)
   %if Sym = '-' %start
      Sign = 1
      Next
   %finish
   Value = 0
   %if Sym # '.' %start
      %signal 6, 5, Pos %unless '0' <= Sym <= '9'
      %cycle
         Value = Value*10.0 + (Sym - '0')
         Next
      %repeat %until %not '0' <= Sym <= '9'
   %finish
   %if Sym = '.' %start
      Exp = 10.0
      %cycle
         Next
         %exit %unless '0' <= Sym <= '9'
         Value = Value + (Sym - '0')/Exp
         Exp = Exp * 10.0
      %repeat
   %finish
   %if Sym = '@' %start
      Sym = SToI (Sub String (Input, Pos + 1, Length (Input)))
      Value = Value * 10.0\Sym
   %finish
   Value = -Value %if Sign # 0
   %result = Value
%end

%systemrealfn FTOR (%string(255)s)
  %result = stor(s)
%end

%systemintegerfn READINTEGER %alias "READ"
! Read a decimal integer.  The radix may be changed using '_' as customary.
%integer i,k,sign,ten=10,max='9'
  %cycle
    k = next symbol
    %exit %if k > ' '
    skip symbol
  %repeat
  sign = 0
  %if k = '-' %start
    sign = 1
    skip symbol;  k = next symbol
  %finish
  %cycle
    %signal 4,1,k,"READ: Non-numeric character" %unless '0'<=k<=max
    i = k-'0'
    %cycle
      skip symbol
      k = next symbol
      k = k-32 %if k>='a'
      %if k>'9' %start
        %exitif k<'A'
        k = k-7
      %finish
      %exit %unless '0' <= k <= max
      i = i*ten-'0'+k
    %repeat
    %exitunless k='_'-7
    ten = i; max = '0'+ten-1
    skipsymbol; k = nextsymbol
    k = k-32 %if k>='a'
    %if k>'9' %start
      k = -1 %if k<'A'
      k = k-7
    %finish
  %repeat
  i = -i %if sign # 0
  %result = i
%end

%systemrealfn READREAL
%integer sign=0,sym
%real value,exp
  %cycle
    sym = nextsymbol
    %exit %if sym > ' '
    skipsymbol
  %repeat
  %if sym = '-' %start
    sign = 1
    skip symbol;  sym = nextsymbol
  %finish
  value = 0
  %if sym # '.' %start
    %signal 4,1,sym,"READ: Non-numeric character" %unless '0' <= sym <= '9'
    %cycle
      value = value*10.0+(sym-'0')
      skip symbol;  sym = nextsymbol
    %repeat %until %not '0' <= sym <= '9'
  %finish
  %if sym = '.' %start
    exp = 10.0
    %cycle
      skip symbol;  sym = nextsymbol
      %exit %unless '0' <= sym <= '9'
      value = value+(sym-'0')/exp
      exp = exp*10.0
    %repeat
  %finish
  %if sym = '@' %start
    skipsymbol
    sym = readinteger
    value = value*10.0\sym
  %finish
  value = -value %if sign # 0
  %result = value
%end

%systemstring(255)%fn READSTRING
! Read a sequence of non-control characters (characters > ' '),
! skipping any leading control characters.  But if a leading quote
! (single or double) is found, proceed in the obvious way.
%string(255)s
%integer term=-1,sym
%bytename b
  b == length(s); b = 0
  readsymbol(sym) %until sym>' '
  term = sym %and readsymbol(sym) %if sym='"' %or sym=''''
  %cycle
    %if sym=term %start
      %exitunless nextsymbol=term
      skipsymbol
    %finish
    b = b+1; b[b] = sym
    sym = nextsymbol; %exitif term<0 %and sym<=' '
    skipsymbol
  %repeat
  %result = s
%end

%systemroutine WRITE (%integer n,p)
  printstring(itos(n,p))
%end

%systemroutine PRINT (%real x, %integer n,m)
  printstring(rtos(x,n,m))
%end

%systemroutine PRINTFL (%real x, %integer n)
  printstring(rtof(x,n))
%end

%systemroutine PHEX1 (%integer x)
  x = x&15; x = x+7 %if x>9; printsymbol(x+'0')
%end

%systemroutine PHEX2 (%integer x)
  phex1(x>>4); phex1(x)
%end

%systemroutine PHEX4 (%integer x)
  phex2(x>>8); phex2(x)
%end

%systemroutine PHEX (%integer x)
  phex4(x>>16); phex4(x)
%end

%systemintegerfn RHEX
%integer n=0,s
  %onevent 4 %start
    %signal 4,1,s,"RHEX: Non-numeric character"
  %finish
  %cycle
    s = nextsymbol; %exitif s>' '
    skipsymbol
  %repeat
  s = s&95 %if s>='a'
  %signal 4 %unless '0'<=s<='9' %or 'A'<=s<='F'
  %while '0'<=s<='9' %or 'A'<=s<='F' %cycle
    s = s-'0'; s = s-7 %if s>9
    n = n<<4+s; skipsymbol; s = nextsymbol
    s = s&95 %if s>='a'
  %repeat
  %result = n
%end

! String manipulation

%systemroutine TOUPPER (%string(*)%name s)
%bytename b
%integer i
  b == length(s); i = b
  %while i>0 %cycle
    i = i-1; b == b[1]
    b = b&95 %if 'a'<=b<='z'
  %repeat
%end

%systemroutine TOLOWER (%string(*)%name s)
%bytename b
%integer i
  b == length(s); i = b
  %while i>0 %cycle
    i = i-1; b == b[1]
    b = b!32 %if 'A'<=b<='Z'
  %repeat
%end

%systemroutine TOMIXED (%string(*)%name s)
%bytename b
%integer i,j=0
  b == length(s); i = b
  %while i>0 %cycle
    i = i-1; b == b[1]
    %if 'A'<=b&95<='Z' %then b = b&95!j %and j = 32 %else j = 0
  %repeat
%end

%systempredicate RESOLVES (%string(*)%name var,match,fore,aft)
!!Resolve the string specified by VAR into FORE and AFT split by MATCH
!![FORE and/or AFT absent is conventionally represented by an address
!! of zero]
%integer i
%option "-noline" {not to perturb pred result (compiler neglects to retest)}
  %integerfn resol(%string(*)%name var,match)
  !Return index position of first occurrence of MATCH within VAR
  %label yes,no
    *clr.l d0
    *clr.w d1
    *move.b (a1)+,d1  {length(match)
    *beq yes          {match="" ->
    *clr.w d2
    *move.b (a0)+,d2  {length(var)
    *sub.b d1,d2
    *bcs no           {length(match)>length(var) ->  {*bug: was bmi
    *subq.w #1,d1
loop1:
    *lea 0(a0,d0),a2
    *move.l a1,a3
    *move d1,d3
loop2:
    *cmpm.b (a2)+,(a3)+
    *dbne d3,loop2 {*bug?was dbeq
    *beq yes
    *addq.w #1,d0
    *dbra d2,loop1
no: *moveq #-1,d0
yes:*addq.l #1,d0
  !** (to be) re-coded for efficiency **
!  %integer i=0,j,l
!    l = length(match)
!    %cycle
!      %result = 0 %if i > length(var)-l
!      i = i+1
!      j = 0
!      %cycle
!        %result = i %if j = l
!        j = j+1
!      %repeat %until charno(var,i+j-1) # charno(match,j)
!    %repeat
  %end

  %routine assign(%string(*)%name dest, %integer from,to)
  !! **NB use of TOSTRING is compiled in-line **
  !! **OK when DEST is also source **
    dest = ""
    %while from <= to %cycle
      dest = dest.tostring(charno(var,from));  from = from+1
    %repeat
  %end

  %routine do aft
    assign(aft,i+length(match),length(var)) %unless aft==nil
  %end

  i = resol(var,match)
  %false %if i = 0
  %if fore ## nil %start
    %if fore ## var %start
      assign(fore,1,i-1)
      do aft
    %finish %else %start
      do aft
      length(var) = i-1
    %finish
  %finish %else do aft
  %true
%end

%systemroutine MOVE (%integer bytes,%name from,to)
%label finished,bytewise,trylong
  *move.l a0,d1; *move.l a1,d2
  *sub.l d1,d2; *and.w #1,d2; *bne bytewise  {buffers misaligned ->
  *move.l d0,d2; *ble finished               {non-positive amount =>
  *and.w #1,d1; *beq trylong                 {buffers word-aligned ->
  *move.b (a0)+,(a1)+; *subq.l #1,d0         {align them
trylong:
  *lsr.l #2,d2; *beq bytewise                {less than 4 bytes to go ->
  *subq.l #1,d2; *swap d2
longouter: *swap d2
longinner: *move.l (a0)+,(a1)+; *dbra d2,longinner
  *swap d2; *dbra d2,longouter
  *and.l #3,d0                               {copy remaining 0:3 bytes
bytewise: *subq.l #1,d0; *bmi finished; *swap d0
byteouter: *swap d0
byteinner: *move.b (a0)+,(a1)+; *dbra d0,byteinner
  *swap d0; *dbra d0,byteouter
finished:
%end

! I/O

%systemroutinespec file op (%integer c,%string(*)%name f,%name x)
%systemrecord(fcb fm)%mapspec fcb open(%integer c,%string(*)%name f,%name x)
%systemroutinespec fcb close(%record(fcb fm)%name x)
%systemroutinespec fcb abort(%record(fcb fm)%name x)

%systemintegerfn FCB size (%record(fcb fm)%name x)
! Returns the size of the file (input or output).
  %result = 0 %if x==nil
  x_fl = x_p %if x_p>x_fl
  %result = x_fl-x_fs
%end

%systemintegerfn FCB pos (%record(fcb fm)%name x)
! Returns the current position in the file (input or output).
  %result = 0 %if x==nil
  %result = x_p-x_fs
%end

%systemintegerfn INSTREAM
  %result = poa_instream
%end

%systemintegerfn OUTSTREAM
  %result = poa_outstream
%end

%externalintegerfn INPUT FILE POSITION
  %result = fcb pos(poa_curin)
%end

%externalintegerfn OUTPUT FILE POSITION
  %result = fcb pos(poa_curout)
%end

%externalintegerfn INPUT FILE SIZE
  %result = fcb size(poa_curin)
%end

%externalintegerfn OUTPUT FILE SIZE
  %result = fcb size(poa_curout)
%end

%systemroutine PROMPT (%string(255)s)
  %returnif poa_curin==nil
  %returnif poa_curin_prompt==nil
  poa_curin_prompt = s
%end

%systemstring(255)%fn INFILENAME
  %result = ":N" %if poa_curin==nil
  %result = poa_curin_filename
%end

%systemstring(255)%fn OUTFILENAME
  %result = ":N" %if poa_curout==nil
  %result = poa_curout_filename
%end

%externalrecord(fcb fm)%map FILE OPEN INPUT (%string(255)f)
  standardise filename(f)
  %result == fcb open(fopopeni,f,nil)
%end

%externalrecord(fcb fm)%map FILE OPEN OUTPUT (%string(255)f)
  standardise filename(f)
  %result == fcb open(fopopeno,f,nil)
%end

%externalrecord(fcb fm)%map FILE OPEN MODIFY (%string(255)f)
  standardise filename(f)
  %result == fcb open(fopopenm,f,nil)
%end

%externalrecord(fcb fm)%map FILE OPEN APPEND (%string(255)f)
  standardise filename(f)
  %result == fcb open(fopopena,f,nil)
%end

%externalintegerfn filesize(%string(255)f)
%record(fcb fm)%name cb == file open input(f)
%integer n = fcb size(cb)
  fcb close(cb)
  %result = n
%end

%externalpredicate exists(%string(255)f)
  %on 3 %start
    %false
  %finish
  fcb close(file open input(f))
  %true
%end

%externalroutine OPENINPUT (%integer s,%string(255)f)
%record(fcb fm)%name fcb
  selectinput(s)
  fcb == file open input(f)
  fcb_next == poa_in(s)
  poa_in(s) == fcb
  poa_curin == fcb
%end

%externalroutine OPENOUTPUT (%integer s,%string(255)f)
%record(fcb fm)%name fcb
  selectoutput(s)
  fcb == file open output(f)
  fcb_next == poa_out(s)
  poa_out(s) == fcb
  poa_curout == fcb
%end

%externalroutine OPENMODIFY (%integer s,%string(255)f)
%record(fcb fm)%name fcb
  selectoutput(s)
  fcb == file open modify(f)
  fcb_next == poa_out(s)
  poa_out(s) == fcb
  poa_curout == fcb
%end

%externalroutine OPENAPPEND (%integer s,%string(255)f)
%record(fcb fm)%name fcb
  selectoutput(s)
  fcb == file open append(f)
  fcb_next == poa_out(s)
  poa_out(s) == fcb
  poa_curout == fcb
%end

%externalroutine LOGOUT
%string(255)fs="."
  standardise filename(fs)
  file op(foplogout,fs,nil)
%end

%externalroutine LOGIN (%string(255)fsu,p)
  standardise filename(fsu)
  file op(foplogin,fsu,p)
%end

%externalroutine QUOTE (%string(255)p)
%string(255)fs="."
  standardise filename(fs)
  file op(fopquote,fs,p)
%end

%externalroutine PASSWORD (%string(255)p)
%string(255)fs="."
  standardise filename(fs)
  file op(foppass,fs,p)
%end
  
%externalroutine CREDIR (%string(255)f)
  standardise filename(f)
  file op(fopcredir,f,nil)
%end

%externalroutine DELETE (%string(255)f)
  standardise filename(f)
  file op(fopdelete,f,nil)
%end

%externalstring(255)%fn FINFO (%string(255)f,%integer n)
%string(255)info
  f = "." %if f=""
  standardise filename(f)
  f = f.","
  f = f.tostring(n>>4+'0')
  f = f.tostring(n&15+'0')
  file op(fopoldfinfo,f,info)
  %result = info
%end

%externalstring(255)%fn NINFO (%string(255)f)
%string(255)info
  standardise filename(f)
  file op(fopinfo,f,info)
  %result = info
%end

%externalroutine RENAME (%string(255)old,new)
  standardise filename(old)
  standardise filename(new)
  file op(foprename,old,new)
%end

%externalroutine COPY (%string(255)from,to)
  standardise filename(from)
  standardise filename(to)
  file op(fopcopy,from,to)
%end

%externalroutine PERMIT (%string(255)f,p)
  standardise filename(f)
  file op(foppermit,f,p)
%end

%externalroutine CHANGE DATE (%string(255)f,d)
  standardise filename(f)
  file op(fopstamp,f,d)
%end

%externalstring(255)%fn DATETIME
%string(255)d = "."
  standardise filename(d)
  file op(foptime,d,d)
  %result = d
%end

%externalroutine FILESTORE CONTROL (%string(255)p)
%string(255)fs = "."
! NB:
! [ new owner
! ^ new quota
! ]1 kill uno
! ]2 kill xno
! ]3 kill port
! ]4 set diag
! ]5 set open state (0 none, 3 syspass, 7 all)
! ]6 set syspass
! ]7 reboot
! ]8 add bad block
! ]9 set date and time
! ]: lpzap
  standardise filename(fs)
  file op(fopspecial,fs,p)
%end

%externalstring(255)%fn DATE
%string(255)dt = datetime
%bytename b == length(dt)
  b = b-1 %while b>0 %and b[b]#' '
  b = b-1 %while b>0 %and b[b]=' '
  %result = dt
%end

%externalstring(255)%fn TIME
%string(255)dt = datetime
%bytename b == length(dt)
%integer p = b
  p = p-1 %while p>0 %and b[p]#' '
  dt = substring(dt,p+1,b)
  %result = dt
%end

%constinteger base {1/1/80} = 29161

%externalstring(19)%fn DECODE DATE AND TIME (%integer code)
%integer d,m,y,hh,mm,ss
%string(19)r="dd/mm/yy  hh.mm.ss"
%bytename b

  %routine p2(%integer n,%bytename b)
    b[1] = rem(n,10)+'0'
    b = rem(n//10,10)+'0'
  %end

  d = (code//(24*60*60)+base)<<2-1
  y = d//1461+1
  d = ((rem(d,1461)+4)>>2)*5-3
  m = d//153-9
  %if m<=0 %start
    m = m+12;  y = y-1
  %finish
  d = (rem(d,153)+5)//5
  b == charno(r,1)
  p2(d,b; m,b[3]; y,b[6])
  ss = rem(code,60); code = code//60
  mm = rem(code,60); hh = rem(code//60,24)
  b == b[10]
  p2(hh,b; mm,b[3]; ss,b[6])
  %result = r
%end

%externalintegerfn ENCODE DATE AND TIME (%string(255)s)
%integer d=0,m=0,y=0,hh=0,mm=0,ss=0
%bytename b,end

  %integerfn num
  %integer n=0
    %result = n %if b==end
    b == b[1]
    %cycle
      %result = n %if b==end
      %if b=' ' %start
        %result = n %unless n=0
      %else
        %result = n %unless '0'<=b<='9'
        n = n*10+b-'0'
      %finish
      b == b[1]
    %repeat
  %end

  b == length(s); end == b[b+1]
  d = num; m = num; y = num; hh = num; mm = num; ss = num
  m = m - 3
  m = m + 12 %and y = y - 1 %if m < 0
  %result = (((((y*1461)>>2+(m*153+2)//5+d-base))*24+hh)*60+mm)*60+ss
%end

%externalstring(255)%fn current user
%string(255)s="current_user"
  %result = "" %unless translated logical name(s)
  %result = s
%end

%externalstring(255)%fn current filestore
%string(255)s="current_filestore"
  %result = "" %unless translated logical name(s)
  %result = s
%end

%externalstring(255)%fn current directory
%string(255)s="."
%bytename l == length(s)
  %result = "" %unless translated logical name(s)
  l = l+1 %and l[l] = ':' %if ']'#l[l]#':'
  %result = s
%end

%externalroutine set directory(%string(255)s)
  standardise filename(s)
  define logical name(".",s)
%end

%recordformat finfof(%string(23)name,%string(5)perms,%string(9)date,time,
                     %integer blocks,extents)

%externalroutine unpack finfo(%string(127)s,%record(finfof)%name r)
%integer pos=1
  %routine scan
    pos = pos+1 %while pos<=length(s) %and charno(s,pos)=' '
  %end
  %integerfn d
  %integer n=0,k
    scan
    %cycle
      %result = n %if pos>length(s); pos = pos+1; k = charno(s,pos-1)-'0'
      %result = n %if k<0 %or k>9; n = n*10+k
    %repeat
  %end
  %routine w(%string(*)%name t,%integer max)
  %integer k
    scan; t = ""
    %cycle
      %returnif pos>length(s) %or max<=0
      k = charno(s,pos); pos = pos+1; max = max-1
      %returnif k=' '
      t = t.tostring(k)
    %repeat
  %end
  r = 0
  w(r_name,23); w(r_perms,5); w(r_date,9); w(r_time,9)
  r_blocks = d; r_extents = d
%end

%externalintegerfn wildness(%string(*)%name s)
%integer k,i,w=0
  %for i=1,1,length(s) %cycle
    k = charno(s,i); w = w+1 %if k='*' %or k='%'
  %repeat
  %result = w
%end

%externalpredicate Matches(%string (*) %name s, p)
! S=Subject, P=Pattern. Pattern is the one with the stars in it.
%integer slen = 0, plen = 0

  %predicate m (%integer spos,ppos)
  %integer psym = 0,ssym = 0
    %cycle
      %if ppos=plen %start
        %true %if spos=slen
        %false
      %finish
      ppos = ppos+1; psym = charno(p,ppos)
      %exitif psym='*'
      %falseif spos=slen
      spos = spos+1; ssym = charno(s,spos)
      psym = ssym %if ssym!32=psym!32 %and 'a'<=psym!32<='z'
      %unless ssym=psym %start
        %falseunless psym='%'
      %finish
    %repeat
    %cycle
      %trueif m(spos,ppos)
      %exitif spos=slen
      spos = spos+1; ssym = charno(s,spos)
    %repeat
    %false
  %end

  slen = length(s)
  plen = length(p)
  %true %if m(0,0)
  %false
%end

%externalpredicate Translate Matches(%string (*) %name s, p, o)
! S=Subject, P=Pattern, O=Object.
! Replace the wild card markers in O with the parts of S which
! correspond to the wild card markers in S.
%bytename slen,plen,olen
%integer i

  %routine inject(%string(255)s)
  %string(255)fore,aft
    %for i = olen,-1,1 %cycle
      %if olen[i]='*' %start
        fore = substring(o,1,i-1)
        aft = substring(o,i+1,olen)
        o = fore.s.aft
        %return
      %finish
    %repeat
    o = o.s
  %end

  %predicate m(%integer spos,ppos)
  %integer psym = 0,ssym = 0
  %string(255)match
    %cycle
      %if ppos=plen %start
        %true %if spos=slen
        %false
      %finish
      ppos = ppos+1; psym = charno(p,ppos)
      %exitif psym='*'
      %falseif spos=slen
      spos = spos+1; ssym = charno(s,spos)
      psym = ssym %if ssym!32=psym!32 %and 'a'<=psym!32<='z'
      %unless ssym=psym %start
        %falseunless psym='%'
        %for i = 1,1,olen %cycle
          %unless '%'#olen[i]#'*' %start
            olen[i] = ssym; i = 0; %exit
          %finish
        %repeat
        %unless i=0 %start
          olen = olen+1; olen[olen] = ssym
        %finish
      %finish
    %repeat
    match = ""
    %cycle
      inject(match) %andtrueif m(spos,ppos)
      %exitif spos=slen
      spos = spos+1; ssym = charno(s,spos)
      match = match.tostring(ssym)
    %repeat
    %false
  %end

  slen == length(s)
  plen == length(p)
  olen == length(o)
  %trueif m(0,0); %false
%end