![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to PROC.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / pfort|
Return to PROC.f CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
1.1 ! root 1: SUBROUTINE PROC(IP, IM, IIM, OK) ! 2: C ! 3: C P.U. AT LAT(IP) CALLS P.U. AT LAT(IM) (NODE(IIM)) ! 4: C PROC COLLECTS ACTUAL PROC TEMPLATE(S) FROM THE CALL IF IT CAN ! 5: C CHECKS FOR MISSING SUBPGMS AND STORES TEMPLATES OFF PGM UNIT ! 6: C AT LAT(IM), THEM PROC CALLS ASLEV TO READJUST LEVELS OF ACTUALS ! 7: C SENT TO LAT(IM) VS LEVEL (IM) ! 8: C ! 9: LOGICAL ERR, SYSERR, ABORT, OK ! 10: INTEGER STACK, SYMLEN, PDSA, DSA, REF, PREF, PNODE, PLAT, FINDND, ! 11: * FIND, SS(120), KBR(1) ! 12: COMMON /CEXPRS/ LSTACK, STACK(620) ! 13: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6 ! 14: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 15: COMMON /CREF/ LREF, PREF, REF(100) ! 16: COMMON /HEAD/ LNODE, PNODE, NODE(500) ! 17: COMMON /SCR1/ LINODE, INODE(500) ! 18: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 19: COMMON /DETECT/ ERR, SYSERR, ABORT ! 20: EQUIVALENCE (SS(1),STACK(501)) ! 21: DATA KBR(1) /0/ ! 22: LSS = 501 ! 23: C ARE THERE ARGS IN THIS REF ! 24: IF (REF(1).NE.0) GO TO 20 ! 25: 10 RETURN ! 26: C CYCLE THROUGH REF ARGS ! 27: C JJ IS LAST ENTRY IN REF FOR ARGS ! 28: C IS PTS TO FIRST FREE WD IN STACK ! 29: C MAX IS 1 IF NO DUMMY PROCS IN REF, ELSE IS EQUAL TO THE ! 30: C NUMBER OF ACTUAL PROCS SUBSTITUTABLE FOR THE DUMMY PROCS ! 31: 20 JJ = REF(1) + 4 ! 32: IS = 1 ! 33: MAX = 0 ! 34: DO 90 I=5,JJ,2 ! 35: C SKIP OVER EXPR AS ACTUAL ARGS AND ALL ACTUALS BUT PROC ARGS ! 36: IF (REF(I).EQ.0) GO TO 90 ! 37: IF (REF(I+1).NE.6) GO TO 90 ! 38: C SEE IF ACTUAL ARG IS DUMMY PROC ARG AT LAT(IP) ! 39: C OR ACTUAL PROCEDURE ! 40: IF (IGATT1(REF(I),4).EQ.1) GO TO 40 ! 41: C HAVE AN ACTUAL PROCEDURE ! 42: L = REF(I) ! 43: L = FINDND(DSA(L+4),K) ! 44: IF (L.NE.0) GO TO 30 ! 45: C IF, AS GATHERING ACTUAL PROCS MATCHED TO DUMMY PROC ARGS ! 46: C PROC FINDS A MISSING SUBPROGM, PROCESSING OF THIS REF CEASES ! 47: L = REF(I) ! 48: CALL ERROR2(20H MISSING SUBPROGRAM , 20, DSA(L+4), 1, 1, 0) ! 49: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1) ! 50: GO TO 10 ! 51: 30 IF (IS+2.GT.LSS) GO TO 200 ! 52: C 2 WD STACK ENTRY FOR AN ACTUAL PROC AS AN ACTUAL ARG ! 53: C IS FIRST WD - 1, 2ND WD - LAT INDEX OF ACTUAL PROC ! 54: STACK(IS) = 1 ! 55: STACK(IS+1) = L ! 56: IF (MAX.EQ.0) MAX = 1 ! 57: IS = IS + 2 ! 58: GO TO 90 ! 59: C HAVE A DUMMY PROC CHECK OUT NO OF ACTUALS ! 60: C MATCHED TO IT AND STACK THOSE WITH COUNTER ON TOP ! 61: 40 L = IP + SYMLEN + 5 ! 62: L = LAT(L) ! 63: IF (L.NE.0) GO TO 50 ! 64: IF (.NOT.OK) GOTO 10 ! 65: CALL ERROR2(26H MISSING ACTUAL PROCEDURES ,26, KBR(1), -1,1,1) ! 66: OK = .FALSE. ! 67: GO TO 10 ! 68: C COLLECT ACTUALS CORRESPONDING TO THIS PROC ARG ! 69: C K IS REL POSIT OF PROC ARG AMONG ALL ARGS AT LAT(IP) ! 70: C L PTS TO TEMPLATE AT LAT(IP) ! 71: 50 K = REF(I) ! 72: K = DSA(K+2) ! 73: C J POINTS TO FIRST ELEMENT ON ARGLIST ! 74: J = IP + SYMLEN + 1 ! 75: J = LAT(J) ! 76: IF (K.LE.1) GO TO 70 ! 77: DO 60 LL=2,K ! 78: J = LAT(J+3) ! 79: 60 CONTINUE ! 80: C K IS REL POSIT OF PROC ARG AMONG PROC ARGS IN LAT(IP) ! 81: C THAT IS IT IS OFFSET NECESS TO READ CORRESP ACTUAL ! 82: C PROCS OFF TEMPLATES AT LAT(IP) ! 83: C J POINTS TO DUMMY PROC ARG ENTRY IN LAT (IP) ! 84: 70 K = LAT(J+1) ! 85: IF (IS+1.GE.LSS) GO TO 200 ! 86: C J POINTS TO POSITION IN STACK OF COUNT OF HOW MANY ! 87: C ACTUALS ARE MATCHED TO THIS DUMMY ! 88: J = IS ! 89: STACK(IS) = 0 ! 90: IS = IS + 1 ! 91: 80 IF (IS+1.GE.LSS) GO TO 200 ! 92: C N WD STACK ENTRY FOR DUMMY PROC ARGS USED AS ACTUAL ARGS IN REF ! 93: C WD 1 CONTAINS NO OF ACTUAL PROCS MATCHED TO THE DUMMY ! 94: C WDS 2 - N CONTAIN THE LAT INDICES OF EACH ACTUAL PROC ! 95: STACK(J) = STACK(J) + 1 ! 96: LL = K + L ! 97: STACK(IS) = LAT(LL) ! 98: IS = IS + 1 ! 99: L = LAT(L) + L ! 100: L = LAT(L) ! 101: IF (L.NE.0) GO TO 80 ! 102: IF (STACK(J).GT.MAX) MAX = STACK(J) ! 103: 90 CONTINUE ! 104: C HAVE COLLECTED ALL PROC ACTUALS CORRESP TO THE PROC ! 105: C ARGS IN THE REF, NOTE MAX IS NO OF TEMPLATES RESULTING FROM ! 106: C THIS REF TO BE PASSED TO LAT(IM) AS LONG AS THEIR DUPS ! 107: C ARE NOT THERE ALREADY ! 108: C BUILD EACH TEMPLATE IN LOOP AND CHECK FOR DUPLICATION ! 109: C IF NOT THERE COPY INTO LAT OFF LAT(IM) AND CHECK LEVEL OF ACTUALS ! 110: C PASSED DOWN VS LEVEL OF LAT(IM) ! 111: IF (MAX.EQ.0) GO TO 10 ! 112: DO 190 I=1,MAX ! 113: C CREATE PROC INDICES PORTION OF TEMPLATE IN SS ! 114: K = 1 ! 115: ISS = 1 ! 116: 100 IF (K.GE.IS) GO TO 110 ! 117: L = 1 ! 118: IF (STACK(K).GT.1) L = I ! 119: IF (ISS+1.GE.120) GO TO 200 ! 120: J = K + L ! 121: SS(ISS) = STACK(J) ! 122: K = K + STACK(K) + 1 ! 123: ISS = ISS + 1 ! 124: GO TO 100 ! 125: C HAVE TEMPLATE IN SS(1) THROUGH SS(ISS-1) ! 126: C SEE IF IT HAS A DUPLICATE AT LAT(IM) ! 127: 110 K = IM + SYMLEN + 5 ! 128: K = LAT(K) ! 129: IST = ISS - 1 ! 130: 120 IF (K.EQ.0) GO TO 150 ! 131: DO 130 L=1,IST ! 132: J = K + L ! 133: IF (LAT(J).NE.SS(L)) GO TO 140 ! 134: 130 CONTINUE ! 135: C FOUND DUPLICATE ! 136: GO TO 190 ! 137: C HAVENT FOUND A DUPLICATE YET ! 138: C SEE IF THERE ARE MORE TEMPLATES TO COMPARE ! 139: 140 K = LAT(K) + K ! 140: K = LAT(K) ! 141: GO TO 120 ! 142: C NOT A DUPLICATE WILL ADD IT ON ! 143: 150 IF (PLAT+IST+2.LE.LLAT) GO TO 160 ! 144: CALL ERROR1(32H IN PROC, TABLE OVERFLOW OF LAT , 32) ! 145: SYSERR = .TRUE. ! 146: GO TO 10 ! 147: C MAKE AN ENTRY CONSISTING OF 1ST WORD - NO OF PROCS+1, SUBSEQUENT ! 148: C WORDS - PROCS LAT INDICES, LAST WORD - PTR ! 149: C TO NEXT SUCH TEMPLATE ! 150: 160 DO 170 L=1,IST ! 151: J = PLAT + L ! 152: LAT(J) = SS(L) ! 153: 170 CONTINUE ! 154: LAT(PLAT) = IST + 1 ! 155: L = PLAT ! 156: PLAT = PLAT + IST + 2 ! 157: J = IM + SYMLEN + 5 ! 158: LAT(PLAT-1) = LAT(J) ! 159: LAT(J) = L ! 160: C CHECK LEVELS ! 161: DO 180 L=1,IST ! 162: J = FIND(SS(L)) ! 163: C FIND HEAD OF GREEN LINKS LIST AT LAT(IM) ! 164: JR = IM + SYMLEN + 3 ! 165: JLR = -SS(L) ! 166: 210 IF(LAT(JR+1) .LE. 0) GOTO 220 ! 167: JR = LAT(JR+1) ! 168: GOTO 210 ! 169: C HAVE TOP OF GREEN LINKS LIST AT LAT(JR) ! 170: 220 IF(LAT(JR+1) .EQ. 0) GOTO 230 ! 171: JR = IABS( LAT(JR+1) ) ! 172: C LOOK FOR DUPLICATE ENTRY ON GREEN LINKS LIST ! 173: IF(LAT(JR) .EQ. JLR) GOTO 240 ! 174: GOTO 220 ! 175: C ADD ON ENTRY TO GREEN LINKS LIST ! 176: 230 IF(PLAT + 2 .GT. LLAT) GOTO 250 ! 177: LAT(PLAT) = JLR ! 178: LAT(PLAT+1) = 0 ! 179: LAT(JR+1) = -PLAT ! 180: PLAT = PLAT+2 ! 181: 240 IF((-1).EQ.INODE(J) .OR. (-2).EQ.INODE(J) .OR. ! 182: * INODE(J).GT.INODE(IIM)) GOTO 180 ! 183: INODE(J) = INODE(IIM) + 1 ! 184: CALL ASLEV (-J) ! 185: IF (SYSERR .OR. ABORT) GO TO 10 ! 186: 180 CONTINUE ! 187: 190 CONTINUE ! 188: GO TO 10 ! 189: 200 SYSERR = .TRUE. ! 190: CALL ERROR1(33H IN PROC, TABLE OVERFLOW OF STACK, 33) ! 191: GO TO 10 ! 192: 250 SYSERR = .TRUE. ! 193: CALL ERROR1(31H IN PROC, TABLE OVERFLOW OF LAT,31) ! 194: GOTO 10 ! 195: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.