1C SYNMCH-- SYNTAX MATCHER 2C 3C COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142 4C ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED 5C WRITTEN BY R. M. SUPNIK 6C 7C DECLARATIONS 8C 9C THIS ROUTINE DETAILS ON BIT 4 OF PRSFLG 10C 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" 17C 18C THE FOLLOWING DATA STATEMENT WAS ORIGINALLY: 19C 20C DATA R50MIN/1RA/ 21C 22 DATA R50MIN/1600/ 23C 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 30C !SET UP PTR TO SYNTAX. 31 DRIVE=0 32C !NO DEFAULT. 33 DFORCE=0 34C !NO FORCED DEFAULT. 35 QPREP=and(OFLAG,OPREP) 36100 J=J+2 37C !FIND START OF SYNTAX. 38 IF((VVOC(J).LE.0).OR.(VVOC(J).GE.R50MIN)) GO TO 100 39 LIMIT=J+VVOC(J)+1 40C !COMPUTE LIMIT. 41 J=J+1 42C !ADVANCE TO NEXT. 43C 44200 CALL UNPACK(J,NEWJ) 45C !UNPACK SYNTAX. 46#ifdef debug 47 IF(DFLAG) PRINT 60,O1,P1,DOBJ,DFL1,DFL2 48#ifdef NOCC 4960 FORMAT('SYNMCH INPUTS TO SYNEQL- ',5I7) 50#else NOCC 5160 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 61C 62C SYNTAX MATCH FAILS, TRY NEXT ONE. 63C 64 IF(O2) 3000,500,3000 65C !IF O2=0, SET DFLT. 661000 IF(O1) 3000,500,3000 67C !IF O1=0, SET DFLT. 68500 IF((QPREP.EQ.0).OR.(QPREP.EQ.SPREP)) DFORCE=J 69C !IF PREP MCH. 70 IF((and(VFLAG,SDRIV)).NE.0) DRIVE=J 713000 J=NEWJ 72 IF(J.LT.LIMIT) GO TO 200 73C !MORE TO DO? 74C SYNMCH, PAGE 2 75C 76C MATCH HAS FAILED. IF DEFAULT SYNTAX EXISTS, TRY TO SNARF 77C ORPHANS OR GWIMS, OR MAKE NEW ORPHANS. 78C 79#ifdef debug 80 IF(DFLAG) PRINT 20,DRIVE,DFORCE 81#ifdef NOCC 8220 FORMAT('SYNMCH, DRIVE=',2I6) 83#else NOCC 8420 FORMAT(' SYNMCH, DRIVE=',2I6) 85#endif NOCC 86#endif 87 IF(DRIVE.EQ.0) DRIVE=DFORCE 88C !NO DRIVER? USE FORCE. 89 IF(DRIVE.EQ.0) GO TO 10000 90C !ANY DRIVER? 91 CALL UNPACK(DRIVE,DFORCE) 92C !UNPACK DFLT SYNTAX. 93C 94C TRY TO FILL DIRECT OBJECT SLOT IF THAT WAS THE PROBLEM. 95C 96 IF((and(VFLAG,SDIR).EQ.0).OR.(O1.NE.0)) GO TO 4000 97C 98C FIRST TRY TO SNARF ORPHAN OBJECT. 99C 100 O1=and(OFLAG,OSLOT) 101 IF(O1.EQ.0) GO TO 3500 102C !ANY ORPHAN? 103 IF(SYNEQL(P1,O1,DOBJ,DFL1,DFL2)) GO TO 4000 104C 105C ORPHAN FAILS, TRY GWIM. 106C 1073500 O1=GWIM(DOBJ,DFW1,DFW2) 108C !GET GWIM. 109#ifdef debug 110 IF(DFLAG) PRINT 30,O1 111#ifdef NOCC 11230 FORMAT('SYNMCH- DO GWIM= ',I6) 113#else NOCC 11430 FORMAT(' SYNMCH- DO GWIM= ',I6) 115#endif NOCC 116#endif debug 117 IF(O1.GT.0) GO TO 4000 118C !TEST RESULT. 119 CALL ORPHAN(-1,ACT,0,and(DOBJ,VPMASK),0) 120 CALL RSPEAK(623) 121 RETURN 122C 123C TRY TO FILL INDIRECT OBJECT SLOT IF THAT WAS THE PROBLEM. 124C 1254000 IF((and(VFLAG,SIND).EQ.0).OR.(O2.NE.0)) GO TO 6000 126 O2=GWIM(IOBJ,IFW1,IFW2) 127C !GWIM. 128#ifdef debug 129 IF(DFLAG) PRINT 40,O2 130#ifdef NOCC 13140 FORMAT('SYNMCH- IO GWIM= ',I6) 132#else NOCC 13340 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 141C 142C TOTAL CHOMP 143C 14410000 CALL RSPEAK(601) 145C !CANT DO ANYTHING. 146 RETURN 147C SYNMCH, PAGE 3 148C 149C NOW TRY TO TAKE INDIVIDUAL OBJECTS AND 150C IN GENERAL CLEAN UP THE PARSE VECTOR. 151C 1526000 IF(and(VFLAG,SFLIP).EQ.0) GO TO 5000 153 J=O1 154C !YES. 155 O1=O2 156 O2=J 157C 1585000 PRSA=and(VFLAG,SVMASK) 159 PRSO=O1 160C !GET DIR OBJ. 161 PRSI=O2 162C !GET IND OBJ. 163 IF(.NOT.TAKEIT(PRSO,DOBJ)) RETURN 164C !TRY TAKE. 165 IF(.NOT.TAKEIT(PRSI,IOBJ)) RETURN 166C !TRY TAKE. 167 SYNMCH=.TRUE. 168#ifdef debug 169 IF(DFLAG) PRINT 50,SYNMCH,PRSA,PRSO,PRSI,ACT,O1,O2 170#ifdef NOCC 17150 FORMAT('SYNMCH- RESULTS ',L1,6I7) 172#else NOCC 17350 FORMAT(' SYNMCH- RESULTS ',L1,6I7) 174#endif NOCC 175#endif 176 RETURN 177C 178 END 179C UNPACK- UNPACK SYNTAX SPECIFICATION, ADV POINTER 180C 181C DECLARATIONS 182C 183 SUBROUTINE UNPACK(OLDJ,J) 184 IMPLICIT INTEGER(A-Z) 185#include "vocab.h" 186#include "parser.h" 187C 188 DO 10 I=1,11 189C !CLEAR SYNTAX. 190 SYN(I)=0 19110 CONTINUE 192C 193 VFLAG=VVOC(OLDJ) 194 J=OLDJ+1 195 IF(and(VFLAG,SDIR).EQ.0) RETURN 196 DFL1=-1 197C !ASSUME STD. 198 DFL2=-1 199 IF(and(VFLAG,SSTD).EQ.0) GO TO 100 200 DFW1=-1 201C !YES. 202 DFW2=-1 203 DOBJ=VABIT+VRBIT+VFBIT 204 GO TO 200 205C 206100 DOBJ=VVOC(J) 207C !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 213C !YES. 214 DFL2=DFW2 215C 216200 IF(and(VFLAG,SIND).EQ.0) RETURN 217 IFL1=-1 218C !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 226C !YES. 227 IFL2=IFW2 228 RETURN 229C 230 END 231C SYNEQL- TEST FOR SYNTAX EQUALITY 232C 233C DECLARATIONS 234C 235 LOGICAL FUNCTION SYNEQL(PREP,OBJ,SPREP,SFL1,SFL2) 236 IMPLICIT INTEGER(A-Z) 237#include "objects.h" 238#include "parser.h" 239C 240 IF(OBJ.EQ.0) GO TO 100 241C !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 246C 247100 SYNEQL=(PREP.EQ.0).AND.(SFL1.EQ.0).AND.(SFL2.EQ.0) 248 RETURN 249C 250 END 251C TAKEIT- PARSER BASED TAKE OF OBJECT 252C 253C DECLARATIONS 254C 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" 264C TAKEIT, PAGE 2 265C 266 TAKEIT=.FALSE. 267C !ASSUME LOSES. 268 IF((OBJ.EQ.0).OR.(OBJ.GT.STRBIT)) GO TO 4000 269C !NULL/STARS WIN. 270 ODO2=ODESC2(OBJ) 271C !GET DESC. 272 X=OCAN(OBJ) 273C !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) 277C !CANT REACH. 278 RETURN 279C 280500 IF(and(SFLAG,VRBIT).EQ.0) GO TO 1000 281 IF(and(SFLAG,VTBIT).EQ.0) GO TO 2000 282C 283C SHOULD BE IN ROOM (VRBIT NE 0) AND CAN BE TAKEN (VTBIT NE 0) 284C 285 IF(SCHLST(0,0,HERE,0,0,OBJ).LE.0) GO TO 4000 286C !IF NOT, OK. 287C 288C ITS IN THE ROOM AND CAN BE TAKEN. 289C 290 IF((and(OFLAG1(OBJ),TAKEBT).NE.0).AND. 291& (and(OFLAG2(OBJ),TRYBT).EQ.0)) GO TO 3000 292C 293C NOT TAKEABLE. IF WE CARE, FAIL. 294C 295 IF(and(SFLAG,VCBIT).EQ.0) GO TO 4000 296 CALL RSPSUB(445,ODO2) 297 RETURN 298C 299C 1000-- IT SHOULD NOT BE IN THE ROOM. 300C 2000-- IT CANT BE TAKEN. 301C 3022000 IF(and(SFLAG,VCBIT).EQ.0) GO TO 4000 3031000 IF(SCHLST(0,0,HERE,0,0,OBJ).LE.0) GO TO 4000 304 CALL RSPSUB(665,ODO2) 305 RETURN 306C TAKEIT, PAGE 3 307C 308C OBJECT IS IN THE ROOM, CAN BE TAKEN BY THE PARSER, 309C AND IS TAKEABLE IN GENERAL. IT IS NOT A STAR. 310C TAKING IT SHOULD NOT HAVE SIDE AFFECTS. 311C IF IT IS INSIDE SOMETHING, THE CONTAINER IS OPEN. 312C THE FOLLOWING CODE IS LIFTED FROM SUBROUTINE TAKE. 313C 3143000 IF(OBJ.NE.AVEHIC(WINNER)) GO TO 3500 315C !TAKE VEHICLE? 316 CALL RSPEAK(672) 317 RETURN 318C 3193500 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) 323C !TOO BIG. 324 RETURN 325C 3263700 CALL NEWSTA(OBJ,559,0,0,WINNER) 327C !DO TAKE. 328 OFLAG2(OBJ)=or(OFLAG2(OBJ),TCHBT) 329 CALL SCRUPD(OFVAL(OBJ)) 330 OFVAL(OBJ)=0 331C 3324000 TAKEIT=.TRUE. 333C !SUCCESS. 334 RETURN 335C 336 END 337C 338C GWIM- GET WHAT I MEAN IN AMBIGOUS SITUATIONS 339C 340C DECLARATIONS 341C 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" 351C GWIM, PAGE 2 352C 353 GWIM=-1 354C !ASSUME LOSE. 355 AV=AVEHIC(WINNER) 356 NOBJ=0 357 NOCARE=and(SFLAG,VCBIT).EQ.0 358C 359C FIRST SEARCH ADVENTURER 360C 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 36450 GWIM=NOBJ 365 RETURN 366C 367C ALSO SEARCH ROOM 368C 369100 ROBJ=FWIM(SFW1,SFW2,HERE,0,0,NOCARE) 370 IF(ROBJ) 500,50,200 371C !TEST RESULT. 372C 373C ROBJ > 0 374C 375200 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 378C !UNREACHABLE? TRY NOBJ 379300 IF(NOBJ.NE.0) RETURN 380C !IF AMBIGUOUS, RETURN. 381 IF(.NOT.TAKEIT(ROBJ,SFLAG)) RETURN 382C !IF UNTAKEABLE, RETURN 383 GWIM=ROBJ 384500 RETURN 385C 386 END 387