	program parser
#
# Verwendete Routinen, die nicht in FORLIB sind:
# Name		File,Bibliothek
# primin	PRIMIN		initialisiert den "Prim.Extractor"
# primex	PRIMEX		liefert den Input ("Prim.Extractor")
#
# Idee und Programmierung	A.Herrmann
#
define	VERSION 'Version 1.0 vom 23.07.84'
#
#
definelist 990	START NXTSYM BACKTR ABORT EXIT	# Labels
definelist 1	REST MOMA SYMB IPOS SPOS	# Backtrack-Eintraege
#
define LUN 6			# Disk unit
define DRIVE 0			# Default drive
#
define BUFMAX 20		# max.Anzahl Symbole im Input-Buffer
define NTEMAX 28		# max.Anzahl Nonterminals
define TERMAX  6		# max.Anzahl Terminals
define PROMAX 59		# max.Anzahl Produktionen
define PROLNG 30		# max.Anzahl von Zeichen in Prod.
define ALTMAX  7		# max.Anzahl Prod'alternativen
define INPMAX 20		# max.Anzahl Zeichen im Inputstring
define SSTMAX 20		# max.Anzahl Eintraege im Symbolstack
define BSTMAX  5		# max.Anzahl Eintraege im Backtrack-Stack
#
define BLANKS x'2020'		# Blanks
define QUMARK x'2B2B'		# Quadrant-Marker
define EMPTY x'202E2E2E'	# leerer Table-Eintrag
#
logical	found,error
#
byte	char,yes,bigyes
#
integer	nteanz,			# Anzahl der Nonterminals,
	teranz,			#	     Terminals,
	proanz,			#	     Produktionen,
	altanz(NTEMAX)		#	     Alternativen
integer	nue(NTEMAX),		# Nonterminals
	sigma(TERMAX)		# Terminals
integer	probuf(10)		# Produktion (String)
integer	prod(PROMAX,10)		# rechte Seite der Produktionen
integer	rhsanz(PROMAX)		# Anz.der Symbole auf der rechten Seite
#
real	pnr,prodnr(PROMAX)		# Prod'nummern (String)
real	table(NTEMAX,TERMAX,ALTMAX)	# Parse Table aus Prod'nummern
#
integer	alter			# mom.Alternative
integer	inppos,inpend,		# Input-Position und -Ende
	sstop,			# Top of Symbol-Stack
	bstop			# Top of Backtrack-Stack
integer	inpstr(INPMAX),		# Input String
	sstack(SSTMAX),		# Symbol-Stack
	bstack(BSTMAX,5)	# Backtrack-Stack
integer	bufpos,buflen,		# Position und Laenge im
	buffer(BUFMAX)		# Input Buffer
integer	inpsym,sstsym		# Input-Symbol, Stack-Symbol
integer	i,j,k,l
#
real	filnam(3)		# String
byte	rep(2)			# encode-Buffer
byte	fmt3(6),fmt4(6)		# Format-Strings
#
data filnam/'TABL','E   ','DTA '/
data fmt3/'(',' ',' ','A','3',')'/
data fmt4/'(',' ',' ','A','4',')'/
data yes,bigyes/'y','Y'/
#
#
write(1,10)
10 format('1PARSER - ',VERSION,/)
#
#	Grammatik und Parse Table einlesen
#
call open(LUN,filnam,DRIVE)
#
read(LUN,20) nteanz
encode(rep,20) nteanz
20 format(i2)
fmt3(2)=rep(1) ; fmt3(3)=rep(2)
read(LUN,fmt3) nue
#
write(1,22) nteanz
22 format(i4,' Nonterminals')
write(1,fmt3) nue
#
read(LUN,20) teranz
encode(rep,20) teranz
fmt3(2)=rep(1) ; fmt3(3)=rep(2)
fmt4(2)=rep(1) ; fmt4(3)=rep(2)
read(LUN,fmt3) sigma
#
write(1,24) teranz
24 format(i4,' Terminals')
write(1,fmt3) sigma
#
read(LUN,20) proanz
write(1,25) proanz
25 format(i4,' Produktionen')
do i=1,proanz
[	read(LUN,26) prodnr(i),probuf
	26 format(a5,10 a3)
#write(1,26) prodnr(i),probuf
	l=0
	do j=3,10
	[	if (probuf(j)==BLANKS) break
		l=l+1
		prod(i,l)=probuf(j)
	]
	rhsanz(i)=l		# Anz.der Symbole auf der rechten Seite
]
#
do i=1,nteanz
[	read(LUN,20) alter
	altanz(i)=alter
	do k=1,alter
	[	read(LUN,fmt4) (table(i,j,k),j=1,teranz) ]
]
write(1,29)
29 format(' Table eingelesen')
#
#	Initialisierung der Datenstrukturen
#
START
inpend=0 ; inppos=1
sstop=1 ; sstack(sstop)=nue(1)
bstop=0 ; error=.false.
#
#	Initialisierung des Primitive Extractors
#
call primin(error,bufpos,buflen,buffer)
if (error) goto EXIT
#
#	Parsing
#
repeat
[
# Naechstes Input-Zeichen holen
#
if (inppos>>inpend)
[	call primex(inpsym,error,bufpos,buflen,buffer)
	if (error) goto ABORT
	inpend=inpend+1
	inpstr(inpend)=inpsym
]
inpsym=inpstr(inppos)
write(1,30) inpsym
30 format(' Input-Symbol: ',a2)
#
# oberstes Stack-Symbol verarbeiten
#
sstsym=sstack(sstop)
write(1,32) sstsym
32 format(' Stack-Symbol: ',a2)
i=1 ; found=.false.			# Stack-Symbol terminal?
while (.not.found && i<=teranz)
	if (sstsym==sigma(i)) found=.true.
	else i=i+1
if (found)
	if (inpsym==sstsym)		# Ja. = Stack-Symbol?
	[	if (inpsym==QUMARK)
		[	if (bstop>>0)	bstop=bstop-1
			inpend=0 ; inppos=0
		]
		sstop=sstop-1
		inppos=inppos+1
		write(1,33)
		33 format(' Shift')
	]
	else goto BACKTR		# Nein, also Backtracking.
else
[	i=1 ; found=.false.		# Stack-Symbol nichtterminal
	while (.not.found && i<=nteanz)
		if (sstsym==nue(i)) found=.true.
		else i=i+1
	if (.not.found) goto ABORT
	j=1 ; found=.false.		# Input-Symbol terminal
	while (.not.found && j<=teranz)
		if (inpsym==sigma(j)) found=.true.
		else j=j+1
	if (.not.found) goto ABORT
	#
	# Symbol-Kombination mit Alternativen ?
	#
	if (altanz(i)==1) alter=1
	else
	[	if (bstop==0 !! sstsym<>bstack(bstop,SYMB))
		[	alter=1
			bstop=bstop+1
			bstack(bstop,REST)=altanz(i)-1
			bstack(bstop,MOMA)=alter
			bstack(bstop,SYMB)=sstsym
			bstack(bstop,IPOS)=inppos
			bstack(bstop,SPOS)=sstop
		]
		else
		[	bstack(bstop,REST)=bstack(bstop,REST)-1
			alter=bstack(bstop,MOMA)+1
			bstack(bstop,MOMA)=alter
		]
		write(1,38) alter
		38 format(i4,'.Alternative')
	]
	#
	# Table Eintrag lesen
	#
	pnr=table(i,j,alter)
	write(1,40) i,j,alter,pnr
	40 format(' Eintrag ',3i4,' = ',a4)
	#
	# "Reduce"
	#
	k=1 ; found=.false.
	while (.not.found && k<=proanz)
		if (pnr==prodnr(k)) found=.true.
		else	k=k+1
	if (.not.found) goto BACKTR		# Error-Eintrag ?
	sstop=sstop-1
	for (l=rhsanz(k); l>=1; l=l-1)
	[	sstop=sstop+1
		sstack(sstop)=prod(k,l)
	]
	write(1,42) rhsanz(k)
	42 format(' Reduce: ',i4,' Symbole gepusht')
	goto NXTSYM
	#
	#	Backtracking
	#
BACKTR	write(1,50)
	50 format(' Backtracking...')
	if (bstop==0) goto ABORT
	if (bstack(bstop,REST)==0)
	[	bstop=bstop-1
		goto BACKTR
	]
	inppos=bstack(bstop,IPOS)
	sstop=bstack(bstop,SPOS)
	sstack(sstop)=bstack(bstop,SYMB)
	#
NXTSYM	# weiter mit naechstem Symbol
	#
]
] until (sstop==0)
#
#	Fertig
#
write(1,60)
60 format('0***  Accepted  ***')
goto EXIT
#
#	Abbruch
#
ABORT	write(1,70)
70 format('0***  Not accepted  ***')
#
#	Ende bzw. Restart
#
EXIT	write(1,80)
80 format('0Restart ? (Y/N) ')
read(1,82) char
82 format(a1)
if (char==yes !! char==bigyes) goto START
#
write(1,90)
90 format(' *** PARSER - Ende ***'/)
#
end


	subroutine primin(error,bufpos,buflen,buffer)
#
logical	error
integer bufpos,buflen,buffer(BUFMAX)
#
write(1,10)
10 format(' PRIMIN - Input: ')
read(1,20,err=90,end=90) buffer
20 format(BUFMAX(a2,1x))
#
90 bufpos=1 ; buflen=0
while (buffer(buflen+1)<>BLANKS && buflen<<BUFMAX)
	buflen=buflen+1
write(1,30) buflen
30 format(' Buflen =',i4)
error=.false.
return
end


	subroutine primex(symbol,error,bufpos,buflen,buffer)
#
logical	error
integer	symbol
integer bufpos,buflen,buffer(BUFMAX)
#
if (bufpos>>buflen) error=.true.
else
[	symbol=buffer(bufpos)
	bufpos=bufpos+1
	error=.false.
	write(1,10) symbol
	10 format(' PRIMEX - liefert ',a2)
]
return
end
