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: 474
Valid CSS Valid XHTML 1.0 Strict