	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")
# inkey		P		liefert Keyboard-Zeichen
#
# Idee und Programmierung	A.Herrmann
#
define	VERSION 'Version 1.4 vom 16.08.84'
# (Grammatik ohne Quadranten-Zerlegung)
#
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 15		# max.Anzahl Nonterminals
define TERMAX  6		# max.Anzahl Terminals
define PROMAX 60		# 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  9		# 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,show
#
byte	char,yes,bigyes
byte	inkey			# function; liefert Keyboard-Zeichen
#
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	x1,y1,x2,y2,x3,y3,x4,y4	# Zielpunkt-Koord.
integer	zx,zy			# naechster Zielpunkt
integer	qcnt			# zaehlt Quadranten
#
integer	i,j,k,l			# Laufindizes
#
real	filnam(3)		# String
byte	rep(2)			# encode-Buffer
byte	fmt3(6),fmt4(11)	# Format-Strings
#
data filnam/'TABL','E   ','DTA '/
data fmt3/'(',' ',' ','A','3',')'/
data fmt4/'(','A','5',',',' ',' ','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)
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
]
#
i=teranz-1 ; encode(rep,20) i
fmt4(5)=rep(1) ; fmt4(6)=rep(2)
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,27)
27 format(' Table eingelesen')
#
#	Initialisierung der Datenstrukturen
#
START
inpend=0 ; inppos=1
sstop=1 ; sstack(sstop)=nue(1)
bstop=0 ; error=.false.
#
write(1,30)
30 format(' C  =7')		# Fenster 0 auf 0,0 bis 29,24 und loeschen
write(1,28)
28 format(' Bildschirm-Protokoll ? (Y/N) ')
char=inkey(.true.)
if (char==yes !! char==bigyes) show=.true.
else show=.false.
#
#	Initialisierung des Primitive Extractors
#
call primin(x1,y1,x2,y2,x3,y3,x4,y4,error,show)
if (error) goto EXIT
qcnt=0 ; zx=x4 ; zy=y4
#
#	Parsing
#
repeat
[
# Naechstes Input-Zeichen holen
#
if (inppos>>inpend)
[	repeat
	[	call primex(zx,zy,inpsym,error,show)
		if (error) goto ABORT
		if (inpsym==QUMARK)
		[	qcnt=qcnt+1
#		if (qcnt==1) [ zx=x2 ; zy=y2 ]
#		else if (qcnt==2) [ zx=x3 ; zy=y3 ]
#		else if (qcnt==3) [ zx=x4 ; zy=y4 ]
		]
	] until (inpsym<>QUMARK !! qcnt>=1)
	inpend=inpend+1
	inpstr(inpend)=inpsym
]
inpsym=inpstr(inppos)
if (show) write(1,31) inpsym
31 format(/' PARSER Input: ',a2)
#
# oberstes Stack-Symbol verarbeiten
#
sstsym=sstack(sstop)
if (show) write(1,32) sstsym
32 format(' PARSER Stack: ',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
	]
	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
		]
	]
	#
	# Table Eintrag lesen
	#
	pnr=table(i,j,alter)
	if (show) 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)
	]
	goto NXTSYM
	#
	#	Backtracking
	#
BACKTR	if (show) 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  ***')
if (qcnt<<4)
[	write(1,72)
	72 format(' Continue ? (Y/N) ')
	char=inkey(.true.)
	if (char<>yes && char<>bigyes) goto EXIT
	error=.false.
	repeat
	[	call primex(zx,zy,inpsym,error,show)
		if (.not.error && inpsym==QUMARK)
			[	qcnt=qcnt+1
#			if (qcnt==1) [ zx=x2 ; zy=y2 ]
#			else if (qcnt==2) [ zx=x3 ; zy=y3 ]
#			else if (qcnt==3) [ zx=x4 ; zy=y4 ]
			]
	] until (error !! qcnt>=1)
]
#
#	Ende bzw. Restart
#
EXIT	write(1,80)
80 format('0PARSER - Restart ? (Y/N) ')
char=inkey(.true.)
if (char==yes !! char==bigyes) goto START
#
write(1,90)
90 format(' *** PARSER - Ende ***'/)
write(1,98)
98 format(' C  o7')			# Fenster 0 auf 0,0 bis 79,24
#
end


	logical function inkey(wait)
#
# Falls wait=true,  wird auf ein Eingabezeichen vom Keyboard gewartet.
# Falls wait=false, wird getestet, ob ein Keyboard-Zeichen anliegt.
#		    Falls nicht, wird 0, sonst das Zeichen uebergeben.
#
logical	wait		# auf Eingabe warten/nicht warten
byte	b		# Byte
byte	cport,dport	# Keyboard Ports (Sio-B)
byte	inp		# internal function
#
data cport,dport/7,5/
#
repeat
[	b=inp(cport) ; b=mod(b,2) ]
until (b==1 !! .not.wait)
if (b==1) inkey=inp(dport)
else inkey=0
end
