Return to PU.f CVS log

Up to [Research Unix] / researchv10no / cmd / pfort

researchv10 Norman

      SUBROUTINE PU
      INTEGER STMT, PSTMT, SYMLEN, OUTUT, SYMHD, BNEXT, HASH, DSA
      INTEGER STACK, DOPT, DOLIST, PDSA, OUTUT2, OUTUT3, OUTUT4
      INTEGER Q(70)
      LOGICAL ERR, BLKD, SYSERR, LOGIF1, LOGIF2, LAB, EOF
      LOGICAL NEW, TOKLAB, EXECUT, P1ERR, OPT, RET, ABORT
      LOGICAL P2, QBR
      COMMON /OPTNS/ OPT(5), P1ERR
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
     *    OUTUT4
      COMMON /CEXPRS/ LSTACK, STACK(620)
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
      COMMON /CHASH/ LHASH, HASH(401)
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /DOS/ DOPT, LDO, DOLIST(192)
      COMMON /TRANS/ Q
      COMMON /PASS/ P2, QBR
C
C     ROUTINE HANDLES CYCLING THROUGH STMTS OF A PGM UNIT.  NEW IS
C     USED TO HANDLE P.U.'S WITHOUT END STMTS.  FLUSHING OF STMTS
C     TO NEXT END OR HEADING STMT IS PROVIDED FOR ILLEGAL SEQUENCING
C     LOGIF1,LOGIF2 ARE USED TO CYCLE THROUGH LOGICAL IF STMTS
C     EOF OF INPUT FILE
C     ERR USED AS ERROR DIAGNOSTIC INDICATOR
C     NEWRD, NEW USED TO CONTROL INPUT
C
      EOF = .FALSE.
      NEW = .FALSE.
C
C     INTER-PROGRAM INITIALIZATION
C     NOST CONTAINS CURRENT STATEMENT NUMBER
C     ITYP CONTAINS TYPE OF STMT
C     BLKD IS TRUE FOR BLOCK DATA PGM UNIT, ELSE FALSE
C     EXECUT IS TRUE FOR AT LEAST ONE EXECUTABLE STMT IN
C      PROGRAM UNIT EXISTING
C     NAME CONTAINS INDEX IN DSA OF PGM UNIT NAME
C     P1ERR USED TO CONTROL WRITING OF SYMBOL TABLE FOR
C      PASS 2
C     RET IS TRUE IF RETURN STMT OCCURS IN P.U. ELSE FALSE
C     NEXT, BNEXT POINT INTO DSA
C     LABHD POINTS TO HEAD OF LABELS LIST IN DSA
C     SYMHD POINTS TO HEAD OF SYMBOLS LIST IN DSA
C     KGP, IGP USED TO CHECK STMT SEQUENCING
C     DOPT,DOLIST USED TO CHECK DO LOOP NESTING
C
   10 NOST = 0
      ITYP = 0
      LTYP = 0
      BLKD = .FALSE.
      EXECUT = .FALSE.
      NAME = 0
      P1ERR = .FALSE.
      RET = .FALSE.
      NEXT = 1
      BNEXT = LDSA
      LABHD = 0
      SYMHD = 0
      KGP = 0
      DOPT = 1
      DOLIST(1) = 1
      DO 20 I=2,6
        DOLIST(I) = 0
   20 CONTINUE
      DO 30 I=1,LHASH
        HASH(I) = 0
   30 CONTINUE
C
C     DONT GOTO NEW PAGE IF NOT PRODUCING LISTING
C
      IF (.NOT.OPT(4)) GO TO 40
      WRITE (OUTUT,99999)
99999 FORMAT (32H1PFORT VERIFIER 1/12/79 VERSION //)
C
C     INPUT NEW STMT; RETURN WHEN HIT EOF STMT
C     FIND LABELS
C
C     HEADING STMT INADVERTENTLY READ BECAUSE OF MISSING END
C
   40 IF (.NOT.NEW) GO TO 70
      NEW = .FALSE.
      NOST = 1
      IF (.NOT.OPT(4)) GO TO 80
      K = NSTMT - 1
      DO 50 I=1,K
        II = STMT(I) + 1
        STACK(I) = Q(II)
   50 CONTINUE
      WRITE (OUTUT,99998) NOST, (STACK(I),I=1,K)
99998 FORMAT (1H , I5, 5X, 80A1)
      GO TO 80
   60 CALL ERROR1(20H UNRECOGNIZABLE STMT, 20)
      ERR = .FALSE.
   70 CALL INSTMT(EOF, NCARD)
      IF (EOF) GO TO 400
   80 LAB = .FALSE.
C
C     TYPST TYPES THE CURRENT STAMT
C     ITYP IS NO 1-30 TELLING STMT WE HAVE
C      KGP IS LEVEL NO 0-6 OF STMT.
C     ICNT IS NO OF CHARACTERS IN STMT IE KI(ITYP)
C
      PSTMT = 6
      CALL TYPST(ITYP, IGP, ICNT)
      IF (ERR) GO TO 60
      PSTMT = 6 + ICNT
      IF (ITYP.GE.6) GO TO 100
      I = ITYP - 1
      CALL TYPST(ITYP, II, K2)
      IF (ITYP.NE.10) GO TO 90
      PSTMT = PSTMT + K2
      IGP = II
      GO TO 110
   90 ITYP = I + 1
  100 I = -1
  110 II = 1
      IF (ITYP.LT.14 .OR. ITYP.EQ.28 .OR. ITYP.EQ.31) II = 2
      IF (ITYP.EQ.29) II = 3
      KEEP = PSTMT
      PSTMT = 1
      IF (TOKLAB(II,K2,KK,.TRUE.)) LAB = .TRUE.
      IF (SYSERR) GO TO 450
C
C     CHECK FOR MAIN PROGRAM OR OTHER HEADING STMTS
C
      IF (NAME) 140, 120, 140
  120 IF (IGP) 130, 150, 130
  130 CALL SETNAM(12)
      GO TO 150
  140 IF (IGP.EQ.0) GO TO 490
C
C     CHECK SEQUENCING OF STMTS
C
  150 IF (BLKD .AND. IGP.GT.3 .AND. ITYP.NE.28) GO TO 160
      IF (IGP.GE.KGP) GO TO 170
      CALL ERROR1(24H ILLEGAL STMT SEQUENCING, 24)
      GO TO 450
  160 CALL ERROR1(32H ILLEGAL STMTS IN BLOCK DATA PGM, 32)
      GO TO 450
C
C     CHECK FOR FIRST ASF DEFN OR EXECUTABLE STMT.
C     TO RESET USAGE OF FCN SUBPGM NAME IN SYMBOL TABLE
C
  170 IF (EXECUT .OR. IGP.LT.4) GO TO 180
      EXECUT = .TRUE.
      K = IGATT1(NAME,8)
      IF (K.EQ.4) CALL SATT1(NAME, 8, 10)
  180 PSTMT = KEEP
      LOGIF2 = .FALSE.
C
C     VALUES OF ITYP
C     1-5 TYPE STMTS: 1 DP, 2 REAL, 3 INT, 4 COMP, 5 LOG
C     6-8 OTHER SPECIFICATION STMTS: 6 EXTERNAL, 7 DIMENSION
C     8 COMMON
C     9-11 HEADING STMTS: 9 SUBROUTINE, 10 FUNCTION, 11 BLOCK DATA
C     12 EQUIVALENCE
C     13 DATA
C     14-27,30,32 EXECUTABLE STMTS: 14 ASSIGN, 15 GOTO, 16 RETURN,
C     17 CONTINUE, 18 CALL, 19 STOP, 20 IF, 21 DO, 22 PAUSE,
C     23 READ, 24 WRITE, 25 REWIND, 26 ENDFILE, 27 BACKSPACE, 30
C     ASSIGNMENT, 32 LOGICAL IF
C     28 END
C     29 FORMAT
C     31 ASF DEFN
C     CLASS CODES
C     0-HEADING STMTS
C     1-SPECIFICATION STMTS (INCLUDING TYPE STMTS)
C     2-EQUIVALENCE
C     3-DATA
C     4-ASF DEF
C     5-EXECUTABLE STMTS AND FORMAT STMTS
C     6-END STMT
C
  190 GO TO (200, 200, 200, 200, 200, 210, 220, 250, 230, 230, 240,
     *    270, 260, 350, 330, 360, 380, 370, 380, 300, 280, 340, 340,
     *    340, 340, 340, 340, 410, 390, 290), ITYP
C
C     TYPE STMTS (SYSERR)
C
  200 CALL TYPE
      GO TO 430
C
C     EXTERNAL STMT (SYSERR)
C
  210 CALL EXTERN
      GO TO 430
C
C     DIMENSION STMT(SYSERR)
C
  220 CALL DIMENS
      GO TO 430
C
C     SUBR/FCN DEFNS (SYSERR)
C
  230 CALL SUBFCN(I)
      GO TO 430
C
C     BLOCK DATA STMT (SYSERR)
C
  240 CALL SETNAM(11)
      BLKD = .TRUE.
      GO TO 430
C
C     COMMON STMT
C
  250 CALL COMMON
      GO TO 430
  260 CALL DATA
      GO TO 430
  270 CALL EQUIV
      GO TO 430
  280 CALL DOSTMT
      GO TO 430
  290 CALL ASSASF(IGP)
      IF (IGP.EQ.4 .AND. LOGIF2) GO TO 320
      GO TO 430
C
C     IF STMTS
C
  300 CALL IFS(LOGIF1)
C
C     FOUND AN ARITH. IF
C
      IF (.NOT.LOGIF1) GO TO 430
C
C     FOUND LOGICAL IF WITHIN LOGICAL IF
C
      IF (LOGIF1 .AND. LOGIF2) GO TO 320
C
C     FOUND A LOGICAL IF; MUS PROCESS REST OFSTMT
C
      LOGIF2 = .TRUE.
      CALL TYPST(ITYP, K, K2)
      IF (.NOT.ERR) GO TO 310
      CALL ERROR1(20H UNRECOGNIZABLE STMT, 20)
      GO TO 430
  310 IF (K.NE.4 .AND. K.NE.5 .OR. ITYP.EQ.21 .OR. ITYP.EQ.29) GO TO 320
      PSTMT = PSTMT + K2
      GO TO 190
  320 CALL ERROR1(27H ILLEGAL STMT IN LOGICAL IF, 27)
      GO TO 430
C
C     GOTO STMTS
C
  330 CALL GOTO
      GO TO 430
C
C      I-O STMTS
C
  340 CALL IO
      GO TO 430
C
C     ASSIGN  STMT
C
  350 CALL ASSIGN
      GO TO 430
C
C     RETURN  CANNOT  APPEAR IN MAIN PGM
C
  360 I = IGATT1(NAME,8)
      IF (I.EQ.12) CALL ERROR1(
     *    44H RETURN STATEMENT MAY NOT APPEAR IN MAIN PGM, 44)
      RET = .TRUE.
      GO TO 380
C
C     CALL STMT
C
  370 CALL CALLS
      GO TO 430
C
C     CHECK FOR EXTRANEOUS INFO AFTER STOP AND CONTINUE STMTS
C
  380 IF (PSTMT.NE.NSTMT) CALL ERROR1(
     *    34H EXTRANEOUS INFO AFTER END OF STMT, 34)
      GO TO 430
C
C     FORMAT
C
  390 IF (.NOT.LAB) CALL ERROR1(26H MISSING FORMAT STMT LABEL, 26)
      CALL FORMAT
      GO TO 430
C
C     CODE TO HANDLE END-OF-FILE WITHOUT AN END STMT
C
  400 IF (ITYP.EQ.28 .OR. ITYP.EQ.0) GO TO 500
      CALL ERROR1(37H WARNING - MISSING END STMT SIMULATED, 37)
      LAB = .FALSE.
      ITYP = 28
  410 CALL END
C
C     CHECK FOR NO CONTINUATION
C
      IF (NCARD.GT.1) CALL ERROR1(34H END LINE CANNOT HAVE CONTINUATION,
     *    34)
C
C     CHECK FOR ENDING ON A GOTO,ARITH IF, STOP OR RETURN
C
      IF ((LTYP.EQ.16 .OR. LTYP.EQ.15 .OR. LTYP.EQ.19 .OR. LTYP.EQ.20)
     *    .OR. BLKD) GO TO 420
      CALL ERROR1(29H ILLEGAL LAST EXECUTABLE STMT, 29)
C
C     CHECK THERE HAVE BEEN EXECUTABLE STMTS
C     CHECK FOR A RETURN STMT IF NECESSARY
C
  420 IF (KGP.NE.5 .AND. .NOT.BLKD) CALL ERROR1(
     *    42H ILLEGAL PROGRAM UNIT, NO EXECUTABLE STMTS, 42)
      I = IGATT1(NAME,8)
      IF (I.EQ.11 .OR. I.EQ.12 .OR. RET) GO TO 430
      CALL ERROR1(36H MISSING RETURN STMT IN PROGRAM UNIT, 36)
C
C     CHECK STMT LABELS FOR DOENDINGS, UPDATE KGP, CHECK TABLE SIZE
C     CHECK FOR CANCELLING SAVING OF SYMBOL TABLE FOR PASS2
C     DUE TO ERRORS IN THIS PGM UNIT
C
  430 KGP = IGP
      IF (ITYP.NE.29) LTYP = ITYP
      IF (LOGIF2) LTYP = 32
      IF (SYSERR) GO TO 450
      IF (.NOT.LAB) GO TO 440
      CALL DOCHK(KK)
      IF (ITYP.LT.14 .OR. ITYP.EQ.28 .OR. ITYP.EQ.31) CALL ERROR1(
     *    37H WARNING - LABELED NONEXECUTABLE STMT, 37)
  440 IF (EOF) GO TO 500
      ERR = .FALSE.
      IF (ITYP.EQ.28) GO TO 10
      GO TO 70
C
C     FLUSH CODE TO NEXT HEADR OR END SMT
C
  450 CALL ERROR1(44H CODE FLUSHED UNTIL NEXT END OR HEADING STMT, 44)
      P1ERR = .TRUE.
      IF (SYSERR) SYSERR = .FALSE.
      LAB = .FALSE.
  460 CALL INSTMT(EOF, NCARD)
      IF (EOF) GO TO 500
      PSTMT = 6
      CALL TYPST(ITYP, IGP, ICNT)
      IF (.NOT.ERR) GO TO 470
      ERR = .FALSE.
      GO TO 460
  470 IF (ITYP.EQ.28) GO TO 410
      IF (ITYP.GT.5) GO TO 480
      PSTMT = PSTMT + ICNT
      CALL TYPST(ITYP, IGP, ICNT)
      IF (ERR) ERR = .FALSE.
      IF (ITYP.EQ.10) GO TO 490
      GO TO 460
  480 IF (ITYP.LT.9 .OR. ITYP.GT.11) GO TO 460
C
C     HAVE FOUND A HEADER STMT; SIMULATE AN END STMT
C
  490 NEW = .TRUE.
      CALL ERROR1(37H WARNING - MISSING END STMT SIMULATED, 37)
      ITYP = 28
      LAB = .FALSE.
      GO TO 410
C
C     PUT ENDING MARKER ON THE DATA FOR PASS2
C
  500 I = 1
      II = 4
      WRITE (OUTUT3) I, II, I
      WRITE (OUTUT2) I, II, I
      RETURN
      END

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.