# 2.11BSD#431 - /usr/src/new/PORT/dungeon/np3.F

       1: C SYNMCH--	SYNTAX MATCHER
       2: C
       3: C COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
       4: C ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
       5: C WRITTEN BY R. M. SUPNIK
       6: C
       7: C DECLARATIONS
       8: C
       9: C THIS ROUTINE DETAILS ON BIT 4 OF PRSFLG
      10: C
      11:         LOGICAL FUNCTION SYNMCH()
      12:         IMPLICIT INTEGER(A-Z)
      13:         LOGICAL SYNEQL,TAKEIT
      14: #include "parser.h"
      15: #include "vocab.h"
      16: #include "debug.h"
      17: C
      18: C   THE FOLLOWING DATA STATEMENT WAS ORIGINALLY:
      19: C
      20: C	DATA R50MIN/1RA/
      21: C
      22:         DATA R50MIN/1600/
      23: C
      24:         SYNMCH=.FALSE.
      25: #ifdef debug
      26:         DFLAG=and(PRSFLG, 16).NE.0
      27:         if(dflag) write(0,*) "synflags=",sdir,sind,sstd,sflip,sdriv,svmask
      28: #endif
      29:         J=ACT
      30: C						!SET UP PTR TO SYNTAX.
      31:         DRIVE=0
      32: C						!NO DEFAULT.
      33:         DFORCE=0
      34: C						!NO FORCED DEFAULT.
      35:         QPREP=and(OFLAG,OPREP)
      36: 100     J=J+2
      37: C						!FIND START OF SYNTAX.
      38:         IF((VVOC(J).LE.0).OR.(VVOC(J).GE.R50MIN)) GO TO 100
      39:         LIMIT=J+VVOC(J)+1
      40: C						!COMPUTE LIMIT.
      41:         J=J+1
      42: C						!ADVANCE TO NEXT.
      43: C
      44: 200     CALL UNPACK(J,NEWJ)
      45: C						!UNPACK SYNTAX.
      46: #ifdef debug
      47:         IF(DFLAG) PRINT 60,O1,P1,DOBJ,DFL1,DFL2
      48: #ifdef NOCC
      49: 60      FORMAT('SYNMCH INPUTS TO SYNEQL- ',5I7)
      50: #else NOCC
      51: 60      FORMAT(' SYNMCH INPUTS TO SYNEQL- ',5I7)
      52: #endif NOCC
      53: #endif
      54:         SPREP=and(DOBJ,VPMASK)
      55:         IF(.NOT.SYNEQL(P1,O1,DOBJ,DFL1,DFL2)) GO TO 1000
      56: #ifdef debug
      57:         IF(DFLAG) PRINT 60,O2,P2,IOBJ,IFL1,IFL2
      58: #endif
      59:         SPREP=and(IOBJ,VPMASK)
      60:         IF(SYNEQL(P2,O2,IOBJ,IFL1,IFL2)) GO TO 6000
      61: C
      62: C SYNTAX MATCH FAILS, TRY NEXT ONE.
      63: C
      64:         IF(O2) 3000,500,3000
      65: C						!IF O2=0, SET DFLT.
      66: 1000    IF(O1) 3000,500,3000
      67: C						!IF O1=0, SET DFLT.
      68: 500     IF((QPREP.EQ.0).OR.(QPREP.EQ.SPREP)) DFORCE=J
      69: C						!IF PREP MCH.
      70:         IF((and(VFLAG,SDRIV)).NE.0) DRIVE=J
      71: 3000    J=NEWJ
      72:         IF(J.LT.LIMIT) GO TO 200
      73: C						!MORE TO DO?
      74: C SYNMCH, PAGE 2
      75: C
      76: C MATCH HAS FAILED.  IF DEFAULT SYNTAX EXISTS, TRY TO SNARF
      77: C ORPHANS OR GWIMS, OR MAKE NEW ORPHANS.
      78: C
      79: #ifdef debug
      80:         IF(DFLAG) PRINT 20,DRIVE,DFORCE
      81: #ifdef NOCC
      82: 20      FORMAT('SYNMCH, DRIVE=',2I6)
      83: #else NOCC
      84: 20      FORMAT(' SYNMCH, DRIVE=',2I6)
      85: #endif NOCC
      86: #endif
      87:         IF(DRIVE.EQ.0) DRIVE=DFORCE
      88: C						!NO DRIVER? USE FORCE.
      89:         IF(DRIVE.EQ.0) GO TO 10000
      90: C						!ANY DRIVER?
      91:         CALL UNPACK(DRIVE,DFORCE)
      92: C						!UNPACK DFLT SYNTAX.
      93: C
      94: C TRY TO FILL DIRECT OBJECT SLOT IF THAT WAS THE PROBLEM.
      95: C
      96:         IF((and(VFLAG,SDIR).EQ.0).OR.(O1.NE.0)) GO TO 4000
      97: C
      98: C FIRST TRY TO SNARF ORPHAN OBJECT.
      99: C
     100:         O1=and(OFLAG,OSLOT)
     101:         IF(O1.EQ.0) GO TO 3500
     102: C						!ANY ORPHAN?
     103:         IF(SYNEQL(P1,O1,DOBJ,DFL1,DFL2)) GO TO 4000
     104: C
     105: C ORPHAN FAILS, TRY GWIM.
     106: C
     107: 3500    O1=GWIM(DOBJ,DFW1,DFW2)
     108: C						!GET GWIM.
     109: #ifdef debug
     110:         IF(DFLAG) PRINT 30,O1
     111: #ifdef NOCC
     112: 30      FORMAT('SYNMCH- DO GWIM= ',I6)
     113: #else NOCC
     114: 30      FORMAT(' SYNMCH- DO GWIM= ',I6)
     115: #endif NOCC
     116: #endif debug
     117:         IF(O1.GT.0) GO TO 4000
     118: C						!TEST RESULT.
     119:         CALL ORPHAN(-1,ACT,0,and(DOBJ,VPMASK),0)
     120:         CALL RSPEAK(623)
     121:         RETURN
     122: C
     123: C TRY TO FILL INDIRECT OBJECT SLOT IF THAT WAS THE PROBLEM.
     124: C
     125: 4000    IF((and(VFLAG,SIND).EQ.0).OR.(O2.NE.0)) GO TO 6000
     126:         O2=GWIM(IOBJ,IFW1,IFW2)
     127: C						!GWIM.
     128: #ifdef debug
     129:         IF(DFLAG) PRINT 40,O2
     130: #ifdef NOCC
     131: 40      FORMAT('SYNMCH- IO GWIM= ',I6)
     132: #else NOCC
     133: 40      FORMAT(' SYNMCH- IO GWIM= ',I6)
     134: #endif NOCC
     135: #endif debug
     136:         IF(O2.GT.0) GO TO 6000
     137:         IF(O1.EQ.0) O1=and(OFLAG,OSLOT)
     138:         CALL ORPHAN(-1,ACT,O1,and(DOBJ,VPMASK),0)
     139:         CALL RSPEAK(624)
     140:         RETURN
     141: C
     142: C TOTAL CHOMP
     143: C
     144: 10000   CALL RSPEAK(601)
     145: C						!CANT DO ANYTHING.
     146:         RETURN
     147: C SYNMCH, PAGE 3
     148: C
     149: C NOW TRY TO TAKE INDIVIDUAL OBJECTS AND
     150: C IN GENERAL CLEAN UP THE PARSE VECTOR.
     151: C
     152: 6000    IF(and(VFLAG,SFLIP).EQ.0) GO TO 5000
     153:         J=O1
     154: C						!YES.
     155:         O1=O2
     156:         O2=J
     157: C
     158: 5000    PRSA=and(VFLAG,SVMASK)
     159:         PRSO=O1
     160: C						!GET DIR OBJ.
     161:         PRSI=O2
     162: C						!GET IND OBJ.
     163:         IF(.NOT.TAKEIT(PRSO,DOBJ)) RETURN
     164: C						!TRY TAKE.
     165:         IF(.NOT.TAKEIT(PRSI,IOBJ)) RETURN
     166: C						!TRY TAKE.
     167:         SYNMCH=.TRUE.
     168: #ifdef debug
     169:         IF(DFLAG) PRINT 50,SYNMCH,PRSA,PRSO,PRSI,ACT,O1,O2
     170: #ifdef NOCC
     171: 50      FORMAT('SYNMCH- RESULTS ',L1,6I7)
     172: #else NOCC
     173: 50      FORMAT(' SYNMCH- RESULTS ',L1,6I7)
     174: #endif NOCC
     175: #endif
     176:         RETURN
     177: C
     178:         END
     179: C UNPACK-	UNPACK SYNTAX SPECIFICATION, ADV POINTER
     180: C
     181: C DECLARATIONS
     182: C
     183:         SUBROUTINE UNPACK(OLDJ,J)
     184:         IMPLICIT INTEGER(A-Z)
     185: #include "vocab.h"
     186: #include "parser.h"
     187: C
     188:         DO 10 I=1,11
     189: C						!CLEAR SYNTAX.
     190:           SYN(I)=0
     191: 10      CONTINUE
     192: C
     193:         VFLAG=VVOC(OLDJ)
     194:         J=OLDJ+1
     195:         IF(and(VFLAG,SDIR).EQ.0) RETURN
     196:         DFL1=-1
     197: C						!ASSUME STD.
     198:         DFL2=-1
     199:         IF(and(VFLAG,SSTD).EQ.0) GO TO 100
     200:         DFW1=-1
     201: C						!YES.
     202:         DFW2=-1
     203:         DOBJ=VABIT+VRBIT+VFBIT
     204:         GO TO 200
     205: C
     206: 100     DOBJ=VVOC(J)
     207: C						!NOT STD.
     208:         DFW1=VVOC(J+1)
     209:         DFW2=VVOC(J+2)
     210:         J=J+3
     211:         IF(and(DOBJ,VEBIT).EQ.0) GO TO 200
     212:         DFL1=DFW1
     213: C						!YES.
     214:         DFL2=DFW2
     215: C
     216: 200     IF(and(VFLAG,SIND).EQ.0) RETURN
     217:         IFL1=-1
     218: C						!ASSUME STD.
     219:         IFL2=-1
     220:         IOBJ=VVOC(J)
     221:         IFW1=VVOC(J+1)
     222:         IFW2=VVOC(J+2)
     223:         J=J+3
     224:         IF(and(IOBJ,VEBIT).EQ.0) RETURN
     225:         IFL1=IFW1
     226: C						!YES.
     227:         IFL2=IFW2
     228:         RETURN
     229: C
     230:         END
     231: C SYNEQL-	TEST FOR SYNTAX EQUALITY
     232: C
     233: C DECLARATIONS
     234: C
     235:         LOGICAL FUNCTION SYNEQL(PREP,OBJ,SPREP,SFL1,SFL2)
     236:         IMPLICIT INTEGER(A-Z)
     237: #include "objects.h"
     238: #include "parser.h"
     239: C
     240:         IF(OBJ.EQ.0) GO TO 100
     241: C						!ANY OBJECT?
     242:         SYNEQL=(PREP.EQ.and(SPREP,VPMASK)).AND.
     243: &               (or(and(SFL1,OFLAG1(OBJ)),
     244: &                 and(SFL2,OFLAG2(OBJ))).NE.0)
     245:         RETURN
     246: C
     247: 100     SYNEQL=(PREP.EQ.0).AND.(SFL1.EQ.0).AND.(SFL2.EQ.0)
     248:         RETURN
     249: C
     250:         END
     251: C TAKEIT-	PARSER BASED TAKE OF OBJECT
     252: C
     253: C DECLARATIONS
     254: C
     255:         LOGICAL FUNCTION TAKEIT(OBJ,SFLAG)
     256:         IMPLICIT INTEGER(A-Z)
     257: #include "parser.h"
     258:         COMMON /STAR/ MBASE,STRBIT
     259: #include "gamestate.h"
     260: #include "state.h"
     261: #include "objects.h"
     262: #include "oflags.h"
     263: #include "advers.h"
     264: C TAKEIT, PAGE 2
     265: C
     266:         TAKEIT=.FALSE.
     267: C						!ASSUME LOSES.
     268:         IF((OBJ.EQ.0).OR.(OBJ.GT.STRBIT)) GO TO 4000
     269: C						!NULL/STARS WIN.
     270:         ODO2=ODESC2(OBJ)
     271: C						!GET DESC.
     272:         X=OCAN(OBJ)
     273: C						!GET CONTAINER.
     274:         IF((X.EQ.0).OR.(and(SFLAG,VFBIT).EQ.0)) GO TO 500
     275:         IF(and(OFLAG2(X),OPENBT).NE.0) GO TO 500
     276:         CALL RSPSUB(566,ODO2)
     277: C						!CANT REACH.
     278:         RETURN
     279: C
     280: 500     IF(and(SFLAG,VRBIT).EQ.0) GO TO 1000
     281:         IF(and(SFLAG,VTBIT).EQ.0) GO TO 2000
     282: C
     283: C SHOULD BE IN ROOM (VRBIT NE 0) AND CAN BE TAKEN (VTBIT NE 0)
     284: C
     285:         IF(SCHLST(0,0,HERE,0,0,OBJ).LE.0) GO TO 4000
     286: C						!IF NOT, OK.
     287: C
     288: C ITS IN THE ROOM AND CAN BE TAKEN.
     289: C
     290:         IF((and(OFLAG1(OBJ),TAKEBT).NE.0).AND.
     291: &               (and(OFLAG2(OBJ),TRYBT).EQ.0)) GO TO 3000
     292: C
     293: C NOT TAKEABLE.  IF WE CARE, FAIL.
     294: C
     295:         IF(and(SFLAG,VCBIT).EQ.0) GO TO 4000
     296:         CALL RSPSUB(445,ODO2)
     297:         RETURN
     298: C
     299: C 1000--	IT SHOULD NOT BE IN THE ROOM.
     300: C 2000--	IT CANT BE TAKEN.
     301: C
     302: 2000    IF(and(SFLAG,VCBIT).EQ.0) GO TO 4000
     303: 1000    IF(SCHLST(0,0,HERE,0,0,OBJ).LE.0) GO TO 4000
     304:         CALL RSPSUB(665,ODO2)
     305:         RETURN
     306: C TAKEIT, PAGE 3
     307: C
     308: C OBJECT IS IN THE ROOM, CAN BE TAKEN BY THE PARSER,
     309: C AND IS TAKEABLE IN GENERAL.  IT IS NOT A STAR.
     310: C TAKING IT SHOULD NOT HAVE SIDE AFFECTS.
     311: C IF IT IS INSIDE SOMETHING, THE CONTAINER IS OPEN.
     312: C THE FOLLOWING CODE IS LIFTED FROM SUBROUTINE TAKE.
     313: C
     314: 3000    IF(OBJ.NE.AVEHIC(WINNER)) GO TO 3500
     315: C						!TAKE VEHICLE?
     316:         CALL RSPEAK(672)
     317:         RETURN
     318: C
     319: 3500    IF(((X.NE.0).AND.(OADV(X).EQ.WINNER)).OR.
     320: &        ((WEIGHT(0,OBJ,WINNER)+OSIZE(OBJ)).LE.MXLOAD))
     321: &        GO TO 3700
     322:         CALL RSPEAK(558)
     323: C						!TOO BIG.
     324:         RETURN
     325: C
     326: 3700    CALL NEWSTA(OBJ,559,0,0,WINNER)
     327: C						!DO TAKE.
     328:         OFLAG2(OBJ)=or(OFLAG2(OBJ),TCHBT)
     329:         CALL SCRUPD(OFVAL(OBJ))
     330:         OFVAL(OBJ)=0
     331: C
     332: 4000    TAKEIT=.TRUE.
     333: C						!SUCCESS.
     334:         RETURN
     335: C
     336:         END
     337: C
     338: C GWIM- GET WHAT I MEAN IN AMBIGOUS SITUATIONS
     339: C
     340: C DECLARATIONS
     341: C
     342:         INTEGER FUNCTION GWIM(SFLAG,SFW1,SFW2)
     343:         IMPLICIT INTEGER(A-Z)
     344:         LOGICAL TAKEIT,NOCARE
     345: #include "parser.h"
     346:         COMMON /STAR/ MBASE,STRBIT
     347: #include "gamestate.h"
     348: #include "objects.h"
     349: #include "oflags.h"
     350: #include "advers.h"
     351: C GWIM, PAGE 2
     352: C
     353:         GWIM=-1
     354: C						!ASSUME LOSE.
     355:         AV=AVEHIC(WINNER)
     356:         NOBJ=0
     357:         NOCARE=and(SFLAG,VCBIT).EQ.0
     358: C
     359: C FIRST SEARCH ADVENTURER
     360: C
     361:         IF(and(SFLAG,VABIT).NE.0)
     362: &               NOBJ=FWIM(SFW1,SFW2,0,0,WINNER,NOCARE)
     363:         IF(and(SFLAG,VRBIT).NE.0) GO TO 100
     364: 50      GWIM=NOBJ
     365:         RETURN
     366: C
     367: C ALSO SEARCH ROOM
     368: C
     369: 100     ROBJ=FWIM(SFW1,SFW2,HERE,0,0,NOCARE)
     370:         IF(ROBJ) 500,50,200
     371: C						!TEST RESULT.
     372: C
     373: C ROBJ > 0
     374: C
     375: 200     IF((AV.EQ.0).OR.(ROBJ.EQ.AV).OR.
     376: &               (and(OFLAG2(ROBJ),FINDBT).NE.0)) GO TO 300
     377:         IF(OCAN(ROBJ).NE.AV) GO TO 50
     378: C						!UNREACHABLE? TRY NOBJ
     379: 300     IF(NOBJ.NE.0) RETURN
     380: C						!IF AMBIGUOUS, RETURN.
     381:         IF(.NOT.TAKEIT(ROBJ,SFLAG)) RETURN
     382: C						!IF UNTAKEABLE, RETURN
     383:         GWIM=ROBJ
     384: 500     RETURN
     385: C
     386:         END

Last modified: 1988-10-21 Generated: 2016-12-26 | Generated by src2html V0.67 page hit count: 636 |