! 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
!