CP/M/CPM_CDROM.iso/simtel/sigm/vols000/vol047/np.for

Text File | 1984-04-29 | 4.3 KB | 181 lines

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)
    LOGICAL*1 INBUF(78)
C
C PARSER OUTPUT
C
    LOGICAL PRSWON
    COMMON /PRSVEC/ PRSA,PRSI,PRSO,PRSWON,PRSCON
C
    COMMON /CHAN/ INPCH,OUTCH,DBCH
C
5    GO TO (90,10),WHO+1            !SEE WHO TO PROMPT FOR.
10    WRITE(OUTCH,50)                !PROMPT FOR GAME.
50    FORMAT(' >',$)
C
90    READ(INPCH,100) INBUF            !GET INPUT.
100    FORMAT(78A1)
C
    DO 200 INLNT=78,1,-1
      IF(INBUF(INLNT).NE.' ') GO TO 300    !NOT BLANK?
200    CONTINUE
    GO TO 5                    !TRY AGAIN.
C
300    DO 400 I=1,INLNT            !CONVERT TO UPPER CASE.
      IF((INBUF(I).GE.'a').AND.(INBUF(I).LE.'z'))
    1    INBUF(I)=INBUF(I)-"40
400    CONTINUE
    PRSCON=1                !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)
    LOGICAL*1 INBUF(78)
    LOGICAL LEX,SYNMCH,DFLAG,VBFLAG
    INTEGER OUTBUF(40)
    COMMON /DEBUG/ DBGFLG,PRSFLG
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
D    DFLAG=(PRSFLG.AND."1).NE.0
    PARSE=.FALSE.                !ASSUME FAILS.
    PRSA=0                    !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    !DO SYN SCAN.
C
C PARSE REQUIRES VALIDATION
C
200    IF(.NOT.VBFLAG) GO TO 350        !ECHO MODE, FORCE FAIL.
    IF(.NOT.SYNMCH(X)) GO TO 100        !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)            !CLEAR ORPHANS.
D    IF(DFLAG) TYPE 10,PARSE,PRSA,PRSO,PRSI
D10    FORMAT(' PARSE RESULTS- ',L7,3I7)
    RETURN
C
C PARSE FAILS, DISALLOW CONTINUATION
C
100    PRSCON=1
D    IF(DFLAG) TYPE 10,PARSE,PRSA,PRSO,PRSI
    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                    !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)
    LOGICAL*1 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
C
    DATA DLIMIT/'A','Z',"100,'1','9',"22,'-','-',"22/
C
    DO 100 I=1,40                !CLEAR OUTPUT BUF.
      OUTBUF(I)=0
100    CONTINUE
C
D    DFLAG=(PRSFLG.AND."2).NE.0
    LEX=.FALSE.                !ASSUME LEX FAILS.
    OP=-1                    !OUTPUT PTR.
50    OP=OP+2                    !ADV OUTPUT PTR.
    CP=0                    !CHAR PTR=0.
C
200    IF(PRSCON.GT.INLNT) GO TO 1000        !END OF INPUT?
    J=INBUF(PRSCON)                !NO, GET CHARACTER,
    PRSCON=PRSCON+1                !ADVANCE PTR.
    IF(J.EQ.'.') GO TO 1000            !END OF COMMAND?
    IF(J.EQ.',') GO TO 1000            !END OF COMMAND?
    IF(J.EQ.' ') GO TO 6000            !SPACE?
    DO 500 I=1,9,3                !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)        !GREEK TO ME, FAIL.
    RETURN
C
C END OF INPUT, SEE IF PARTIAL WORD AVAILABLE.
C
1000    IF(PRSCON.GT.INLNT) PRSCON=1        !FORCE PARSE RESTART.
    IF((CP.EQ.0).AND.(OP.EQ.1)) RETURN    !ANY RESULTS?
    IF(CP.EQ.0) OP=OP-2            !ANY LAST WORD?
    LEX=.TRUE.
D    IF(DFLAG) TYPE 10,CP,OP,PRSCON,(OUTBUF(I),I=1,OP+1)
D10    FORMAT(' LEX RESULTS- ',3I7/1X,10O7)
    RETURN
C
C LEGITIMATE CHARACTERS: LETTER, DIGIT, OR HYPHEN.
C
4000    J1=J-DLIMIT(I+2)            !CVT TO R50.
D    IF(DFLAG) TYPE 20,J,J1,CP
D20    FORMAT(' LEX- CHAR= ',3I7)
    IF(CP.GE.6) GO TO 200            !IGNORE IF TOO MANY CHAR.
    K=OP+(CP/3)                !COMPUTE WORD INDEX.
    GO TO (4100,4200,4300),(MOD(CP,3)+1)    !BRANCH ON CHAR.
4100    J2=J1*780                !CHAR 1... *780
    OUTBUF(K)=OUTBUF(K)+J2+J2        !*1560 (40 ADDED BELOW).
4200    OUTBUF(K)=OUTBUF(K)+(J1*39)        !*39 (1 ADDED BELOW).
4300    OUTBUF(K)=OUTBUF(K)+J1            !*1.
    CP=CP+1
    GO TO 200                !GET NEXT CHAR.
C
C SPACE
C
6000    IF(CP.EQ.0) GO TO 200            !ANY WORD YET?
    GO TO 50                !YES, ADV OP.
C
    END