Source to dungeon-2.5.6/np.f
C SPARSE- START OF PARSE
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
C THIS ROUTINE DETAILS ON BIT 2 OF PRSFLG
C
INTEGER FUNCTION SPARSE(LBUF,LLNT,VBFLAG)
IMPLICIT INTEGER(A-Z)
INTEGER LBUF(40)
LOGICAL LIT,QHERE,OTEST,DFLAG,VBFLAG
C
C PARSER OUTPUT
C
LOGICAL PRSWON
COMMON /PRSVEC/ PRSA,PRSI,PRSO,PRSWON,PRSCON
C
C PARSER STATE
C
COMMON /ORPHS/ OFLAG,OACT,OSLOT,OPREP,ONAME
COMMON /LAST/ LASTIT
COMMON /PV/ ACT,O1,O2,P1,P2
C
C GAME STATE
C
LOGICAL TELFLG
COMMON /PLAY/ WINNER,HERE,TELFLG
COMMON /DEBUG/ DBGFLG,PRSFLG,GDTFLG
C
C OBJECTS
C
COMMON /OBJCTS/ OLNT,ODESC1(220),ODESC2(220),ODESCO(220),
1 OACTIO(220),OFLAG1(220),OFLAG2(220),OFVAL(220),
2 OTVAL(220),OSIZE(220),OCAPAC(220),OROOM(220),
3 OADV(220),OCAN(220),OREAD(220)
C
COMMON /OINDEX/ GARLI,FOOD,GUNK,COAL,MACHI,DIAMO,TCASE,BOTTL
COMMON /OINDEX/ WATER,ROPE,KNIFE,SWORD,LAMP,BLAMP,RUG
COMMON /OINDEX/ LEAVE,TROLL,AXE
COMMON /OINDEX/ RKNIF,KEYS,ICE,BAR
COMMON /OINDEX/ COFFI,TORCH,TBASK,FBASK,IRBOX
COMMON /OINDEX/ GHOST,TRUNK,BELL,BOOK,CANDL
COMMON /OINDEX/ MATCH,TUBE,PUTTY,WRENC,SCREW,CYCLO,CHALI
COMMON /OINDEX/ THIEF,STILL,WINDO,GRATE,DOOR
COMMON /OINDEX/ HPOLE,LEAK,RBUTT,RAILI
COMMON /OINDEX/ POT,STATU,IBOAT,DBOAT,PUMP,RBOAT
COMMON /OINDEX/ STICK,BUOY,SHOVE,BALLO,RECEP,GUANO
COMMON /OINDEX/ BROPE,HOOK1,HOOK2,SAFE,SSLOT,BRICK,FUSE
COMMON /OINDEX/ GNOME,BLABE,DBALL,TOMB
COMMON /OINDEX/ LCASE,CAGE,RCAGE,SPHER,SQBUT
COMMON /OINDEX/ FLASK,POOL,SAFFR,BUCKE,ECAKE,ORICE,RDICE,BLICE
COMMON /OINDEX/ ROBOT,FTREE,BILLS,PORTR,SCOL,ZGNOM
COMMON /OINDEX/ EGG,BEGG,BAUBL,CANAR,BCANA
COMMON /OINDEX/ YLWAL,RDWAL,PINDR,RBEAM
COMMON /OINDEX/ ODOOR,QDOOR,CDOOR,NUM1,NUM8
COMMON /OINDEX/ WARNI,CSLIT,GCARD,STLDR
COMMON /OINDEX/ HANDS,WALL,LUNGS,SAILO,AVIAT,TEETH
COMMON /OINDEX/ ITOBJ,EVERY,VALUA,OPLAY,WNORT,GWATE,MASTER
C
C ADVENTURERS
C
COMMON /ADVS/ ALNT,AROOM(4),ASCORE(4),AVEHIC(4),
1 AOBJ(4),AACTIO(4),ASTREN(4),AFLAG(4)
C
COMMON /AINDEX/ PLAYER,AROBOT,AMASTR
C
C VERBS
C
COMMON /VINDEX/ CINTW,DEADXW,FRSTQW,INXW,OUTXW
COMMON /VINDEX/ WALKIW,FIGHTW,FOOW
COMMON /VINDEX/ MELTW,READW,INFLAW,DEFLAW,ALARMW,EXORCW
COMMON /VINDEX/ PLUGW,KICKW,WAVEW,RAISEW,LOWERW,RUBW
COMMON /VINDEX/ PUSHW,UNTIEW,TIEW,TIEUPW,TURNW,BREATW
COMMON /VINDEX/ KNOCKW,LOOKW,EXAMIW,SHAKEW,MOVEW,TRNONW,TRNOFW
COMMON /VINDEX/OPENW,CLOSEW,FINDW,WAITW,SPINW,BOARDW,UNBOAW,TAKEW
COMMON /VINDEX/ INVENW,FILLW,EATW,DRINKW,BURNW
COMMON /VINDEX/ MUNGW,KILLW,ATTACW,SWINGW
COMMON /VINDEX/ WALKW,TELLW,PUTW,DROPW,GIVEW,POURW,THROWW
COMMON /VINDEX/ DIGW,LEAPW,STAYW,FOLLOW
COMMON /VINDEX/ HELLOW,LOOKIW,LOOKUW,PUMPW,WINDW
COMMON /VINDEX/ CLMBW,CLMBUW,CLMBDW,TRNTOW
C SPARSE, PAGE 2
C
C VOCABULARIES
C
COMMON /BUZVOC/ BVOC(20)
COMMON /PRPVOC/ PVOC(45)
COMMON /DIRVOC/ DVOC(75)
INTEGER AVOC(405)
COMMON /ADJVOC/ AVOC1(184),AVOC2(114),AVOC3(106),AVOCND
INTEGER VVOC(935)
COMMON /VRBVOC/ VVOC1(92),VVOC1A(108),VVOC1B(38),VVOC2(104),
1 VVOC3(136),
2 VVOC4(116),VVOC5(134),VVOC6(117),VVOC7(89),VVOCND
INTEGER OVOC(1021)
COMMON /OBJVOC/ OVOC1(159),OVOC2(144),OVOC3(150),OVOC4(128),
1 OVOC5(111),OVOC6(104),OVOC6A(97),OVOC7(127),OVOCND
C
EQUIVALENCE (VVOC(1),VVOC1(1))
EQUIVALENCE (AVOC(1),AVOC1(1))
EQUIVALENCE (OVOC(1),OVOC1(1))
C
C BEGINNING DATA SECTION
DATA R50MIN/1600/,R50WAL/36852/
OTEST(R)=(R.GT.0).AND.(R.LT.R50MIN)
C
C SPARSE, PAGE 7
C
C SET UP FOR PARSING
C
SPARSE=-1
C ASSUME PARSE FAILS.
ADJ=0
C CLEAR PARTS HOLDERS.
ACT=0
PREP=0
PPTR=0
O1=0
O2=0
P1=0
P2=0
C
BUZLNT=20
PRPLNT=45
C JDM was 48?????????
DIRLNT=75
C SPARSE, PAGE 8
C
C NOW LOOP OVER INPUT BUFFER OF LEXICAL TOKENS.
C
C DO 1000 I=1,LLNT,2
C CANNOT BE DO LOOP, AS IT IS BRANCHED INTO, THEREFORE FAKE WITH GOTO
I = 1
9801 CONTINUE
C TWO WORDS/TOKEN.
LBUF1=LBUF(I)
C GET CURRENT TOKEN.
LBUF2=LBUF(I+1)
IF(LBUF1.EQ.0) GO TO 1500
C END OF BUFFER?
C
C CHECK FOR BUZZ WORD
C
DO 50 J=1,BUZLNT,2
IF((LBUF1.EQ.BVOC(J)).AND.(LBUF2.EQ.BVOC(J+1)))
1 GO TO 1000
C IGNORE BUZZ WORDS.
50 CONTINUE
C
C CHECK FOR ACTION OR DIRECTION
C
IF(ACT.NE.0) GO TO 75
C GOT ACTION ALREADY?
J=1
C CHECK FOR ACTION.
125 IF((LBUF1.EQ.VVOC(J)).AND.(LBUF2.EQ.VVOC(J+1)))
1 GO TO 3000
150 J=J+2
C ADV TO NEXT SYNONYM.
IF(.NOT.OTEST(VVOC(J))) GO TO 125
C ANOTHER VERB?
J=J+VVOC(J)+1
C NO, ADVANCE OVER SYNTAX.
IF(VVOC(J).NE.-1) GO TO 125
C TABLE DONE?
C
75 IF((ACT.NE.0).AND.((VVOC(ACT).NE.R50WAL).OR.
1 (PREP.NE.0))) GO TO 200
C NO ACTION OR WALK?
DO 100 J=1,DIRLNT,3
C THEN CHK FOR DIR.
IF((LBUF1.EQ.DVOC(J)).AND.(LBUF2.EQ.DVOC(J+1)))
1 GO TO 2000
100 CONTINUE
C
C NOT AN ACTION, CHECK FOR PREPOSITION, ADJECTIVE, OR OBJECT.
C
200 DO 250 J=1,PRPLNT,3
C LOOK FOR PREPOSITION.
IF((LBUF1.EQ.PVOC(J)).AND.(LBUF2.EQ.PVOC(J+1)))
1 GO TO 4000
250 CONTINUE
C
J=1
C LOOK FOR ADJECTIVE.
300 IF((LBUF1.EQ.AVOC(J)).AND.(LBUF2.EQ.AVOC(J+1)))
1 GO TO 5000
J=J+1
325 J=J+1
C ADVANCE TO NEXT ENTRY.
IF(OTEST(AVOC(J))) GO TO 325
C A RADIX 50 CONSTANT?
IF(AVOC(J).NE.-1) GO TO 300
C POSSIBLY, END TABLE?
C
J=1
C LOOK FOR OBJECT.
450 IF((LBUF1.EQ.OVOC(J)).AND.(LBUF2.EQ.OVOC(J+1)))
1 GO TO 600
J=J+1
500 J=J+1
IF(OTEST(OVOC(J))) GO TO 500
IF(OVOC(J).NE.-1) GO TO 450
C
C NOT RECOGNIZABLE
C
IF(VBFLAG) CALL RSPEAK(601)
RETURN
C SPARSE, PAGE 9
C
C OBJECT PROCESSING (CONTINUATION OF DO LOOP ON PREV PAGE)
C
600 OBJ=GETOBJ(J,ADJ,0)
C IDENTIFY OBJECT.
IF(OBJ.LE.0) GO TO 6000
C IF LE, COULDNT.
IF(OBJ.NE.ITOBJ) GO TO 650
C "IT"?
OBJ=GETOBJ(0,0,LASTIT)
C FIND LAST.
IF(OBJ.LE.0) GO TO 6000
C IF LE, COULDNT.
C
650 IF(PREP.EQ.9) GO TO 8000
C "OF" OBJ?
IF(PPTR.EQ.2) GO TO 7000
C TOO MANY OBJS?
PPTR=PPTR+1
IF(PPTR.EQ.1)O1=OBJ
IF(PPTR.EQ.2)O2=OBJ
C STUFF INTO VECTOR.
IF(PPTR.EQ.1)P1=PREP
IF(PPTR.EQ.2)P2=PREP
700 PREP=0
ADJ=0
1000 CONTINUE
I = I+2
IF(I.LE.LLNT)GOTO 9801
C AT LAST.
C
C NOW SOME MISC CLEANUP
C
1500 IF(ACT.EQ.0) ACT=ZAND(OFLAG,OACT)
C IF NO ACT, STEAL ORPHAN.
IF(ACT.EQ.0) GO TO 9000
C IF STILL NONE, PUNT.
IF(ADJ.NE.0) GO TO 10000
C IF DANGLING ADJ, PUNT.
C
IF((OFLAG.NE.0).AND.(OPREP.NE.0).AND.(PREP.EQ.0).AND.
1 (O1.NE.0).AND.(O2.EQ.0).AND.(ACT.EQ.OACT))
2 GO TO 11000
C
SPARSE=0
C PARSE SUCCEEDS.
IF(PREP.EQ.0) GO TO 1750
C IF DANGLING PREP,
IF(PPTR.EQ.1)PPQQ=P1
IF(PPTR.EQ.2)PPQQ=P2
IF((PPTR.EQ.0).OR.(PPQQ.NE.0))
1 GO TO 12000
C AND HAVE 'PICK FROB UP',
IF(PPTR.EQ.1)P1 = PREP
IF(PPTR.EQ.2)P2 = PREP
C CVT TO 'PICK UP FROB'.
1750 CONTINUE
C WIN.
RETURN
C SPARSE, PAGE 10
C
C SPECIAL PARSE PROCESSORS
C
C 2000-- DIRECTION
C
2000 PRSA=WALKW
C VERB IS WALK.
PRSO=DVOC(J+2)
C GET DIRECTION.
SPARSE=1
C WIN TOTALLY.
RETURN
C
C 3000-- ACTION
C
3000 ACT=J
C SAVE INDEX TO VERB.
OACT=0
C NO ORPHAN.
GO TO 1000
C DONE.
C
C 4000-- PREPOSITION
C
4000 IF(PREP.NE.0) GO TO 4500
C ALREADY HAVE ONE?
PREP=PVOC(J+2)
C NO, GET INDEX.
ADJ=0
C NO ADJECTIVE.
GO TO 1000
C
4500 IF(VBFLAG) CALL RSPEAK(616)
C YES, GAG AND LOSE.
RETURN
C
C 5000-- ADJECTIVE
C
5000 ADJ=J
C SAVE ADJECTIVE.
J=ZAND(ONAME,OFLAG)
IF((J.NE.0).AND.(I.GE.LLNT)) GO TO 600
GO TO 1000
C
C 6000-- UNIDENTIFIABLE OBJECT (INDEX INTO OVOC IS J)
C
6000 IF(OBJ.LT.0) GO TO 6100
C IF LT, AMBIGUOUS.
I=579
C NOT HERE OR
IF(LIT(HERE)) I=618
C NOT LIT.
IF(VBFLAG) CALL RSPEAK(I)
RETURN
C LOSE.
C
6100 IF(OBJ.NE.-10000) GO TO 6200
C INSIDE VEHICLE?
IF(VBFLAG) CALL RSPSUB(620,ODESC2(AVEHIC(WINNER)))
RETURN
C
6200 IF(VBFLAG) CALL RSPEAK(619)
C CANT DISTINGUISH.
IF(ACT.EQ.0) ACT=ZAND(OFLAG,OACT)
C IF NO ACT, GET ORPHAN.
CALL ORPHAN(-1,ACT,O1,PREP,J)
C ORPHAN THE WORLD.
RETURN
C
C 7000-- TOO MANY OBJECTS.
C
7000 IF(VBFLAG) CALL RSPEAK(617)
RETURN
C
C 8000-- RANDOMNESS FOR "OF" WORDS
C
8000 IF(PPTR.EQ.1)OOQQ=O1
IF(PPTR.EQ.2)OOQQ=O2
IF(OOQQ.EQ.OBJ) GO TO 700
C IGNORE IF OK.
IF(VBFLAG) CALL RSPEAK(601)
RETURN
C
C 9000-- NO ACTION, PUNT
C
9000 IF(O1.EQ.0) GO TO 10000
C ANY DIRECT OBJECT?
IF(VBFLAG) CALL RSPSUB(621,ODESC2(O1))
C WHAT TO DO?
CALL ORPHAN(-1,0,O1,0,0)
RETURN
C
C 10000-- TOTAL CHOMP
C
10000 IF(VBFLAG) CALL RSPEAK(622)
C HUH?
RETURN
C
C 11000-- ORPHAN PREPOSITION. CONDITIONS ARE
C O1.NE.0, O2=0, PREP=0, ACT=OACT
C
11000 IF(OSLOT.NE.0) GO TO 11500
C ORPHAN OBJECT?
P1=OPREP
C NO, JUST USE PREP.
GO TO 1750
C
11500 O2=O1
C YES, USE AS DIRECT OBJ.
P2=OPREP
O1=OSLOT
P1=0
GO TO 1750
C
C 12000-- TRUE HANGING PREPOSITION.
C ORPHAN FOR LATER.
C
12000 CALL ORPHAN(-1,ACT,0,PREP,0)
C ORPHAN PREP.
GO TO 1750
C
END
C GETOBJ-- FIND OBJ DESCRIBED BY ADJ, NAME PAIR
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
C THIS ROUTINE DETAILS ON BIT 3 OF PRSFLG
C
INTEGER FUNCTION GETOBJ(OIDX,AIDX,SPCOBJ)
IMPLICIT INTEGER(A-Z)
LOGICAL THISIT,GHERE,LIT,CHOMP,DFLAG
C
COMMON /OBJFLG/ VABIT,VRBIT,VTBIT,VCBIT,VEBIT,VFBIT,VPMASK
C
C GAME STATE
C
LOGICAL TELFLG
COMMON /PLAY/ WINNER,HERE,TELFLG
C
C MISCELLANEOUS VARIABLES
C
COMMON /STAR/ MBASE,STRBIT
COMMON /DEBUG/ DBGFLG,PRSFLG,GDTFLG
C
C OBJECTS
C
COMMON /OBJCTS/ OLNT,ODESC1(220),ODESC2(220),ODESCO(220),
1 OACTIO(220),OFLAG1(220),OFLAG2(220),OFVAL(220),
2 OTVAL(220),OSIZE(220),OCAPAC(220),OROOM(220),
3 OADV(220),OCAN(220),OREAD(220)
C
COMMON /OFLAGS/ VISIBT,READBT,TAKEBT,DOORBT,TRANBT,FOODBT,
1 NDSCBT,DRNKBT,CONTBT,LITEBT,VICTBT,BURNBT,FLAMBT,
2 TOOLBT,TURNBT,ONBT
COMMON /OFLAGS/ FINDBT,SLEPBT,SCRDBT,TIEBT,CLMBBT,ACTRBT,
1 WEAPBT,FITEBT,VILLBT,STAGBT,TRYBT,NOCHBT,OPENBT,
2 TCHBT,VEHBT,SCHBT
C
C ADVENTURERS
C
COMMON /ADVS/ ALNT,AROOM(4),ASCORE(4),AVEHIC(4),
1 AOBJ(4),AACTIO(4),ASTREN(4),AFLAG(4)
C
C VOCABULARIES
C
COMMON /OBJVOC/ OVOC(1021)
C GETOBJ, PAGE 2
C
CHOMP=.FALSE.
AV=AVEHIC(WINNER)
OBJ=0
C ASSUME DARK.
IF(.NOT.LIT(HERE)) GO TO 200
C LIT?
C
OBJ=SCHLST(OIDX,AIDX,HERE,0,0,SPCOBJ)
C SEARCH ROOM.
IF(OBJ) 1000,200,100
C TEST RESULT.
100 IF((AV.EQ.0).OR.(AV.EQ.OBJ).OR.
1 (ZAND(OFLAG2(OBJ),FINDBT).NE.0)) GO TO 200
IF(OCAN(OBJ).EQ.AV) GO TO 200
C TEST IF REACHABLE.
CHOMP=.TRUE.
C PROBABLY NOT.
C
200 IF(AV.EQ.0) GO TO 400
C IN VEHICLE?
NOBJ=SCHLST(OIDX,AIDX,0,AV,0,SPCOBJ)
C SEARCH VEHICLE.
IF(NOBJ) 1100,400,300
C TEST RESULT.
300 CHOMP=.FALSE.
C REACHABLE.
IF(OBJ.EQ.NOBJ) GO TO 400
C SAME AS BEFORE?
IF(OBJ.NE.0) NOBJ=-NOBJ
C AMB RESULT?
OBJ=NOBJ
C
400 NOBJ=SCHLST(OIDX,AIDX,0,0,WINNER,SPCOBJ)
C SEARCH ADVENTURER.
IF(NOBJ) 1100,600,500
C TEST RESULT
500 IF(OBJ.NE.0) NOBJ=-NOBJ
C AMB RESULT?
1100 OBJ=NOBJ
C RETURN NEW OBJECT.
600 IF(CHOMP) OBJ=-10000
C UNREACHABLE.
1000 GETOBJ=OBJ
C
IF(GETOBJ.NE.0) GO TO 1500
C GOT SOMETHING?
DO 1200 I=STRBIT+1,OLNT
C NO, SEARCH GLOBALS.
IF(.NOT.THISIT(OIDX,AIDX,I,SPCOBJ)) GO TO 1200
IF(.NOT.GHERE(I,HERE)) GO TO 1200
C CAN IT BE HERE?
IF(GETOBJ.NE.0) GETOBJ=-I
C AMB MATCH?
IF(GETOBJ.EQ.0) GETOBJ=I
1200 CONTINUE
C
1500 CONTINUE
C END OF SEARCH.
RETURN
END
C SCHLST-- SEARCH FOR OBJECT
C
C DECLARATIONS
C
INTEGER FUNCTION SCHLST(OIDX,AIDX,RM,CN,AD,SPCOBJ)
IMPLICIT INTEGER(A-Z)
LOGICAL THISIT,QHERE,NOTRAN,NOVIS
C
COMMON /STAR/ MBASE,STRBIT
C
C OBJECTS
C
COMMON /OBJCTS/ OLNT,ODESC1(220),ODESC2(220),ODESCO(220),
1 OACTIO(220),OFLAG1(220),OFLAG2(220),OFVAL(220),
2 OTVAL(220),OSIZE(220),OCAPAC(220),OROOM(220),
3 OADV(220),OCAN(220),OREAD(220)
C
COMMON /OFLAGS/ VISIBT,READBT,TAKEBT,DOORBT,TRANBT,FOODBT,
1 NDSCBT,DRNKBT,CONTBT,LITEBT,VICTBT,BURNBT,FLAMBT,
2 TOOLBT,TURNBT,ONBT
COMMON /OFLAGS/ FINDBT,SLEPBT,SCRDBT,TIEBT,CLMBBT,ACTRBT,
1 WEAPBT,FITEBT,VILLBT,STAGBT,TRYBT,NOCHBT,OPENBT,
2 TCHBT,VEHBT,SCHBT
C
C FUNCTIONS AND DATA
C
NOTRAN(O)=(ZAND(OFLAG1(O),TRANBT).EQ.0).AND.
1 (ZAND(OFLAG2(O),OPENBT).EQ.0)
NOVIS(O)=(ZAND(OFLAG1(O),VISIBT).EQ.0)
C
SCHLST=0
C NO RESULT.
DO 1000 I=1,OLNT
C SEARCH OBJECTS.
IF(NOVIS(I).OR.
1 (((RM.EQ.0).OR.(.NOT.QHERE(I,RM))).AND.
2 ((CN.EQ.0).OR.(OCAN(I).NE.CN)).AND.
3 ((AD.EQ.0).OR.(OADV(I).NE.AD)))) GO TO 1000
IF(.NOT.THISIT(OIDX,AIDX,I,SPCOBJ)) GO TO 200
IF(SCHLST.NE.0) GO TO 2000
C GOT ONE ALREADY?
SCHLST=I
C NO.
C
C IF OPEN OR TRANSPARENT, SEARCH THE OBJECT ITSELF.
C
200 IF(NOTRAN(I)) GO TO 1000
C
C SEARCH IS CONDUCTED IN REVERSE. ALL OBJECTS ARE CHECKED TO
C SEE IF THEY ARE AT SOME LEVEL OF CONTAINMENT INSIDE OBJECT 'I'.
C IF THEY ARE AT LEVEL 1, OR IF ALL LINKS IN THE CONTAINMENT
C CHAIN ARE OPEN, VISIBLE, AND HAVE SEARCHME SET, THEY CAN QUALIFY
C AS A POTENTIAL MATCH.
C
DO 500 J=1,OLNT
C SEARCH OBJECTS.
IF(NOVIS(J).OR. (.NOT.THISIT(OIDX,AIDX,J,SPCOBJ)))
1 GO TO 500
C VISIBLE & MATCH?
X=OCAN(J)
C GET CONTAINER.
300 IF(X.EQ.I) GO TO 400
C INSIDE TARGET?
IF(X.EQ.0) GO TO 500
C INSIDE ANYTHING?
IF(NOVIS(X).OR.NOTRAN(X).OR.
1 (ZAND(OFLAG2(X),SCHBT).EQ.0)) GO TO 500
X=OCAN(X)
C GO ANOTHER LEVEL.
GO TO 300
C
400 IF(SCHLST.NE.0) GO TO 2000
C ALREADY GOT ONE?
SCHLST=J
C NO.
500 CONTINUE
C
1000 CONTINUE
RETURN
C
2000 SCHLST=-SCHLST
C AMB RETURN.
RETURN
C
END
C THISIT-- VALIDATE OBJECT VS DESCRIPTION
C
C DECLARATIONS
C
LOGICAL FUNCTION THISIT(OIDX,AIDX,OBJ,SPCOBJ)
IMPLICIT INTEGER(A-Z)
LOGICAL NOTEST
C
C VOCABULARIES
C
COMMON /OBJVOC/ OVOC(1021)
COMMON /ADJVOC/ AVOC(405)
C
C FUNCTIONS AND DATA
C
NOTEST(O)=(O.LE.0).OR.(O.GE.R50MIN)
DATA R50MIN/1600/
C
THISIT=.FALSE.
C ASSUME NO MATCH.
IF((SPCOBJ.NE.0).AND.(OBJ.EQ.SPCOBJ)) GO TO 500
C
C CHECK FOR OBJECT NAMES
C
I=OIDX+1
100 I=I+1
IF(NOTEST(OVOC(I))) RETURN
C IF DONE, LOSE.
IF(OVOC(I).NE.OBJ) GO TO 100
C IF FAIL, CONT.
C
IF(AIDX.EQ.0) GO TO 500
C ANY ADJ?
I=AIDX+1
200 I=I+1
IF(NOTEST(AVOC(I))) RETURN
C IF DONE, LOSE.
IF(AVOC(I).NE.OBJ) GO TO 200
C IF FAIL, CONT.
C
500 THISIT=.TRUE.
RETURN
END
C SYNMCH-- SYNTAX MATCHER
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
C THIS ROUTINE DETAILS ON BIT 4 OF PRSFLG
C
LOGICAL FUNCTION SYNMCH()
IMPLICIT INTEGER(A-Z)
LOGICAL SYNEQL,TAKEIT,DFLAG
C
C PARSER OUTPUT
C
LOGICAL PRSWON
COMMON /PRSVEC/ PRSA,PRSI,PRSO,PRSWON,PRSCON
C
COMMON /DEBUG/ DBGFLG,PRSFLG,GDTFLG
C
COMMON /ORPHS/ OFLAG,OACT,OSLOT,OPREP,ONAME
COMMON /PV/ ACT,O1,O2,P1,P2
COMMON /SYNTAX/VFLAG,DOBJ,DFL1,DFL2,DFW1,DFW2,
1 IOBJ,IFL1,IFL2,IFW1,IFW2
COMMON /VRBVOC/ VVOC(935)
COMMON /SYNFLG/ SDIR,SIND,SSTD,SFLIP,SDRIV,SVMASK
COMMON /OBJFLG/ VABIT,VRBIT,VTBIT,VCBIT,VEBIT,VFBIT,VPMASK
DATA R50MIN/1600/
C
SYNMCH=.FALSE.
J=ACT
C SET UP PTR TO SYNTAX.
DRIVE=0
C NO DEFAULT.
DFORCE=0
C NO FORCED DEFAULT.
QPREP=ZAND(OFLAG,OPREP)
C VALID ORPHAN PREP FLAG.
100 J=J+2
C FIND START OF SYNTAX.
IF((VVOC(J).LE.0).OR.(VVOC(J).GE.R50MIN)) GO TO 100
LIMIT=J+VVOC(J)+1
C COMPUTE LIMIT.
J=J+1
C ADVANCE TO NEXT.
C
200 CALL UNPACK(J,NEWJ)
C UNPACK SYNTAX.
SPREP=ZAND(DOBJ,VPMASK)
C SAVE EXPECTED PREP.
IF(.NOT.SYNEQL(P1,O1,DOBJ,DFL1,DFL2)) GO TO 1000
SPREP=ZAND(IOBJ,VPMASK)
C SAVE EXPECTED PREP.
IF(SYNEQL(P2,O2,IOBJ,IFL1,IFL2)) GO TO 6000
C
C SYNTAX MATCH FAILS, TRY NEXT ONE.
C
IF(O2) 3000,500,3000
C IF O2=0, SET DFLT.
1000 IF(O1) 3000,500,3000
C IF O1=0, SET DFLT.
500 IF((QPREP.EQ.0).OR.(QPREP.EQ.SPREP)) DFORCE=J
C IF PREP MCH.
IF(ZAND(VFLAG,SDRIV).NE.0) DRIVE=J
C IF DRIVER, RECORD.
3000 J=NEWJ
IF(J.LT.LIMIT) GO TO 200
C MORE TO DO?
C SYNMCH, PAGE 2
C
C MATCH HAS FAILED. IF DEFAULT SYNTAX EXISTS, TRY TO SNARF
C ORPHANS OR GWIMS, OR MAKE NEW ORPHANS.
C
IF(DRIVE.EQ.0) DRIVE=DFORCE
C NO DRIVER? USE FORCE.
IF(DRIVE.EQ.0) GO TO 10000
C ANY DRIVER?
CALL UNPACK(DRIVE,DFORCE)
C UNPACK DFLT SYNTAX.
C
C TRY TO FILL DIRECT OBJECT SLOT IF THAT WAS THE PROBLEM.
C
IF((ZAND(VFLAG,SDIR).EQ.0).OR.(O1.NE.0)) GO TO 4000
C
C FIRST TRY TO SNARF ORPHAN OBJECT.
C
O1=ZAND(OFLAG,OSLOT)
IF(O1.EQ.0) GO TO 3500
C ANY ORPHAN?
IF(SYNEQL(P1,O1,DOBJ,DFL1,DFL2)) GO TO 4000
C
C ORPHAN FAILS, TRY GWIM.
C
3500 O1=GWIM(DOBJ,DFW1,DFW2)
C GET GWIM.
IF(O1.GT.0) GO TO 4000
C TEST RESULT.
CALL ORPHAN(-1,ACT,0,ZAND(DOBJ,VPMASK),0)
C FAILS, ORPHAN.
CALL RSPEAK(623)
RETURN
C
C TRY TO FILL INDIRECT OBJECT SLOT IF THAT WAS THE PROBLEM.
C
4000 IF((ZAND(VFLAG,SIND).EQ.0).OR.(O2.NE.0)) GO TO 6000
O2=GWIM(IOBJ,IFW1,IFW2)
C GWIM.
IF(O2.GT.0) GO TO 6000
IF(O1.EQ.0) O1=ZAND(OFLAG,OSLOT)
CALL ORPHAN(-1,ACT,O1,ZAND(DOBJ,VPMASK),0)
CALL RSPEAK(624)
RETURN
C
C TOTAL CHOMP
C
10000 CALL RSPEAK(601)
C CANT DO ANYTHING.
RETURN
C SYNMCH, PAGE 3
C
C NOW TRY TO TAKE INDIVIDUAL OBJECTS AND
C IN GENERAL CLEAN UP THE PARSE VECTOR.
C
6000 IF(ZAND(VFLAG,SFLIP).EQ.0) GO TO 5000
C FLIP?
J=O1
C YES.
O1=O2
O2=J
C
5000 PRSA=ZAND(VFLAG,SVMASK)
C GET VERB.
PRSO=O1
C GET DIR OBJ.
PRSI=O2
C GET IND OBJ.
IF(.NOT.TAKEIT(PRSO,DOBJ)) RETURN
C TRY TAKE.
IF(.NOT.TAKEIT(PRSI,IOBJ)) RETURN
C TRY TAKE.
SYNMCH=.TRUE.
RETURN
C
END
C UNPACK- UNPACK SYNTAX SPECIFICATION, ADV POINTER
C
C DECLARATIONS
C
SUBROUTINE UNPACK(OLDJ,J)
IMPLICIT INTEGER(A-Z)
C
COMMON /VRBVOC/ VVOC(935)
C
COMMON /SYNFLG/ SDIR,SIND,SSTD,SFLIP,SDRIV,SVMASK
COMMON /OBJFLG/ VABIT,VRBIT,VTBIT,VCBIT,VEBIT,VFBIT,VPMASK
COMMON /SYNTAX/ VFLAG,DOBJ,DFL1,DFL2,DFW1,DFW2,
1 IOBJ,IFL1,IFL2,IFW1,IFW2
INTEGER SYN(11)
EQUIVALENCE (SYN(1),VFLAG)
C
DO 10 I=1,11
C CLEAR SYNTAX.
SYN(I)=0
10 CONTINUE
C
VFLAG=VVOC(OLDJ)
J=OLDJ+1
IF(ZAND(VFLAG,SDIR).EQ.0) RETURN
C DIR OBJECT?
DFL1=-1
C ASSUME STD.
DFL2=-1
IF(ZAND(VFLAG,SSTD).EQ.0) GO TO 100
C STD OBJECT?
DFW1=-1
C YES.
DFW2=-1
DOBJ=VABIT+VRBIT+VFBIT
GO TO 200
C
100 DOBJ=VVOC(J)
C NOT STD.
DFW1=VVOC(J+1)
DFW2=VVOC(J+2)
J=J+3
IF(ZAND(DOBJ,VEBIT).EQ.0) GO TO 200
C VBIT = VFWIM?
DFL1=DFW1
C YES.
DFL2=DFW2
C
200 IF(ZAND(VFLAG,SIND).EQ.0) RETURN
C IND OBJECT?
IFL1=-1
C ASSUME STD.
IFL2=-1
IOBJ=VVOC(J)
IFW1=VVOC(J+1)
IFW2=VVOC(J+2)
J=J+3
IF(ZAND(IOBJ,VEBIT).EQ.0) RETURN
C VBIT = VFWIM?
IFL1=IFW1
C YES.
IFL2=IFW2
RETURN
C
END
C SYNEQL- TEST FOR SYNTAX EQUALITY
C
C DECLARATIONS
C
LOGICAL FUNCTION SYNEQL(PREP,OBJ,SPREP,SFL1,SFL2)
IMPLICIT INTEGER(A-Z)
C
C OBJECTS
C
COMMON /OBJCTS/ OLNT,ODESC1(220),ODESC2(220),ODESCO(220),
1 OACTIO(220),OFLAG1(220),OFLAG2(220),OFVAL(220),
2 OTVAL(220),OSIZE(220),OCAPAC(220),OROOM(220),
3 OADV(220),OCAN(220),OREAD(220)
C
COMMON /OBJFLG/ VABIT,VRBIT,VTBIT,VCBIT,VEBIT,VFBIT,VPMASK
C
IF(OBJ.EQ.0) GO TO 100
C ANY OBJECT?
SYNEQL=(PREP.EQ.ZAND(SPREP,VPMASK)).AND.
1 ((ZOR(ZAND(SFL1,OFLAG1(OBJ)),
2 ZAND(SFL2,OFLAG2(OBJ)))).NE.0)
RETURN
C
100 SYNEQL=(PREP.EQ.0).AND.(SFL1.EQ.0).AND.(SFL2.EQ.0)
RETURN
C
END
C TAKEIT- PARSER BASED TAKE OF OBJECT
C
C DECLARATIONS
C
LOGICAL FUNCTION TAKEIT(OBJ,SFLAG)
IMPLICIT INTEGER(A-Z)
C
COMMON /OBJFLG/ VABIT,VRBIT,VTBIT,VCBIT,VEBIT,VFBIT,VPMASK
COMMON /STAR/ MBASE,STRBIT
C
C GAME STATE
C
LOGICAL TELFLG
COMMON /PLAY/ WINNER,HERE,TELFLG
COMMON /STATE/ MOVES,DEATHS,RWSCOR,MXSCOR,MXLOAD,
1 LTSHFT,BLOC,MUNGRM,HS,EGSCOR,EGMXSC
C
C OBJECTS
C
COMMON /OBJCTS/ OLNT,ODESC1(220),ODESC2(220),ODESCO(220),
1 OACTIO(220),OFLAG1(220),OFLAG2(220),OFVAL(220),
2 OTVAL(220),OSIZE(220),OCAPAC(220),OROOM(220),
3 OADV(220),OCAN(220),OREAD(220)
C
COMMON /OFLAGS/ VISIBT,READBT,TAKEBT,DOORBT,TRANBT,FOODBT,
1 NDSCBT,DRNKBT,CONTBT,LITEBT,VICTBT,BURNBT,FLAMBT,
2 TOOLBT,TURNBT,ONBT
COMMON /OFLAGS/ FINDBT,SLEPBT,SCRDBT,TIEBT,CLMBBT,ACTRBT,
1 WEAPBT,FITEBT,VILLBT,STAGBT,TRYBT,NOCHBT,OPENBT,
2 TCHBT,VEHBT,SCHBT
C
C ADVENTURERS
C
COMMON /ADVS/ ALNT,AROOM(4),ASCORE(4),AVEHIC(4),
1 AOBJ(4),AACTIO(4),ASTREN(4),AFLAG(4)
C TAKEIT, PAGE 2
C
TAKEIT=.FALSE.
C ASSUME LOSES.
IF((OBJ.EQ.0).OR.(OBJ.GT.STRBIT)) GO TO 4000
C NULL/STARS WIN.
ODO2=ODESC2(OBJ)
C GET DESC.
X=OCAN(OBJ)
C GET CONTAINER.
IF((X.EQ.0).OR.(ZAND(SFLAG,VFBIT).EQ.0)) GO TO 500
IF(ZAND(OFLAG2(X),OPENBT).NE.0) GO TO 500
CALL RSPSUB(566,ODO2)
C CANT REACH.
RETURN
C
500 IF(ZAND(SFLAG,VRBIT).EQ.0) GO TO 1000
C SHLD BE IN ROOM?
IF(ZAND(SFLAG,VTBIT).EQ.0) GO TO 2000
C CAN BE TAKEN?
C
C SHOULD BE IN ROOM (VRBIT NE 0) AND CAN BE TAKEN (VTBIT NE 0)
C
IF(SCHLST(0,0,HERE,0,0,OBJ).LE.0) GO TO 4000
C IF NOT, OK.
C
C ITS IN THE ROOM AND CAN BE TAKEN.
C
IF((ZAND(OFLAG1(OBJ),TAKEBT).NE.0).AND.
1 (ZAND(OFLAG2(OBJ),TRYBT).EQ.0)) GO TO 3000
C
C NOT TAKEABLE. IF WE CARE, FAIL.
C
IF(ZAND(SFLAG,VCBIT).EQ.0) GO TO 4000
C IF NO CARE, RETURN.
CALL RSPSUB(445,ODO2)
RETURN
C
C 1000-- IT SHOULD NOT BE IN THE ROOM.
C 2000-- IT CANT BE TAKEN.
C
2000 IF(ZAND(SFLAG,VCBIT).EQ.0) GO TO 4000
C IF NO CARE, RETURN
1000 IF(SCHLST(0,0,HERE,0,0,OBJ).LE.0) GO TO 4000
CALL RSPSUB(665,ODO2)
RETURN
C TAKEIT, PAGE 3
C
C OBJECT IS IN THE ROOM, CAN BE TAKEN BY THE PARSER,
C AND IS TAKEABLE IN GENERAL. IT IS NOT A STAR.
C TAKING IT SHOULD NOT HAVE SIDE AFFECTS.
C IF IT IS INSIDE SOMETHING, THE CONTAINER IS OPEN.
C THE FOLLOWING CODE IS LIFTED FROM SUBROUTINE TAKE.
C
3000 IF(OBJ.NE.AVEHIC(WINNER)) GO TO 3500
C TAKE VEHICLE?
CALL RSPEAK(672)
RETURN
C
3500 IF(((X.NE.0).AND.(OADV(X).EQ.WINNER)).OR.
1 ((WEIGHT(0,OBJ,WINNER)+OSIZE(OBJ)).LE.MXLOAD))
2 GO TO 3700
CALL RSPEAK(558)
C TOO BIG.
RETURN
C
3700 CALL NEWSTA(OBJ,559,0,0,WINNER)
C DO TAKE.
OFLAG2(OBJ)=ZOR(OFLAG2(OBJ),TCHBT)
C TOUCHED.
CALL SCRUPD(OFVAL(OBJ))
OFVAL(OBJ)=0
C
4000 TAKEIT=.TRUE.
C SUCCESS.
RETURN
C
END
C GWIM- GET WHAT I MEAN IN AMBIGOUS SITUATIONS
C
C DECLARATIONS
C
INTEGER FUNCTION GWIM(SFLAG,SFW1,SFW2)
IMPLICIT INTEGER(A-Z)
LOGICAL TAKEIT,NOCARE
C
COMMON /OBJFLG/ VABIT,VRBIT,VTBIT,VCBIT,VEBIT,VFBIT,VPMASK
COMMON /STAR/ MBASE,STRBIT
C
C GAME STATE
C
LOGICAL TELFLG
COMMON /PLAY/ WINNER,HERE,TELFLG
C
C OBJECTS
C
COMMON /OBJCTS/ OLNT,ODESC1(220),ODESC2(220),ODESCO(220),
1 OACTIO(220),OFLAG1(220),OFLAG2(220),OFVAL(220),
2 OTVAL(220),OSIZE(220),OCAPAC(220),OROOM(220),
3 OADV(220),OCAN(220),OREAD(220)
C
COMMON /OFLAGS/ VISIBT,READBT,TAKEBT,DOORBT,TRANBT,FOODBT,
1 NDSCBT,DRNKBT,CONTBT,LITEBT,VICTBT,BURNBT,FLAMBT,
2 TOOLBT,TURNBT,ONBT
COMMON /OFLAGS/ FINDBT,SLEPBT,SCRDBT,TIEBT,CLMBBT,ACTRBT,
1 WEAPBT,FITEBT,VILLBT,STAGBT,TRYBT,NOCHBT,OPENBT,
2 TCHBT,VEHBT,SCHBT
C
C ADVENTURERS
C
COMMON /ADVS/ ALNT,AROOM(4),ASCORE(4),AVEHIC(4),
1 AOBJ(4),AACTIO(4),ASTREN(4),AFLAG(4)
C GWIM, PAGE 2
C
GWIM=-1
C ASSUME LOSE.
AV=AVEHIC(WINNER)
NOBJ=0
NOCARE=ZAND(SFLAG,VCBIT).EQ.0
C
C FIRST SEARCH ADVENTURER
C
IF(ZAND(SFLAG,VABIT).NE.0)
1 NOBJ=FWIM(SFW1,SFW2,0,0,WINNER,NOCARE)
IF(ZAND(SFLAG,VRBIT).NE.0) GO TO 100
50 GWIM=NOBJ
RETURN
C
C ALSO SEARCH ROOM
C
100 ROBJ=FWIM(SFW1,SFW2,HERE,0,0,NOCARE)
IF(ROBJ) 500,50,200
C TEST RESULT.
C
C ROBJ > 0
C
200 IF((AV.EQ.0).OR.(ROBJ.EQ.AV).OR.
1 (ZAND(OFLAG2(ROBJ),FINDBT).NE.0)) GO TO 300
IF(OCAN(ROBJ).NE.AV) GO TO 50
C UNREACHABLE? TRY NOBJ
300 IF(NOBJ.NE.0) RETURN
C IF AMBIGUOUS, RETURN.
IF(.NOT.TAKEIT(ROBJ,SFLAG)) RETURN
C IF UNTAKEABLE, RETURN
GWIM=ROBJ
500 RETURN
C
END
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(INBUF,INLNT,WHO)
IMPLICIT INTEGER(A-Z)
CHARACTER INBUF(78)
CHARACTER*20 INFMTX
COMMON /XINFMT/ INFMTX
C
C PARSER OUTPUT
C
LOGICAL PRSWON
COMMON /PRSVEC/ PRSA,PRSI,PRSO,PRSWON,PRSCON
C
COMMON /CHAN/ INPCH,OUTCH,DBCH,ZRECL
C
5 GO TO (90,10),WHO+1
C SEE WHO TO PROMPT FOR.
10 WRITE(OUTCH,INFMTX)
C PROMPT FOR GAME.
C50 FORMAT(' >',$)
C
90 READ(INPCH,100) INBUF
C GET INPUT.
100 FORMAT(78A1)
C
DO 200 INLNT=78,1,-1
IF(INBUF(INLNT).NE.' ') GO TO 300
C NOT BLANK?
200 CONTINUE
GO TO 5
C TRY AGAIN.
C
300 DO 400 I=1,INLNT
C CONVERT TO UPPER CASE.
IF((INBUF(I).GE.'a').AND.(INBUF(I).LE.'z'))
1 INBUF(I)=CHAR(ICHAR(INBUF(I))-32)
400 CONTINUE
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,DFLAG,VBFLAG
INTEGER OUTBUF(40)
COMMON /DEBUG/ DBGFLG,PRSFLG,GDTFLG
C
C PARSER OUTPUT
C
LOGICAL PRSWON
COMMON /PRSVEC/ PRSA,PRSI,PRSO,PRSWON,PRSCON
COMMON /LAST/ LASTIT
COMMON /XSRCH/ XMIN,XMAX,XDOWN,XUP,
1 XNORTH,XSOUTH,XENTER,XEXIT,XEAST,XWEST
C
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()) 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.
RETURN
C
C PARSE FAILS, DISALLOW CONTINUATION
C
100 PRSCON=1
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 DECLARATIONS
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 DFLAG,VBFLAG
C
C PARSER OUTPUT
C
LOGICAL PRSWON
COMMON /PRSVEC/ PRSA,PRSI,PRSO,PRSWON,PRSCON
C
COMMON /DEBUG/ DBGFLG,PRSFLG,GDTFLG
C
DATA DLIMIT/'A','Z',' ','1','9',' ','-','-',' '/
DLIMIT(3) = CHAR(64)
DLIMIT(6) = CHAR(18)
DLIMIT(9) = CHAR(18)
C
DO 100 I=1,40
C CLEAR OUTPUT BUF.
OUTBUF(I)=0
100 CONTINUE
C
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)))
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
C ANY RESULTS?
IF(CP.EQ.0) OP=OP-2
C ANY LAST WORD?
LEX=.TRUE.
RETURN
C
C LEGITIMATE CHARACTERS: LETTER, DIGIT, OR HYPHEN.
C
4000 J1=ICHAR(J)-ICHAR(DLIMIT(I+2))
C CVT TO R50.
IF(CP.GE.6) GO TO 200
C IGNORE IF TOO MANY CHAR.
K=OP+(CP/3)
C COMPUTE WORD INDEX.
ZZZ=OUTBUF(K)
C BY JDM,FOR VAX
GO TO (4100,4200,4300),(MOD(CP,3)+1)
C BRANCH ON CHAR.
4100 J2=J1*780
C CHAR 1... *780
C OUTBUF(K)=OUTBUF(K)+J2+J2
C *1560 (40 ADDED BELOW).
ZZZ=ZZZ+J2+J2
C4200 OUTBUF(K)=OUTBUF(K)+(J1*39)
C *39 (1 ADDED BELOW).
4200 ZZZ=ZZZ+J1*39
C4300 OUTBUF(K)=OUTBUF(K)+J1
C *1.
4300 ZZZ=ZZZ+J1
OUTBUF(K)=ZOR(ZZZ,0)
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