V10/cmd/pfort/INTEXT.f
LOGICAL FUNCTION INTEXT(LL, L1, L2, BR)
C
C LL POINTS TO DSA ENTRY OF FCN NAME
C L1 POINTS INTO STACK TO BEGINNING OF ARGS
C L2 POINTS INTO STACK TO LAST ARG ENTRY
C BR .TRUE. MEANS LOOK FOR BOTH EXTERNALS ND INTRINS
C BR FALSE MEANS JUST LOOK FOR EXTERNALS
C ROUTINE CHECKS FOR REFERENCES TO INTRINSIC OR BASIC EXTERNAL
C FCNS; RETURNS TRUE IF FINDS INTRINSIC FCN. CHECKS INTRINSICS
C ARGS FOR USAGE, TYPE AND NUMBER. MARKS POSSIBLE BASIC EXTDRNAL
C FCNS SENT DOWN TO IT
C
INTEGER STACK, BL, PDSA, DSA, FCN(6), Z
LOGICAL BR
COMMON /CEXPRS/ LSTACK, STACK(620)
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /INTS/ Z(346)
COMMON /FACTS/ NAME, NOST, ITYP, IASF
DATA BL /1H /
INTEXT = .FALSE.
CALL S5UNPK(DSA(LL+4), FCN(1), 6)
K = 1
DO 40 I=1,55
K1 = K + 1
K2 = K1 + Z(K) - 1
L = 0
DO 10 J=K1,K2
L = L + 1
IF (FCN(L).NE.Z(J)) GO TO 30
10 CONTINUE
IF (L.EQ.6) GO TO 60
L = L + 1
DO 20 J=L,6
IF (FCN(J).NE.BL) GO TO 30
20 CONTINUE
GO TO 60
30 K = K2 + 2
40 CONTINUE
50 RETURN
C
C DIFFERENTIATES BETWEEN A POSSIBLE BASIC EXTERNAL AND POSSIBLE
C INTRINSIC FCN
C
60 L = MOD(Z(K2+1),1024)/512
C
C IF POSSIBLE BASIC EXTERNAL CHECK TYPE AND SET IT IF NOT ALREADY
C EXPLICITLY SET
C
IF (L.NE.1) GO TO 70
L = IGATT1(LL,1)
IF (L/8.GE.1) GO TO 190
L = MOD(Z(K2+1),8)
IF (BR) L = L + 8
CALL SATT1(LL, 1, L)
C
C MARK AS USED IN PASS 1
C
GO TO 190
C
C CHEKC IF IN EXTERNAL STMT IF SO NOT AN INTRINSIC
C
70 IF (.NOT.BR) GO TO 50
L = IGATT1(LL,8)
IF (L.EQ.13) GO TO 50
C
C CHECK IF EXPLICITLY TYPES DIFFERENTLY THAN EXPECTED
C
L = IGATT1(LL,1)
J = MOD(Z(K2+1),8)
IF (L.GE.8) GO TO 80
CALL SATT1(LL, 1, J+8)
GO TO 90
80 IF (J.NE.MOD(L,8)) GO TO 50
C
C K POINTS TO THE FUNCTION ENTRY IN Z
C K1 POINTS TO FIRST LETTER IN FCN-NAME; K2 TO LAST LETTER
C FIELDS IN ATTRIBUTE WORD ARE AS FOLLOWS:
C BITS 0-2 TYPE FCN
C BITS 3-5 TYPE ARGS
C BIT 6 IF 1, FIXED NO ARGS; IF 0 VARIABLE NO OF ARGS
C BITS 7-8 MINIMUM NUMBER OF ARGS
C BITS 9 IF 0, INTRINSIC; IF 1 BASIC EXTERNAL
C BITS 10 IF 1 USED IN PASS 1; ELSE NOT REFERENCED
C
C FCN IS INTRINSIC
C CHECK NUMBER OF ARGS
C
90 I = MOD(Z(K2+1),128)/64
J = MOD(Z(K2+1),512)/128
IF (I) 100, 100, 120
C
C VARIABLE NUMBER OF ARGS ALLOWED
C MUST BE AT LEAST J
C
100 IF ((L2-L1+1)/2.GE.J) GO TO 130
110 CALL ERROR2(29H INCORRECT NUMBER OF ARGS IN , 29, DSA(LL+4),
* 1, 1, 1)
GO TO 180
C
C FIXED NUMBER OF ARGS
C
120 IF ((L2-L1+1)/2.NE.J) GO TO 110
C
C CHECK THRU ARG LIST OR PROPER TYPE ID AS AN ARG;
C CHECK TYPE AND THAT ARGS ARE SCALARS
C
130 L = MOD(Z(K2+1),64)/8
DO 170 N=L1,L2,2
C
C CHECK FOR EXPRESSION AS ARG
C
IF (STACK(N).EQ.0) GO TO 160
C
C CHECK USAGE
C
I = IGATT1(STACK(N),8)
IF (I.EQ.10 .OR. ((I.EQ.2 .OR. I.EQ.5 .OR. I.EQ.14) .AND.
* STACK(N+1).NE.6)) GO TO 160
IF (I.NE.0) GO TO 140
CALL SATT1(STACK(N), 8, 10)
GO TO 160
140 IF (I.EQ.1 .AND. ITYP.NE.31) GO TO 150
I = STACK(N)
IF (DSA(I+2).EQ.IASF) GO TO 160
150 CALL ERROR2(40H ILLEGAL ARGUMENT IN INTRINSIC REFERENCE, 40,
* DSA(LL+4), 1, 1, 1)
GO TO 170
C
C CHECK STRUCTURE
C
160 IF (STACK(N+1)/8.EQ.1) CALL ERROR2(
* 48H ILLEGAL STRUCTURE OF ARG IN INTRINSIC REFERENCE, 48,
* DSA(LL+4), 1, 1, 1)
C
C CHECK TYPE
C
IF (MOD(STACK(N+1),8).NE.L) CALL ERROR2(
* 43H ILLEGAL TYPE OF ARG IN INTRINSIC REFERENCE, 43,
* DSA(LL+4), 1, 1, 1)
170 CONTINUE
180 INTEXT = .TRUE.
I = IGATT1(LL,8)
IF (I.NE.0) GO TO 190
CALL SATT1(LL, 8, 14)
C
C MARK FCN AS USED
C
190 K = Z(K2+1)/1024
IF (K.EQ.0) Z(K2+1) = Z(K2+1) + 1024
GO TO 50
END