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