    !  If Emas-a.
    include  "ecsc03:constsinc"
    include  "ecsc03:heapspecs"
    include  "ecsc03:iospecs"
    include  "ecsc03:utilspecs"
    !

    recordformatspec  af
    recordformatspec  if
    recordformatspec  pf
    recordformatspec  qf
    recordformatspec  qlistf
    recordformat  af(record (af)name  next,record (if)name  item,integer  n)
    recordformat  if(record (if)name  next,
    (record (pf)name  phrase or  string (*)name  s), integer  type)
    recordformat  lexf(byteinteger  type, v, integer  first, last)
    recordformat  pf(record (pf)name  next, prev, record (af)name  alt,
    string (*)name  s, integer  type,  done)
    recordformat  pnamef(record (pf)name  p)
    recordformat  parsef(integer  level,    {level in parsetree}
    lp,                                     {first lexical item this record covers}
    tp1,                                    {start of text covered by record}
    tp2,                                    {end of text covered by record}
    (record (pf)name  phrase or  record (af)name  alt or  record (if)name  item),
    integer  type)
                                            {Phrase, Alternative or Item}
                                            { 'a' for Alternative}
                                            { 'i' for Item}
                                            { 'p' for Phrase}
                                            {  + type of item}
                                            { 'a' for Atom}
                                            {  'b' for Built-in-Phrase}
                                            {  'p' for phrase}
    recordformat  qf(record (qf)name  next, prev, record (pf)name  p)
    recordformat  qlistf(record (qf)name  head, tail)
    recordformat  strnamef(string (*)name  n)

    constinteger  maxbuffs=5000
    ownstring (255) addletts=""
    ownbyteintegerarray  alias(0:255)=0(*)
    owninteger  aliaslower, aliasupper      {  Markers for aliasing.}
    owninteger  alphabetical                {  Type of ordering for grammars.}
    ownrecord (qlistf) analysislist         {  Head of list of analyses}
    owninteger  anno=0                      {  Number af analyses found.}
    externalrecord (parsef)array  anrec(0:maxanrecs)
    externalinteger  ap=0
    constinteger  atraceflag=1
    owninteger  bipflags, bipflagsread
    constintegerarray  bipl(128:255)=0, 5, 0(125), 1
    ownrecord (parsef)array  bnrec(0:maxanrecs)
    constinteger  btraceflag=2
    ownrecord (lexf)array  buff(0:maxbuffs)
    ownstring (255) delletts=""
    ownstring (255) failure message=""
    owninteger  first=yes
    externalstring (255) grammarname=""
    ownstring (63) helpfile="ecsc03:bnfhelp"
    constinteger  integerflag=16_0001       {  Bit for B.I.P. Integer}
    ownbytearray  letter(0:255)= c
    'n'(65), 'y'(26), 'n'(6), 'y'(26), 'n'(*)
    ownrecord (qlistf) level1, level2       {  For printing grammar by levels.}
    owninteger  levels                      {  Type of ordering for grammars.}
    routinespec  list analysis(string (255) s,
    record (parsef)arrayname  anrec, integer  ap)
    owninteger  lp
    constinteger  markflag=16_0020          {  Bit for B.I.P. Marker}
    owninteger  maxap=0
    owninteger  maxlex, maxlp=0, maxlevel=0, maxnamelength=31
    constinteger  maxstr=1023
    constinteger  maxvals=500, maxworkspace=16383
    constinteger  nameflag=16_0002          {  Bit for B.I.P. Name}
    constrecord (af)name  nilla=0
    constrecord (if)name  nilli=0
    constrecord (pf)name  nillp=0
    constrecord (pnamef)name  nillpn=0
    constrecord (qf)name  nillq=0
    constrecord (qlistf)name  nillql=0
    ownstring (*)name  nills
    constinteger  ptraceflag=4
    constinteger  stringflag=16_0008        {  Bit for B.I.P. String}
    constinteger  symbolflag=16_0010        {  Bit for B.I.P. Symbol}
    !  String terminator, must be duplicated for retention within a string.
    constinteger  quote='"'
    owninteger  reportt=yes
    ownrecord (pf)name  root phrase
    owninteger  spall=yes, spcount=0, spelide=yes
    ownrecord (strnamef)array  str(-maxstr:0)
    owninteger  strno=0
    owninteger  terminator=nl
    externalbyteintegerarray  text(0:maxtexts)
    externalinteger  traceflags=0
    conststring (7)array  type(129:160)= c
    "Integer", "Name", "", "Word", ""(3), "String", ""(7), "Symbol", ""(15),
    "Marker"
    ownintegerarray  val(0:maxvals)
    owninteger  valno
    constbyteintegerarray  wanted(0:255)= c
    no(46), yes, no(18), yes(26), no(5), yes(26), no(6), no(128)
    constinteger  wordflag=16_0004          {  Bit for B.I.P. Word}

    ownrecord (pf)name  current phrase, head phrase, last phrase
    ownrecord (if)name  current item, last item
    ownrecord (af)name  current alt, last alt
    owninteger  level=0
    owninteger  level indent=1, arrowtip=20, linewidth=79
    ownstring (255) item, phrase
    ownstring (1) alt separator="|", item separator="+"
    externalinteger  textlength

    routine  print hex(integer  d)
    integer  i, j
    constbyteintegerarray  hex(0:15)= c
    '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'a', 'b', 'c', 'd', 'e',
    'f'
      for  i=28, -4, 0 cycle
        print symbol(hex((d>>i)&16_f))
        space if  i&4=0
        space if  i=16
      repeat
    end

    routine  testgram(string (255) s)
    record (af)name  a
    record (if)name  i
    record (pf)name  p
    integer  aa, ii, pp, an, in, pn
    string (63) as, is, ps

      message(s," ") if  s#""
      as=""; is=""; ps=""
      pn=0
      p==head phrase
      while  p##nillp cycle
        pp=addr(p)
        if  0#pp<=10000 then  message("Dud Phrase ".itod(pn)."==".itoh(pp)," mon")
        as=""; is=""; ps=p_s
        an=0
        a==p_alt
        while  a##nilla cycle
          aa=addr(a)
          as=ps." ".itod(an); is=""
          if  0#aa<=10000 then  message("Dud Alt ".as."==".itoh(aa)," ") c
          elsestart
            in=0
            i==a_item
            while  i##nilli cycle
              ii=addr(i)
              is=as." ".itod(in)
              if  0#ii<=10000 then  message("Dud Item ".is."==".itoh(ii)," ") c
              elsestart
                if  i_type=0 then  ii=addr(i_s) and  s="S" c
                else  ii=addr(i_phrase) and  s="Phrase"
                if  0#ii<=10000 then  c
                message("Dud ".p_s."  Item ".is." ".s."==".itoh(ii)," ")
              finish
              i==i_next
              in=in+1
            repeat
          finish
          a==a_next
          an=an+1
        repeat
        p==p_next
        pn=pn+1
      repeat
    end

    record (qf)map  newq
    record (qf)name  q
    record (qf) qpattern
      q==record(new(qpattern))
      q_next==nillq; q_prev==nillq
      q_p==nillp
      result ==q
    end

    record (qlistf)map  newqlist
    record (qlistf)name  q
    record (qlistf) qpattern
      q==record(new(qpattern))
      q_head==nillq; q_tail==nillq
      result ==q
    end

    routine  remove spaces(string (*)name  a)
    string (255) u, v
      a=u.v while  a->u.(" ").v
    end

    routine  print array(string (255) s,  byteintegerarrayname  a,
    integer  l, u)
    integer  i, j
      message("Bounds inside out, ".itod(l).", ".itod(u), "stop") if  u<l
      print string(s."  from ".itod(l)." to ".itod(u))
      newline
      j=0
      for  i=l, 1, u cycle
        write(a(i), 3)
        j=j+1
        newline and  j=0 if  j=16
      repeat
      newline
    end

    stringfn  lextext(integer  lp, lq)
    integer  i, j
    string (255) x
      x=""
      for  i=lp, 1, lq cycle
        x=x.tostring(text(j)) for  j=buff(i)_first, 1, buff(i)_last
      repeat
      result =x
    end

    routine  print ptr(string (255) s, name  a)
    integer  d
      d=addr(a)
      print string(s."  ")
      print hex(d)
    end

    routine  list strings(string (255) s)
    integer  i, oldout
      oldout=outstream
      select output(2)
      print string(snl.s.snl) unless  s=""
      if  strno>-1 thenstart
        print string("No strings")
        newline
        select output(oldout)
        return
      finish
      for  i=-1, -1, strno cycle
        write(-i, 3)
        print ptr("  ", str(i)_n)
        if  str(i)_n="" then  print string("  """"") c
        else  print string("  ".str(i)_n)
        newline
      repeat
      select output(oldout)
    end

    routine  list phrase(record (pf)name  p)
      print ptr("Phrase=".p_s."  Type=".itod(p_type), p); newline
      print ptr("Next==", p_next)
      print ptr(" Alt==", p_alt)
      print ptr("   S==", p_s); newline
    end

    routine  list alt(record (af)name  alt)
    string (80) s
      s="Alt ".itod(alt_n)
      s=s." " while  length(s)<8
      print ptr(s, alt)
      print ptr("  Next==", alt_next)
      print ptr("  Item==", alt_item)
      newline
    end

    routine  list item(string (255) s, record (if)name  item)
    string (255) t
      print ptr(s, item)
      print string("  Type=".itod(item_type))
      if  item_type=0 then  print ptr("  """.item_s."""", item_s) c
      else  print ptr("  ".item_phrase_s, item_phrase)
      print ptr("  Next==", item_next)
      newline
    end

    record (pf)map  phr(string (255) s)
    record (pf)name  p
      s=lower(s)
      p==head phrase
      while  p##nillp cycle
        result ==p if  p_s=s
        p==p_next
      repeat
      result ==nillp
    end

    !  If the item is an atom, the value is a string enclosed in quotation
    !  marks, with internal quotation marks doubled.
    !  If the item is a phrase, the value is the name of the phrase unless
    !  it is a Built-in-phrase, when the result is BIP(type).

    string (255)fn  string of item(record (if)name  item)
    integer  i, j
    string (255) t, u
    record (qf)name  q
      if  item_type=0 thenstart
        t=item_s
        j=0
        u=""
        length(u)=255
    !  Make sure that quotation marks are doubled within the string.
        for  i=1, 1, length(t) cycle
          j=j+1
          charno(u, j)=charno(t, i)
          j=j+1 and  charno(u, j)='"' if  charno(t, i)='"'
        repeat
        length(u)=j
        result ="""".u.""""
      finishelse  c
      if  item_type&16_ff>=128 then  result ="BIP(".type(item_type).")"
    !  Deal with phrase names.
      t=item_phrase_s
      if  levels=yes thenstart
    !  Put phrase names on list for printing.
        q==newq
        q_p==item_phrase
        if  q_p_done=-1 thenstart
    !  Mark phrase as on list.
          q_p_done=level
    !  Put phrase on list for printing by levels.
          append cell(q, level1)
        finish
        t=t."(".itod(item_phrase_done).")" if  0<=item_phrase_done<level-1
      finish
      result =t
    end

    string (255)fn  string of alt(record (af)name  alt)
    string (255) t, u
    record (if)name  i
    !  point at first item of alternative.
      i==alt_item
      t=""
      while  i##nilli cycle
        u=string of item(i)
        exit  if  u=""
        if  t="" then  t=u else  t=t.item separator.u
    !  move to next item.
        i==i_next
      repeat
      result =t
    end

    routine  print item(string (255) s, record (if)name  i)
      print string(snl.s.snl)
      if  i==nilli thenstart
        print string("    Nill item  ")
        print ptr("at ", i)
        newline
        return
      finish
      spaces(4)
      write(i_type, 3)
      print string("  ".string of item(i)."  ")
      print ptr("Next=", i_next)
      newline
    end

    routine  print alt(record (af)name  a)
    record (if)name  i
      if  a==nilla thenstart
        print ptr("  Nill alt at ", a)
        newline
        return
      finish
      print string("  Alt")
      write(a_n, 3)
      newline
      i==a_item
      cycle
        print item("", i)
        exit  if  i==nilli
        i==i_next
      repeat
    end

    routine  list production(record (pf)name  p)
    record (af)name  a
    record (if)name  i
      if  p==nillp thenstart
        print ptr("Nill production at ", p)
        newline
        return
      finish
      list phrase(p)
      newline
      a==p_alt
      while  a##nilla cycle
        list alt(a)
        i==a_item
        while  i##nilli cycle
          list item("  ", i)
          i==i_next
        repeat
        a==a_next
      repeat
      newline
    end

    routine  list grammar(string (255) s)
    integer  oldout
    record (pf)name  p
      oldout=outstream
      select output(2)
      print string(snl.s.snl)
      list strings("Strings read in grammar:")
      print string("Bipflags="); print hex(bipflags); newline
      print ptr("Nillp", nillp); newline
      print ptr("Nilla", nilla); newline
      print ptr("Nilli", nilli); newline
      p==head phrase
      while  p##nillp cycle
        list production(p)
        p==p_next
      repeat
      newline
      close output unless  outfile=".out"
      select output(oldout)
    end

    routine  output phrase(string (255) s, record (pf)name  p)
      print string(snl.snl.s.snl.snl) unless  s=""
      print string("Nillp.".snl) and  return  if  p==nillp
      print string(p_s."  Type=".pad(itod(p_type), -3, sp))
    end

    routine  output alt(string (255) s, record (af)name  alt)
      print string(s)
      print string("N=".pad(itod(alt_n), -3, sp))
      print string("  ".string of alt(alt))
      newline
    end

    routine  output production(string (255) s, record (pf)name  p)
    record (af)name  a
      output phrase(s, p)
      newline
      a==p_alt
      while  a##nilla cycle
        output alt("", a)
        a==a_next
      repeat
      newline
    end

    routine  output grammar(string (255) s)
    record (pf)name  p
    integer  i
      print string(snl.s.snl) unless  s=""
      print string(snl."Strings used in the grammar.".snl.snl)
      if  strno>-1 thenstart
        print string("No strings")
        newline
      finishelsestart
        for  i=-1, -1, strno cycle
          write(-i, 3)
          print string("  ".str(i)_n)
          newline
        repeat
      finish
      print string("Bipflags="); print hex(bipflags); newline
      print ptr("Nillp", nillp); newline
      print ptr("Nilla", nilla); newline
      print ptr("Nilli", nilli); newline
      p==head phrase
      while  p##nillp cycle
        output production("", p)
        p==p_next
      repeat
      newline
    end

    routine  extend(string (*)name  s, integer  i)
      i=i-length(s)
      i=1 if  i<=0
      s=s." " for  i=i, -1, 1
    end

    record (parsef)map  newanrec(integer  type, lp)
    record (parsef)name  ar
    string (255) s
      ap=ap+1
      list analysis("", anrec, ap) and  c
      message("No more cells for analysis record", "mon") if  ap>maxanrecs
      ar==anrec(ap)
      ar_level=level
      ar_lp=lp
      if  type&16_FF='a' then  ar_alt==current alt else  c
      if  type&16_FF='i' then  ar_item==current item else  c
      ar_phrase==current phrase
      ar_tp1=buff(lp)_first
      ar_tp2=buff(lp)_last
      ar_type=type
      result ==ar
    end

    string (*)mapspec  plant string(string (255) s)

    routine  new phrase(record (pf)name  q)
    record (pf)name  p
    record (pf) ppattern
      p==record(new(ppattern))
      p_alt==nilla; p_done=-1; p_next==nillp; p_prev==nillp
      if  head phrase==nillp then  head phrase==p else  c
      if  last phrase##nillp then  last phrase_next==p else  c
      message("Nill Last phrase and non-nill Head phrase.", "stop")
      last phrase==p
      p_s==plant string(q_s)
      p_next==nillp
      p_alt==nilla
      p_type=q_type
    end

    routine  new alt(integer  altno)
    record (af)name  p
    record (af) apattern
      p==record(new(apattern))
      if  current phrase_alt==nilla then  current phrase_alt==p c
      else  if  last alt##nilla then  last alt_next==p
      last alt==p
      last alt_next==nilla
      last alt_item==nilli
      last alt_n=altno
      last item==nilli
    end

    routine  new item(record (if)name  q)
    record (if)name  p
    record (if) ipattern
      p==record(new(ipattern))
      p=q
      p_next==nilli
    !  connect to alt, if free, else to last item.
      message("New item while last alt is null.", "stop") if  last alt==nilla
      if  last alt_item==nilli then  last alt_item==p else  c
      if  last item##nilli then   last item_next==p else  c
      message("Last item null while alt_item non-null.", "stop")
      last item==p
    end

    routine  print lex(integer  n)
    integer  i
      write(n, 3); space
      write(buff(n)_type, 3); space
      write(buff(n)_first, 3); space
      write(buff(n)_last, 3); spaces(3)
      for  i=buff(n)_first, 1, buff(n)_last cycle
        print symbol(text(i))
      repeat
      space and  write(val(buff(n)_v), 1) if  buff(n)_v#0
    end

    routine  list lex(integer  max)
    integer  i
      print string("Textlength=".itod(textlength)."  Max=".itod(max));newline
      i=1
      while  i<=max and  buff(i)_type#255 cycle
        print lex(i)
        newline
        i=i+1
      repeat
    end

    string (255)fn  string of anrec(integer  i)
    string (255) s, t
    record (parsef)name  a
      a==anrec(i)
      s="I=".itod(i); extend(s, 5); t=s
      s="Level=".itod(a_level); extend(s, 9); t=t.s
      s="type=".tostring(a_type&16_ff)
      s=s."+".itod((a_type>>8)&16_ff) if  a_type&16_ff='i'
      extend(s, 12); t=t.s
      if  a_type='a' then  s="Alt ".itod(a_alt_n) else  s=""
      extend(s, 7); t=t.s
      s="Lp=".itod(a_lp); extend(s, 6); t=t.s
      s="tp1=".itod(a_tp1); extend(s, 7); t=t.s
      s="tp2=".itod(a_tp2); extend(s, 7); t=t.s
      if  a_type='p' then  s=itoh(addr(a_phrase)) else  c
      if  a_type='a' then  s=itoh(addr(a_alt)) else  c
      s=itoh(addr(a_item)); extend(s, 10); t=t.s
      if  a_type&16_ff='i' thenstart
        s=string of item(a_item)
      finishelse  c
      if  a_type='p' thenstart
        if  a_phrase==nillp then  s="""Nillp""" elsestart
          if  a_phrase_s==nills then  s="""Nills""" c
          else  s=a_phrase_s
        finish
      finish
      t=t.s unless  a_type='a'
      result =t
    end

    routine  trace anrec(string (255) s, integer  i)
      trace(s.snl.string of anrec(i))
    end

    routine  list analysis(string (255) s,
    record (parsef)arrayname  anrec, integer  ap)
    integer  i
      message("No analysis of ".s, "") and  return  if  ap<1
      message("Analysis of ".s, "") unless  s=""
      for  i=1, 1, ap cycle
        print string(string of anrec(i))
        newline
      repeat
      newline
    end

    externalroutine  print parse(string (255) s)
    record (parsef)name  ar
    record (if)name  i
    string (255) t
    integer  j, k, l
      message(s." is accepted", "") and  return  if  reportt=no
      print string(s.snl) if  s#""
      for  l=1, 1, ap cycle
        ar==anrec(l)
        if  ar_type&16_ff='i' thenstart
          k=level indent*ar_level
          i==ar_item
          if  i_type=0 then  t="Atom=" else  t=""
          t=t.string of item(i) if  i_type#1
          if  i_type>=128 thenstart
            t=t."="
            t=t.tostring(text(j)) for  j=ar_tp1, 1, ar_tp2
          finish
          if  i_type#1 thenstart
            spaces(k)
            print string(t)
            newline
          finish
        finishelse  c
        if  ar_type='p' thenstart
          k=level indent*ar_level
          spaces(k)
          print string(ar_phrase_s)
          print string("->")
          print string(string of alt(anrec(l+1)_alt))
          newline
        finish
      repeat
      newline
    end

    routine  print production(record (pf)name  p, integer  sp)
    record (af)name  a
    record (if)name  i
    string (255) t
    integer  j, outposn
    !  Print lhs of production.
      t=p_s
      t=" ".t while  length(t)<arrowtip-4
      print string(t." -> ")
    !  Point at first alternative.
      a==p_alt
      outposn=arrowtip
      if  a==nilla thenstart
        print string(" *** UNDEFINED ***")
      finishelsestart
        cycle
          t=string of alt(a)
          if  a_next==nilla then  j=0 else  j=1
          if  outposn+length(t)+sp+j>linewidth thenstart
            newline
            spaces(arrowtip+sp)
            outposn=arrowtip
          finish
          print string(t); outposn=outposn+length(t)
          a==a_next
          exit  if  a==nilla
          print string(alt separator); outposn=outposn+1
        repeat
      finish
      newline; outposn=0
    end

    stringfn  string of production(record (pf)name  p)
    record (af)name  a
    integer  ct
    record (if)name  i
    string (255) t, u, v
    integer  j
    ! Line-number.
      t=itod(ct)." "
      t=" ".t for  j=1, 1, 5-length(t)
      ct=ct+1
      if  p_alt_n<=127 thenstart
        t=t.p_s
    !  point at first alternative.
        a==p_alt
        if  a==nilla thenstart
          t=t." -> *** UNDEFINED ***"
        finishelsestart
          t=t." -> "
          if  p_type&16_ff>=128 thenstart
            t=t."BIP(".type(p_type).")"
            result =t
          finish
          v=""
          cycle
            u=string of alt(a)
            exit  if  length(v)+length(t)+length(u)+2>250
            if  length(t)+length(u)>linewidth thenstart
              j=length(t)
              t=t.alt separator unless  tostring(charno(t, j))=alt separator c
              or  (charno(t, j-1)='>' and  charno(t, j)=' ')
              v=v.t.snl
              t=""
            finish
            t=t.u
            a==a_next
            exit  if  a==nilla
            t=t.alt separator
          repeat
        finish
        v=v.t
        result =v
      finish
    end

    routine  put out parse(string (255) s)
    integer  i, j, k, level
    string (255) t
      print string(s.snl) if  s#""
      level=0
      for  i=1, 1, ap cycle
        if  anrec(i)_level<level thenstart
          print symbol(')') for  level=level-1, -1, anrec(i)_level
        finishelse  c
        if  anrec(i)_level>level thenstart
          print symbol('(')
          level=level+1
        finish
        if  anrec(i)_type='p' then  c
          print string(anrec(i)_phrase_s) else  c
        if  anrec(i)_type&16_ff='i' thenstart
          print string(anrec(i)_item_s) unless  anrec(i)_item==nilli
        finish
        newline
      repeat
      newline
    end

    routine  extend heap(record (pnamef)arrayname  a, integer  i, j)
    record (pf)name  b
    !  This is thought of as a part of the heap beginning at a(1).
      return  if  2*i>j
      return  if  2*i+1>j and  a(i)_p_s>=a(2*i)_p_s
      if  2*i+1>j thenstart
        if  a(i)_p_s<a(2*i)_p_s thenstart
          b==a(i)_p
          a(i)_p==a(2*i)_p
          a(2*i)_p==b
          extend heap(a, 2*i, j)
        finish
        return
      finish
      if  a(2*i)_p_s>=a(2*i+1)_p_s thenstart
        if  a(2*i)_p_s>a(i)_p_s thenstart
          b==a(i)_p
          a(i)_p==a(2*i)_p
          a(2*i)_p==b
          extend heap(a, 2*i, j)
        finish
      finishelse  c
      if  a(2*i+1)_p_s>a(i)_p_s thenstart
        b==a(i)_p
        a(i)_p==a(2*i+1)_p
        a(2*i+1)_p==b
        extend heap(a, 2*i+1, j)
      finish
    end

    routine  sort(record (pnamef)arrayname  a, integer  last)
    integer  n
    record (pf)name  c
      return  if  last<=1
      n=1
      n=2*n while  2*n<last
    !  Make heap.
      extend heap(a, n, last) for  n=n-1,- 1,1
    !  Complete Ordering.
      for  n=last, -1 , 2 cycle
        c==a(n)_p
        a(n)_p==a(1)_p
        a(1)_p==c
        extend heap(a, 1, n-1)
      repeat
    end

    routine  sort phrases
    record (pf)name  p
    integer  i, last, n
      p==head phrase
      i=0
      while  p##nillp cycle
        i=i+1
        p==p_next
      repeat
      last=i

    begin
    record (pnamef)array  a(0:last)
      p==head phrase
      for  i=1, 1, last cycle
        a(i)_p==p
        p==p_next
      repeat
      sort(a, last)
      head phrase==a(1)_p
      for  i=1, 1, last-1 cycle
        a(i)_p_next==a(i+1)_p
      repeat
      a(last)_p_next==nillp
    end     ;! Of block.

    end     ;!  Of Sort Phrases

    routine  sort phrase names(record (qlistf)name  head phrase)
    integer  i, last, n
    record (qf)name  p
      p==head phrase_head
      i=0
      while  p##nillq cycle
        i=i+1
        p==p_next
      repeat
      last=i

    begin
    record (pnamef)array  a(0:last)
      p==head phrase_head
      for  i=1, 1, last cycle
        a(i)_p==p_p
        p==p_next
      repeat
      sort(a, last)
    !  The list dependant from Head Phrase is till of the rightr length for use.
    !  It needs its pnames to be pointed at the right ps.
      p==head phrase_head
      for  i=1, 1, last cycle
        p_p==a(i)_p
        p==p_next
      repeat
    end     ;! Of block.

    end     ;!  of Sort Phrase Names.

    routine  print directives
    record (pf)name  p
    string (255) x
    integer  empty, i, k, l, oldout
    !  Find space to leave to left of arrow.
      p==head phrase
      k=0
      while  p##nillp cycle
        l=length(p_s)
        k=l if  k<l
        p==p_next
      repeat
      k=k+5
      l=arrowtip
      arrowtip=k if  arrowtip<k
    !  Directives in the grammar.
      if  terminator#nl thenstart
        print string(".terminator=".tostring(terminator))
        newline
      finish
      if  spelide=yes thenstart
        x=".Elide "
        if  spall=yes then  x=x."all " else  x=x."multiple "
        x=x."spaces"
        print string(x)
        newline
      finish
      if  addletts#"" thenstart
        print string(".addletters ".addletts)
        newline
      finish
      if  delletts#"" thenstart
        print string(".removeletters ".delletts)
        newline
      finish
      if  aliaslower=yes then  print string(".lower".snl) else  c
      if  aliasupper=yes then  print string(".upper".snl)
    !  Built-in-phrases.
      if  bipflags#0 thenstart
        empty=yes
        spaces(arrowtip-17)    ;!  Length of "builtinphrase"=13
        print string("Builtinphrase -> ")
        if  bipflags&integerflag#0 thenstart
          empty=no
          print string("Integer")
          p==phr("integer")
          p_done=0
        finish
        if  bipflags&nameflag#0 thenstart
          if  empty=no then  print string(alt separator) else  empty=no
          print string("Name")
          p==phr("name")
          p_done=0
        finish
        if  bipflags&wordflag#0 thenstart
          if  empty=no then  print string(alt separator) else  empty=no
          print string("Word")
          p==phr("word")
          p_done=0
        finish
        if  bipflags&stringflag#0 thenstart
          if  empty=no then  print string(alt separator) else  empty=no
          print string("String")
          p==phr("string")
          p_done=0
        finish
        if  bipflags&symbolflag#0 thenstart
          if  empty=no then  print string(alt separator) else  empty=no
          print string("Symbol")
          p==phr("symbol")
          p_done=0
        finish
        if  bipflags&markflag#0 thenstart
          if  empty=no then  print string(alt separator) else  empty=no
          print string("Marker")
          p==phr("marker")
          p_done=0
        finish
        newline
      finish
    end

    routine  print grammar alphabetically
    record (pf)name  p
    string (255) x
    integer  ct, empty, i, k, l, oldout
      select output(1)
      alphabetical=yes; levels=no
      print directives
    !  Sort Phrases into alphabetical order.
      sort phrases
    !  Print productions.
      p==head phrase
      ct=1
      cycle
    ! Print line-number.
        write(ct, 3); space
        ct=ct+1
        print production(p, 5)
        p==p_next
        exit  if  p==nillp
      repeat
      newline
      alphabetical=no; levels=no
      print string(".end".snl.snl.grammarname.snl.snl)
    end

    routine  print grammar by levels
    record (pf)name  p
    record (qf)name  q, r
    string (255) x
    integer  empty, i, k, l, oldout
      select output(1)
      alphabetical=no; levels=yes
      print directives
    !  Print productions.
      level=0
      level1_head==nillq; level1_tail==nillq
      p==root phrase
      return  if  p==nillp
      q==newq
      q_p==root phrase
      append cell(q, level1)
      while  level1_head##nillq cycle
        print string("Level ".itod(level).snl)
        level=level+1
        level2_head==level1_head; level2_tail==level1_tail
        level1_head==nillq; level1_tail==nillq
        sort phrase names(level2)
        q==level2_head
        while  q##nillq cycle
          if  q_p==nillp then  print string("*** MISSING PRODUCTION ***".snl) c
          else  c
          if  q_p_type<=127 then   print production(q_p, 0)
    !  String of Item, called from Print Production, puts phrase names on
    !  list Level1.
          q==q_next
        repeat
        newline
    !  Delete list of phrases done.
        delete list(level2)
      repeat
      alphabetical=no; levels=no
    !  Clear donemarkers.
      p==head phrase
      while  p##nillp cycle
        p_done=-1
        p==p_next
      repeat
      print string(".end".snl.snl.grammarname.snl.snl)
    end

    !  This skips spaces within names, which are otherwise of Imp type.
    !  This leaves the terminating " or nl or + or | in the input stream.
    !  It converts case as prescribed.

    routine  read name(string (*)name  a)
    integer  j
      skip symbol while  next symbol=sp or  next symbol=nl
      a=""
      j=next symbol
      while  'a'<=j<='z' or  'A'<=j<='Z' or  '0'<=j<='9' c
      or  j=' ' or  j='.' or  j='?' cycle
        skip symbol
    !  Omit spaces.
        a=a.tostring(j) unless  j=' '
        j=next symbol
      repeat
    !  Convert if prescribed.
      if  aliaslower=yes then  a=lower(a) else  c
      if  aliasupper=yes then  a=upper(a)
    end

    routine  read word(string (*)name  a)
    integer  j
      skip symbol while  next symbol=sp
      a=""
      while  'a'<=next symbol<='z' or  'A'<=next symbol<='Z' cycle
        read symbol(j)
        a=a.tostring(j)
      repeat
    end

    !  This converts case as prescribed.

    routine  read atom(string (*)name  a)
    integer  j
    string (255) s
      return  unless  next symbol='"'
      skip symbol    ;! Get rid of leading string quote.
      a=""
      cycle
        read symbol(j)
        if  j=quote thenstart
          exit  unless  next symbol=quote
          read symbol(j)
        finish
        a=a.tostring(j)
      repeat
    !  Delete spaces if there is anything else.
      s=a
      remove spaces(s)
    !  Convert as prescribed.
      if  aliaslower=yes then  a=lower(a) else  c
      if  aliasupper=yes then  a=upper(a)
    end

    !  This skips leading spaces and newlines
    !  It does not read the terminating newline of a line of text.

    routine  read line(string (*)name  a)
    integer  i
      skip symbol while  next symbol=sp or  next symbol=nl
      a=""
      cycle
        exit  if  next symbol=nl
        read symbol(i)
        a=a.tostring(i)
      repeat
    end

    !  This reads up to NL and skips it if the terminator=NL.
    !  It reads up to NL and skips it if the first character of the text is '.'.
    !  In other cases it reads up to the terminator and skips it.
    !  It converts case as prescribed.

    externalstring (255)fn  fill buffer(integer  terminator)
    integer  i, flag, j
    string (255) s
      skip symbol c
      while  next symbol=sp or  next symbol=nl or  next symbol=terminator
      if  next symbol='.' or  next symbol='?' thenstart
        s=""
        while  next symbol#nl cycle
          read symbol(j)
          s=s.tostring(j)
        repeat
        skip symbol
        result =s
      finish
      text(i)=0 for  i=0, 1, maxtexts
      textlength=0
      flag=no
      for  i=1, 1, maxtexts cycle
        flag=yes and  exit  if  (text(1)='.' and  next symbol=nl) c
        or  (text(1)='?' and  i=2 and  next symbol=nl) or  next symbol=terminator
        read symbol(j)
    !  Case conversion.
        text(i)=alias(j)
      repeat
      if  flag=yes thenstart
        skip symbol              ;!  Get rid of terminator or nl.
        textlength=i-1
        i=textlength
        i=i-1 while  i>0 and  (text(i)=nl or  text(i)=sp)
        textlength=i
        if  textlength<=255 then  text(0)=textlength else  text(0)=255
        result =""
      finish
      s="Text too long for buffer.".snl
      text(0)=73
      text(i)='.' for  i=71, 1, 73
      s=s.string(addr(text(0)))
      message(s, "stop")
    end

    string (*)map  plant string(string (255) s)
    integer  i
    string (255) b
    !  returns a pointer to the string if it is already known.
    !  else inserts the string and returns a pointer to it.
      if  strno<0 thenstart
        for  i=strno, 1, -1 cycle
          result ==str(i)_n if  str(i)_n=s
        repeat
      finish
      strno=strno-1
      str(strno)_n==string(new(b))
      str(strno)_n=s
      result ==str(strno)_n
    end

    integerfn  plant phrase(string (255) s)
    record (pf)name  p
    record (pf) q
    !  finds phrase if already recorded.
      p==head phrase
      while  p##nillp cycle
        result =addr(p) if  p_s=s
        p==p_next
      repeat
    !  phrase not already planted.
      q_next==nillp
      q_alt==nilla
      q_s==plant string(s)
      q_type=1
      new phrase(q)
      result =addr(last phrase)
    end

    routine  read lhs
    string (255) s, t, u
    integer  flag, j
    !  The loop is used so that Help can be requested.
      cycle
        prompt("Phrase-name: ")
        read name(phrase)
        s=lower(phrase)
        phrase=s
    !  Excise spaces.
        s=t.u while  s->t.(" ").u
        return  if  (s->t.(".").u and  t="") or  s="builtinphrase"
        h(helpfile.", phrase") and  continue  if  s="?"
        h(helpfile) and  continue  if  s="help"
        skip symbol while  next symbol=sp or  next symbol=nl
        if  next symbol='-' thenstart
          skip symbol
          skip symbol and  exit  if  next symbol='>'
        finish
        message("After last phrase name=".last phrase_s.snl. c
        "No -> after phrase-name '".phrase."', try again", "")
        list strings("Strings read in grammar so far.")
        print grammar by levels
        stop
      repeat
      current phrase==record(plant phrase(phrase))
    end

    routine  read item
    integer  flag, i, j
    record (if) q
    string (255) s
    !  This lowers all items except atoms.
      q_next==nilli
      skip symbol while  next symbol=sp
    !  type=0 for atom, type=1 for phrase not built-in,
    !  type>=128 for built-in phrase.
      cycle
    !  This is inside a loop so that Help can be requested.
        if  next symbol='"' thenstart
          q_type=0
          read atom(item)
          q_s==plant string(item)
        finishelsestart
          read name(item)
          s=lower(item)
          item=s
          h(helpfile) and  continue  if  s="?" or  s="help"
          q_phrase==record(plant phrase(item))
          q_type=q_phrase_type
        finish
        exit
      repeat
    !  Plant item.
      new item(q)
    end

    routine  set up bip(integer  number, string (255) phrase)
    record (if) q
      current phrase==record(plant phrase(phrase))
      current phrase_type=number+128
      current phrase_alt==nilla
    !  set up record for alternative.
      new alt(1)
    !  set up record for item.
      q_type=number+128
      q_phrase==current phrase
      q_next==nilli
      new item(q)
    end

    routine  set up bips(integer  flags)
      set up bip(integerflag, "integer") if  flags&integerflag=integerflag
      set up bip(nameflag, "name") if  flags&nameflag=nameflag
      set up bip(wordflag, "word") if  flags&wordflag=wordflag
      set up bip(stringflag, "string") if  flags&stringflag=stringflag
      set up bip(symbolflag, "symbol") if  flags&symbolflag=symbolflag
      set up bip(markflag, "marker") if  flags&markflag=markflag
    end

    routine  read bipflags
    string (255) x
      bipflags=0
      cycle
        skip symbol while  next symbol=sp
        exit  if  next symbol=nl
        read word(x)
        x=lower(x)
        if  x="name" then  bipflags=bipflags+nameflag else  c
        if  x="word" then  bipflags=bipflags+wordflag else  c
        if  x="string" then  bipflags=bipflags+stringflag else  c
        if  x="symbol" then  bipflags=bipflags+symbolflag else  c
        if  x="marker" then  bipflags=bipflags+markflag else  c
        if  x="integer" then  bipflags=bipflags+integerflag else  c
        message(x." is not a Built-in Phrase", "stop")
        skip symbol while  next symbol=sp
        exit  unless  tostring(next symbol)=alt separator
        skip symbol
      repeat
    end

    routine  read alt(integername  altno)
      altno=altno+1
    !  set up record for next alternative.
      new alt(altno)
      cycle
        prompt("Item: ")
        read item
        skip symbol while  next symbol=sp
        exit  unless  tostring(next symbol)=item separator
        skip symbol    ;!  Get rid of Item separator.
        skip symbol while  next symbol=sp or  next symbol=nl
      repeat
    end

    externalstringfn  obey command(string (255) v)
    integer  flag, i
    string (255) u, w
      w=lower(v)
    !  Remove spaces from command.
      w=u.v while  w->u.(" ").v
    !  Case analysis
      if  w->v.(".addletters").u and  v="" thenstart
        u=u.v while  u->u.(tostring(nl)).v
        letter(charno(u, i))=yes for  i=1, 1, length(u)
        addletts=u
        result ="continue"
      finish
      if  w->v.(".removeletters ").u and  v="" thenstart
        u=u.v while  u->u.(tostring(nl)).v
        letter(charno(u, i))=no for  i=1, 1, length(u)
        delletts=u
        result ="continue"
      finish
      if  w->v.(".resetletters ").u and  v="" thenstart
        letter(i)=no for  i=0, 1, 255
        letter(i)=yes for  i='A', 1, 'Z'
        letter(i)=yes for  i='a', 1, 'z'
        addletts=""; delletts=""
        result ="continue"
      finish
      if  w=".help" then  h(helpfile) else  c
      if  w="?" then  h(helpfile.", commands") else  c
      if  w->v.("indent=").u then  level indent=dtoi(u) else  c
      if  w=".listanalysis" then  list analysis("", anrec, ap) else  c
      if  w=".listgrammar" then  list grammar("") else  c
      if  w=".listlex" then  list lex(maxlex) else  c
      if  w=".liststrings" then  list strings("") else  c
      if  w=".lower" thenstart
        aliaslower=yes
        alias(i)=lowercase(i) for  i=0, 1, 255
        str(i)_n=lower(str(i)_n) for  i=-1, -1, 255
      finishelse  c
      if  w=".noalias" thenstart
        alias(i)=i for  i=0, 1, 255
        aliaslower=no
        aliasupper=no
      finishelse  c
      if  w=".noreport" then  reportt=no else  c
      if  w=".outputparse" then  put out parse("") else  c
      if  w=".output" then  output grammar("") else  c
      if  w->(".printgrammar").u thenstart
        if  u->("alpha").u then  print grammar alphabetically c
        else  print grammar by levels
      finishelse  c
      if  w=".printparse" then  print parse("") else  c
      if  w=".sortgrammar" then  sort phrases else  c
      if  w->(".terminator=").u thenstart
        if  u="" then  terminator=nl else  terminator=charno(u, 1)
      finishelse  c
      if  w->(".trace=").u thenstart
        flag=no
        u=lower(u)
        traceflags=0
        if  u->("atoms").v or  u->("phrases").v or  u->("bips").v thenstart
          if  u->v.("atoms").u thenstart
            u=v.u
            traceflags=traceflags!atraceflag
            flag=yes
          finish
          if  u->v.("bips").u thenstart
            u=v.u
            traceflags=traceflags!btraceflag
            flag=yes
          finish
          if  u->v.("phrases").u thenstart
            u=v.u
            traceflags=traceflags!ptraceflag
            flag=yes
          finish
        finish
        if  u="all" then  traceflags=16_f and  flag=yes else  c
        if  u="none" then  traceflags=0 and  flag=yes
        message("The RHS is not recognised in .trace=".u," ") if  flag=no
      finishelse  c
      if  w=".upper" thenstart
        aliasupper=yes
        alias(i)=uppercase(i) for  i=0, 1, 255
        str(i)_n=upper(str(i)_n) for  i=-1, -1, strno
      finishelse  c
      if  w=".word" then  print string(string(addr(text(0))).snl)  else  c
      if  w=".report" then  reportt=yes else  c
      if  w=".end" then  result =end else  c
      if  w->(".elide").u thenstart
        spelide=yes
        if  u->("all").u then  spall=yes else  spall=no
      finishelse  message(w." is not recognised as a command.", "")
      result ="continue"
    end

    routine  read production
    string (255) x, y
    integer  altno, i, j
      read lhs
    !  Test for command. Obey it if found.
      x=lower(phrase)
      x=x.y while  x->x.(" ").y
      if  length(x)>0 and  charno(x, 1)='.' thenstart
        return  if  x=end
        read symbol(j)
        while  j#nl cycle
          x=x.tostring(j)
          read symbol(j)
        repeat
        x=obey command(x)
        return
      finish
      first=no
      if  x="builtinphrase" thenstart
        skip symbol while  next symbol=sp
        message("Faulty format of 'Builtinphrase", "stop") unless  next symbol='-'
        skip symbol
        message("Faulty format of 'Builtinphrase", "stop") unless  next symbol='>'
        skip symbol    ;!  Skip arrow.
        read bipflags
        bipflagsread=yes
        set up bips(bipflags)
      finishelsestart
        altno=0
        cycle
          read alt(altno)
          exit  unless  tostring(next symbol)=alt separator
          skip symbol    ;!  Get rid of Alt separator.
    !  Skip spaces and newlines after Alt Separator.
          skip symbol while  next symbol=sp or  next symbol=nl
        repeat
        root phrase==current phrase if  phrase="root"
      finish
    end

    routine  clear anrecs
    integer  i
      anrec(i)=0 and  bnrec(i)=0 for  i=0, 1, maxanrecs
      ap=0; maxap=0
    end

    externalroutine  start parser
    integer  i
      alias(i)=i for  i=0, 1, 255
      aliaslower=no; aliasupper=no
      alphabetical=no; levels=no
      clear anrecs
    end

    routine  start lists
    integer  i
    string (*)name  s
    record (parsef) n
    record (pf) ppattern
    record (af) apattern
    record (if) ipattern
      start heap
      strno=0
      nills==plant string("nill")
      str(i)_n==nills for  i=-2, -1, -maxstr
      anrec(i)=0 for  i=0, 1, maxanrecs
      first=yes
    ! set up initial pointers.
      current phrase==nillp; head phrase==nillp; last phrase==nillp
      last alt==nilla
      last item==nilli
    !  current phrase==record(plant phrase("root"))
      level1_head==nillp; level1_tail==nillp
      level2_head==nillp; level2_tail==nillp
    end

    routine  mark grammar by levels
    record (af)name  a
    record (if)name  i
    record (pf)name  p
    record (qf)name  q, r
      level1_head==nillq; level1_tail==nillq
      p==root phrase
      return  if  p==nillp
      q==newq
      q_p==root phrase
    !  Mark root phrase as used.
      q_p_done=q_p_done!8
      append cell(q, level1)
      while  level1_head##nillq cycle
        level2_head==level1_head; level2_tail==level1_tail
        level1_head==nillq; level1_tail==nillq
        q==level2_head
        while  q##nillq cycle
          a==q_p_alt
          while  a##nilla cycle
            i==a_item
            while  i##nilli cycle
              if  i_type=1 thenstart
                if  i_phrase_done&8=0 thenstart
                  i_phrase_done=i_phrase_done!8
                  r==newq
                  r_p==i_phrase
                  append cell(r, level1)
                finish
              finish
              i==i_next
            repeat
            a==a_next
          repeat
          q==q_next
        repeat
    !  Delete list of phrases done.
        delete list(level2)
      repeat
    end

    routine  check grammar
    !  p_done=0 if no failures.
    !  p_done&1=1 if an Alt missing.
    !  p_done&2=2 if an item missing.
    !  p_done&8=8 if phrase defined but not used.
    integer  altno
    record (af)name  a
    record (pf)name  p
    record (if)name  q
    integer  res
      p==head phrase
      while  p##nillp cycle
        p_done=0
        p==p_next
      repeat
    !  Look for undefined phrases and alts.
      p==head phrase
      while  p##nillp cycle
        altno=1
        a==p_alt
        p_done=p_done!1 if  a==nilla
        while  a##nilla cycle
          q==a_item
          p_done=p_done!2 if  q==nilli
          a==a_next
        repeat
        p==p_next
      repeat
    !  Mark used phrases.
      mark grammar by levels
    !  Report any undefined or unused objects.
      res=0
      p==head phrase
      while  p##nillp cycle
        p_done=p_done!!8
        if  p_done&1=1 thenstart
          print string(p_s." lacks Alternative ".itod(altno))
          newline
        finish
        if  p_done&2=2 thenstart
          print string("Alternative ".itod(altno)." of ".p_s. c
          " lacks items.")
          newline
        finish
        if  p_done&8=8 and  p_s#"root" and  p_type=1 thenstart
          print string("Phrase ".p_s." is defined but not used.")
          newline
        finish
        res=res!p_done if  p_type=1
        p==p_next
      repeat
      stop  if  res&(\8)#0
    !  Clear done markers.
      p==head phrase
      while  p##nillp cycle
        p_done=-1
        p==p_next
      repeat
    end

    externalroutine  read grammar(integername  nogrammar)
    !  The grammar must contain a production for the phrase 'root'.
    !  It may contain a production of the form:-
    !  builtinphrase->integer|name|word|string|symbol|marker
    !  in which any of these named items may be absent.
    !  The alternatives present indicate which built-in phrases are to be used.
    !  Every Phrase must have at least one Alternative.
    !  Every Alternative must have at least one Item.
    !  The grammar must end with the line  .end

    integer  j
    record (pf)name  p
    record (af)name  a
    record (if)name  i

      State("Reading Grammar.")
      first=yes; nogrammar=no
      current phrase==nillp
      head phrase==nillp; last phrase==nillp
      root phrase==nillp
    !  Defaults for elision of spaces.
      spall=yes; spelide=yes
      start lists
      bipflagsread=no
      cycle
        read production
      repeat  until  phrase=end
      read line(grammarname)
      nogrammar=yes and  return  if  first=yes    ;!  No grammar.
    !  Defaults for BIPflags=Integer, Name, String, Symbol.
      bipflags=integerflag+nameflag+stringflag+symbolflag c
      and  bipflagsread=yes and  set up bips(bipflags) if  bipflagsread=no
    !  Correct types of items pointing at phrases.
      p==head phrase
      while  p##nillp cycle
        a==p_alt
        while  a##nilla cycle
          i==a_item
          while  i##nilli cycle
            i_type=i_phrase_type if  i_type=1
            i==i_next
          repeat
          a==a_next
        repeat
        p==p_next
      repeat
      state("Grammar Read.")
      check grammar
    end

    externalroutine  destroy grammar
    record (pf)name  p, q
    record (af)name  a, b
    record (if)name  i, j
    integer  n
    !  Get rid of phrases, their alternatives and the items of those.
      p==head phrase
      while  p##nillp cycle
        a==p_alt
        while  a##nilla cycle
          i==a_item
          while  i##nilli cycle
            j==i
            i==i_next
            dispose(j)
          repeat
          b==a
          a==a_next
          dispose(b)
        repeat
        q==p
        p==p_next
        dispose(q)
      repeat
    !  Get rid of strings.
      dispose(str(n)) for  n=1, 1, strno
    end

    routine  error(string (255) s)
      print grammar by levels
      message(s, "mon")
    end

    integerfn  compare atom(integername  lp, record (if)name  i,
    record (parsef)name  ar)
    !  This assumes that an atom of the grammar will match a number of complete
    !  lexical items.
    integer  j, k, l, m, oldlp
    string (255) xxx

      if  traceflags&atraceflag#0 thenstart
        xxx=""
        xxx=xxx.tostring(text(j)) for  j=buff(lp)_first, 1, buff(lp)_last
        xxx="Level ".itod(level)." Compare  Atom: ". c
        i_s." with ".xxx." at ".itod(buff(lp)_first)
        trace(xxx)
      finish
      xxx=itod(level)." Atom ".i_s
      m=0; oldlp=lp
      if  i_s="" thenstart
    !  Null atom matches everything.
        ar_tp2=ar_tp1-1
        xxx="Null atom:"
        trace(xxx."  Yes") if  traceflags&ptraceflag#0
        result =yes
      finishelsestart
        j=1; l=buff(lp)_first; m=0
        cycle
    !  Compare a lexical item.
          unless  text(l)=charno(i_s, j) thenstart
            trace(xxx."  No") if  traceflags&atraceflag#0
            result =no
          finish
          j=j+1
          exit  if  j>length(i_s)
          l=l+1
    !  Move to next lexical item if this one is exhausted.
          if  l>buff(lp+m)_last thenstart
            m=m+1
            if  lp+m>maxlex thenstart
              trace(xxx."  No") if  traceflags&atraceflag#0
              result =no
            finish
            l=buff(lp+m)_first
          finish
        repeat
    !  Atom does not match unless end of lexical item has been reached exactly.
        unless  l=buff(lp+m)_last thenstart
          trace(xxx."  no") if  traceflags&atraceflag#0
          result =no
        finish
    !  adjust lp to next lexical item.
        lp=lp+m+1
    !  plant position of end of matching text.
        ar_tp2=l
        ar_item==i
        trace(xxx."  Yes") if  traceflags&atraceflag#0
        result =yes
      finish
    end

    integerfn  compare bip(integername  lp, record (if)name  i,
    record (parsef)name  ar)
    integer  j
    string (255) xxx
      if  traceflags&btraceflag#0 thenstart
        xxx=""
        xxx=xxx.tostring(text(j)) for  j=buff(lp)_first, 1, buff(lp)_last
        xxx="level ".itod(level)." Compare Bip: ". c
        i_phrase_s." with ".xxx." at ".itod(buff(lp)_first)
        trace(xxx)
      finish
      xxx=itod(level)." Bip ".i_phrase_s
      if  i_type=buff(lp)_type thenstart
    !  Is a b.i.p. of the right sort.
        ar_tp2=buff(lp)_last
        lp=lp+1
        trace(xxx."  Yes") if  traceflags&btraceflag#0
        result =yes
      finish
    !  not a known built-in-phrase (129 or 130 or 132 or 136).
      trace(xxx."  No") if  traceflags&btraceflag#0
      result =no
    end

    externalroutine  lexiscan(integer  la, integername  lb, integer  flags)
    string (*)name  s
    integer  v
    integer  i, j, p, q
    !  Built-in phrases are marked by a type>128 in buff.
    !  For an integer, type=129 and the value is in v
    !  For a name, type=130, indices of first and last characters are
    !  in buff.
    !  For a word, type=132, indices of first and last characters are
    !  in buff.
    !  For a string, type=136, indices of bounding quotes are in buff.
    !  For a marker for Mairigram ($letter{ or $letter2{ and }), type=160.
    !  For a character, type=144, both indices in buff point at the character.
    !  At the end of the parse, buff_last=buff_first-1.
    !  The source text is assumed to start at text(1).
    !  If required, all spaces will be elided or multiple spaces will be
    !  reduced to one.
    !  The scanned pointers start at buff(1).

      buff(i)=0 for  i=0, 1, maxbuffs
      spcount=0; valno=0
      p=1; q=1
      while  p<=la and  q<=maxbuffs cycle
    !  Elide newlines.
        if  text(p)=nl then  p=p+1 and  continue  else  c
        if  text(p)=sp and  spelide=yes thenstart
    !  Elide spaces.
          spcount=spcount+1
          if  spall=yes then  p=p+1 and  continue  else  c
          if  spcount>=2 then  p=p+1 and  continue
        finishelse  spcount=0
        buff(q)_first=p
        if  markflag&bipflags=markflag and  (text(p)='}' or  c
          (text(p)='$' and  ( text(p+2)='{' or  text(p+3)='{'))) thenstart
    !  Markers are built-in phrase 160 for Mairis's Grammar, e.g. $XX{, $PP{ etc.
          buff(q)_type=128+markflag
          buff(q)_first=p
          if  text(p)='$' thenstart
            if  text(p+2)='{' then  p=p+3 else   p=p+4
          finishelse  p=p+1
        finishelse  c
        if  flags&nameflag=nameflag c
        and  ('a'<=text(p)<='z' or  'A'<=text(p)<='Z') thenstart
    !  names are built-in-phrase 130.
          buff(q)_type=128+nameflag
          p=p+1 while  p<=la and  ('a'<=text(p)<='z' or  'A'<=text(p)<='Z' c
          or  '0'<=text(p)<='9')
        finishelse  c
        if  flags&integerflag=integerflag and  '0'<=text(p)<='9' thenstart
    !  integers are built-in phrase 129.
          buff(q)_type=128+integerflag
          v=0
          while  p<=la and  '0'<=text(p)<='9' cycle
            v=10*v+text(p)-'0'
            p=p+1
          repeat
          valno=valno+1
          val(valno)=v
          buff(q)_v=valno
        finishelse  c
        if  flags&wordflag=wordflag c
        and  letter(text(p))=yes thenstart
    !  Words are built-in phrase 132.
          buff(q)_type=128+wordflag
          p=p+1 while  p<=la and  letter(text(p))=yes
        finishelse  c
        if  flags&stringflag=stringflag and  text(p)=quote thenstart
    !  Strings are built-in phrase 136.
          p=p+1    ;! skip leading quote.
          buff(q)_type=128+stringflag
          while  p<=la cycle
            if  text(p)=quote thenstart
              p=p+1
              exit  if  text(p)#quote
            finish
            p=p+1
          repeat
        finishelsestart
    !  Symbols are built-in phrase 146.
          buff(q)_type=128+symbolflag
          buff(q)_first=p
          p=p+1
        finish
        buff(q)_last=p-1
        q=q+1
      repeat
      lb=q-1
    !  Plant dummy record at end of lexical records.
      buff(q)_first=buff(lb)_last+1; buff(q)_last=buff(q)_first-1
      buff(q)_type=255
    end

    integerfn  compare phrase(string (15) fun)
    integer  flag, j, k, res
    record (af)name  a
    record (parsef)name  ar
    record (if)name  i
    record (pf)name  p
    string (255) xxx

      if  fun="start" thenstart
        level=0
        current phrase==root phrase
        current alt==nilla
        current item==nilli
      finishelse  -> start1

    start:
      error("No cases for phrase ".current phrase_s) if  current phrase_alt==nilla
      if  traceflags&ptraceflag#0 thenstart
        xxx=""
        xxx=xxx.tostring(text(j)) for  j=buff(lp)_first, 1, buff(lp)_last
        xxx="Level ".itod(level)." Comparing Phrase ". c
        current phrase_s." with ".xxx." at ".itod(buff(lp)_first)
        trace(xxx)
      finish
    !  Plant record for phrase.
      ar==newanrec('p', lp)
    !  Set first alternative.
      current alt==current phrase_alt
      ar==newanrec('a', lp)

    start1:
      level=ar_level+1
      lp=ar_lp
    !  Set first item, plant record.
      current item==current alt_item

    compare:
    !  Compare.
      ar==newanrec('i'+current item_type<<8, lp)
      if  current item_type=0 thenstart
    !  Atom.
        res=compare atom(lp, current item, ar)
      finishelse  c
      if  current item_type&16_ff>=128 thenstart
    !  Built-in Phrase.
        res=compare bip(lp, current item, ar)
      finishelsestart
        current phrase==current item_phrase
        current alt==current phrase_alt
        current item==current alt_item
        ->start
      finish

    back:
    !  Plant copy of analysis if it deals with largest part of string to date.
      if  maxlp<lp thenstart
        if  res=yes then  maxap=ap else  maxap=ap-1
        bnrec(j)=0 for  j=maxap, -1, ap
        bnrec(j)=anrec(j) for  j=1, 1, ap
        maxlp=lp-1    ;!  Lp points at first unmatched lexical item.
      finish
    !  Reset current values.
      level=anrec(ap)_level
      current item==anrec(ap)_item
      j=ap
      j=j-1 until  anrec(j)_level=level-1 and  anrec(j)_type='a'
      current alt==anrec(j)_alt
      j=j-1
      current phrase==anrec(j)_phrase
      if  res=yes thenstart
    !  Match found.
        anrec(j+1)_tp2=anrec(ap)_tp2
        anrec(j)_tp2=anrec(ap)_tp2
    !  Search for next item.
    !  BIPs and Atoms are in the current item. Phrases are in the next record
    !  and are followed by records for Alt.
    !  If the Current item has no successor, then look back to the beginning of
    !  the alt and look for the successor to the preceding phrase by moving
    !  To the item which points at it.
        j=ap
        while  current item_next==nilli cycle
          j=j-1 until  j=0 or  (anrec(j)_level=level-1 and  anrec(j)_type='a')
          if  j>0 thenstart
            anrec(j)_tp2=anrec(ap)_tp2
            j=j-1    ;!  Move to Phrase.
            if  j>0 thenstart
              anrec(j)_tp2=anrec(ap)_tp2
              j=j-1    ;!  Move to item.
            finish
          finish
          if  j<=0 thenstart
            result =yes if  anrec(ap)_tp2=textlength
            ->nextalt
          finish
          level=level-1
          if  level=0 thenstart
            result =yes if  anrec(ap)_tp2=textlength
            current phrase==anrec(j)_phrase
            current alt==anrec(j+1)_alt_next
            ->nextalt
          finish
          ar==anrec(j)
          current item==ar_item
          current phrase==anrec(j+1)_phrase
          current alt==anrec(j+2)_alt
        repeat
        current item==ar_item_next
        ->compare
      finish
    !  No match.
    nextalt:
    !  Unwind.
      ar==anrec(ap)
      cycle
    !  Back to a record of an alternative. (Must be at an item of some sort.)
        cycle
          ar=0
          ap=ap-1
          result =no if  ap<=0
          ar==anrec(ap)
        repeat  until  ar_type='a'
        current alt==ar_alt
        current item==nilli
    !  Find current phrase, which may have changed.
        j=ap-1
        current phrase==anrec(j)_phrase
        level=ar_level
        if  current alt_next##nilla thenstart
    !  More Alts.
          current alt==current alt_next
          ar_alt==current alt
          ->start1
        finish
      repeat
    end

    externalintegerfn  parse(integer  lb)
    record (qlistf)name  anlist
    record (qf)name  q
    integer  p, i
      message("No text provided.", "") and  result =no unless  lb>0
      message("No Root phrase.", "") and  result =no if  root phrase==nillp
      level=0; maxlevel=0; maxap=0; maxlp=0
      message("No grammar", "") and  result =no if  head phrase==nillp
      maxlex=0
      lexiscan(lb, maxlex, bipflags)
      ap=0; lp=1
      current phrase==root phrase
      i=compare phrase("start")
      lp=lp-1    ;!  lp pointed at the next unscanned lexical item.
      while  lp=maxlex cycle
    !  Match found.
        anno=anno+1
        anlist==newqlist
        for  i=1, 1, ap cycle
          q==newq
          q=anrec(i)
          append cell(q, anlist)
        repeat
        append cell(anlist, analysislist)
        clear anrecs
        compare phrase("next")
      repeat
      result =anno
    end

    externalroutine  parsefail
    integer  i, j
    string (255) x
      i=maxap
      i=i-1 while  i>0 and  bnrec(i)_tp2=0
      i=bnrec(i)_tp2
      print string("Text does not parse beyond |"); newline
      print symbol(text(i)) for  i=1, 1, i
      print string("|")
      print symbol(text(i)) for  i=i+1, 1, textlength
      newline
      j=textlength; j=20 if  j>20
      x=""
      x=x.tostring(text(i)) for  i=1, 1, j
      message (x." does not parse."," ")
    end

    externalroutine  backtrack
    integer  i, j
    record (qlistf)name  qlist
    record (qf)name  q
    string (*)name  t
    string (255) u, v
    integer  flag, i, j, k, listt
      message("No text provided.", "") and  return  if  textlength=0
      i=parse(textlength)
      if  i=0 thenstart
        parsefail
        anrec(j)=bnrec(j) for  j=1, 1, maxap
        ap=maxap
        print parse("")
      finishelsestart
        print string("Text"); newline
        print symbol(text(i)) for  i=1, 1, textlength
        newline
        print string(itod(anno)." Parses")
        j=0
        qlist==analysislist_head
        while  qlist##nillql cycle
          ap=0; j=j+1
          q==qlist_head
          while  q##nillq cycle
            ap=ap+1
            anrec(ap)=q_p
            q==q_next
          repeat
          print parse("Parse ".itod(j))
          qlist==qlist_next
          clear anrecs
        repeat
      finish
    end

    {Main Program}

    !  This expects streams:-  Grammar, Text/Output, Lists.
    !  It puts listings of grammar etc. out on stream 2.

    {!  If Vax.}
    {%begin}
    {%string(255) s}
    !
    !  If Emas-a.
    externalroutine  cfg alias  "c#cfg"(string (255) s)
    !
    integer  nullgrammar
    string (255) x, y
    string (63) phase

      on  event  9 start
        select output(0)
        print string("Input ended in ".phase.snl)
        close
        return
      finish

      helpfile="ecsc03:cfghelp"
      start parser
      cycle
        unless  s="" thenstart
          set default streams(".in, .in/.out, .out")
          streams(s)
          select input(1); select output(1)
          prompt("Grammar: ")
          phase="Reading Grammar"
          read grammar(nullgrammar)
          exit  if  nullgrammar=yes
          select input(2)
          phase="Parsing"
          cycle
            x=""
            cycle
              prompt("Text: ")
              s=fill buffer(terminator) until  s#"" or  textlength>0
              exit  if  s=""
              x=obey command(s)
            repeat  until  x=end
            exit  if  x=end
            h(helpfile.", text") and  continue  if  x="?"
            h(helpfile) and  continue  if  x="help"
            backtrack
          repeat
          destroy grammar
          close
        finish
        streams("")
        select input(0); select output(0)
        prompt("I-O Streams: ")
        cycle
          skip symbol if  next symbol=nl
          read line(s)
          s=lower(s)
          h(helpfile.", I-O") and  s="" and  continue  if  s="?"
          h(helpfile) and  continue  if  s="help"
          exit  if  s=end
          x="" unless  s->x.(", ").y
          x=s if  x="" and  not  s->x.("/").y
          exit  if  x=".in" or  (x#"" and  exists(x)=yes)
          message(x." does not exist. Please try again", "")
        repeat
      repeat  until  s=end
    end

    externalintegerfn  parse up to(integer  terminator)
    string (255) x
      x=""
      cycle
        prompt("Text: ")
        x=fill buffer(terminator) until  x#"" or  textlength>0
        h(helpfile.", text") and  continue  if  x="?"
        h(helpfile) and  continue  if  x=".help"
        exit  if  x=""
        x=obey command(x)
      repeat  until  x=end
      result =no if  x=end
      result =parse(textlength)
    end

    {!  If Vax.}
    {%endofprogram}
    !
    !  If Emas.
    endoffile
    !