![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to EXPR.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 EXPR.f CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
1.1 ! root 1: INTEGER FUNCTION EXPR(LOGEX) ! 2: C ! 3: C LOGEX IS A DUMMY ARG , NEVER USED ! 4: C FALSE IF AN ARITHMETIC EXPRESSION WAS FOUND ! 5: C PRE IS PRECEDENCE TABLE, PRE(I,J) GIVES ACTION TAKEN WHEN OP I ! 6: C IS ON THE STACK, OP J IN THE INPUT ! 7: C CUROP IS CURRENT TOKEN TYPE ! 8: C PREVOP IS PREVIOUS TOKEN TYPE (LAST ONE PROCESSED BEFORE CUROP) ! 9: C STACK IS OPERAND STACK GROWING FROM TOP (1,2 ETC) ! 10: C OPERATER STACK GROWING FROM BOTTOM UP(100,99 ETC) ! 11: C PARENS COUNTS NESTING LEVEL OF PARENTHESES AND FUNCTION CALLS ! 12: C ! 13: C*****EXPRS ! 14: C PT (INT) POINTER TO NEXT FREE WORD ON OPERAND STACK (GROWS ! 15: C FROM STACK(1)) ! 16: C PB (INT) POINTER TO NEXT FREE WORD ON OPERATOR STACK (GROWS ! 17: C FROM STACK(LSTACK)) ! 18: C AO(*,*) (INT) ARRAY GIVES TYPES OF ARITH OPERATIONS ! 19: C AO(I,J) = TYPE OF (TYPE I <ARITH-OP> TYPE J) ! 20: C RO(*,*) (INT) ARRAY TELLS LEGALITY OF RELATIONAL OPERATIONS ! 21: C RO(I,J) = 1 IF TYPE I <RELOP> TYPEJ IS LEGAL; ELSE IS 0 ! 22: C EX(*,*) (INT) ARRAY GIVES TYPES OF ** OPERATION ! 23: C EX(I,J) = TYPE OF (TYPE I <**> TYPE J) ! 24: C ! 25: INTEGER PRE(12,12), EX(4,4), AO(4,4), CUROP, PREVOP, RO(3,3), ! 26: * STACK, PARENS, STMT, PSTMT, PT, PB, SYMLEN, PDSA, OUTUT, ! 27: * GETTOK, IBR(14), JBR(13), ADJ(5,4), OUTUT2, DSA, OUTUT3, ! 28: * OUTUT4, PREF, REF ! 29: LOGICAL FLUSH, ERR, SYSERR, CALLST, DOVAR, OPT, ABORT, P1ERR ! 30: LOGICAL INTEXT ! 31: COMMON /DETECT/ ERR, SYSERR, ABORT ! 32: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 33: COMMON /EXPRS/ PT, PB, AO, RO, EX ! 34: COMMON /CEXPRS/ LSTACK, STACK(620) ! 35: COMMON /CREF/ LREF, PREF, REF(100) ! 36: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3, ! 37: * OUTUT4 ! 38: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 39: COMMON /OPTNS/ OPT(5), P1ERR ! 40: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 41: DATA K /0/ ! 42: DATA PRE(1,1) /6/, PRE(1,2) /6/, PRE(1,3) /4/, PRE(1,5) /4/, ! 43: * PRE(1,6) /2/, PRE(1,7) /4/, PRE(1,8) /6/, PRE(1,9) /6/, ! 44: * PRE(1,10) /6/, PRE(1,4) /-1/, PRE(1,11) /6/, PRE(2,1) /-1/, ! 45: * PRE(2,2) /-1/, PRE(2,3) /-1/, PRE(2,5) /-1/, PRE(2,6) /-1/, ! 46: * PRE(2,7) /-1/, PRE(2,8) /-1/, PRE(2,9) /-1/, PRE(2,10) /-1/, ! 47: * PRE(2,4) /-1/, PRE(2,11) /-1/, PRE(3,1) /6/, PRE(3,2) /6/, ! 48: * PRE(3,3) /-1/, PRE(3,5) /4/, PRE(3,6) /2/, PRE(3,7) /6/, ! 49: * PRE(3,8) /6/, PRE(3,9) /6/, PRE(3,10) /6/, PRE(3,4) /-1/, ! 50: * PRE(3,11) /6/, PRE(5,1) /5/, PRE(5,2) /7/, PRE(5,3) /4/, ! 51: * PRE(5,5) /4/, PRE(5,6) /2/, PRE(5,7) /4/, PRE(5,8) /-1/, ! 52: * PRE(5,9) /4/, PRE(5,10) /4/, PRE(5,4) /4/, PRE(5,11) /4/, ! 53: * PRE(6,1) /5/, PRE(6,2) /1/, PRE(6,3) /4/, PRE(6,5) /4/, ! 54: * PRE(6,6) /2/, PRE(6,7) /4/, PRE(6,8) /3/, PRE(6,9) /4/, ! 55: * PRE(6,10) /4/, PRE(6,4) /4/, PRE(6,11) /4/ ! 56: DATA PRE(7,1) /6/, PRE(7,2) /6/, PRE(7,3) /4/, PRE(7,5) /4/, ! 57: * PRE(7,6) /2/, PRE(7,7) /6/, PRE(7,8) /6/, PRE(7,9) /6/, ! 58: * PRE(7,10) /6/, PRE(7,4) /-1/, PRE(7,11) /6/, PRE(8,1) /-1/, ! 59: * PRE(8,2) /-1/, PRE(8,3) /-1/, PRE(8,5) /-1/, PRE(8,6) /-1/, ! 60: * PRE(8,7) /-1/, PRE(8,8) /-1/, PRE(8,9) /-1/, PRE(8,10) /-1/, ! 61: * PRE(8,4) /-1/, PRE(8,11) /-1/, PRE(9,1) /5/, PRE(9,2) /6/, ! 62: * PRE(9,3) /4/, PRE(9,5) /4/, PRE(9,6) /2/, PRE(9,7) /4/, ! 63: * PRE(9,8) /6/, PRE(9,9) /6/, PRE(9,10) /6/, PRE(9,4) /4/, ! 64: * PRE(9,11) /4/, PRE(10,1) /5/, PRE(10,2) /6/, PRE(10,3) /4/, ! 65: * PRE(10,5) /4/, PRE(10,6) /2/, PRE(10,7) /4/, PRE(10,8) /6/, ! 66: * PRE(10,9) /4/, PRE(10,10) /6/, PRE(10,4) /4/, PRE(10,11) /4/, ! 67: * PRE(4,1) /5/, PRE(4,2) /6/, PRE(4,3) /4/, PRE(4,5) /4/, ! 68: * PRE(4,6) /2/, PRE(4,7) /4/, PRE(4,8) /6/, PRE(4,9) /6/, ! 69: * PRE(4,10) /6/, PRE(4,4) /-1/, PRE(4,11) /4/, PRE(11,1) /5/, ! 70: * PRE(11,2) /6/, PRE(11,3) /4/, PRE(11,5) /4/, PRE(11,6) /2/, ! 71: * PRE(11,7) /4/, PRE(11,8) /6/, PRE(11,9) /6/, PRE(11,10) /6/, ! 72: * PRE(11,4) /-1/, PRE(11,11) /6/ ! 73: DATA PRE(12,1), PRE(12,3), PRE(12,7), PRE(12,11) /4*6/, PRE(12,2) ! 74: * /6/, PRE(12,5) /4/, PRE(12,6) /2/, PRE(12,8) /6/, PRE(12,4), ! 75: * PRE(12,9), PRE(12,10) /3*6/, PRE(1,12), PRE(2,12), PRE(3,12), ! 76: * PRE(7,12), PRE(12,12) /5*-1/, PRE(5,12), PRE(6,12), ! 77: * PRE(8,12), PRE(9,12), PRE(10,12), PRE(4,12), PRE(11,12) /7*4/ ! 78: DATA IBR(1), IBR(3), IBR(7), IBR(12) /4*1/, IBR(2) /2/, IBR(4), ! 79: * IBR(11) /2*3/, IBR(9), IBR(10) /2*5/, IBR(8), IBR(5), IBR(6) ! 80: * /3*4/, IBR(13) /2/, IBR(14) /4/, JBR(1), JBR(12) /2*1/, ! 81: * JBR(2), JBR(3), JBR(7), JBR(9), JBR(10), JBR(11), JBR(8) ! 82: * /7*2/, JBR(4) /3/, JBR(5), JBR(6) /2*4/, JBR(13) /4/ ! 83: DATA ADJ(1,1), ADJ(1,2), ADJ(1,3) /3*-1/, ADJ(1,4) /0/, ADJ(2,1), ! 84: * ADJ(2,2) /2*0/, ADJ(2,3), ADJ(2,4) /2*-1/, ADJ(3,1) /1/, ! 85: * ADJ(3,4) /0/, ADJ(3,2), ADJ(3,3) /2*-1/, ADJ(5,1) /1/, ! 86: * ADJ(5,3), ADJ(5,4) /2*0/, ADJ(5,2) /-1/, ADJ(4,1), ADJ(4,3), ! 87: * ADJ(4,4) /3*0/, ADJ(4,2) /-1/ ! 88: C ! 89: C CODES IN OPERAND STACK ! 90: C 0....DOUBLE PRECISION 1....REAL 2....INTEGER ! 91: C 3....COMPLEX 4....LOGICAL 5....HOLLERITH ! 92: C 6....PROCEDURE NAME ! 93: C CODES FOR OPERATORS ! 94: C 11 +,- 12 ) 13 ** 14 .NOT. 15 ( 16 FCN( ! 95: C 17 /,* 18 , 19 .AND. 20 .OR. 21 .EQ. 22 UNARY -,+ ! 96: C ! 97: PB = LSTACK ! 98: PT = 1 ! 99: CALLST = .FALSE. ! 100: PREVOP = -1 ! 101: CUROP = 0 ! 102: PARENS = 0 ! 103: FLUSH = .FALSE. ! 104: EXPR = -1 ! 105: 10 IF (PSTMT.LT.NSTMT .AND. .NOT.CALLST) GO TO 110 ! 106: C ! 107: C FINISH RECOGNITION OF EXPRESSION; POP OPERAND STACK AND RETURN ! 108: C TYPE OF EXPRESSION ! 109: C ! 110: 20 IF (PARENS.EQ.0) GO TO 40 ! 111: 30 CALL ERROR1(37H UNBALANCED PARENTHESES IN EXPRESSION, 37) ! 112: IF (FLUSH) GO TO 530 ! 113: GO TO 80 ! 114: 40 IF (PB.EQ.LSTACK .OR. CALLST) GO TO 60 ! 115: 50 CALL POP ! 116: IF (ERR) GO TO 530 ! 117: IF (PB.LT.LSTACK) GO TO 50 ! 118: 60 IF (PT.NE.3) GO TO 90 ! 119: IF (STACK(1).EQ.0) GO TO 70 ! 120: I = IGATT1(STACK(1),8) ! 121: IF (I.EQ.0) CALL SATT1(STACK(1), 8, 10) ! 122: 70 EXPR = STACK(2) ! 123: 80 PSTMT = K2 ! 124: ERR = .FALSE. ! 125: RETURN ! 126: 90 CALL ERROR1(29H INVALID SYNTAX IN EXPRESSION, 29) ! 127: IF (FLUSH) GO TO 530 ! 128: GO TO 80 ! 129: 100 CALL ERROR1(31H EXPRESSION TOO LONG TO PROCESS, 31) ! 130: GO TO 530 ! 131: C ! 132: C CONTINUING PROCESSING THE EXPRESSION, IDENTIFY NEXT TOKEN, ! 133: C ! 134: 110 CUROP = GETTOK(PSTMT,K2) ! 135: IF (ERR) GO TO 80 ! 136: C ! 137: C SEE END OF EXPRESSION: ")" <ID> OR <LABEL>; GETTOK RETURNS ! 138: C SAME CODES AS THOSE ABOVE EXCEPT 6 IS ID, 16 IS FCN( OR ARRAY ELE ! 139: C ! 140: IF (CUROP.NE.6 .AND. CUROP.NE.2 .AND. CUROP.NE.16 .OR. ! 141: * PREVOP.NE.12) GO TO 120 ! 142: K2 = PSTMT ! 143: GO TO 20 ! 144: C ! 145: C CHECK FOR ADJACENT OPERATORS OR OPERANDS. ! 146: C ! 147: 120 IF (PREVOP.LE.6) GO TO 130 ! 148: I = IBR(PREVOP-10) ! 149: GO TO 140 ! 150: 130 I = IBR(13) ! 151: IF(PREVOP.EQ.(-1)) I = IBR(14) ! 152: 140 IF (CUROP.LE.6) GO TO 150 ! 153: I2 = JBR(CUROP-10) ! 154: GO TO 160 ! 155: 150 I2 = JBR(13) ! 156: 160 IF (I.GE.3 .AND. I2.EQ.1) CUROP = 22 ! 157: IF (ADJ(I,I2)) 170, 190, 180 ! 158: 170 CALL ERROR1(44H ADJACENT PLACEMENT OF OPERATORS OR OPERANDS, 44) ! 159: GO TO 530 ! 160: 180 CALL ERROR1( ! 161: * 54H WARNING - ADJACENT PLACEMENT OF OPERATOR AND UNARY -+, 54) ! 162: 190 IF (CUROP.GT.6 .AND. CUROP.NE.16) GO TO 290 ! 163: IF (CUROP.LT.6) GO TO 280 ! 164: C ! 165: C PROCESS ID OR FCN( OR ARRAY ELEMENT OR ARRAY ! 166: C LOOKUP SYMBOL TABLE ENTRY TO IDENTIFY ARRAYS AND TO IMPLICITLY ! 167: C TYPE IDENTIFIERS IF NECESSARY. ! 168: C ! 169: IF (CUROP.EQ.6) GO TO 200 ! 170: K = LOOKUP(K2-1,.FALSE.) ! 171: GO TO 210 ! 172: 200 K = LOOKUP(K2,.FALSE.) ! 173: 210 IF (SYSERR) GO TO 530 ! 174: I1 = IGATT1(K,1) ! 175: I2 = IGATT1(K,7) ! 176: I3 = IGATT1(K,8) ! 177: C ! 178: C IMPLICITLY TYPE IDENTIFIERS AND FCNS ! 179: C ! 180: IF (I1.GT.0) GO TO 220 ! 181: I1 = 1 ! 182: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2 ! 183: CALL SATT1(K, 1, I1) ! 184: C ! 185: C SEPARATE ARRAY ELEMENT, FCN REFERENCE,ASF REF. ! 186: C ! 187: 220 I1 = MOD(I1,8) ! 188: IF (CUROP.NE.16) GO TO 250 ! 189: IF (I2.EQ.0) GO TO 240 ! 190: C ! 191: C ARRAY ELEMENT--CHECK FOR BEING IN ASF DEF AND PEEL OFF ! 192: C SUBSCRIPTS, CHECKING THEIR NUMBER ! 193: C ! 194: IF (ITYP.NE.31) GO TO 230 ! 195: CALL ERROR1(39H ILLEGAL USE OF ARRAY IN ASF DEFINITION, 39) ! 196: 230 CUROP = I1 ! 197: I1 = CUROP + 16 ! 198: PSTMT = K2 ! 199: CALL SUBS(K2, I2) ! 200: IF (ERR .OR. SYSERR) GO TO 80 ! 201: GO TO 270 ! 202: C ! 203: C PROCESS FCN( OR ASF( REFERENCE; CHECK USAGE TO SEE ! 204: C IF IS A LEGAL FCN OR ASF NAME I.E. IF WAS USED ! 205: C AS A FCN, SUBR, ASF, OR WAS IN AN EXTERNAL STMT. ! 206: C ! 207: 240 IF (I3.EQ.0 .OR. I3.EQ.2 .OR. I3.EQ.5 .OR. I3.EQ.6 .OR. I3.EQ.13 ! 208: * .OR. I3.EQ.14) GO TO 290 ! 209: C ! 210: C ACTUAL USAGE WILL BE DETERMINED BY CODE WHICH ! 211: C STORES CALL TEMPLATE ! 212: C ! 213: CALL ERROR1(18H ILLEGAL USE OF ID, 18) ! 214: GO TO 530 ! 215: C ! 216: C VARIABLE, ARRAY, PROCEDURE NAME ! 217: C ! 218: 250 IF (I2.EQ.0) GO TO 260 ! 219: C ! 220: C ARRAY ! 221: C ! 222: CUROP = I1 ! 223: I1 = CUROP + 8 ! 224: IF (I3.EQ.0) CALL SATT1(K, 8, 10) ! 225: GO TO 270 ! 226: C ! 227: C VARIABLE OR PROCEDURE ! 228: C LEAVE IDS USAGE UNSET ! 229: C THEY WILL BE SET LATER BY APPEARING AS OPERANDS OR BY BEING ! 230: C DEFINED AS FCN OR SUBROUTINE REFS BY FOLLOWING PGMS ! 231: C ! 232: 260 IF (I3.EQ.0) GO TO 270 ! 233: IF (I3.EQ.5 .OR. I3.EQ.6 .OR. I3.EQ.13) I1 = 6 ! 234: IF (I3.EQ.10 .OR. I1.EQ.6) GO TO 270 ! 235: IF (ITYP.EQ.31 .AND. I3.EQ.1 .AND. DSA(K+2).EQ.IASF) GO TO 270 ! 236: CALL ERROR1(36H ILLEGAL VARIABLE USED IN EXPRESSION, 36) ! 237: GO TO 530 ! 238: C ! 239: C ENTER ARRAY,ID, PROCEDURE NAME, ARRAY ELEMENT INTO OPERAND STACK ! 240: C UPDATE PREVOP,PSTMT. ALSO ENTER SYMBOL TABLE INDEX FOR THESE ! 241: C PREVOP = 0,1,...6 FOR OPERANDS ! 242: C 11,12,...22 FOR OPERATORS ! 243: C ! 244: 270 IF (PT+2.GE.PB) GO TO 100 ! 245: STACK(PT) = K ! 246: STACK(PT+1) = I1 ! 247: PT = PT + 2 ! 248: PREVOP = CUROP ! 249: PSTMT = K2 ! 250: GO TO 10 ! 251: C ! 252: C ARE PROCESSING A CONSTANT ! 253: C ! 254: 280 I1 = CUROP ! 255: K = 0 ! 256: GO TO 270 ! 257: C ! 258: C ARE PROCESSING AN OPERATER ! 259: C PRE(I,J) CONTAINS ACTION TAKEN GIVEN OPERATOR I ON STACK ! 260: C AND OPERATOR J IN INPUT ! 261: C ! 262: 290 KNAME = K ! 263: IF (CUROP.EQ.15 .OR. CUROP.EQ.16) PARENS = PARENS + 1 ! 264: IF (CUROP.EQ.12) PARENS = PARENS - 1 ! 265: IF (PARENS.GE.0) GO TO 300 ! 266: FLUSH = .TRUE. ! 267: GO TO 30 ! 268: C ! 269: C CHECKS FOR LEADING UNARY +,- IN EXPRESSIONS ! 270: C ! 271: 300 IF (PB.EQ.LSTACK) GO TO 460 ! 272: I = STACK(PB+1) - 10 ! 273: I2 = CUROP - 10 ! 274: K = PRE(I,I2) ! 275: 310 IF (-1.NE.K) GO TO 320 ! 276: FLUSH = .TRUE. ! 277: GO TO 90 ! 278: 320 GO TO (330, 470, 520, 480, 480, 490, 510), K ! 279: C ! 280: C CREATE TEMPLATE FROM FCN CALL ! 281: C ! 282: 330 IF (ITYP.EQ.18 .AND. PARENS.EQ.0) CALLST = .TRUE. ! 283: L1 = STACK(PB+2) ! 284: L2 = PT - 1 ! 285: C ! 286: C CHECK FOR NO ARGS ! 287: C ! 288: IF (L2.GT.L1) GO TO 340 ! 289: CALL ERROR1(18H MISSING ARGUMENTS, 18) ! 290: GO TO 450 ! 291: C ! 292: C CHECK FOR NOT CHANGING THROUGH SUBROUTINE CALL THE DO CONTROL ! 293: C VARIABLE OF A CURRENT LOOP OR ANY ADJUSTIBLE DIMENSION DUMMY ARG ! 294: C ! 295: 340 DO 380 I=L1,L2,2 ! 296: IF (STACK(I)) 350, 380, 350 ! 297: 350 IF (DOVAR(STACK(I))) STACK(I+1) = STACK(I+1) + 32 ! 298: I1 = IGATT1(STACK(I),4) ! 299: IF (I1) 380, 380, 360 ! 300: 360 I1 = IGATT1(STACK(I),6) ! 301: IF (I1) 380, 380, 370 ! 302: 370 STACK(I+1) = STACK(I+1) + 64 ! 303: 380 CONTINUE ! 304: C ! 305: C CHECK FOR USE OF ID AS FCN ONCE AND AS SUBROUTINE LATER ! 306: C OR VICE VERSA ! 307: C ! 308: I = STACK(PB+3) ! 309: L = IGATT1(I,8) ! 310: IF (L.EQ.2 .OR. L.EQ.5 .OR. L.EQ.6) GO TO 410 ! 311: IF (.NOT.INTEXT(I,L1,L2,.TRUE.)) GO TO 390 ! 312: C ! 313: C FOUND AN INTRINSIC FCN ! 314: C CHECK NOT IN A CALL STMT USED AS A SUBROUTINE ! 315: C ! 316: IF (CALLST) GO TO 420 ! 317: GO TO 450 ! 318: C ! 319: C DEFINE FCN( USAGE IF UNSET ! 320: C SET USAGE OF ID USED AS A PROC ! 321: C ! 322: 390 IF (CALLST) GO TO 400 ! 323: CALL SATT1(I, 8, 5) ! 324: GO TO 430 ! 325: 400 CALL SATT1(I, 8, 6) ! 326: GO TO 430 ! 327: C ! 328: C CHECK USAGE OF PROC ALREADY USED IN PROGRAM UNIT ! 329: C ! 330: 410 IF (CALLST .AND. L.EQ.6 .OR. .NOT.CALLST .AND. (L.EQ.5 .OR. ! 331: * L.EQ.2)) GO TO 430 ! 332: 420 CALL ERROR1(18H ILLEGAL REFERENCE, 18) ! 333: GO TO 450 ! 334: 430 IF (.NOT.OPT(3) .OR. P1ERR) GO TO 450 ! 335: C ! 336: C LOAD INTO STACK COUNT OF WORDS IN DESCRIPTOR, INDEX OF FCN ! 337: C IN SYMBOL TABLE, STMT NO OF REFERENCE ! 338: C ! 339: IF (PT+3.GE.PB) GO TO 100 ! 340: STACK(PT) = PT - STACK(PB+2) ! 341: STACK(PT+1) = STACK(PB+3) ! 342: STACK(PT+2) = NOST ! 343: STACK(PT+3) = 6 - IGATT1(STACK(PB+3),8) ! 344: L3 = PT + 3 ! 345: ICOD = 2 ! 346: L = L2 - L1 + 5 ! 347: IF (L.LE.LREF) GO TO 440 ! 348: CALL ERROR1(44H IN EXPR, TABLE OVERFLOW OF REF, REF IGNORED, 44) ! 349: GO TO 450 ! 350: 440 WRITE (OUTUT3) L, ICOD, (STACK(I),I=PT,L3), (STACK(I),I=L1,L2) ! 351: C ! 352: C FCN REF POPPED AND PROPER TYPE PUT ON OPERAND STACK ! 353: C ! 354: 450 PT = STACK(PB+2) ! 355: I1 = IGATT1(STACK(PB+3),1) ! 356: STACK(PT) = 0 ! 357: STACK(PT+1) = MOD(I1,8) ! 358: PT = PT + 2 ! 359: PB = PB + 3 ! 360: GO TO 520 ! 361: C ! 362: C HANDLES FIRST OPERATOR IN EXPRESSION--WILL ALWAYS BE PUSHED ONTO ! 363: C OPERATOR STACK. FCN( HAS SPECIAL PUSH. ! 364: C ! 365: 460 IF (CUROP.NE.16) GO TO 480 ! 366: C ! 367: C FOUND "FCN(" CONSTRUCT ; STORE 3 THINGS IN STACK ! 368: C PTR TO FCN NAME IN SYMBOL TABLE; PTR TO 1ST ARGE IN STACK ; ! 369: C OPERAND CODE FOR FCN( ! 370: C ! 371: 470 IF (PB-3.LE.PT) GO TO 100 ! 372: STACK(PB) = KNAME ! 373: STACK(PB-1) = PT ! 374: STACK(PB-2) = CUROP ! 375: PB = PB - 3 ! 376: GO TO 520 ! 377: C ! 378: C SIMPLE PUSH ONTO OPERATOR STACK ! 379: C ! 380: 480 IF (PB-1.EQ.PT) GO TO 100 ! 381: STACK(PB) = CUROP ! 382: PB = PB - 1 ! 383: GO TO 520 ! 384: C ! 385: C POP OPERATOR FROM STACK. IF STACK EMPTY, PUSH CUROP ONTO ! 386: C STACK. ELSE TAKE ACTION SPECIFIED BY PRE(TOP OPERATOR,CUROP). ! 387: C ! 388: 490 CALL POP ! 389: IF (ERR) GO TO 530 ! 390: IF (PB.LT.LSTACK) GO TO 500 ! 391: GO TO 480 ! 392: 500 I = STACK(PB+1) - 10 ! 393: K = PRE(I,CUROP-10) ! 394: GO TO 310 ! 395: C ! 396: C POP "(" WHEN HAVE FINISHED A PARENTHESIZED EXPRESSION ! 397: C ! 398: 510 CALL POP ! 399: IF (ERR) GO TO 530 ! 400: C ! 401: C UPDATE PREVOP,PSTMT AFTER FINISHING PROCESSING AN OPERATOR ! 402: C ! 403: 520 PREVOP = CUROP ! 404: PSTMT = K2 ! 405: GO TO 10 ! 406: C ! 407: C JOB OF THIS CODE IS TO FLISH TO END OF UNRECOGNIZABLE ! 408: C EXPRESSION ! 409: C ! 410: 530 K2 = PSTMT ! 411: ERR = .FALSE. ! 412: 540 IF (K2.GE.NSTMT) GO TO 80 ! 413: IF (STMT(K2).EQ.65) PARENS = PARENS + 1 ! 414: IF (STMT(K2).NE.62) GO TO 550 ! 415: PARENS = PARENS - 1 ! 416: IF (PARENS.EQ.0) GO TO 560 ! 417: 550 K2 = K2 + 1 ! 418: GO TO 540 ! 419: 560 I = GETTOK(K2,I2) ! 420: K2 = I2 ! 421: IF ((I.EQ.1 .OR. I.EQ.6) .OR. ERR) GO TO 80 ! 422: GO TO 540 ! 423: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.