zork-fortran/np.for

C RDLINE-	READ INPUT LINE
C
C COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
C ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
C WRITTEN BY R. M. SUPNIK
C
C DECLARATIONS
C
	SUBROUTINE RDLINE(BUFFER,LENGTH,WHO)
	IMPLICIT INTEGER(A-Z)
	CHARACTER BUFFER(78)
	character*78 sysbuf
	include 'parser.h'
	include 'io.h'

5	GO TO (90,10),WHO+1
C						!SEE WHO TO PROMPT FOR.
10	WRITE(OUTCH,50)
C						!PROMPT FOR GAME.
50	FORMAT(' >',$)

90	READ(INPCH,100) BUFFER
100	FORMAT(78A1)

	DO 200 LENGTH=78,1,-1
	  IF(BUFFER(LENGTH).NE.' ') GO TO 250
200	CONTINUE
	GO TO 5
C						!TRY AGAIN.

C
C	check for shell escape here before things are
C	converted to upper case
C
C NO SHELL ESCAPE /*TAA*/

250	CONTINUE
C250	if (buffer(1) .ne. '!') go to 300
C	do 275 j=2,length
C	  sysbuf(j-1:j-1) = buffer(j)
C275	continue
C	sysbuf(j:j) = char(0)
C	call system(sysbuf)
C	go to 5

C CONVERT TO UPPER CASE
300	DO 400 I=1,LENGTH
 	  IF((BUFFER(I).GE.'a').AND.(BUFFER(I).LE.'z'))
     &	BUFFER(I)=char(ichar(BUFFER(I))-32)
400	CONTINUE

	if(LENGTH.EQ.0) GO TO 5
	PRSCON=1
C						!RESTART LEX SCAN.
	RETURN
	END
C PARSE-	TOP LEVEL PARSE ROUTINE
C
C DECLARATIONS
C
C THIS ROUTINE DETAILS ON BIT 0 OF PRSFLG
C
	LOGICAL FUNCTION PARSE(INBUF,INLNT,VBFLAG)
	IMPLICIT INTEGER(A-Z)
	CHARACTER INBUF(78)
	LOGICAL LEX,SYNMCH,VBFLAG
	INTEGER OUTBUF(40)
	include 'debug.h'
	include 'parser.h'
	include 'xsrch.h'
C
D	DFLAG=IAND(PRSFLG,1).NE.0
	PARSE=.FALSE.
C						!ASSUME FAILS.
	PRSA=0
C						!ZERO OUTPUTS.
	PRSI=0
	PRSO=0
C
	IF(.NOT.LEX(INBUF,INLNT,OUTBUF,OUTLNT,VBFLAG)) GO TO 100
	IF(SPARSE(OUTBUF,OUTLNT,VBFLAG)) 100,200,300
C						!DO SYN SCAN.
C
C PARSE REQUIRES VALIDATION
C
200	IF(.NOT.VBFLAG) GO TO 350
C						!ECHO MODE, FORCE FAIL.
	IF(.NOT.SYNMCH(X)) GO TO 100
C						!DO SYN MATCH.
	IF((PRSO.GT.0).AND.(PRSO.LT.XMIN)) LASTIT=PRSO
C
C SUCCESSFUL PARSE OR SUCCESSFUL VALIDATION
C
300	PARSE=.TRUE.
350	CALL ORPHAN(0,0,0,0,0)
C						!CLEAR ORPHANS.
D	if(dflag) write(0,*) 'parse good'
D	IF(DFLAG) PRINT 10,PARSE,PRSA,PRSO,PRSI
D10	FORMAT(' PARSE RESULTS- ',L7,3I7)
	RETURN
C
C PARSE FAILS, DISALLOW CONTINUATION
C
100	PRSCON=1
D	if(dflag) write(0,*) 'parse failed'
D	IF(DFLAG) PRINT 10,PARSE,PRSA,PRSO,PRSI
	RETURN
C
	END
C ORPHAN- SET UP NEW ORPHANS
C
C DECLARATIONS
C
	SUBROUTINE ORPHAN(O1,O2,O3,O4,O5)
	IMPLICIT INTEGER(A-Z)
	COMMON /ORPHS/ A,B,C,D,E
C
	A=O1
C						!SET UP NEW ORPHANS.
	B=O2
	C=O3
	D=O4
	E=O5
	RETURN
	END
C LEX-	LEXICAL ANALYZER
C
C
C THIS ROUTINE DETAILS ON BIT 1 OF PRSFLAG
C
	LOGICAL FUNCTION LEX(INBUF,INLNT,OUTBUF,OP,VBFLAG)
	IMPLICIT INTEGER(A-Z)
	CHARACTER INBUF(78),J,DLIMIT(9)
	INTEGER OUTBUF(40)
	LOGICAL VBFLAG
	include 'parser.h'
C
	include 'debug.h'
C
	DATA DLIMIT/'A','Z','\x40','1','9','\x12','-','-','\x12'/
C
	DO 100 I=1,40
C						!CLEAR OUTPUT BUF.
	  OUTBUF(I)=0
100	CONTINUE
C
D	DFLAG=IAND(PRSFLG,2).NE.0
	LEX=.FALSE.
C						!ASSUME LEX FAILS.
	OP=-1
C						!OUTPUT PTR.
50	OP=OP+2
C						!ADV OUTPUT PTR.
	CP=0
C						!CHAR PTR=0.
C
200	IF(PRSCON.GT.INLNT) GO TO 1000
C						!END OF INPUT?
	J=INBUF(PRSCON)
C						!NO, GET CHARACTER,
	PRSCON=PRSCON+1
C						!ADVANCE PTR.
	IF(J.EQ.'.') GO TO 1000
C						!END OF COMMAND?
	IF(J.EQ.',') GO TO 1000
C						!END OF COMMAND?
	IF(J.EQ.' ') GO TO 6000
C						!SPACE?
	DO 500 I=1,9,3
C						!SCH FOR CHAR.
	  IF((J.GE.DLIMIT(I)).AND.(J.LE.DLIMIT(I+1)))
     &	GO TO 4000
500	CONTINUE
C
	IF(VBFLAG) CALL RSPEAK(601)
C						!GREEK TO ME, FAIL.
	RETURN
C
C END OF INPUT, SEE IF PARTIAL WORD AVAILABLE.
C
1000	IF(PRSCON.GT.INLNT) PRSCON=1
C						!FORCE PARSE RESTART.
	IF((CP.EQ.0).AND.(OP.EQ.1)) RETURN
	IF(CP.EQ.0) OP=OP-2
C						!ANY LAST WORD?
	LEX=.TRUE.
D	IF(DFLAG) PRINT 10,CP,OP,PRSCON,(OUTBUF(I),I=1,OP+1)
D10	FORMAT(' LEX RESULTS- ',3I7/1X,10I7)
	RETURN
C
C LEGITIMATE CHARACTERS: LETTER, DIGIT, OR HYPHEN.
C
4000	J1=ichar(J)-ichar(DLIMIT(I+2))
D	IF(DFLAG) PRINT 20,J,J1,CP
D20	FORMAT(' LEX- CHAR= ',A1,2I7)
	IF(CP.GE.6) GO TO 200
C						!IGNORE IF TOO MANY CHAR.
	K=OP+(CP/3)
C						!COMPUTE WORD INDEX.
	GO TO (4100,4200,4300),(MOD(CP,3)+1)
C						!BRANCH ON CHAR.
4100	J2=J1*780
C						!CHAR 1... *780
	OUTBUF(K)=OUTBUF(K)+J2+J2
C						!*1560 (40 ADDED BELOW).
4200	OUTBUF(K)=OUTBUF(K)+(J1*39)
C						!*39 (1 ADDED BELOW).
4300	OUTBUF(K)=OUTBUF(K)+J1
C						!*1.
	CP=CP+1
	GO TO 200
C						!GET NEXT CHAR.
C
C SPACE
C
6000	IF(CP.EQ.0) GO TO 200
C						!ANY WORD YET?
	GO TO 50
C						!YES, ADV OP.
C
	END