![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to INTEXT.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 INTEXT.f CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
1.1 root 1: LOGICAL FUNCTION INTEXT(LL, L1, L2, BR)
2: C
3: C LL POINTS TO DSA ENTRY OF FCN NAME
4: C L1 POINTS INTO STACK TO BEGINNING OF ARGS
5: C L2 POINTS INTO STACK TO LAST ARG ENTRY
6: C BR .TRUE. MEANS LOOK FOR BOTH EXTERNALS ND INTRINS
7: C BR FALSE MEANS JUST LOOK FOR EXTERNALS
8: C ROUTINE CHECKS FOR REFERENCES TO INTRINSIC OR BASIC EXTERNAL
9: C FCNS; RETURNS TRUE IF FINDS INTRINSIC FCN. CHECKS INTRINSICS
10: C ARGS FOR USAGE, TYPE AND NUMBER. MARKS POSSIBLE BASIC EXTDRNAL
11: C FCNS SENT DOWN TO IT
12: C
13: INTEGER STACK, BL, PDSA, DSA, FCN(6), Z
14: LOGICAL BR
15: COMMON /CEXPRS/ LSTACK, STACK(620)
16: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
17: COMMON /INTS/ Z(346)
18: COMMON /FACTS/ NAME, NOST, ITYP, IASF
19: DATA BL /1H /
20: INTEXT = .FALSE.
21: CALL S5UNPK(DSA(LL+4), FCN(1), 6)
22: K = 1
23: DO 40 I=1,55
24: K1 = K + 1
25: K2 = K1 + Z(K) - 1
26: L = 0
27: DO 10 J=K1,K2
28: L = L + 1
29: IF (FCN(L).NE.Z(J)) GO TO 30
30: 10 CONTINUE
31: IF (L.EQ.6) GO TO 60
32: L = L + 1
33: DO 20 J=L,6
34: IF (FCN(J).NE.BL) GO TO 30
35: 20 CONTINUE
36: GO TO 60
37: 30 K = K2 + 2
38: 40 CONTINUE
39: 50 RETURN
40: C
41: C DIFFERENTIATES BETWEEN A POSSIBLE BASIC EXTERNAL AND POSSIBLE
42: C INTRINSIC FCN
43: C
44: 60 L = MOD(Z(K2+1),1024)/512
45: C
46: C IF POSSIBLE BASIC EXTERNAL CHECK TYPE AND SET IT IF NOT ALREADY
47: C EXPLICITLY SET
48: C
49: IF (L.NE.1) GO TO 70
50: L = IGATT1(LL,1)
51: IF (L/8.GE.1) GO TO 190
52: L = MOD(Z(K2+1),8)
53: IF (BR) L = L + 8
54: CALL SATT1(LL, 1, L)
55: C
56: C MARK AS USED IN PASS 1
57: C
58: GO TO 190
59: C
60: C CHEKC IF IN EXTERNAL STMT IF SO NOT AN INTRINSIC
61: C
62: 70 IF (.NOT.BR) GO TO 50
63: L = IGATT1(LL,8)
64: IF (L.EQ.13) GO TO 50
65: C
66: C CHECK IF EXPLICITLY TYPES DIFFERENTLY THAN EXPECTED
67: C
68: L = IGATT1(LL,1)
69: J = MOD(Z(K2+1),8)
70: IF (L.GE.8) GO TO 80
71: CALL SATT1(LL, 1, J+8)
72: GO TO 90
73: 80 IF (J.NE.MOD(L,8)) GO TO 50
74: C
75: C K POINTS TO THE FUNCTION ENTRY IN Z
76: C K1 POINTS TO FIRST LETTER IN FCN-NAME; K2 TO LAST LETTER
77: C FIELDS IN ATTRIBUTE WORD ARE AS FOLLOWS:
78: C BITS 0-2 TYPE FCN
79: C BITS 3-5 TYPE ARGS
80: C BIT 6 IF 1, FIXED NO ARGS; IF 0 VARIABLE NO OF ARGS
81: C BITS 7-8 MINIMUM NUMBER OF ARGS
82: C BITS 9 IF 0, INTRINSIC; IF 1 BASIC EXTERNAL
83: C BITS 10 IF 1 USED IN PASS 1; ELSE NOT REFERENCED
84: C
85: C FCN IS INTRINSIC
86: C CHECK NUMBER OF ARGS
87: C
88: 90 I = MOD(Z(K2+1),128)/64
89: J = MOD(Z(K2+1),512)/128
90: IF (I) 100, 100, 120
91: C
92: C VARIABLE NUMBER OF ARGS ALLOWED
93: C MUST BE AT LEAST J
94: C
95: 100 IF ((L2-L1+1)/2.GE.J) GO TO 130
96: 110 CALL ERROR2(29H INCORRECT NUMBER OF ARGS IN , 29, DSA(LL+4),
97: * 1, 1, 1)
98: GO TO 180
99: C
100: C FIXED NUMBER OF ARGS
101: C
102: 120 IF ((L2-L1+1)/2.NE.J) GO TO 110
103: C
104: C CHECK THRU ARG LIST OR PROPER TYPE ID AS AN ARG;
105: C CHECK TYPE AND THAT ARGS ARE SCALARS
106: C
107: 130 L = MOD(Z(K2+1),64)/8
108: DO 170 N=L1,L2,2
109: C
110: C CHECK FOR EXPRESSION AS ARG
111: C
112: IF (STACK(N).EQ.0) GO TO 160
113: C
114: C CHECK USAGE
115: C
116: I = IGATT1(STACK(N),8)
117: IF (I.EQ.10 .OR. ((I.EQ.2 .OR. I.EQ.5 .OR. I.EQ.14) .AND.
118: * STACK(N+1).NE.6)) GO TO 160
119: IF (I.NE.0) GO TO 140
120: CALL SATT1(STACK(N), 8, 10)
121: GO TO 160
122: 140 IF (I.EQ.1 .AND. ITYP.NE.31) GO TO 150
123: I = STACK(N)
124: IF (DSA(I+2).EQ.IASF) GO TO 160
125: 150 CALL ERROR2(40H ILLEGAL ARGUMENT IN INTRINSIC REFERENCE, 40,
126: * DSA(LL+4), 1, 1, 1)
127: GO TO 170
128: C
129: C CHECK STRUCTURE
130: C
131: 160 IF (STACK(N+1)/8.EQ.1) CALL ERROR2(
132: * 48H ILLEGAL STRUCTURE OF ARG IN INTRINSIC REFERENCE, 48,
133: * DSA(LL+4), 1, 1, 1)
134: C
135: C CHECK TYPE
136: C
137: IF (MOD(STACK(N+1),8).NE.L) CALL ERROR2(
138: * 43H ILLEGAL TYPE OF ARG IN INTRINSIC REFERENCE, 43,
139: * DSA(LL+4), 1, 1, 1)
140: 170 CONTINUE
141: 180 INTEXT = .TRUE.
142: I = IGATT1(LL,8)
143: IF (I.NE.0) GO TO 190
144: CALL SATT1(LL, 8, 14)
145: C
146: C MARK FCN AS USED
147: C
148: 190 K = Z(K2+1)/1024
149: IF (K.EQ.0) Z(K2+1) = Z(K2+1) + 1024
150: GO TO 50
151: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.