![[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.