1C RDLINE- READ INPUT LINE 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 9 SUBROUTINE RDLINE(BUFFER,LENGTH,WHO) 10 IMPLICIT INTEGER(A-Z) 11 CHARACTER BUFFER(78) 12#ifndef PDP 13 character*78 sysbuf 14#endif 15#include "parser.h" 16#include "io.h" 17 18#ifdef PDP 195 if (WHO .eq. 1) call prompt 20C read a line of input 2190 call rdlin(BUFFER,LENGTH) 22#else 235 GO TO (90,10),WHO+1 24C !SEE WHO TO PROMPT FOR. 2510 WRITE(OUTCH,50) 26C !PROMPT FOR GAME. 27#ifdef NOCC 2850 FORMAT('>',$) 29#else NOCC 3050 FORMAT(' >',$) 31#endif NOCC 32 3390 READ(INPCH,100, END=210) BUFFER 34100 FORMAT(78A1) 35 36 DO 200 LENGTH=78,1,-1 37 IF(BUFFER(LENGTH).NE.' ') GO TO 250 38200 CONTINUE 39 GO TO 5 40C !END OF FILE 41210 STOP 42C !TRY AGAIN. 43 44C 45C check for shell escape here before things are 46C converted to upper case 47C 48250 if (buffer(1) .ne. '!') go to 300 49 do 275 j=2,length 50 sysbuf(j-1:j-1) = buffer(j) 51275 continue 52 sysbuf(length:length) = char(0) 53 call system(sysbuf) 54 go to 5 55 56C CONVERT TO UPPER CASE 57300 DO 400 I=1,LENGTH 58 IF(and((BUFFER(I).GE.'a'),(BUFFER(I).LE.'z'))) 59& BUFFER(I)=char(ichar(BUFFER(I))-32) 60400 CONTINUE 61#endif PDP 62 63 if(LENGTH.EQ.0) GO TO 5 64 PRSCON=1 65C !RESTART LEX SCAN. 66 RETURN 67 END 68C PARSE- TOP LEVEL PARSE ROUTINE 69C 70C DECLARATIONS 71C 72C THIS ROUTINE DETAILS ON BIT 0 OF PRSFLG 73C 74 LOGICAL FUNCTION PARSE(INBUF,INLNT,VBFLAG) 75 IMPLICIT INTEGER(A-Z) 76 CHARACTER INBUF(78) 77 LOGICAL LEX,SYNMCH,VBFLAG 78 INTEGER OUTBUF(40) 79#include "debug.h" 80#include "parser.h" 81#include "xsrch.h" 82C 83#ifdef debug 84 DFLAG=and(PRSFLG,1).NE.0 85#endif 86 PARSE=.FALSE. 87C !ASSUME FAILS. 88 PRSA=0 89C !ZERO OUTPUTS. 90 PRSI=0 91 PRSO=0 92C 93#ifdef PDP 94C LEX recoded in C for pdp version (see lex.c) 95 if(.not. lex(INBUF,INLNT,OUTBUF,OUTLNT,VBFLAG,PRSCON)) goto 100 96#else 97 IF(.NOT.LEX(INBUF,INLNT,OUTBUF,OUTLNT,VBFLAG)) GO TO 100 98#endif 99 IF(SPARSE(OUTBUF,OUTLNT,VBFLAG)) 100,200,300 100C !DO SYN SCAN. 101C 102C PARSE REQUIRES VALIDATION 103C 104200 IF(.NOT.VBFLAG) GO TO 350 105C !ECHO MODE, FORCE FAIL. 106 IF(.NOT.SYNMCH(X)) GO TO 100 107C !DO SYN MATCH. 108 IF(and((PRSO.GT.0),(PRSO.LT.XMIN))) LASTIT=PRSO 109C 110C SUCCESSFUL PARSE OR SUCCESSFUL VALIDATION 111C 112300 PARSE=.TRUE. 113350 CALL ORPHAN(0,0,0,0,0) 114C !CLEAR ORPHANS. 115#ifdef debug 116 if(dflag) write(0,*) "parse good" 117 IF(DFLAG) PRINT 10,PARSE,PRSA,PRSO,PRSI 118#ifdef NOCC 11910 FORMAT('PARSE RESULTS- ',L7,3I7) 120#else NOCC 12110 FORMAT(' PARSE RESULTS- ',L7,3I7) 122#endif NOCC 123#endif 124 RETURN 125C 126C PARSE FAILS, DISALLOW CONTINUATION 127C 128100 PRSCON=1 129#ifdef debug 130 if(dflag) write(0,*) "parse failed" 131 IF(DFLAG) PRINT 10,PARSE,PRSA,PRSO,PRSI 132#endif 133 RETURN 134C 135 END 136C ORPHAN- SET UP NEW ORPHANS 137C 138C DECLARATIONS 139C 140 SUBROUTINE ORPHAN(O1,O2,O3,O4,O5) 141 IMPLICIT INTEGER(A-Z) 142 COMMON /ORPHS/ A,B,C,D,E 143C 144 A=O1 145C !SET UP NEW ORPHANS. 146 B=O2 147 C=O3 148 D=O4 149 E=O5 150 RETURN 151 END 152#ifndef PDP 153C LEX- LEXICAL ANALYZER 154C 155C 156C THIS ROUTINE DETAILS ON BIT 1 OF PRSFLAG 157C 158 LOGICAL FUNCTION LEX(INBUF,INLNT,OUTBUF,OP,VBFLAG) 159 IMPLICIT INTEGER(A-Z) 160 CHARACTER INBUF(78),J,DLIMIT(9) 161 INTEGER OUTBUF(40),ZLIMIT(9) 162 LOGICAL VBFLAG 163#include "parser.h" 164C 165#include "debug.h" 166C 167c the System V compiler doesn't like octal initialization of character 168c arrays, so the following is done for its benefit 169c 170c DATA DLIMIT/'A','Z',o'100','1','9',o'22','-','-',o'22'/ 171c 172 DATA ZLIMIT/o'101',o'132',o'100',o'61',o'71',o'22',o'55',o'55',o'22'/ 173c 174 do 99 i=1,9 175 dlimit(i) = char(zlimit(i)) 176c ! copy integers to chars 17799 continue 178C 179 DO 100 I=1,40 180C !CLEAR OUTPUT BUF. 181 OUTBUF(I)=0 182100 CONTINUE 183C 184#ifdef debug 185 DFLAG=and(PRSFLG,2).NE.0 186#endif debug 187 LEX=.FALSE. 188C !ASSUME LEX FAILS. 189 OP=-1 190C !OUTPUT PTR. 19150 OP=OP+2 192C !ADV OUTPUT PTR. 193 CP=0 194C !CHAR PTR=0. 195C 196200 IF(PRSCON.GT.INLNT) GO TO 1000 197C !END OF INPUT? 198 J=INBUF(PRSCON) 199C !NO, GET CHARACTER, 200 PRSCON=PRSCON+1 201C !ADVANCE PTR. 202 IF(J.EQ.'.') GO TO 1000 203C !END OF COMMAND? 204 IF(J.EQ.',') GO TO 1000 205C !END OF COMMAND? 206 IF(J.EQ.' ') GO TO 6000 207C !SPACE? 208 DO 500 I=1,9,3 209C !SCH FOR CHAR. 210 IF(and((J.GE.DLIMIT(I)),(J.LE.DLIMIT(I+1)))) 211& GO TO 4000 212500 CONTINUE 213C 214 IF(VBFLAG) CALL RSPEAK(601) 215C !GREEK TO ME, FAIL. 216 RETURN 217C 218C END OF INPUT, SEE IF PARTIAL WORD AVAILABLE. 219C 2201000 IF(PRSCON.GT.INLNT) PRSCON=1 221C !FORCE PARSE RESTART. 222 IF(and((CP.EQ.0),(OP.EQ.1))) RETURN 223 IF(CP.EQ.0) OP=OP-2 224C !ANY LAST WORD? 225 LEX=.TRUE. 226#ifdef debug 227 IF(DFLAG) PRINT 10,CP,OP,PRSCON,(OUTBUF(I),I=1,OP+1) 228#ifdef NOCC 22910 FORMAT('LEX RESULTS- ',3I7/1X,10O7) 230#else NOCC 23110 FORMAT(' LEX RESULTS- ',3I7/1X,10O7) 232#endif NOCC 233#endif debug 234 RETURN 235C 236C LEGITIMATE CHARACTERS: LETTER, DIGIT, OR HYPHEN. 237C 2384000 J1=ichar(J)-ichar(DLIMIT(I+2)) 239#ifdef debug 240 IF(DFLAG) PRINT 20,J,J1,CP 241#ifdef NOCC 24220 FORMAT('LEX- CHAR= ',3I7) 243#else NOCC 24420 FORMAT(' LEX- CHAR= ',3I7) 245#endif NOCC 246#endif debug 247 IF(CP.GE.6) GO TO 200 248C !IGNORE IF TOO MANY CHAR. 249 K=OP+(CP/3) 250C !COMPUTE WORD INDEX. 251 GO TO (4100,4200,4300),(MOD(CP,3)+1) 252C !BRANCH ON CHAR. 2534100 J2=J1*780 254C !CHAR 1... *780 255 OUTBUF(K)=OUTBUF(K)+J2+J2 256C !*1560 (40 ADDED BELOW). 2574200 OUTBUF(K)=OUTBUF(K)+(J1*39) 258C !*39 (1 ADDED BELOW). 2594300 OUTBUF(K)=OUTBUF(K)+J1 260C !*1. 261 CP=CP+1 262 GO TO 200 263C !GET NEXT CHAR. 264C 265C SPACE 266C 2676000 IF(CP.EQ.0) GO TO 200 268C !ANY WORD YET? 269 GO TO 50 270C !YES, ADV OP. 271C 272 END 273#endif PDP 274