* * $Id: sicmpl.F,v 1.3 1997/03/14 11:57:30 mclareni Exp $ * * $Log: sicmpl.F,v $ * Revision 1.3 1997/03/14 11:57:30 mclareni * WNT mods * * Revision 1.2.2.1 1997/01/21 11:35:42 mclareni * All mods for Winnt 96a on winnt branch * * Revision 1.2 1996/04/02 22:17:33 thakulin * Support for EPC Fortran: remove char-int equivalences and use F90 * transfer facility. * * Revision 1.1.1.1 1995/12/12 14:36:15 mclareni * Imported sources * * #include "sigma/pilot.h" *CMZ : 1.10/01 26/10/93 15.09.52 by Carlo E. Vandoni *-- Author : SUBROUTINE SICMPL C ....................................................... C PURPOSE C TO SCAN TRANSFORMED INPUT STRING IOUTS(IC) FOR C MATCHING SYNTATICAL RULES C C USAGE C CALL SICMPL C C COMM. BLOCKS USED C COM1 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C SITRAX C SICLRP C SICMPR C SIERSY C SIFIND C SIINPS C SIONAM C OUTPUT C SISAVP C C... PAW VERSION ... MAY 1988 C C ...................................................... C #include "sigma/sigc.inc" #include "sigma/pawc.inc" #include "sigma/sigcmp.inc" C C COMMON/SICPH1/IC,I15,XDUMM C C #include "sigma/sicph2.inc" #include "sigma/sichel.inc" #include "sigma/sicfor.inc" *+CDE,SICSYM C INTEGER SIDSTP DIMENSION XZ(2) LOGICAL IND,INDR EQUIVALENCE (IOC,IPOINT) EQUIVALENCE (XZ(1), IOUTS(1)) #if !defined(CERNLIB_CRAY) CHARACTER IVAL(27)*4 #endif #if defined(CERNLIB_CRAY) CHARACTER IVAL(27)*8 #endif #if !defined(CERNLIB_F90) && !defined(CERNLIB_QFEPC) DIMENSION IDELI(27) EQUIVALENCE(IVAL(1),IDELI(1)) #endif SAVE KTHEN,KELSE,KFI,KEND,KEQUA,KARRA,KY SAVE KOPEN,KCLOS,KCOMM SAVE IVAL DATA KTHEN /4HTHEN/ DATA KELSE /4HELSE/ DATA KFI /4HFI / DATA KEND /4HEND / DATA KEQUA /4H= / #if !defined(CERNLIB_CRAY) DATA KARRA /4HARRA/ #endif #if defined(CERNLIB_CRAY) DATA KARRA /8HARRAY / #endif DATA KY /4HY / DATA KOPEN /4H( / DATA KCLOS /4H) / DATA KCOMM /4H, / DATA IVAL( 1)/'+'/ DATA IVAL( 2)/'-'/ DATA IVAL( 3)/'/'/ DATA IVAL( 4)/'('/ DATA IVAL( 5)/')'/ DATA IVAL( 6)/'='/ DATA IVAL( 7)/','/ DATA IVAL( 8)/'!'/ DATA IVAL( 9)/'#'/ DATA IVAL(10)/'%'/ DATA IVAL(11)/'&'/ DATA IVAL(12)/'"'/ DATA IVAL(13)/':'/ DATA IVAL(14)/''''/ DATA IVAL(15)/'['/ DATA IVAL(16)/']'/ DATA IVAL(17)/'*'/ DATA IVAL(18)/'$'/ DATA IVAL(19)/' '/ DATA IVAL(20)/'.'/ DATA IVAL(21)/'@'/ DATA IVAL(22)/'^'/ DATA IVAL(23)/'<'/ DATA IVAL(24)/'>'/ DATA IVAL(25)/'@'/ DATA IVAL(26)/'?'/ DATA IVAL(27)/';'/ C C STACKS USED IN BRANCH. C C SIDSTP - MAIN SYNTACTICAL TABLE OF COMPILER. C KS - POINTER OF MAIN SYNTACTICAL TABLE. C C NSTA - MAIN STACK OF SYNTACTICALLY DRIVEN SECOND PHASE. C IST - ITS POINTER. STACK UNIT EQUALS 3 WORDS. C C ICSTA - STACK OF MAIN COUNTER OF EXPRESSIONS C ICSP - ITS POINTER C C ONE STACK ENTRY CONSISTS OF THE FOLLOWING WORDS.. C 2) IC - POINTS TO INTERMEDIATE CODE IN IOUTS JUST CHECKED C 1) KS - POINTER TO ENTRY IN SYNTAX TABLE C 3) IOC - EQUAL TO IPOINT BITPOINTER IN OUTPUTAREA C C C IDISP - STACK OF DISPLAY LIST C LDISP - ITS POINTER. C C NAMS - STACK FOR FUNCTION OR ARRAY NAMES (ALSO FOR READ,PRINT) C LNS - ITS POINTER. C C C C C CALL SITRAX(' SICMPL ') C STACKED SYSTEM PARAMETER ICOUNT COUNTS EXPR&PARAM LIST ITEMS ICOUNT=0 C C PREVIOUS TRUE C ICSP = 1 LNS = 1 IST=1 KS=1 IC = 1 C CALL SISAVP CEV PRINT 333,IST,KS,KK,IC C 333 FORMAT(' IST=',I4,' KS=',I4,' KK=',I4,' IC=',I4) 1000 CALL SIINPS( 2 ) C KI15=1 C 1 CONTINUE C IF SERIALLY PROCESSED OR REACHED, GO TO PROCESS END/OR KK=SIDSTP(2,KS) CEV PRINT 333,IST,KS,KK,IC IF (KK.NE.0) GO TO 16 C 2 CONTINUE MG=SIDSTP(1,KS) MOR=SIDSTP(3,KS) NT=SIDSTP(6,KS) LIT=SIDSTP(5,KS) LITH=SIDSTP(4,KS) * print 334,ks,lith,lith *334 format(' 334 ',i6,a8,i15) CEV* PRINT 334,MG,MOR,NT,LITH,LIT,LIT C 334 FORMAT(' MG=',I4,2X,'MOR=',I4,2X,'NT=',I4, C 12X,'LITH=',A4,2X,'LIT=',A4,2X,I4) C PRINT *,ist,ks,ic,ioc,' and mg=',mg GO TO (3,19,6,5,3,16), MG C C C DEFINITION/REPEAT - DESCRIPTOR EQUAL 1 OR 5. 3 NSTA(IST)=KS NSTA(IST+1)=IC NSTA(IST+2)=IOC IST=IST+3 CALL SICMPR( ' STCK ' ) KS=NT GO TO 1 C C C SHORT LITERAL - DESCRIPTOR = 3. C THE SHORT LITERAL MIGHT BE A DELIMITER ONLY. C FIND IF ""LITERAL"" ON INPUT STRING 6 CONTINUE CALL SICMPR( ' LIT ' ) CEV* PRINT 335,LIT,IDELI(LIT),IDELI(LIT),IOUTS(IC),IOUTS(IC) CEV* 335 FORMAT(' LIT=',I4,'IDELI=',A4,I4,'IOUTS=',A4,I4) #if defined(CERNLIB_F90) || defined(CERNLIB_QFEPC) LIT=transfer(IVAL(LIT),LIT) #else LIT=IDELI(LIT) #endif IF( IOUTS(IC) .EQ. 4) GO TO 14 8 KS=SIDSTP(3,KS) CALL SICMPR( ' OR ' ) IF(KS.EQ.0) GO TO 11 C OR FIND - OMIT SERIALLY PROCESSED OR CALL SICMPR( ' OMOR ' ) GO TO 2 C C C LONG LITERAL - DESCRIPTOR = 4. C THE LONG LITERAL MIGHT BE A RESERVED WORD ONLY. 5 CONTINUE CALL SICMPR( ' LITL ' ) LIT = SIDSTP(5,KS + 1) LITH=SIDSTP(4,KS+1) * print 1334,ks,lith,lith *1334 format(' 1334 ',i6,a8,i15) IF(IOUTS(IC) .EQ. 3) GO TO 114 C NO FIND NEXT OR GO TO 8 C IF STACK EMPTY - NO MATCH - INVALID SYNTAX GO TO ALARM SIGNAL. 11 IF (IST.EQ.1) GO TO 3000 IST=IST-3 KS=NSTA(IST) IC=NSTA(IST+1) IOC=NSTA(IST+2) CALL SICMPR( ' UNST ' ) IF(SIDSTP(1,KS).EQ.1)GO TO 13 GO TO 8 13 KS=KS+1 GO TO 1 C IF NO COMPARE ""LITERAL"" AND SYNTAX LITERAL,GO 14 CONTINUE IF (LIT.NE.IOUTS(IC+1)) GO TO 8 IC=IC+2 IF (MG.EQ.4) KS=KS+1 KS=KS+1 CALL SICMPR( ' EQLI ' ) GO TO 1 C--- IOUTS(IC).EQ.3 114 CONTINUE #if !defined(CERNLIB_CRAY) IF (LITH.NE.IOUTS(IC+1).OR.LIT.NE.IOUTS(IC+2)) GO TO 8 #endif #if defined(CERNLIB_CRAY) IF (LITH.NE.IOUTS(IC+1)) GO TO 8 #endif IC=IC+3 IF (MG.EQ.4) KS=KS+1 KS=KS+1 CALL SICMPR( ' EQLI ' ) GO TO 1 C C C OR/END PROCESSING, END OF TABLE - DESCRIPTOR = 6. 16 IF (IST.EQ.1) GO TO 18 IST=IST-3 KS=NSTA(IST) CALL SICMPR( ' END ' ) IF(SIDSTP(1,KS).EQ.1)GO TO 1 KS=KS+1 GO TO 1 C VALID SYNTAX OF STATEMENT - TRUE RETURN. 18 IND=.TRUE. IF(IC.NE.(I15-KI15))GOTO 3000 RETURN C C GENERAL SYNTACTICAL ERROR - 1. 3000 CALL SIERSY(1) IQUEST(1)=-1 CEV* PRINT 12655,IC,I15,KI15 CEV* PRINT 333,IST,KS,KK,IC *12655 FORMAT(' IC=',I4,' I15=',I4,' KI15=',I4) GO TO 1000 C C C SYNTACTICAL ROUTINES PROCESSING. - DESCRIPTOR = 2. 19 CONTINUE CALL SICMPR( ' SUBR ' ) IF(NT .GT. 18) GO TO 45 C NT FROM 1 TO 18. * 20 CONTINUE GO TO (21,22,23,25,26,27,28,29,30,32,33,34,35,36,37,38,39,60), NT 45 NT = NT - 18 C NT FROM 18 UP. GO TO (79,80,81,82,83,84,85,86,87,88,89,90,91,92), NT C C C 1 EMPTY ROUTINE 21 GO TO 42 C C C 2 OUTPUT 22 CALL SIOUTP (LIT) GO TO 42 C C C 3 LABEL DECLARATION 23 GO TO ( 2301,2302 ), LIT C C IF LABELLED STATEMENT PRESERVE LABEL IN LABDO AND PROCESS IT. 2301 IF( IOUTS(IC) .NE. 1 ) GO TO 40 CEV KI15=-1 CALL SIERSY(1) IQUEST(1)=-1 CEV LABDO = XZ( IC+1 ) CEV I = LABDO CEV CALL SILAFI( I, INDR ) CEV IF( INDR ) GO TO 2330 CEV CALL SILABA( I, -9 ) GO TO 46 C C FIND IF LABEL IS A DO LABEL AND PROCESS IT. 2302 CONTINUE 2320 CONTINUE 9876 CONTINUE CALL SIINPS( 3 ) GO TO 1 C C C 4 PROCESS STRING LOADING. 25 CONTINUE C--- 26 - STRING PROCESSING HOOKS CALL SIOUTP(26) NRES = IOUTS(IC) * 9 july NRESO=NRES-1 CALL SIOUTP(NRESO) * PRINT 2599,NRES,IOUTS(IC),IOUTS(IC) *CHECK IF NULL STRING IF(NRESO.EQ.0)IC=IC+2 IF(NRESO.EQ.0)goto 41 *cev mar 1992 2510 IC = IC + 1 CALL SIOUTP(IOUTS(IC)) * PRINT 2599,NRES,IOUTS(IC),IOUTS(IC) 2599 FORMAT(I4,' = ',A4,A1) NRES=NRES-1 * 9 july * IF(NRES.EQ.1) IC=IC+1 IF(NRES.EQ.1) go to 41 * IF(NRES.EQ.0)GO TO 41 GO TO 2510 C C C 5 IF THEN ELSE FI PROCESSING. 26 GO TO ( 2601,2602,2603,2604 ), LIT C C--- 401 - IF STMT 2601 CALL SIOUTP(401) GO TO 42 C 2602 CONTINUE CEV CALL SILAPU( I ) C--- 409 - SIGTOZ CEv CALL SIOUTP(409) CEV CALL SIOUTP(I) GO TO 42 C 2603 LSTAPO = LSTAPO - 1 GO TO 42 C 2604 CONTINUE CEV CALL SILABA( 512, 9 ) LSTAPO = LSTAPO - 1 GO TO 42 C C C 6 MULTISTATEMENT PROCESSING. (BEGIN/END OF MULTISTATEMENT). 27 GO TO ( 2701,2702,2703,2704,42), LIT C C BEGIN OF MULTISTATEMENT CONSTRUCTION PASSING. 2701 CONTINUE GO TO 42 C C END OF MULTISTATEMENT CONSTRUCTION PASSING. 2702 CONTINUE GO TO 42 C 2703 CONTINUE GO TO 42 C C READ NEXT STATEMENT AND FIND IF NOT- THEN, FI, ELSE, END. 2704 CONTINUE IF( IOUTS(IC) .NE. 5 ) GO TO 2710 CALL SISAVP CALL SIINPS( 1 ) 2710 CALL SIOUTP(29) CALL SIOUTP(28) IF( IOUTS(IC) .NE. 3 ) GO TO 42 NRES = IOUTS( IC+1 ) C NRESH=IOUTS(IC+2) IF((NRES .EQ. KTHEN) .OR. 1 (NRES .EQ. KFI ) .OR. 1 (NRES .EQ. KELSE) .OR. 1 (NRES .EQ. KEND ) ) GO TO 40 GO TO 42 C C C 7 PROCESS ASSIGNEMENT STATEMENT. 28 GO TO (2801,2802,2803,2804 ), LIT C C LEFT PART AS A SIMPLE VARIABLE. 2801 IF (IOUTS(IC).NE.3) GO TO 40 IF(IOUTS(IC+3).NE.4.OR.IOUTS(IC+4).NE.KEQUA)GO TO 40 LARSI = 3 2810 NRES = IOUTS( IC + 1 ) NRESH=IOUTS(IC+2) CALL SIFIND(NRES,NRESH,NCODE,2,INDR) IF ( INDR ) GO TO 2811 CALL SIFIND(NRES,NRESH,NCODE,5,INDR) IF(INDR) GO TO 2811 *5646 FORMAT('KARRA ',2A8) #if !defined(CERNLIB_CRAY) IF((NRES.EQ.KARRA).AND.(NRESH.EQ.KY )) GO TO 2811 #endif #if defined(CERNLIB_CRAY) IF(NRES.EQ.KARRA) GO TO 2811 #endif C C I DO NOT OUTPUT ANYMORE 002 C (BEGIN OF AN ASSIGNMENT STATEMENT C CALL SIONAM(IOUTS(IC+1),IOUTS(IC+2)) IC=IC+1 GO TO 46 C SYSTEM FUNCTION NAME USED AS LEFT PART OF ASSIGNEMENT. 2811 CALL SIERSY( 3 ) IQUEST(1)=-3 GO TO 9876 C C LEFT PART AS ARRAY OR PROGRAMMERS FUNCTION NAME. 2802 IF( IOUTS(IC) .NE. 3 ) GO TO 40 IF(IOUTS(IC+3).NE.4.OR.IOUTS(IC+4).NE.KOPEN)GO TO 40 C NOT A LEFT PARENTHESIS FOLLOWING C C CHECK IF ASSIGNMENT OPERATOR IS COMING AT ALL. OTHERWISE IT IS A C DISPLAY STMT - E.G. COS(X):X . C ICTEM=IC+4 2806 CONTINUE IF(IOUTS(ICTEM).EQ.5)GO TO 40 C FIVE MEANS EOS. NOT AN ASSIGNMENT STMT. IF(IOUTS(ICTEM).EQ.4.AND.IOUTS(ICTEM+1).EQ.KEQUA)GO TO 2805 ICTEM=ICTEM+2 GO TO 2806 2805 CONTINUE LARSI = 5 GO TO 2810 C C GENERATE INDEX, N-DIMENSIONS. C--- 4 - INDEX N-DIM 2803 CALL SIOUTP(4) GO TO 42 C C GENERATE ASSIGN SIMPLE/ARRAY-PR.FUNCTION NAME. 2804 CALL SIOUTP(LARSI) GO TO 42 C C C 8 OUTPUT CONST ZERO 29 CALL SIOUTP(32) CALL SIOUTP(000) GO TO 42 C C C 9 PROCESS NUMERICAL CONSTANT AS OPERAND IN EXPRESSION. 30 IF (IOUTS(IC).EQ.2) GO TO 31 IF(IOUTS(IC).EQ.6) GO TO 6464 GO TO 40 31 A = XZ(IC + 1) IF(ABS(A).GT.511.) GO TO 63 IF(A - AINT(A) .NE. 0) GO TO 63 I1 = INT(A) I = IABS(I1) IF(I .GT. 511) GO TO 63 IF(I1 .GT. 0) GO TO 61 C--- 33 - NEGKON CALL SIOUTP(33) GO TO 62 C--- 32 - SIPOSK 61 CALL SIOUTP(32) 62 CALL SIOUTP(I) GO TO 64 C--- 6 - KONST 63 CALL SIOUTP(6) CALL SIOUTP(A) 64 IC = IC + 2 GO TO 42 C 6464 CONTINUE I=IOUTS(IC+1) CC--- 31 - SICKON CALL SIOUTP(31) CALL SIOUTP(CMPCOM(I)) CALL SIOUTP(CMPCOM(I+1)) C A=XZ(IC+1) C B=XZ(IC+2) C CALL OUTPUT(A,60) C CALL OUTPUT(B,60) GO TO 64 CC C 10 PROCESS SIMPLE VARIABLE. (VARIABLE AND NOT ( ). 32 IF (IOUTS(IC).NE.3) GO TO 40 IF(IOUTS(IC+3).EQ.4.AND.IOUTS(IC+4).EQ.KOPEN)GO TO 40 CALL SIONAM(IOUTS(IC+1),IOUTS(IC+2)) IC=IC+1 GO TO 64 C C C 11 PROCESS FUNCTION CALL AND PARAMETER COUNTING. 33 CONTINUE GOTO(3301,3302),LIT 3301 CONTINUE IF(IOUTS(IC).NE.3) GOTO 40 NAMS(1,LNS)=IOUTS(IC+1) NAMS(2,LNS)=IOUTS(IC+2) IC=IC+1 LNS=LNS+1 GOTO 46 C 3302 CONTINUE LNS = LNS - 1 NRES = NAMS(1,LNS) NRESH=NAMS(2,LNS) CALL SIFIND(NRES,NRESH,NCODE,2,INDR) IF( .NOT. INDR ) GO TO 154 C C SYSTEM FUNCTION FOUND. CEV* PRINT 336,NRES,NCODE C 336 FORMAT(' SYSTEM FUNCTION FOUND',A4,2X,I4) IF(NCODE.LT.1000) GO TO 1111 IF(NCODE.LT.2000) GO TO 2222 IF(NCODE.LT.3000) GO TO 3333 IF(NCODE.LT.4000) GO TO 4444 I1=0 I=NCODE-10000 GO TO 3382 1111 CONTINUE I1=0 I=NCODE GO TO 8888 2222 CONTINUE I1=1 I=NCODE-1000 GO TO 8888 3333 CONTINUE I1=2 I=NCODE-2000 GO TO 8888 4444 CONTINUE I1=3 I=NCODE-3000 8888 CONTINUE C IF( I1 .NE. 0 ) GO TO 151 C C SYSTEM FUNCTION WITH VARIABLE PARAMETER NO. (31,FUNCT-NO,PARAM-NO) C--- 25 - SYSOP (VAR. NO. PARAMETERS) CALL SIOUTP(25) CALL SIOUTP(I) GOTO 3392 151 IF(I1.NE.ICOUNT) GO TO 153 C C SYSTEM FUNCTION WITH KNOWN PARAMETER NO. (26, FUNCT-NO ) C THERE IS MATCH OF PARAMETERS NUMBER. C--- 22 - SYSFUN,SILDRV OR SYSOP CALL SIOUTP(22) CALL SIOUTP(I) GOTO 3393 C ERROR - NO MATCH OF PARAMETER NO OF SYSTEM FUNCTION. 153 CALL SIERSY( 5 ) IQUEST(1)=-5 GO TO 9876 C 3382 CONTINUE C ISSUE OBJECT CODE WITHOUT 26B OR 31B CALL SIOUTP(I) IF(I1.NE.0) GOTO 3393 GOTO 3392 C C USERS SOMETHING CALL. (NAME-LOAD, 27, PARAM-NO ) 154 CALL SIONAM(NAMS(1,LNS),NAMS(2,LNS)) CORR IC=IC+1 C--- 23 - NAME FUNCTION CALL CALL SIOUTP(23) C 3392 CONTINUE CALL SIOUTP(ICOUNT) 3393 CONTINUE ICSP=ICSP-1 ICOUNT=ICSTA(ICSP) GOTO 42 C C C 12 FREE NUMBER OF SEMANTIC ROUTINE. 34 CONTINUE GO TO 42 C C C 13 STACK OR UNSTACK ICOUNT WHICH COUNTS EXPR. LIST ITEMS C *************************************************************** C UNSTACKING IS NOT PERFORMED FOR A FALSE RETURN C HENCE THIS CAN ONLY WORK IF FALSE RETURN GOES TO STATEMENT LEVEL C WHERE ALL STACKED ICOUNTS BECOME IRRELEVANT C *************************************************************** 35 CONTINUE GOTO(3501,3502),LIT C 3501 ICSTA(ICSP)=ICOUNT ICSP=ICSP+1 ICOUNT=0 GOTO 42 C 3502 CALL SIOUTP(ICOUNT) ICSP=ICSP-1 ICOUNT=ICSTA(ICSP) GOTO 42 C C C 14 PROCESS EXPRESSION LIST PARAMETERS. 36 CONTINUE C INCREMENT THE EXPRESSION COUNTER ICOUNT=ICOUNT+1 C IF ITEM DOES NOT END IN A COMMA * print 8887,IOUTS(IC+1) 8887 format(' before if ',a4) IF(IOUTS(IC).NE.4.OR.IOUTS(IC+1).NE.KCOMM) GOTO 42 C C SKIP OVER COMMA IF ANY (MAKE SEPARATOR COMMA REDUNDANT) IC=IC+2 IF(IOUTS(IC).NE.5.AND.(IOUTS(IC).NE.4.OR.IOUTS(IC+1).NE.KCLOS)) ,GOTO 42 C IF NEXT TOKEN IS END OF STATEMENT OR RIGHT PARENTHESIS C WE HAVE ANOTHER MISSING INDEX C THIS CANNOT BE CHECKED BY MISS.IND. AS REPEAT LOOP HANGS CALL SIOUTP(24) ICOUNT=ICOUNT+1 GOTO 42 C C C 15 PROCESS SUBROUTINE/FUNCTION DECLARATION. 37 CONTINUE GOTO(3701,3702,3703,3704,3705,3706,3707,3717),LIT C 3701 I1=415 C C SUBROUTINE C ITYPE=4 GO TO 3720 C 3702 I1=414 C C FUNCTION C ITYPE=3 3720 CONTINUE CALL SICLRP CEV CALL SILAPU( I ) C--- 28 - BOS CALL SIOUTP(28) CALL SIOUTP(I1) CEV CALL SILAPU( I ) CALL SIOUTP(I) GO TO 42 3707 CONTINUE I1=419 ITYPE=8 GOTO3720 3717 CONTINUE I1=418 ITYPE=7 GOTO3720 C C NO LIST C 3703 IF( IOUTS(IC) .NE. 3 ) GO TO 40 IF(IOUTS(IC+3).EQ.4.AND.IOUTS(IC+4).EQ.KOPEN)GO TO 40 IF( IOUTS(IC+2) .NE. 5 ) GO TO 40 3730 NRES = IOUTS( IC+1 ) NRESH=IOUTS(IC+2) CALL SIFIND(NRES,NRESH,NCODE,2,INDR) IF( INDR ) GO TO 40 CALL SIONAM(IOUTS(IC+1),IOUTS(IC+2)) IC=IC+1 GO TO 46 C C LIST C 3704 IF( IOUTS(IC) .NE. 3 ) GO TO 40 IF(IOUTS(IC+3).NE.4.OR.IOUTS(IC+4).NE.KOPEN)GO TO 40 GO TO 3730 C C END AFTER LIST. C C END OF S/F HEADER - BODY CODING BEGIN. 3705 CALL SIOUTP(I1+2) CALL SIOUTP(LISIM) GO TO 42 C C END OF SUB ROUTINE/FU NCTION CODING. 3706 CALL SIOUTP(35) CALL SIOUTP(34) CALL SIOUTP(415) CALL SIOUTP(35) C--- 777 - IPROGR(I) END CALL SIOUTP(777) I1 = MOD( IPOINT, 60 ) IF( I1 .EQ. 0 ) GO TO 3760 DO 3710 I = I1, 56, 3 C CALL SIOUTP(0,3) C-- Since O don't knwo what does this mean I did as follows (V.Fine 26.06.96) CALL SIOUTP(3) 3710 CONTINUE CEV CALL SILABA(512,0) LSTAPO = LSTAPO - 1 3760 CALL SIOUTP(I1) IF(I1.EQ.0)GO TO 3741 DO 3740 I = 1, I1 3740 CONTINUE 3741 CONTINUE CEV CALL SILABA(512,0) LSTAPO = LSTAPO - 1 CALL SIOUTP(28) C--- 24 - EMPTY INDEX EXPRESSION GO TO 42 C C C 16 PROCESS SIMPLE LIST STRUCTURE. 38 GO TO (3801, 3802 ), LIT 3801 LISIM = 1 GO TO 42 3802 LISIM = LISIM + 1 GO TO 42 C C C 17 PROCESS FUNCTIONAL FORM AS AN ACTUAL PARAMETER OF FUNCTION CALL 39 CONTINUE GO TO 42 C C C 18 FREE NUMBER OF SEMANTIC ROUTINE. 60 CONTINUE GO TO 42 C C C 19 PROCESS ZEROISING OF DISPLAY COUNTERS 79 LDISP = 1 DO 100 LL=1,50 100 IDISP(LL) = 0 LWIND = 0 * ISYMP=1 GO TO 42 C CTESTC CTESTC 20 PROCESS SYMBOLIC STRING IN DISPLAY LIST (1). CTESTC 80 CONTINUE C C 21 PROCESS OVER ELEMENT IN DISPLAY LIST (8). 81 LDISP = LDISP + 1 IDISP(LDISP) = IDISP(LDISP) + 8 GO TO 42 C C C 22 PROCESS COMMA IN DISPLAY LIST 82 LDISP = LDISP + 1 GO TO 42 C C C 23 PROCESS END OF DISPLAY LIST 83 CONTINUE C FIND IF NEED OF OUTPUT(SCALEX). C JD = 1 JN = 1 I9SW=0 * ISYMP=1 IF ( MOD(LWIND,1) .NE. 0 ) GO TO 201 DO 202 I = 1, LDISP IF( IDISP(I) .NE. 8 ) GO TO 205 KD(JD) = LDISP - I JD = JD + 1 GO TO 202 205 KN(JN) = LDISP - I JN = JN + 1 202 CONTINUE IF( JD .NE. 1) I9SW=1 C C FIND IF NEED OF OUTPUT(SCALEY) 201 IF ( MOD(LWIND,8) .NE. 0 ) GO TO 204 IF( JN .EQ. 1) GO TO 204 C--- 110 - SCALEY C C SCALE BUSSINESS DONE. C C NORMAL 100, OVER 10, DOTTED 1, IN IDISP ARRAY. 204 CONTINUE C--- 109 - SCALEX JN = 1 JD = 1 DO 220 I = 1, LDISP C C FIND OVER ELEMENT. IF(IDISP(I+1).EQ.8)GO TO 219 C C FIND DOTTED ELEMENT. 212 IF( IDISP(I) .EQ. 1 ) GO TO 211 C C SKIP OVER ELEMENTS. IF( IDISP(I) .EQ. 8 ) GO TO 220 C C NORMAL ELEMENT EXISTS. KN(JN) = LDISP - I JN = JN + 1 C C FIND IF BEFORE NORMAL WAS DOTTED. IF( JD .EQ. 1 ) GO TO 220 C--- 112 - DISPLAY DOTTED JD = 1 GO TO 220 C C DOTTED EXISTS. 211 KD(JD) = LDISP - I JD = JD + 1 C C FIND IF BEFORE DOTTED WAS NORMAL. IF(JN .EQ. 1 ) GO TO 220 C--- 111 - DISPLAY JN = 1 GO TO 220 C C OVER ELEMENT EXISTS. 219 KO = LDISP - I - 1 C C FIND IF DOTTED BEFORE. IF( JD .EQ. 1 ) GO TO 215 C--- 112 - DISPLAY DOTTED JD = 1 C C OUTPUT( FIX ELEMENT ) C--- 108 - FIXX (POINTER) 218 CALL SIOUTP(108) CALL SIOUTP(KO) GO TO 212 C C FIND IF NORMAL BEFORE. 215 IF( JN .EQ. 1 ) GO TO 218 C--- 111 - DISPLAY JN = 1 GO TO 218 220 CONTINUE C C END OF DISPLAY LIST PROCESSING. IF( JN .EQ. 1 ) GO TO 214 C--- 111 - DISPLAY 214 IF( JD .EQ. 1 ) GO TO 221 C--- 112 - DISPLAY DOTTED C C OUTPUT PICTURE END, NO OF DISPLAY LIST ALL ELEMENTS. C (FOR DROPP) C--- 103 - PICTURE END 221 CALL SIOUTP(103) CALL SIOUTP(LDISP) GO TO 42 C C C 24 PROCESS DISPLAY SIMPLE ELEMENT (64). 84 IDISP(LDISP) = IDISP(LDISP) + 64 GO TO 42 C C C 25 TRACK OPTION PROCESSING. C OUTPUT SINGLE INTEGER CONSTANT (IF EXIST , ZERO OTHERWISE.) 85 I = 0 IF(IOUTS(IC) .NE. 2) GO TO 44 I = XZ(IC + 1) IC = IC + 2 C--- 34 - TRACK I 44 CALL SIOUTP(34) CALL SIOUTP(I) GO TO 42 C C C 26 WINDOW OF DISPLAY LIST PROCESSING. 86 GO TO (8601, 8602), LIT C C 26(1) SET THERE WERE WIND X AND OUTPUT WINDOW X. 8601 LWIND = LWIND + 1 C--- 105 - SETWX CALL SIOUTP(105) GO TO 42 C C 26(2) SET THERE WERE WIND Y AND OUTPUT WINDOWY. 8602 LWIND = LWIND + 8 C--- 106 - SETWY CALL SIOUTP(106) GO TO 42 C C C 27 PROCESSING OF DO HEAD AND TAIL. 87 GO TO ( 8701,8702,8703 ), LIT C 8703 IF( IOUTS(IC) .NE. 2 ) GO TO 40 I = XZ(IC+1) CEV CALL SILAFI( I, INDR ) C--- 32 - POSKOM CALL SIOUTP(32) CALL SIOUTP(I) GO TO 46 C C--- 32 - POSKOM 8702 CALL SIOUTP(32) CALL SIOUTP(1) C C--- 402 - DO BEGIN 8701 CALL SIOUTP(402) CEV CALL SILAPU( I ) CEV CALL SILABA( I, 9 ) GO TO 42 C C C 28 FIND IF CONTROL NAME EXIST ON THE LIST AND OUTPUT ASSOCIATED VA 88 CONTINUE GO TO(8801,8802,8803),LIT 8801 CONTINUE IF(IOUTS(IC).NE.3)GO TO 40 NRES = IOUTS(IC + 1) NRESH=IOUTS(IC+2) CALL SIFIND(NRES,NRESH,NCODE,1,INDR) IF( .NOT. INDR ) GO TO 40 C CONTROL NAME FOUND. CALL SIOUTP(NCODE) CDC GO TO 46 GO TO 48 8802 CONTINUE IF(IOUTS(IC).NE.3)GO TO 40 NRES=IOUTS(IC+1) NRESH=IOUTS(IC+2) CALL SIFIND(NRES,NRESH,NCODE,6,INDR) IF(.NOT.INDR)GO TO 40 NAMS(1,LNS)=NRES NAMS(2,LNS)=NRESH LNS=LNS+1 GO TO 8999 8803 LNS=LNS-1 C NRES=NAMS(1,LNS) C NRESH=NAMS(2,LNS) CALL SIOUTP(NCODE) GO TO 42 C C C 29 PROCESSING OF RESERVED WORDS STANDING ALONE, C WITH SIMPLE LIST AND WITH EXPRESSION LIST. 89 GO TO ( 8901,8902,8903,8904,8905 ), LIT C C RESERVED WITH SIMPLE LIST. 8901 IF( IOUTS( IC ) .NE. 3 ) GO TO 40 NRES = IOUTS( IC + 1 ) NRESH=IOUTS(IC+2) CALL SIFIND(NRES,NRESH,NCODE,3,INDR) IF(.NOT.INDR)GO TO 40 GO TO 8999 C 8902 CALL SIOUTP(NCODE) CALL SIOUTP(LISIM) GO TO 42 C C RESERVED WITH EXPRESSION LIST. 8903 IF( IOUTS( IC ) .NE. 3 ) GO TO 40 C C PICK UP NAME FROM INTERMEDIATE CODE AREA IOUTS C AND STACK IT IN VAR-ARRAY STACK NAMS IF FOUND C NRES = IOUTS( IC + 1 ) NRESH=IOUTS(IC+2) CALL SIFIND(NRES,NRESH,NCODE,4,INDR) IF (.NOT. INDR) GOTO 40 NAMS(1,LNS)=NRES NAMS(2,LNS)=NRESH LNS=LNS+1 IC=IC+1 GOTO 46 C 8904 LNS=LNS-1 NRES=NAMS(1,LNS) NRESH=NAMS(2,LNS) CALL SIFIND(NRES,NRESH,NCODE,4,INDR) CALL SIOUTP(NCODE) GO TO 42 C C RESERVED STANDING ALONE. 8905 IF( IOUTS( IC ) .NE. 3 ) GO TO 40 NRES = IOUTS( IC + 1 ) NRESH=IOUTS(IC+2) CALL SIFIND(NRES,NRESH,NCODE,5,INDR) IF ( .NOT. INDR ) GO TO 40 CEV* PRINT 2006,NCODE,NRES * 2006 FORMAT(' .... NCODE=',I8,' NRES=',I8) CALL SIOUTP (NCODE) IF(NCODE.NE.403)GO TO 8999 8999 CONTINUE IC = IC + 2 +1 GO TO 42 C C C 30 CALL STATEMENT PROCESSING. 90 GO TO ( 9001,9002,9003 ), LIT 9001 IF( IOUTS(IC) .NE. 3 ) GO TO 40 IF( IOUTS(IC+3) .NE. 5 ) GO TO 40 C--- 405 - CALL BEGIN CALL SIOUTP(405) CALL SIONAM(IOUTS(IC+1),IOUTS(IC+2)) IC=IC+1 C--- 410 - CALL END CALL SIOUTP(410) GO TO 46 C 9002 IF( IOUTS(IC) .NE. 3 ) GO TO 40 IF(IOUTS(IC+3).NE.4.OR.IOUTS(IC+4).NE.KOPEN)GO TO 40 C--- 405 - CALL BEGIN CALL SIOUTP(405) GO TO 42 C C--- 410 - CALL END 9003 CALL SIOUTP(410) GO TO 42 C C C 31 GO TO STATEMENT PROCESSING. 91 GO TO ( 9101, 9102 ), LIT C 9101 IF( IOUTS(IC) .NE. 2 ) GO TO 40 IF( IOUTS(IC+2) .NE. 5 ) GO TO 40 I1 = XZ(IC + 1) CEV CALL SILAFI( I1, INDR ) C--- 404 - GO TO LABLE CALL SIOUTP(404) CALL SIOUTP(I1) GO TO 46 C C--- 408 - SIGTOX 9102 CALL SIOUTP(408) GO TO 42 C C C 32 MISSING INDEX 92 CONTINUE C IF EXPR.LIST ITEM IS NOT A PLAIN COMMA IF(IOUTS(IC).NE.4.OR.IOUTS(IC+1).NE.KCOMM) GOTO 40 C C WE HAVE A MISSING INDEX C MISSING INDEX AFTER TRAILING COMMA IS HANDLED BY SR14(000) CALL SIOUTP(24) GO TO 42 C C C C COMM. RETURN POINTS. -FALSE RETURN POINT. 40 GO TO 8 C C TRUE RETURN POINT NO. 1. 41 IC=IC+1 C C TRUE RETURN POINT NO. 2. 42 KS=KS+1 GO TO 1 C--- IC MODIFIED FOR !STOP --- NEW RETURN 48 48 IC=IC+1 C TRUE RETURN POINT NO. 3. 46 IC = IC + 2 KS = KS + 1 GO TO 1 C C--- TRUE RETURN POINT NO. 4 --- NEW C--- THIS IS BECAUSE NAME NOW TWO WORDS FOR EXAMPLE: ASSIGNMENT C--- !!! NO YET IMPLEMENTED ................. C END