Return to SETNOD.f CVS log

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

researchv10 Norman

      SUBROUTINE SETNOD
      INTEGER PLAT, COM, PNODE, PDSA, DSA, SYMLEN, PP, SYMHD, PCOM,
     *    SETARG, FINDND, FINDCM
      LOGICAL ERR, SYSERR, ABORT
      COMMON /COMS/ LCOM, PCOM, COM(300)
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /HEAD/ LNODE, PNODE, NODE(500)
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /TABL/ NEXT, LABHD, SYMHD, IBNEXT
      COMMON /SCR1/ LINODE, INODE(500)
C
C     LAT-IS THE CALLING GRAPH PLUS AUXILIARY NODES
C     PLAT-IS NEXT FREE WORD IN LAT
C     LLAT-IS LENGTH OF LAT
C     NODE-IS LIST OF ALL CALLING NODES INDICES IN LAT
C        (WILL BE IN ALPHABETIC ORDER BEFORE CHECKING COMMENCES)
C     PNODE-IS NEXT FREE WORD IN NODE
C     LNODE-IS LENGTH OF NODE
C
C     P.U. NODE IN LAT
C     WD 1.....PACKED CHARACTERS OF NAME OF SUBPGM
C     WD2.....NUMBER OF ARGS
C     WD3.....PTR TO HEAD OF LINEAR LINKED ORDERED LIST OF
C     ARGUMENT NODES IN LAT
C     WD4.....PTR TO HEAD OF LINEAR LINKED LIST OF COMMON NODES
C     IN LAT
C     WD5.....PTR TO HEAD OF LINEAR LINKED LIST OF INDICES IN
C     LAT OF ENTRIES FOR PARENT NODES
C     WD6.....PTR TO HEAD OF LINEAR LINKED LIST OF INDICES IN
C     LAT OF ENTRIES FOR DESCENDENT NODES
C     WD7.....PTR TO HEAD OF LINEAR LINKED LIST OF SEQUENCE NOS OF
C     BAD REFERENCES;  INCONSISTANT TYPE OF FCN/SUBR REFERENCE, INCORR
C     NUMBER OF ARGS, AND RECURSIVE CALL OF SELF ARE THE THREE
C     TYPES OF BAD REFS
C     WD8.....BITS 0-2 TYPE OF SUBPGM:  0 SUBR, 1 FCN, 2 BLOCK DATA,
C      3 MAIN, 4 ASF, 5 SUPEROOT
C     BITS 3-5 (IF FCN OR ASF) CONTAIN TYPE OF FCN: 0 DP, 1 RL,
C     2 INT, 3 COMP, 4 LOG
C
C     ARGUMENT NODE IN LAT
C     WD1.....ATTRIBUTES (SAME AS IN DSA, SEE LOOKUP)
C     WD2.....LENGTH (IN PROCEDURE ARGS THIS WORD POINTS TO
C     HEAD OF LINEAR LINKED LIST OF ACTUAL SUBPGM NAMES ASSOCIATED
C     WITH THIS ARG IN THE PROGRAM; ALSO HAVE INDEX IN LAT OF
C     SUBPRGM IN WHICH THE ASSOC OCCURS
C     WD 3.....PTR TO HEAD OF LINEAR LINKED LIST OF PARENT ARGS
C     (ARGS FROM PARENT RTNES SENT DOWN TO BE ASSOC. WITH THIS ARG)
C     WD 4.....PTR TO HEAD OF LINEAR LINKED LIST OF DESC. ARGS
C     (ARGS FROM DESC RTNES WHICH THIS ARG IS ASSOC. WITH)
C     WD 5.....PTR TO NEXT ARG NODE OR 0
C
C     COMMON NODE IN LAT
C     WD 1.....INDEX OF ENTRY FOR THIS COMMON IN COM
C     WD 2.....1 IF COMMON STORED INTO BY THIS P.U. ELSE 0
C     WD 3.....PTR TO NEXT COMMON NODE
C     CREATE NODE PTR TO NEW NODE IN LAT
C
      IF (PNODE.GT.LNODE) GO TO 170
      IF (PLAT+SYMLEN+7.GT.LLAT) GO TO 190
C
C     CHECK IF SUBPROGRAM HAS NAME SAME AS ANOTHER SUBPROGRAM
C     OR A COMMON BLOCK
C
      II = IGATT1(NAME,8)
      IF (II.EQ.11) GO TO 10
      IF (FINDND(DSA(NAME+4),IROOT)) 10, 10, 20
   10 IF (FINDCM(DSA(NAME+4))) 40, 40, 30
   20 ERR = .TRUE.
   30 CALL ERROR2(45H SUBPROGRAM AND/OR COMMON BLOCK NAME CONFLICT, 45,
     *  DSA(NAME+4), 1, 1, 1)
      IF (.NOT.ERR) GO TO 40
      ERR = .FALSE.
      ABORT = .TRUE.
      GO TO 160
   40 NODE(PNODE) = PLAT
      IROOT = PNODE
      PNODE = PNODE + 1
C
C     ENTER NAME INTO NODE
C
      DO 50 I=1,SYMLEN
        L = NAME + 3 + I
        LL = PLAT - 1 + I
        LAT(LL) = DSA(L)
   50 CONTINUE
C
C     PP POINTS TO CURRENT RTNE NODE IN LAT
C
      PP = PLAT
      PLAT = LL + 6
      LL = LL + 1
      DO 60 I=LL,PLAT
        LAT(I) = 0
   60 CONTINUE
C
C     0 SUBR, 1 FCN, 2 BLOCK DATA, 3 MAIN, 4 ASF, 5 SUPEROOT
C
      LAT(PLAT+1) = II/4
C     INITIALIZE LEVEL OF BLOCK DATA TO -2
      IF (LAT(PLAT+1).EQ.2) INODE(IROOT) = -2
      IF (LAT(PLAT+1).NE.1) GO TO 70
      L = IGATT1(NAME,1)
      LAT(PLAT+1) = LAT(PLAT+1) + 8*MOD(L,8)
   70 PLAT = PLAT + 2
C
C     HAVING INITIALIZED NODE TO 0, LOOK FOR ARGS
C
      IF (DSA(NAME+2)) 80, 90, 80
   80 L = PP + SYMLEN
      LAT(L) = SETARG(PP,NAME)
      IF (SYSERR) GO TO 160
C
C     READ THROUGH SYMBOL TABLE FOR COMMON BLOCK DEFNS AND ASF DEFS
C     AND SETTING OF COMMON REGION
C
   90 K = SYMHD
  100 IF (K) 110, 160, 110
  110 LL = IGATT1(K,8)
C
C     CHECK FOR ASF AND COMMON DEFNS OR COMMON
C     SETTING INFO
C
      GO TO (140, 120, 140, 140, 140, 140, 130, 150, 140, 150, 140,
     *    140, 140, 140), LL
C
C     CREATE ASF NODE
C
  120 CALL SETASF(PP, K)
      IF (SYSERR) GO TO 160
      GO TO 140
C
C     CREATE COM ENTRY
C
  130 CALL SETCOM(PP, K)
      IF (SYSERR) GO TO 160
  140 K = DSA(K+3)
      GO TO 100
C
C     CHECK IF ELEMENT IN COMMON
C
  150 LL = IGATT1(K,2)
      L = IGATT1(K,5)
      IF (L.NE.1 .OR. LL.NE.1) GO TO 140
      L = DSA(K+2)
      L = DSA(L+1)
      CALL MKCOM(PP, L)
      IF (SYSERR) GO TO 160
      GO TO 140
  160 RETURN
  170 CALL ERROR1(34H IN SETNOD, TABLE OVERFLOW OF NODE, 34)
  180 SYSERR = .TRUE.
      GO TO 160
  190 CALL ERROR1(33H IN SETNOD, TABLE OVERFLOW OF LAT, 33)
      GO TO 180
      END

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