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

