V10/cmd/pfort/PROC.f
SUBROUTINE PROC(IP, IM, IIM, OK)
C
C P.U. AT LAT(IP) CALLS P.U. AT LAT(IM) (NODE(IIM))
C PROC COLLECTS ACTUAL PROC TEMPLATE(S) FROM THE CALL IF IT CAN
C CHECKS FOR MISSING SUBPGMS AND STORES TEMPLATES OFF PGM UNIT
C AT LAT(IM), THEM PROC CALLS ASLEV TO READJUST LEVELS OF ACTUALS
C SENT TO LAT(IM) VS LEVEL (IM)
C
LOGICAL ERR, SYSERR, ABORT, OK
INTEGER STACK, SYMLEN, PDSA, DSA, REF, PREF, PNODE, PLAT, FINDND,
* FIND, SS(120), KBR(1)
COMMON /CEXPRS/ LSTACK, STACK(620)
COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /CREF/ LREF, PREF, REF(100)
COMMON /HEAD/ LNODE, PNODE, NODE(500)
COMMON /SCR1/ LINODE, INODE(500)
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /DETECT/ ERR, SYSERR, ABORT
EQUIVALENCE (SS(1),STACK(501))
DATA KBR(1) /0/
LSS = 501
C ARE THERE ARGS IN THIS REF
IF (REF(1).NE.0) GO TO 20
10 RETURN
C CYCLE THROUGH REF ARGS
C JJ IS LAST ENTRY IN REF FOR ARGS
C IS PTS TO FIRST FREE WD IN STACK
C MAX IS 1 IF NO DUMMY PROCS IN REF, ELSE IS EQUAL TO THE
C NUMBER OF ACTUAL PROCS SUBSTITUTABLE FOR THE DUMMY PROCS
20 JJ = REF(1) + 4
IS = 1
MAX = 0
DO 90 I=5,JJ,2
C SKIP OVER EXPR AS ACTUAL ARGS AND ALL ACTUALS BUT PROC ARGS
IF (REF(I).EQ.0) GO TO 90
IF (REF(I+1).NE.6) GO TO 90
C SEE IF ACTUAL ARG IS DUMMY PROC ARG AT LAT(IP)
C OR ACTUAL PROCEDURE
IF (IGATT1(REF(I),4).EQ.1) GO TO 40
C HAVE AN ACTUAL PROCEDURE
L = REF(I)
L = FINDND(DSA(L+4),K)
IF (L.NE.0) GO TO 30
C IF, AS GATHERING ACTUAL PROCS MATCHED TO DUMMY PROC ARGS
C PROC FINDS A MISSING SUBPROGM, PROCESSING OF THIS REF CEASES
L = REF(I)
CALL ERROR2(20H MISSING SUBPROGRAM , 20, DSA(L+4), 1, 1, 0)
CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
GO TO 10
30 IF (IS+2.GT.LSS) GO TO 200
C 2 WD STACK ENTRY FOR AN ACTUAL PROC AS AN ACTUAL ARG
C IS FIRST WD - 1, 2ND WD - LAT INDEX OF ACTUAL PROC
STACK(IS) = 1
STACK(IS+1) = L
IF (MAX.EQ.0) MAX = 1
IS = IS + 2
GO TO 90
C HAVE A DUMMY PROC CHECK OUT NO OF ACTUALS
C MATCHED TO IT AND STACK THOSE WITH COUNTER ON TOP
40 L = IP + SYMLEN + 5
L = LAT(L)
IF (L.NE.0) GO TO 50
IF (.NOT.OK) GOTO 10
CALL ERROR2(26H MISSING ACTUAL PROCEDURES ,26, KBR(1), -1,1,1)
OK = .FALSE.
GO TO 10
C COLLECT ACTUALS CORRESPONDING TO THIS PROC ARG
C K IS REL POSIT OF PROC ARG AMONG ALL ARGS AT LAT(IP)
C L PTS TO TEMPLATE AT LAT(IP)
50 K = REF(I)
K = DSA(K+2)
C J POINTS TO FIRST ELEMENT ON ARGLIST
J = IP + SYMLEN + 1
J = LAT(J)
IF (K.LE.1) GO TO 70
DO 60 LL=2,K
J = LAT(J+3)
60 CONTINUE
C K IS REL POSIT OF PROC ARG AMONG PROC ARGS IN LAT(IP)
C THAT IS IT IS OFFSET NECESS TO READ CORRESP ACTUAL
C PROCS OFF TEMPLATES AT LAT(IP)
C J POINTS TO DUMMY PROC ARG ENTRY IN LAT (IP)
70 K = LAT(J+1)
IF (IS+1.GE.LSS) GO TO 200
C J POINTS TO POSITION IN STACK OF COUNT OF HOW MANY
C ACTUALS ARE MATCHED TO THIS DUMMY
J = IS
STACK(IS) = 0
IS = IS + 1
80 IF (IS+1.GE.LSS) GO TO 200
C N WD STACK ENTRY FOR DUMMY PROC ARGS USED AS ACTUAL ARGS IN REF
C WD 1 CONTAINS NO OF ACTUAL PROCS MATCHED TO THE DUMMY
C WDS 2 - N CONTAIN THE LAT INDICES OF EACH ACTUAL PROC
STACK(J) = STACK(J) + 1
LL = K + L
STACK(IS) = LAT(LL)
IS = IS + 1
L = LAT(L) + L
L = LAT(L)
IF (L.NE.0) GO TO 80
IF (STACK(J).GT.MAX) MAX = STACK(J)
90 CONTINUE
C HAVE COLLECTED ALL PROC ACTUALS CORRESP TO THE PROC
C ARGS IN THE REF, NOTE MAX IS NO OF TEMPLATES RESULTING FROM
C THIS REF TO BE PASSED TO LAT(IM) AS LONG AS THEIR DUPS
C ARE NOT THERE ALREADY
C BUILD EACH TEMPLATE IN LOOP AND CHECK FOR DUPLICATION
C IF NOT THERE COPY INTO LAT OFF LAT(IM) AND CHECK LEVEL OF ACTUALS
C PASSED DOWN VS LEVEL OF LAT(IM)
IF (MAX.EQ.0) GO TO 10
DO 190 I=1,MAX
C CREATE PROC INDICES PORTION OF TEMPLATE IN SS
K = 1
ISS = 1
100 IF (K.GE.IS) GO TO 110
L = 1
IF (STACK(K).GT.1) L = I
IF (ISS+1.GE.120) GO TO 200
J = K + L
SS(ISS) = STACK(J)
K = K + STACK(K) + 1
ISS = ISS + 1
GO TO 100
C HAVE TEMPLATE IN SS(1) THROUGH SS(ISS-1)
C SEE IF IT HAS A DUPLICATE AT LAT(IM)
110 K = IM + SYMLEN + 5
K = LAT(K)
IST = ISS - 1
120 IF (K.EQ.0) GO TO 150
DO 130 L=1,IST
J = K + L
IF (LAT(J).NE.SS(L)) GO TO 140
130 CONTINUE
C FOUND DUPLICATE
GO TO 190
C HAVENT FOUND A DUPLICATE YET
C SEE IF THERE ARE MORE TEMPLATES TO COMPARE
140 K = LAT(K) + K
K = LAT(K)
GO TO 120
C NOT A DUPLICATE WILL ADD IT ON
150 IF (PLAT+IST+2.LE.LLAT) GO TO 160
CALL ERROR1(32H IN PROC, TABLE OVERFLOW OF LAT , 32)
SYSERR = .TRUE.
GO TO 10
C MAKE AN ENTRY CONSISTING OF 1ST WORD - NO OF PROCS+1, SUBSEQUENT
C WORDS - PROCS LAT INDICES, LAST WORD - PTR
C TO NEXT SUCH TEMPLATE
160 DO 170 L=1,IST
J = PLAT + L
LAT(J) = SS(L)
170 CONTINUE
LAT(PLAT) = IST + 1
L = PLAT
PLAT = PLAT + IST + 2
J = IM + SYMLEN + 5
LAT(PLAT-1) = LAT(J)
LAT(J) = L
C CHECK LEVELS
DO 180 L=1,IST
J = FIND(SS(L))
C FIND HEAD OF GREEN LINKS LIST AT LAT(IM)
JR = IM + SYMLEN + 3
JLR = -SS(L)
210 IF(LAT(JR+1) .LE. 0) GOTO 220
JR = LAT(JR+1)
GOTO 210
C HAVE TOP OF GREEN LINKS LIST AT LAT(JR)
220 IF(LAT(JR+1) .EQ. 0) GOTO 230
JR = IABS( LAT(JR+1) )
C LOOK FOR DUPLICATE ENTRY ON GREEN LINKS LIST
IF(LAT(JR) .EQ. JLR) GOTO 240
GOTO 220
C ADD ON ENTRY TO GREEN LINKS LIST
230 IF(PLAT + 2 .GT. LLAT) GOTO 250
LAT(PLAT) = JLR
LAT(PLAT+1) = 0
LAT(JR+1) = -PLAT
PLAT = PLAT+2
240 IF((-1).EQ.INODE(J) .OR. (-2).EQ.INODE(J) .OR.
* INODE(J).GT.INODE(IIM)) GOTO 180
INODE(J) = INODE(IIM) + 1
CALL ASLEV (-J)
IF (SYSERR .OR. ABORT) GO TO 10
180 CONTINUE
190 CONTINUE
GO TO 10
200 SYSERR = .TRUE.
CALL ERROR1(33H IN PROC, TABLE OVERFLOW OF STACK, 33)
GO TO 10
250 SYSERR = .TRUE.
CALL ERROR1(31H IN PROC, TABLE OVERFLOW OF LAT,31)
GOTO 10
END