Return to END.f CVS log

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

researchv10 Norman

      SUBROUTINE END
C
C     ROUTINE SAVES SYMBOL TABLE FOR 2ND PASS
C     CHECKS VARIABLE DIMENSIONING IN FCN/SUBR PU'S
C     CANNOT RESET DUMMY ARGS USED IN VARIABLE DIMENSIONING;
C     CHECKS SUCH BOUNDS FOR TYPE INTEGER
C     CALLS OUTSYM TO PRINT SYMBOL TABLE
C     CHECKS FOR UNDEFINED LABELS,MISSING DO ENDINGS,
C     PROPER BRANCHING THROUGHOUT PGM,
C     FIXES UP ALL LABELS WHOSE SCOPE IS NOT YET LIMITED
C     SETS USAGE OF ALL IDS TO VARIABLE IF USAGE NOT YET SET
C     RESETS FCN USAGE IN FCN  SUBPROGRAM
C
      INTEGER OUTUT, OUTUT2, OUTUT3, OUTUT4
      INTEGER PDSA, SYMLEN, BNEXT, SYMHD, STACK, DSA
      LOGICAL OPT, P1ERR
      COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
     *    OUTUT4
      COMMON /OPTNS/ OPT(5), P1ERR
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /CEXPRS/ LSTACK, STACK(620)
      I = IGATT1(NAME,8)
      IF((I.NE.3 .AND. I.NE.10) .OR. DSA(NAME+2).EQ.0) GOTO 40
C
C     ARGUMENT CHECKING- FOR USE IN VARIABLE DIMENSIONING OF ARRAYS
C
      LL = 1
      L = DSA(NAME+2)
      NPAR = 0
   10 IF (L.EQ.0) GO TO 40
      NPAR = NPAR + 1
C     CHECK FOR PROC ARGS TO ENTER THEIR RELATIVE POSIT
C     IN ARGLIST IN WD 3 OF THEIR SYMBOL TABLE ENTRY
      I = IGATT1(DSA(L),8)
      IF (I.NE.5 .AND. I.NE.6 .AND. I.NE.13) GO TO 20
      I = DSA(L)
      DSA(I+2) = NPAR
      GO TO 30
   20 I = IGATT1(DSA(L),6)
      IF (I.EQ.0) GO TO 30
      I = IGATT1(DSA(L),7)
      IF (I.NE.0) GO TO 30
      I = IGATT1(DSA(L),5)
      K = DSA(L)
      IF (I.GT.0) CALL ERROR2(
     *    57H ILLEGALLY RESET DUMMY ARG USED IN VARIABLE DIMENSIONING ,
     *  57, DSA(K+4), 1, 1, 1)
      I = IGATT1(K,1)
      IF (MOD(I,8).NE.2) CALL ERROR2(
     *  47H ILLEGAL DATA TYPE USED IN ADJUSTIBLE DIMENSION, 47
     *  , DSA(K+4), 1, 1, 1)
   30 L = DSA(L+1)
      GO TO 10
C
C     OUTPUT TABLE
C
   40 CALL DOCHK(1)
C
C     CHECK LABELS DEFINED AND WITHIN SCOPE
C
      I = LABHD
   50 IF (I.EQ.0) GO TO 110
      L = IGATT1(I,2)
      IF (L.EQ.1) GO TO 60
      CALL ERROR2(17H UNDEFINED LABEL , 17, DSA(I+4), 1, 1, 1)
      GO TO 100
   60 L = IGATT1(I,1)
      IF (L.NE.1) GO TO 100
      L = DSA(I+2)
      L1 = DSA(L)
      KK = DSA(L+1)
      L2 = DSA(I+1)
C
C     L3 POINTS TO LAST ELEMENT ON CIRCULAR LIST
C
      L3 = L2
   70 IF (DSA(L2).LE.KK .AND. DSA(L2).GE.L1) GO TO 90
      IF (DSA(L2).LT.0) GO TO 80
      CALL ERROR2(15H ILLEGAL BRANCH, 15, DSA(L2), -1, 1, 1)
      GO TO 90
   80 DSA(L2) = IABS(DSA(L2))
   90 L2 = DSA(L2+1)
      IF (L2.NE.L3) GO TO 70
  100 I = DSA(I+3)
      GO TO 50
C
C     SET <ID> USAGE IF NOT YET SET
C
  110 I = SYMHD
  120 IF (I.EQ.0) GO TO 150
      K = IGATT1(I,8)
      IF (K.NE.0) GO TO 130
      CALL SATT1(I, 8, 10)
      GO TO 140
  130 IF (K.NE.6) GO TO 140
      IF (IGATT1(I,1)/8.NE.1) GO TO 140
      CALL ERROR2(33H SUBROUTINE NAME CANNOT BE TYPED , 33, DSA(I+4),
     *  1, 1, 1)
  140 I = DSA(I+3)
      GO TO 120
C
C     RESET FCN USAGE IN FCN PROGRAM UNIT
C
  150 I = IGATT1(NAME,8)
      IF (I.NE.10) GO TO 160
      CALL SATT1(NAME, 8, 4)
      I = IGATT1(NAME,5)
      IF (I.EQ.0) CALL ERROR1(23H FUNCTION VALUE NOT SET, 23)
C
C     SAVE BINARY COPY OF SYMBOL TABLE
C
  160 IF (OPT(3) .AND. .NOT.P1ERR) GO TO 170
      CALL ERROR1(36H P-U NOT SAVED FOR PASS2 PROCESSING , 36)
      K = 3
      L = 1
      WRITE(OUTUT2) L,K,L
      WRITE(OUTUT3) L,K,L
      GOTO 180
 170  K = 1
      L = NEXT - 1
      I = L + 3
      WRITE (OUTUT2) I, K, (DSA(I),I=1,L), NAME, SYMHD, LABHD
      L = 3
      WRITE (OUTUT3) K, L, K
  180 CALL OUTSYM
      RETURN
      END

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