C COMPILED FROM 'HS.MACMAC.DATA' WITH * MACHINE='CDC' DL'85APR21. C *********************************** C * * C * UNIVERSITY COLLEGE LONDON * qub'91oct1st: C * * C++ C * FORTRAN MACRO-PROCESSOR * interactive C * * code... C * VERSION 1 MOD 5 * C-- C * * qub'93jan17: C *********************************** +isp,nchar... C C C THIS PROGRAM IS WRITTEN IN ASA STANDARD FORTRAN, AND IS DESIGNED C TO PROCESS STATEMENTS WRITTEN IN THE FORTRAN MACRO-PROCESSING C LANGUAGE INVENTED BY DAY AND SHAW. THIS LANGUAGE HAS THE C FOLLOWING FEATURES - C C OPERATORS - * / + - ++ = ( ) C --------- C C FUNCTIONS - &(EXPRESSION) REPLACED BY CHAR. VALUE C --------- &L(EXPRESSION) LENGTH OF CHAR. VALUE C &S(EXPRESSION,START,END) SUBSTRING OF CHAR. VALUE C C C STATEMENTS - + COMMENT C ---------- * CALL NAME(PARAMETER LIST) C * MACRO NAME(PARAMETER LIST) C * IF(EXPRESSION.RL.EXPRESSION)STATEMENT C * GO TO LABEL (ONLY IN A MACRO) C * EXPRESSION (ASSIGNMENT) C * CONTINUE C * RETURN C * END C C PRINTING - A CARD WITH PRINT IN COLS. 1-5 AND A NUMERIC DIGIT C ANYWHERE ON THE REST OF THE CARD WILL CHANGE THE C PRINT LEVEL. THE FOLLOWING LEVELS EXIST - C PRINT 0 NO PRINTING C PRINT 1 NO MACROS, NO REPLACEMENTS, NO MACRO C EXPANSIONS (INPUT DECK WITHOUT MACROS) C PRINT 2 NO REPLACEMENTS, NO MACRO EXPANSIONS C (REPEAT INPUT DECK) C PRINT 3 FIRST AND LAST VERSIONS OF STATEMENTS C WITH REPLACEMENTS, NO MACRO EXPANSIONS C (THIS IS THE DEFAULT PRINT LEVEL) C PRINT 4 AS FOR 3, PLUS NON-STAR STATEMENTS C GENERATED BY MACROS C PRINT 5 FIRST AND LAST REPLACEMENTS, MACRO C EXPANSIONS C PRINT 6 EVERY SUCCESSIVE REPLACEMENT, MACRO C EXPANSIONS C PRINT 7 LEAVE ONE BLANK LINE C PRINT LEVEL REMAINS UNCHANGED C PRINT 8 LEAVE FIVE BLANK LINES C PRINT LEVEL REMAINS UNCHANGED C PRINT 9 SKIP TO A NEW PAGE C PRINT LEVEL REMAINS UNCHANGED C C PROGRAMMER - DR A. C. DAY C COMPUTER CENTRE C UNIVERSITY COLLEGE LONDON C 19, GORDON STREET C LONDON WC1H 0AH. C C DISCLAIMER - WHILST IT IS BELIEVED THAT THIS PROGRAM FULFILLS ITS C SPECIFICATIONS, NO RESPONSIBILITY CAN BE ASSUMED FOR C THE RESULTS OF ITS MALFUNCTIONING. 7 DECEMBER 1970 C C character*15 infile, outfile DIMENSION KARD(72),KHASH(51),KARS(51),KTYPE(51),IPTR(5000),ISTORE( C5000),NOMEN(4,199),ITAB(15,4),IOP(11),KEY(41),IFOP(2,6),KEND(4),IP CRNT(4) COMMON /INFO/ LURD,LUWR,LUPCH,NLINE,LTLINE,NPAGE,MAMP,KPRNT,MACLEV C ,KSP,KAMP,KP,KC,KZERO,KAST,LAVS1,LAVS2,IST1,IST2,NCARD,LPRINT,KEN CD,IPRNT,IFOP,IOP,ITAB,KARD ,KHASH,KARS,KTYPE,KEY,NOMEN,IPTR,ISTORE * ,isp,nchar DATA NRET/1/ 100 FORMAT(72A1,I8) 200 FORMAT(20X,72A1,I8) C SET UP KHASH VECTOR OF CRUSHED CHARACTERS DO 333 I=1,nchar 333 KHASH(I)=I C SORT CHARACTERS BY RIPPLE SORT L=nchar-1 111 J=0 M=KHASH(1) K1=KARS(M) DO 113 I=2,L N=KHASH(I) K2=KARS(N) IF(K1)1111,1112,1112 1111 IF(K2)1113,1114,1114 1112 IF(K2)112,1113,1113 1113 IF(K1-K2)112,1114,1114 1114 KHASH(I-1)=N KHASH(I)=M J=1 GO TO 113 112 K1=K2 M=N 113 CONTINUE L=L-1 IF(L.GT.1.AND.J.GT.0)GO TO 111 C SET UP AVAILABLE SPACE LIST J=1 DO 222 I=2,5000 IPTR(J)=I 222 J=I IPTR(5000)=0 DO 444 I=1,199 444 NOMEN(1,I)=0 C+++++ LURD=8 print *,' MACPROC -- do name OUTFILE:' read *, outfile open(LUPCH,FILE=outfile,STATUS='NEW') 777 print*,NCARD,'/10 records read; name INFILE (STOPs if =END):' read *, infile if(infile.eq.'END') go to 6 open(LURD,FILE=infile,STATUS='UNKNOWN') C----- C C READ A CARD C 1 READ(LURD,100)KARD 1 read(LURD,100,END=777)KARD 14 CALL IDENT(KSTP) C+++++ if(KSTP.eq.0) go to 777 C----- C FORCE CHANGE OF PRINT LEVEL IF PRINT CARD FOUND 15 IF(KPRNT.NE.LPRINT)GO TO 14 GO TO (2,4,5,12,9,9),KSTP C C COMMENT CARD - PUNCH IT 2 NCARD=NCARD+10 C WRITE(LUPCH,100)KARD,NCARD C+++++ do 3 i=72,1,-1 new=i if(KARD(i).ne.KSP) go to 8 3 continue 8 write(LUPCH,100) (KARD(i),i=1,new) C----- IF(LPRINT.EQ.0)GO TO 1 C PRINT IT ALSO NLINE=NLINE+1 IF(NLINE.GT.LTLINE)CALL OUTPUT(4) WRITE(LUWR,200)KARD,NCARD C INCREMENT LINE COUNT AND TEST FOR END OF PAGE 37 GO TO (1,117),NRET C C + CARD FOUND 4 IF(LPRINT.EQ.0)GO TO 1 45 NLINE=NLINE+1 IF(NLINE.GT.LTLINE)CALL OUTPUT(4) C WRITE(LUWR,200)KARD C+++++ do 46 i=72,1,-1 new=i if(KARD(i).ne.KSP) go to 47 46 continue 47 write(LUWR,200) (KARD(i),i=1,new) C----- GO TO 37 C C TEST FOR & IN CARD 9 DO 10 I=1,72 K=KARD(I) IF(K.LT.0)GO TO 91 IF(KAMP)10,92,92 91 IF(KAMP.GE.0)GO TO 10 92 IF(K.EQ.KAMP)GO TO 12 10 CONTINUE GO TO 2 C C * END CARD FOUND 5 IF(LPRINT.GT.0)WRITE(LUWR,200)KARD 6 STOP C C PLACE STATEMENT IN CHAINED STORE 12 J=1 NRET=2 CALL CELL(IST1,0,0) IST2=IST1 115 IF(LPRINT.GT.0)GO TO 45 117 DO 13 I=J,72 K=KRUSH(KARD(I)) 13 CALL CELL(IST2,-1,KHASH(K)) J=7 C READ(LURD,100)KARD read(LURD,100,END=777)KARD CALL IDENT(KSTP) IF(KSTP.EQ.5)GO TO 115 ** CALL CELL(IST2,-1,49) call cell(ist2,-1,isp) CALL AMPERS IPT=IPTR(IST1) N=0 C TEST FOR + COMMENT IF(ISTORE(IPT).EQ.40)GO TO 147 C TEST FOR *-STATEMENT IF(ISTORE(IPT).NE.42)GO TO 145 DO 120 I=1,5 IPT=IPTR(IPT) IF(IPT.EQ.0)GO TO 145 120 CONTINUE C TEST FOR CONTINUATION ***** IF(ISTORE(IPT).EQ.49)GO TO 130 IF(ISTORE(IPT).EQ.isp)GO TO 130 IF(ISTORE(IPT).NE.1)GO TO 145 C *-STATEMENT FOUND - IDENTIFY AND EXECUTE IT 130 IF(MAMP.EQ.0)GO TO 132 IF(LPRINT.GT.2)CALL OUTPUT(1) 132 CALL TYPE CALL IDENT(KSTP) GO TO 150 145 N=2 147 IF(LPRINT.GT.2)N=N+1 IF(N.GT.0)CALL OUTPUT(N) 150 CALL FREE(IST1,IST2) NRET=1 GO TO 15 END BLOCK DATA DIMENSION KARD(72),KHASH(51),KARS(51),KTYPE(51),IPTR(5000),ISTORE( C5000),NOMEN(4,199),ITAB(15,4),IOP(11),KEY(41),IFOP(2,6),KEND(4),IP CRNT(4) COMMON /INFO/ LURD,LUWR,LUPCH,NLINE,LTLINE,NPAGE,MAMP,KPRNT,MACLEV C ,KSP,KAMP,KP,KC,KZERO,KAST,LAVS1,LAVS2,IST1,IST2,NCARD,LPRINT,KEN CD,IPRNT,IFOP,IOP,ITAB,KARD ,KHASH,KARS,KTYPE,KEY,NOMEN,IPTR,ISTORE * ,isp,nchar C SET VARIOUS INITIAL VALUES DATA KSP,KAMP,KP,KC,KZERO,KAST/1H ,1H&,1HP,1HC,1H0,1H*/ DATA NCARD/0/,MACLEV/0/,NPAGE/1/,LAVS1/1/,LAVS2/5000/ C SET UNIT NUMBERS FOR READING, WRITING AND PUNCHING DATA LURD,LUWR,LUPCH/5,6,7/ C SET NUMBER OF LINES PER PAGE AND DEFAULT PRINTING LEVEL DATA LTLINE/75/,NLINE/76/,LPRINT,KPRNT/2*3/ DATA KEND(1),KEND(2),KEND(3),KEND(4)/1HE,1HN,1HD,1H / DATA IPRNT(1),IPRNT(2),IPRNT(3),IPRNT(4)/1HR,1HI,1HN,1HT/ C CHARACTER SET (isp=nchar=49 set in Colin Day's code without ':') data isp,nchar/50,50/ DATA KARS( 1),KARS( 2),KARS( 3),KARS( 4) /1H0,1H1,1H2,1H3/ DATA KARS( 5),KARS( 6),KARS( 7),KARS( 8) /1H4,1H5,1H6,1H7/ DATA KARS( 9),KARS(10),KARS(11),KARS(12) /1H8,1H9,1HA,1HB/ DATA KARS(13),KARS(14),KARS(15),KARS(16) /1HC,1HD,1HE,1HF/ DATA KARS(17),KARS(18),KARS(19),KARS(20) /1HG,1HH,1HI,1HJ/ DATA KARS(21),KARS(22),KARS(23),KARS(24) /1HK,1HL,1HM,1HN/ DATA KARS(25),KARS(26),KARS(27),KARS(28) /1HO,1HP,1HQ,1HR/ DATA KARS(29),KARS(30),KARS(31),KARS(32) /1HS,1HT,1HU,1HV/ DATA KARS(33),KARS(34),KARS(35),KARS(36) /1HW,1HX,1HY,1HZ/ DATA KARS(37),KARS(38),KARS(39),KARS(40) /1H$,1H(,1H),1H+/ DATA KARS(41),KARS(42),KARS(43),KARS(44) /1H-,1H*,1H/,1H./ DATA KARS(45),KARS(46),KARS(47),KARS(48) /1H,,1H=,1H',1H&/ data kars(49),kars(50) /1H:,1H / ** DATA KARS(49) /1H / C TYPES OF CHARACTERS DATA KTYPE(1),KTYPE(2),KTYPE(3),KTYPE(4),KTYPE(5),KTYPE(6), C KTYPE(7),KTYPE(8),KTYPE(9),KTYPE(10) /10*2/ DATA KTYPE(11),KTYPE(12),KTYPE(13),KTYPE(14),KTYPE(15),KTYPE(16), C KTYPE(17),KTYPE(18),KTYPE(19),KTYPE(20),KTYPE(21),KTYPE(22), C KTYPE(23),KTYPE(24),KTYPE(25),KTYPE(26),KTYPE(27),KTYPE(28), C KTYPE(29),KTYPE(30),KTYPE(31),KTYPE(32),KTYPE(33),KTYPE(34), C KTYPE(35),KTYPE(36),KTYPE(37) /27*3/ DATA KTYPE(38),KTYPE(39),KTYPE(40),KTYPE(41)/4,5,6,7/ DATA KTYPE(42),KTYPE(43),KTYPE(44),KTYPE(45)/8,9,12,13/ DATA KTYPE(46),KTYPE(47),KTYPE(48) /10,11,14/, * ktype(49),ktype(50) /13,15/ ** DATA KTYPE(49) /15/ --- before squeezing in ':' qub'93jan17th. C C RELATIONAL OPERATORS C E Q L T DATA IFOP(1,1),IFOP(2,1),IFOP(1,2),IFOP(2,2) /15,27, 22,30/ C L E G T DATA IFOP(1,3),IFOP(2,3),IFOP(1,4),IFOP(2,4) /22,15, 17,30/ C G E N E DATA IFOP(1,5),IFOP(2,5),IFOP(1,6),IFOP(2,6) /17,15, 24,15/ C SYMBOL-STATE TABLE DATA ITAB( 1,1),ITAB( 2,1),ITAB( 3,1),ITAB( 4,1) /-1,23,13,91/ DATA ITAB( 5,1),ITAB( 6,1),ITAB( 7,1),ITAB( 8,1) /-1,42,42,-2/ DATA ITAB( 9,1),ITAB(10,1),ITAB(11,1),ITAB(12,1) /-2,-2,33,-1/ DATA ITAB(13,1),ITAB(14,1),ITAB(15,1) /-1,-2, 1/ DATA ITAB( 1,2),ITAB( 2,2),ITAB( 3,2),ITAB( 4,2) /-1,23,13,91/ DATA ITAB( 5,2),ITAB( 6,2),ITAB( 7,2),ITAB( 8,2) /-2,-2,-2,-2/ DATA ITAB( 9,2),ITAB(10,2),ITAB(11,2),ITAB(12,2) /-2,-2,33,-2/ DATA ITAB(13,2),ITAB(14,2),ITAB(15,2) /-2,-2, 2/ DATA ITAB( 1,3),ITAB( 2,3),ITAB( 3,3),ITAB( 4,3) /60,-2,-2,-2/ DATA ITAB( 5,3),ITAB( 6,3),ITAB( 7,3),ITAB( 8,3) /103,64,62,62/ DATA ITAB( 9,3),ITAB(10,3),ITAB(11,3),ITAB(12,3) /62,51,-2,83/ DATA ITAB(13,3),ITAB(14,3),ITAB(15,3) /83,-2, 3/ DATA ITAB( 1,4),ITAB( 2,4),ITAB( 3,4),ITAB( 4,4) /-1,23,13,91/ DATA ITAB( 5,4),ITAB( 6,4),ITAB( 7,4),ITAB( 8,4) /-2,72,-2,-2/ DATA ITAB( 9,4),ITAB(10,4),ITAB(11,4),ITAB(12,4) /-2,-2,33,-2/ DATA ITAB(13,4),ITAB(14,4),ITAB(15,4) /-2,-2,4/ C PRIORITIES FOR FOLLOWING OPERATORS DATA IOP(1),IOP(2),IOP(3),IOP(4),IOP(5),IOP(6),IOP(7),IOP(8), C IOP(9),IOP(10),IOP(11) / 1, 8, 8, 4,2,6,6,7,7,3, 5/ C EOS URY+ URY- ( ) + - * / = ++ C KEYWORDS WITH LENGTHS C C A L L DATA KEY(1),KEY(2),KEY(3),KEY(4),KEY(5) /4,13,11,22,22/ C C O N T DATA KEY(6),KEY(7),KEY(8),KEY(9),KEY(10) /8,13,25,24,30/ C I N U E DATA KEY(11),KEY(12),KEY(13),KEY(14),KEY(15)/19,24,31,15,3/ C E N D G DATA KEY(16),KEY(17),KEY(18),KEY(19),KEY(20)/15,24,14,4,17/ C O T O I DATA KEY(21),KEY(22),KEY(23),KEY(24),KEY(25)/25,30,25,3,19/ C F ( M A DATA KEY(26),KEY(27),KEY(28),KEY(29),KEY(30)/16,38,5,23,11/ C C R O R DATA KEY(31),KEY(32),KEY(33),KEY(34),KEY(35)/13,28,25,6,28/ C E T U R N DATA KEY(36),KEY(37),KEY(38),KEY(39),KEY(40)/15,30,31,28,24/ DATA KEY(41) /0/ END SUBROUTINE AMPERS C C TAKES A STATEMENT (OR LAST PART OF ONE) IN CHAINED STORE C REPLACES ALL &-FUNCTIONS AND TESTS FOR *-STATEMENT C DIMENSION KARD(72),KHASH(51),KARS(51),KTYPE(51),IPTR(5000),ISTORE( C5000),NOMEN(4,199),ITAB(15,4),IOP(11),KEY(41),IFOP(2,6),KEND(4),IP CRNT(4) COMMON /INFO/ LURD,LUWR,LUPCH,NLINE,LTLINE,NPAGE,MAMP,KPRNT,MACLEV C ,KSP,KAMP,KP,KC,KZERO,KAST,LAVS1,LAVS2,IST1,IST2,NCARD,LPRINT,KEN CD,IPRNT,IFOP,IOP,ITAB,KARD ,KHASH,KARS,KTYPE,KEY,NOMEN,IPTR,ISTORE * ,isp,nchar MAMP=0 C MAKE A STACK OF ALL &-FUNCTIONS LAMP=0 IPT=IST1 10 NPT=IPTR(IPT) IF(NPT.EQ.0)GO TO 30 C TEST FOR & IF(ISTORE(NPT).NE.48)GO TO 20 CALL CELL(LAMP,1,IPT) 20 IPT=NPT GO TO 10 C TEST FOR EMPTY STACK 30 IF(LAMP.EQ.0)RETURN C EXECUTE &-FUNCTION ON TOP OF STACK IPT=ISTORE(LAMP) CALL FREE(LAMP,LAMP) NPT=IPTR(IPT) MK=1 C MOVE BEYOND & 40 NPT=IPTR(NPT) IF(NPT.EQ.0)GO TO 30 K=ISTORE(NPT) C TEST FOR BLANK IF(K.EQ.isp)GO TO 40 C TEST FOR ( IF(K.EQ.38)GO TO 50 C TEST FOR L IF(MK.GT.1)GO TO 30 IF(K.NE.22)GO TO 45 MK=2 GO TO 40 C TEST FOR S 45 IF(K.NE.29)GO TO 30 MK=3 GO TO 40 C MOVE BEYOND ( 50 NPT=IPTR(NPT) IF(NPT.EQ.0)GO TO 30 IF(MACLEV.EQ.0)GO TO 33 IF(MAMP.GT.0)GO TO 34 IF(LPRINT.GE.5)CALL OUTPUT(1) GO TO 35 33 IF(MAMP.EQ.0)GO TO 35 34 IF(LPRINT.GE.6)CALL OUTPUT(1) 35 MAMP=1 CALL EXPRN(NPT,INIT,IFIN) 60 CALL CONV(INIT,IFIN,1) GO TO (70,80,90),MK 65 INIT=0 C INSERT CHARACTER STRING 70 K=IPTR(IPT) IF(NPT.EQ.0)GO TO 990 IF(ISTORE(NPT).NE.39)GO TO 990 IF(INIT.EQ.0)IFIN=IPT IPTR(IPT)=INIT IPTR(IFIN)=IPTR(NPT) CALL FREE(K,NPT) GO TO 10 C &L FUNCTION 80 I=INIT J=IFIN INIT=-1 IFIN=0 CALL FREE(I,J) MK=1 82 IF(I.EQ.0)GO TO 60 IFIN=IFIN+1 I=IPTR(I) GO TO 82 C &S FUNCTION 90 DO 91 I=1,2 IF(NPT.EQ.0)GO TO 990 C TEST FOR COMMA IF(ISTORE(NPT).NE.45)GO TO 990 NPT=IPTR(NPT) C GET NEXT PARAMETER AND CONVERT TO NUMERIC CALL EXPRN(NPT,J,J2) CALL CONV(J,J2,-1) IF(I.EQ.2)GO TO 92 91 I2=J2 C TEST PARAMETERS 92 IF(J2.LT.I2)GO TO 65 IF(INIT.EQ.0)GO TO 70 K=1 IF(I2.LE.1)GO TO 95 C STRIP OFF BEGINNING I=INIT 93 J=IPTR(I) IF(J.EQ.0)GO TO 94 K=K+1 IF(K.EQ.I2)GO TO 94 I=J GO TO 93 C FREE BEGINNING 94 CALL FREE(INIT,I) INIT=J C GET MIDDLE SECTION 95 I=INIT 96 IF(K.EQ.J2)GO TO 97 J=IPTR(I) IF(J.EQ.0)GO TO 98 K=K+1 I=J GO TO 96 C FREE REMAINING SECTION 97 K=IPTR(I) CALL FREE(K,IFIN) 98 IFIN=I GO TO 70 C INCOMPLETE REPLACEMENT FUNCTION 990 CALL ERROR(NPT,10) RETURN END SUBROUTINE CELL(IPT,IFLAG,IDAT) C C RELEASES A CELL FROM THE AVAILABLE SPACE LIST, STORING IDAT IN IT C IF IFLAG IS - THE CELL IS ATTACHED TO IPT C 0 THE CELL ADDRESS IS PLACED IN IPT C + THE CELL IS PUSHED DOWN ON IPT C DIMENSION KARD(72),KHASH(51),KARS(51),KTYPE(51),IPTR(5000),ISTORE( C5000),NOMEN(4,199),ITAB(15,4),IOP(11),KEY(41),IFOP(2,6),KEND(4),IP CRNT(4) COMMON /INFO/ LURD,LUWR,LUPCH,NLINE,LTLINE,NPAGE,MAMP,KPRNT,MACLEV C ,KSP,KAMP,KP,KC,KZERO,KAST,LAVS1,LAVS2,IST1,IST2,NCARD,LPRINT,KEN CD,IPRNT,IFOP,IOP,ITAB,KARD ,KHASH,KARS,KTYPE,KEY,NOMEN,IPTR,ISTORE * ,isp,nchar IF(LAVS1.LE.0)GO TO 1 I=LAVS1 LAVS1=IPTR(LAVS1) ISTORE(I)=IDAT IF(IFLAG)10,20,30 C FLAG -VE 10 IF(IPT.GT.0)IPTR(IPT)=I 20 IPT=I IPTR(IPT)=0 RETURN C FLAG +VE 30 IPTR(I)=IPT IPT=I RETURN 1 WRITE(LUWR,'(22H ***STORE EXHAUSTED***)') STOP END SUBROUTINE CONV(INIT,IFIN,IFLAG) C C CONVERTS VALUES FOR WHICH INIT AND IFIN ARE POINTERS C IF IFLAG IS 0 THE VALUE IS TAKEN FROM NOMEN C + THE VALUE IS CONVERTED TO TYPE CHARACTER C -1 THE VALUE IS CONVERTED TO TYPE NUMERIC C DIMENSION KARD(72),KHASH(51),KARS(51),KTYPE(51),IPTR(5000),ISTORE( C5000),NOMEN(4,199),ITAB(15,4),IOP(11),KEY(41),IFOP(2,6),KEND(4),IP CRNT(4) COMMON /INFO/ LURD,LUWR,LUPCH,NLINE,LTLINE,NPAGE,MAMP,KPRNT,MACLEV C ,KSP,KAMP,KP,KC,KZERO,KAST,LAVS1,LAVS2,IST1,IST2,NCARD,LPRINT,KEN CD,IPRNT,IFOP,IOP,ITAB,KARD ,KHASH,KARS,KTYPE,KEY,NOMEN,IPTR,ISTORE * ,isp,nchar C SET FLAG FOR VALUE NOT IN NOMEN MNOMEN=0 C IS VALUE ALREADY CHARACTER 5 IF(INIT)6,30,10 C IS VALUE MACRO, INDIRECT, OR NUMERIC 6 IF(INIT.GT.-2)GO TO 40 C MAKE VALUE DIRECT 8 INIT=IPTR(IFIN) IFIN=ISTORE(IFIN) C SET FLAG MNOMEN=1 GO TO 5 C CHARACTER VALUE - TEST IFLAG 10 IF(IFLAG.GE.0)GO TO 24 C CONVERT TO NUMERIC IPT=INIT C SET MARK FOR POSITIVE MK=1 12 IF(IPT.EQ.0)GO TO 20 K=ISTORE(IPT) IF(K-40)20,18,14 14 IF(K.NE.isp)GO TO 16 C SKIP BLANK IPT=IPTR(IPT) GO TO 12 16 IF(K.NE.41)GO TO 20 MK=-1 C SKIP SIGN 18 IPT=IPTR(IPT) 20 CALL NUM(IPT,I) C TRAP BAD CHARACTER TO NUMERIC CONVERSION IF(IPT.NE.0)CALL ERROR(IPT,9) IF(MNOMEN.EQ.0)CALL FREE(INIT,IFIN) IFIN=ISIGN(I,MK) 22 INIT=-1 RETURN C TEST WHETHER STRING SHOULD BE COPIED 24 IF(MNOMEN.EQ.0)RETURN C COPY STRING I=INIT K=ISTORE(I) CALL CELL(INIT,0,K) J=INIT 1 I=IPTR(I) IF(I.EQ.0)GO TO 2 K=ISTORE(I) CALL CELL(J,-1,K) GO TO 1 2 IFIN=J RETURN C ZERO VALUE - TEST IFLAG 30 IF(IFLAG.GE.0)RETURN IFIN=0 GO TO 22 C NUMERIC VALUE - TEST FLAG 40 IF(IFLAG.LE.0)RETURN C CONVERT TO CHARACTER 41 MARK=0 IF(IFIN.LT.0)MARK=-1 IDAT=IABS(IFIN) CALL CELL(INIT,0,MOD(IDAT,10)+1) IFIN=INIT 42 IDAT=IDAT/10 IF(IDAT.EQ.0)GO TO 43 CALL CELL(INIT,1,MOD(IDAT,10)+1) GO TO 42 43 IF(MARK.EQ.0)RETURN C INSERT - SIGN CALL CELL(INIT,1,41) RETURN C MACRO NAME FOUND END SUBROUTINE ERROR(IPT,N) C C PRINTS OUT ERROR MESSAGES - IPT POINTS TO POSN IN STRING C DIMENSION IBUF(13) DIMENSION KARD(72),KHASH(51),KARS(51),KTYPE(51),IPTR(5000),ISTORE( C5000),NOMEN(4,199),ITAB(15,4),IOP(11),KEY(41),IFOP(2,6),KEND(4),IP CRNT(4) COMMON /INFO/ LURD,LUWR,LUPCH,NLINE,LTLINE,NPAGE,MAMP,KPRNT,MACLEV C ,KSP,KAMP,KP,KC,KZERO,KAST,LAVS1,LAVS2,IST1,IST2,NCARD,LPRINT,KEN CD,IPRNT,IFOP,IOP,ITAB,KARD ,KHASH,KARS,KTYPE,KEY,NOMEN,IPTR,ISTORE * ,isp,nchar NLINE=NLINE+4 WRITE(LUWR,'(1H0)') CALL OUTPUT(1) GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13 ),N 1 WRITE(LUWR,'(25H ***INVALID EXPRESSION***)') GO TO 50 2 WRITE(LUWR,'(25H ***FMP ERROR IN EXPRN***)') GO TO 50 3 WRITE(LUWR,'(34H ***FINAL APOSTROPHE IS MISSING***)') RETURN 4 WRITE(LUWR,'(25H ***ERROR IN STATEMENT***)') GO TO 50 5 WRITE(LUWR,'(24H ***MACRO NOT DEFINED***)') RETURN 6 WRITE(LUWR,'(37H ***NAME HAS BEEN USED FOR A MACRO***)') RETURN 7 WRITE(LUWR,'(39H ***EQUALS SIGN NOT PRECEDED BY NAME***)') GO TO 50 8 WRITE(LUWR,'(27H ***GO TO NOT IN A MACRO***)') RETURN 9 WRITE(LUWR,'(28H ***STRING IS NOT NUMERIC***)') GO TO 50 10 WRITE(LUWR,'(28H ***INCOMPLETE &-FUNCTION***)') GO TO 50 11 WRITE(LUWR,'(31H ***LABEL NOT FOUND IN MACRO***)') RETURN 12 WRITE(LUWR,'(33H ***MACRO STATEMENT IN A MACRO***)') RETURN 13 WRITE(LUWR,'(33H ***DIVISION BY ZERO ATTEMPTED***)') C BUILD UP CHARACTERS IN BUFFER 50 DO 52 I=1,10 51 IF(IPT.EQ.0)GO TO 54 K=ISTORE(IPT) IBUF(I)=KARS(K) IPT=IPTR(IPT) IF(K.EQ.isp)GO TO 51 52 CONTINUE I=11 IF(IPT.EQ.0)GO TO 54 525 DO 53 J=I,13 53 IBUF(J)=KARS(isp) GO TO 55 C END OF STRING FOUND - ADD EOS 54 IBUF(I)=KARS(15) IBUF(I+1)=KARS(25) IBUF(I+2)=KARS(29) I=I+3 IF(I.LE.13)GO TO 525 55 WRITE(LUWR,'(26H - ERROR OCCURRED BEFORE ,13A1)') ibuf WRITE(LUWR,'(1H0)') NLINE=NLINE+2 RETURN END SUBROUTINE EXPRN(IPT,INIT,IFIN) C C ON ENTRY IPT POINTS TO THE FIRST CHARACTER OF AN EXPRESSION C IN CHAINED STORAGE C IPT IS SET TO THE FIRST CHARACTER BEYOND THE EXPRESSION C IF THE EXPRESSION IS OF TYPE CHARACTER, C INIT IS SET TO POINT TO THE BEGINNING OF THE RESULT C IFIN IS SET TO POINT TO THE END OF THE RESULT C IF THE EXPRESSION IS NUMERIC C INIT IS MADE -1 AND IFIN HOLDS THE NUMERICAL VALUE C DIMENSION KARD(72),KHASH(51),KARS(51),KTYPE(51),IPTR(5000),ISTORE( C5000),NOMEN(4,199),ITAB(15,4),IOP(11),KEY(41),IFOP(2,6),KEND(4),IP CRNT(4) COMMON /INFO/ LURD,LUWR,LUPCH,NLINE,LTLINE,NPAGE,MAMP,KPRNT,MACLEV C ,KSP,KAMP,KP,KC,KZERO,KAST,LAVS1,LAVS2,IST1,IST2,NCARD,LPRINT,KEN CD,IPRNT,IFOP,IOP,ITAB,KARD ,KHASH,KARS,KTYPE,KEY,NOMEN,IPTR,ISTORE * ,isp,nchar IF(IPT.NE.0)GO TO 5 2 INIT=0 RETURN C SET THE INITIAL STATE IN THE SYMBOL STATE TABLE 5 ISTAT=1 NBR=0 C INITIALISE THE OPERATOR STACK LOP=0 C INITIALISE THE OPERAND STACK POINTERS LOPN1=0 LOPN2=0 C GET THE NEXT CHARACTER AND ITS TYPE 10 K=ISTORE(IPT) ISYMB=KTYPE(K) C GET THE NEXT STATE FROM THE SYMBOL-STATE TABLE 15 ISTAT=ITAB(ISYMB,ISTAT) C TEST FOR ERROR OR END OF EXPRESSION IF(ISTAT)980,400,50 C TEST FOR ACTION 50 IF(ISTAT.LT.10)GO TO 300 IACT=ISTAT/10 ISTAT=ISTAT-IACT*10 C BRANCH ACCORDING TO ACTION GO TO (110,120,130,140,150,160,170,180,149,159,2),IACT C LETTER FOUND - GET NAME AND PUSH DOWN ON OPERAND STACKS 110 CALL NAME(IPT,INT) 114 IOP1=-2 IOP2=NOMEN(3,INT) IF(IOP2.EQ.-3)GO TO 970 115 CALL CELL(LOPN1,1,IOP1) CALL CELL(LOPN2,1,IOP2) C NO NEED TO MOVE ON IF(IPT.EQ.0)GO TO 180 GO TO 10 C NUMERIC DIGIT FOUND -GET NUMBER AND PUSH DOWN ON OPERAND STACKS 120 CALL NUM(IPT,IOP2) IOP1=-1 GO TO 115 C APOSTROPHE FOUND - GET STRING AND PUSH DOWN ON OPERAND STACKS 130 CALL STRING(IPT,IOP1,IOP2) GO TO 115 C UNARY PLUS OR MINUS 140 ISYMB=ISYMB-4 GO TO 160 C LEFT BRACKET 149 NBR=NBR+1 C LEFT BRACKET OR EQUALS - PUSH ON TOP OF STACK 150 CALL CELL(LOP,1,ISYMB) GO TO 300 C RIGHT BRACKET 159 IF(NBR.EQ.0)GO TO 180 NBR=NBR-1 C OPERATOR FOUND - COMPARE WITH OPERATOR ON TOP OF STACK 160 IF(LOP.EQ.0)GO TO 150 IPR=ISTORE(LOP) IF(IOP(ISYMB).GT.IOP(IPR))GO TO 150 C PERFORM THE OPERATION IF(IPR.GE.6)GO TO 165 GO TO (990,161,161,164,990),IPR C UNARY PLUS OR MINUS - CONVERT TOP OPERAND TO NUMERIC 161 I=ISTORE(LOPN1) J=ISTORE(LOPN2) CALL CONV(I,J,-1) ISTORE(LOPN1)=I ISTORE(LOPN2)=J IF(IPR.EQ.3)ISTORE(LOPN2)=-ISTORE(LOPN2) C POP OPERATOR FROM STACK 163 CALL FREE(LOP,LOP) GO TO 160 C LEFT BRACKET ON STACK - IS NEW SYMBOL A RIGHT BRACKET 164 IF(ISYMB.NE.5)GO TO 990 C YES - POP STACK AND LOSE NEW OPERATOR CALL FREE(LOP,LOP) GO TO 300 C BINARY OPERATOR TO BE OBEYED - GET TOP TWO OPERANDS 165 IOPN1=ISTORE(LOPN1) IOPN2=ISTORE(LOPN2) CALL FREE(LOPN1,LOPN1) CALL FREE(LOPN2,LOPN2) IOPN3=ISTORE(LOPN1) IOPN4=ISTORE(LOPN2) IF(IPR-10)166,266,267 166 IPR=IPR-5 C MAKE SURE OPERANDS ARE NUMERIC FOR NUMERIC OPERATIONS CALL CONV(IOPN1,IOPN2,-1) CALL CONV(IOPN3,IOPN4,-1) 168 GO TO (261,262,263,264),IPR C + 261 IOPN4=IOPN4+IOPN2 GO TO 265 C - 262 IOPN4=IOPN4-IOPN2 GO TO 265 C * 263 IOPN4=IOPN4*IOPN2 GO TO 265 C / 264 IF(IOPN2.NE.0)GO TO 2645 CALL ERROR(IPT,13) GO TO 265 2645 IOPN4=IOPN4/IOPN2 C STORE RESULT 265 ISTORE(LOPN1)=-1 ISTORE(LOPN2)=IOPN4 GO TO 163 C = 266 CALL CONV(IOPN1,IOPN2,0) IF(IOPN3.EQ.-2)GO TO 2664 CALL ERROR(IPT,7) GO TO 2 2664 I=IPTR(IOPN4) J=ISTORE(IOPN4) IF(I.NE.-2)GO TO 2665 IOPN4=J GO TO 2664 2665 CALL FREE(I,J) IPTR(IOPN4)=IOPN1 ISTORE(IOPN4)=IOPN2 GO TO 163 C ++ 267 CALL CONV(IOPN1,IOPN2,1) IF(IOPN1.EQ.0)GO TO 163 CALL CONV(IOPN3,IOPN4,1) ISTORE(LOPN1)=IOPN1 ISTORE(LOPN2)=IOPN2 IF(IOPN3.EQ.0)GO TO 163 C CONCATENATE THE STRINGS IPTR(IOPN4)=IOPN1 ISTORE(LOPN1)=IOPN3 GO TO 163 C CONCATENATION OPERATOR FOUND 170 ISTORE(LOP)=11 C HAS END OF EXPRESSION ALREADY BEEN DETECTED 300 IF(ISYMB.EQ.1)GO TO 400 IPT=IPTR(IPT) IF(IPT.NE.0)GO TO 10 C END OF EXPRESSION 180 ISYMB=1 GO TO 15 C END OF EVALUATION 400 IF(LOPN1.EQ.0)GO TO 2 CALL FREE(LOP,LOP) INIT=ISTORE(LOPN1) IFIN=ISTORE(LOPN2) CALL FREE(LOPN1,LOPN1) CALL FREE(LOPN2,LOPN2) RETURN C SYNTAX ERROR IN EXPRESSION 970 CALL ERROR(0,6) GO TO 2 980 CALL ERROR(IPT,1) GO TO 2 990 CALL ERROR(IPT,2) STOP END SUBROUTINE FREE(INIT,IFIN) DIMENSION KARD(72),KHASH(51),KARS(51),KTYPE(51),IPTR(5000),ISTORE( C5000),NOMEN(4,199),ITAB(15,4),IOP(11),KEY(41),IFOP(2,6),KEND(4),IP CRNT(4) COMMON /INFO/ LURD,LUWR,LUPCH,NLINE,LTLINE,NPAGE,MAMP,KPRNT,MACLEV C ,KSP,KAMP,KP,KC,KZERO,KAST,LAVS1,LAVS2,IST1,IST2,NCARD,LPRINT,KEN CD,IPRNT,IFOP,IOP,ITAB,KARD ,KHASH,KARS,KTYPE,KEY,NOMEN,IPTR,ISTORE * ,isp,nchar IF(INIT.LE.0)RETURN IPTR(LAVS2)=INIT J=IFIN IF(J.GT.0)GO TO 2 J=INIT 1 I=IPTR(J) IF(I.EQ.0)GO TO 3 J=I GO TO 1 2 I=IPTR(IFIN) IPTR(IFIN)=0 IFIN=I 3 LAVS2=J RETURN END SUBROUTINE IDENT(N) C C FINDS THE TYPE OF THE CARD IN KARD AND LEAVES TYPE IN N C N = 1 COMMENT C 2 +COMMENT C 3 * END C 4 * OTHER C 5 CONTINUATION LINE C 6 INITIAL LINE C DIMENSION KARD(72),KHASH(51),KARS(51),KTYPE(51),IPTR(5000),ISTORE( C5000),NOMEN(4,199),ITAB(15,4),IOP(11),KEY(41),IFOP(2,6),KEND(4),IP CRNT(4) COMMON /INFO/ LURD,LUWR,LUPCH,NLINE,LTLINE,NPAGE,MAMP,KPRNT,MACLEV C ,KSP,KAMP,KP,KC,KZERO,KAST,LAVS1,LAVS2,IST1,IST2,NCARD,LPRINT,KEN CD,IPRNT,IFOP,IOP,ITAB,KARD ,KHASH,KARS,KTYPE,KEY,NOMEN,IPTR,ISTORE * ,isp,nchar IF(KPRNT.EQ.LPRINT)GO TO 10 15 IF(KPRNT.LT.7)GO TO 6 IF(KPRNT.GT.9)GO TO 4 IF(LPRINT.EQ.0)GO TO 5 IF(NLINE.GT.LTLINE)GO TO 5 I=KPRNT-6 GO TO (1,2,3),I C PRINT 7 - LEAVE A BLANK LINE 1 WRITE(LUWR,101) 101 FORMAT(1X) NLINE=NLINE+1 GO TO 5 C PRINT 8 - LEAVE 5 BLANK LINES 2 NLINE=NLINE+5 IF(NLINE.GT.LTLINE)GO TO 5 WRITE(LUWR,102) 102 FORMAT(1H0/1H0/) GO TO 5 C PRINT 9 - SKIP TO A NEW PAGE 3 NLINE=LTLINE+1 GO TO 5 4 CONTINUE 5 KPRNT=LPRINT 6 LPRINT=KPRNT C TEST FOR COMMENT 10 K=KARD(1) K=KRUSH(K) K=KHASH(K) IF(K.NE.13)GO TO 20 N=1 RETURN C TEST FOR + CARD 20 IF(K.NE.40)GO TO 25 N=2 RETURN C TEST FOR PRINT 25 IF(K.NE.26)GO TO 30 DO 80 I=2,5 L=KARD(I) KR=IPRNT(I-1) IF((L.LT.0.AND.KR.GE.0).OR.(L.GE.0.AND.KR.LT.0))GO TO 30 IF(L.NE.KR)GO TO 30 80 CONTINUE C TEST FOR PREVIOUS PRINT CARD IF(KPRNT.NE.LPRINT)GO TO 15 KPRNT=0 DO 90 I=6,72 K=KARD(I) IF(K.LT.0)GO TO 85 IF(KSP)87,86,86 85 IF(KSP.GE.0)GO TO 87 86 IF(K.EQ.KSP)GO TO 90 87 CONTINUE J=KRUSH(KARD(I)) KPRNT=KHASH(J)-1 GO TO 95 90 CONTINUE C 95 READ(LURD,100)KARD 95 read(LURD,100,END=98)KARD GO TO 10 100 FORMAT(72A1) C TEST FOR CONTINUATION 30 L=KARD(6) IF(L.LT.0)GO TO 33 IF(KSP.LT.0)GO TO 32 IF(L.EQ.KSP)GO TO 40 32 IF(KZERO)120,36,36 33 IF(KSP.GE.0)GO TO 35 IF(L.EQ.KSP)GO TO 40 35 IF(KZERO.GE.0)GO TO 120 36 IF(L.NE.KZERO)GO TO 120 C TEST FOR * CARD 40 IF(K.NE.42)GO TO 130 C TEST FOR * END J=1 KD=KEND(1) DO 50 I=7,72 L=KARD(I) IF(L.LT.0)GO TO 45 IF(KSP.LT.0)GO TO 42 IF(L.EQ.KSP)GO TO 50 42 IF(KD)60,48,48 45 IF(KSP.GE.0)GO TO 47 IF(L.EQ.KSP)GO TO 50 47 IF(KD.GE.0)GO TO 60 48 IF(L.NE.KD)GO TO 60 J=J+1 KD=KEND(J) 50 CONTINUE IF(J.LT.4)GO TO 60 N=3 RETURN C ANOTHER * CARD 60 N=4 RETURN 120 N=5 RETURN C INITIAL LINE 130 N=6 RETURN C+++++ 98 N=0 RETURN C----- END FUNCTION KRUSH(K) DIMENSION KARD(72),KHASH(51),KARS(51),KTYPE(51),IPTR(5000),ISTORE( C5000),NOMEN(4,199),ITAB(15,4),IOP(11),KEY(41),IFOP(2,6),KEND(4),IP CRNT(4) COMMON /INFO/ LURD,LUWR,LUPCH,NLINE,LTLINE,NPAGE,MAMP,KPRNT,MACLEV C ,KSP,KAMP,KP,KC,KZERO,KAST,LAVS1,LAVS2,IST1,IST2,NCARD,LPRINT,KEN CD,IPRNT,IFOP,IOP,ITAB,KARD ,KHASH,KARS,KTYPE,KEY,NOMEN,IPTR,ISTORE * ,isp,nchar C PERFORMS BINARY SEARCH THROUGH THE CHARACTERS TO IDENTIFY K ** KRUSH=49 krush=isp C TEST SPECIALLY FOR BLANK (FOR SPEED) IF(K)1,2,2 1 IF(KSP)3,4,4 2 IF(KSP)4,3,3 3 IF(K-KSP)4,10,4 4 N=0 L=24 ** DO 9 I=1,6 do 9 i=1,7 M=N+L J=KHASH(M) J=KARS(J) IF(K)5,6,6 5 IF(J)7,8,8 6 IF(J)9,7,7 7 IF(J-K)8,11,9 8 N=M 9 L=(L+1)/2 10 RETURN 11 KRUSH=M RETURN END SUBROUTINE NAME(IPT,INT) C C ON ENTRY, IPT POINTS TO THE FIRST CHARACTER OF A NAME IN C CHAINED STORAGE C INT IS SET TO THE ROW OF NOMEN CONTAINING THE NAME C DIMENSION NOM(2) DIMENSION KARD(72),KHASH(51),KARS(51),KTYPE(51),IPTR(5000),ISTORE( C5000),NOMEN(4,199),ITAB(15,4),IOP(11),KEY(41),IFOP(2,6),KEND(4),IP CRNT(4) COMMON /INFO/ LURD,LUWR,LUPCH,NLINE,LTLINE,NPAGE,MAMP,KPRNT,MACLEV C ,KSP,KAMP,KP,KC,KZERO,KAST,LAVS1,LAVS2,IST1,IST2,NCARD,LPRINT,KEN CD,IPRNT,IFOP,IOP,ITAB,KARD ,KHASH,KARS,KTYPE,KEY,NOMEN,IPTR,ISTORE * ,isp,nchar NOM(1)=0 NOM(2)=0 C GET THE NAME INTO BUFFER NOM DO 1 I=1,2 DO 1 J=1,4 11 IF(IPT.EQ.0)GO TO 2 K=ISTORE(IPT) IF(K.NE.isp)GO TO 15 C BLANK FOUND IPT=IPTR(IPT) GO TO 11 15 IF(KTYPE(K).GT.3)GO TO 2 NOM(I)=NOM(I)*38+K 1 IPT=IPTR(IPT) C SKIP BLANKS 12 IF(IPT.EQ.0)GO TO 2 IF(ISTORE(IPT).NE.isp)GO TO 2 IPT=IPTR(IPT) GO TO 12 2 INC=-199 INT=MOD(IABS(NOM(1)+NOM(2)),199)+1 C TEST WHETHER NAME IS ALREADY STORED 3 IF(NOMEN(1,INT).EQ.0)GO TO 6 DO 4 J=1,2 IF(NOMEN(J,INT).NE.NOM(J))GO TO 5 4 CONTINUE C NAME IS STORED ALREADY AT POSITION INT RETURN C STEP ON IN HASH TABLE 5 INC=INC+2 INT=INT+IABS(INC) IF(INT.GT.199)INT=INT-199 IF(INC.LT.199)GO TO 3 C HASH TABLE FULL 8 WRITE(LUWR,100) 100 FORMAT(26H ***TOO MANY NAMES USED***) STOP C NAME IS NOT STORED, SO STORE IT 6 DO 7 J=1,2 7 NOMEN(J,INT)=NOM(J) C STORE VALUE AS A NULL CHARACTER STRING CALL CELL(NOMEN(3,INT),0,0) NOMEN(4,INT)=0 RETURN END SUBROUTINE NUM(IPT,IRES) C C ON ENTRY IPT POINTS TO THE FIRST DIGIT OF A NUMBER IN CHAINED C STORE C IRES IS SET TO THE BINARY VALUE OF THE NUMBER C IPT IS MOVED ON TO THE NEXT CHARACTER BEYOND THE NUMBER C BLANKS ARE IGNORED C DIMENSION KARD(72),KHASH(51),KARS(51),KTYPE(51),IPTR(5000),ISTORE( C5000),NOMEN(4,199),ITAB(15,4),IOP(11),KEY(41),IFOP(2,6),KEND(4),IP CRNT(4) COMMON /INFO/ LURD,LUWR,LUPCH,NLINE,LTLINE,NPAGE,MAMP,KPRNT,MACLEV C ,KSP,KAMP,KP,KC,KZERO,KAST,LAVS1,LAVS2,IST1,IST2,NCARD,LPRINT,KEN CD,IPRNT,IFOP,IOP,ITAB,KARD ,KHASH,KARS,KTYPE,KEY,NOMEN,IPTR,ISTORE * ,isp,nchar IRES=0 1 IF(IPT.EQ.0)RETURN K=ISTORE(IPT) IF(K.NE.isp)GO TO 3 2 IPT=IPTR(IPT) GO TO 1 3 IF(K.GT.10)RETURN IRES=IRES*10+K-1 GO TO 2 END SUBROUTINE OUTPUT(MPRINT) C C PRINTS A STATEMENT HELD IN CHAINED STORAGE C DIMENSION LINE(72) DIMENSION KARD(72),KHASH(51),KARS(51),KTYPE(51),IPTR(5000),ISTORE( C5000),NOMEN(4,199),ITAB(15,4),IOP(11),KEY(41),IFOP(2,6),KEND(4),IP CRNT(4) COMMON /INFO/ LURD,LUWR,LUPCH,NLINE,LTLINE,NPAGE,MAMP,KPRNT,MACLEV C ,KSP,KAMP,KP,KC,KZERO,KAST,LAVS1,LAVS2,IST1,IST2,NCARD,LPRINT,KEN CD,IPRNT,IFOP,IOP,ITAB,KARD ,KHASH,KARS,KTYPE,KEY,NOMEN,IPTR,ISTORE * ,isp,nchar 100 FORMAT(72A1,I8) 200 FORMAT(20X,72A1,I8) 300 FORMAT(10X,I5,1X,1H+,3X,72A1,I8) 400 FORMAT(47H1U.C.L. FORTRAN MACRO PROCESSOR VERSION 1 MOD 5,40X,4HPA CGE,I5/) C C MPRINT IS NOW 1 IF THE STATEMENT IS TO BE PRINTED ONLY C 2 IF THE STATEMENT IS TO BE PUNCHED ONLY C 3 IF THE STATEMENT IS TO BE PRINTED AND PUNCHD C 4 IF A TITLE IS TO BE WRITTEN OUT C IF(MPRINT.GE.4)GO TO 250 C BLANK OUT BUFFER IPT=IST1 INIT=1 11 DO 12 I=INIT,72 12 LINE(I)=KSP C SET MARK FOR NO NON-BLANK CHARACTERS IN LINE MARK=0 DO 13 I=INIT,72 IPT=IPTR(IPT) IF(IPT.EQ.0)GO TO 14 K=ISTORE(IPT) C TEST FOR BLANK IF(K.EQ.isp)GO TO 13 MARK=1 LINE(I)=KARS(K) new=I 13 CONTINUE 14 IF(MARK.EQ.0)RETURN C TEST WHETHER LINE IS TO BE PUNCHED IF(MPRINT.EQ.1)GO TO 20 NCARD=NCARD+10 C WRITE(LUPCH,100)LINE,NCARD C+++++ write(LUPCH,100) (LINE(i),i=1,new) C----- C TEST WHETHER LINE IS TO BE PRINTED IF(MPRINT.EQ.2)GO TO 21 20 NLINE=NLINE+1 IF(NLINE.LE.LTLINE)GO TO 15 250 WRITE(LUWR,400)NPAGE NPAGE=NPAGE+1 NLINE=0 IF(MPRINT.EQ.4)RETURN 15 IF(MPRINT.EQ.1)GO TO 16 IF(MACLEV.GT.0)GO TO 19 C TO BE PRINTED AND PUNCHED - TEST WHETHER IN A MACRO WRITE(LUWR,200)LINE,NCARD GO TO 21 C TO BE PRINTED ONLY - TEST WHETHER IN A MACRO 16 IF(MACLEV.GT.0)GO TO 17 WRITE(LUWR,200)LINE GO TO 21 17 WRITE(LUWR,300)MACLEV,LINE GO TO 21 19 WRITE(LUWR,300)MACLEV,LINE,NCARD 21 IF(IPT.EQ.0)RETURN IF(IPTR(IPT).EQ.IST2)RETURN C MAKE A CONTINUATION LINE INIT=7 DO 22 I=1,5 22 LINE(I)=KSP LINE(6)=KC GO TO 11 END SUBROUTINE STASH(NPT) C C PACKS AWAY A MACRO C DIMENSION KARD(72),KHASH(51),KARS(51),KTYPE(51),IPTR(5000),ISTORE( C5000),NOMEN(4,199),ITAB(15,4),IOP(11),KEY(41),IFOP(2,6),KEND(4),IP CRNT(4) COMMON /INFO/ LURD,LUWR,LUPCH,NLINE,LTLINE,NPAGE,MAMP,KPRNT,MACLEV C ,KSP,KAMP,KP,KC,KZERO,KAST,LAVS1,LAVS2,IST1,IST2,NCARD,LPRINT,KEN CD,IPRNT,IFOP,IOP,ITAB,KARD ,KHASH,KARS,KTYPE,KEY,NOMEN,IPTR,ISTORE * ,isp,nchar 100 FORMAT(72A1) 200 FORMAT(20X,72A1) C FIRST INSERT NAME CALL NAME(NPT,MNAME) IF(NOMEN(3,MNAME).NE.-3)GO TO 5 C NAME HAS BEEN USED BEFORE FOR A MACRO - FREE IT I=NOMEN(4,MNAME) 1 J=IPTR(I) CALL FREE(J,0) I=ISTORE(I) IF(I.GT.0)GO TO 1 CALL FREE(NOMEN(4,MNAME),0) CALL CELL(NOMEN(3,MNAME),0,0) 5 KEPT=NOMEN(3,MNAME) I=IPTR(KEPT) J=ISTORE(KEPT) CALL FREE(I,J) NOMEN(3,MNAME)=-3 NOMEN(4,MNAME)=KEPT CALL CELL(NODE,0,0) ISTORE(KEPT)=NODE CALL IDENT(KSTP) IF(NPT.EQ.0)GO TO 20 N=0 N1=0 C TEST FOR ( IF(ISTORE(NPT).EQ.38)GO TO 15 10 CALL ERROR(NPT,4) GO TO 20 C GET NEXT PARAMETER 15 NPT=IPTR(NPT) IF(NPT.EQ.0)GO TO 10 CALL NAME(NPT,INT) CALL CELL(N,-1,INT) IF(N1.EQ.0)N1=N C TEST FOR ) OR , IF(NPT.EQ.0)GO TO 10 IF(ISTORE(NPT).EQ.45)GO TO 15 IF(ISTORE(NPT).NE.39)GO TO 10 IPTR(NODE)=N1 GO TO 20 C READ NEW CARD 18 READ(LURD,100)KARD 19 CALL IDENT(KSTP) IF(KPRNT.NE.LPRINT)GO TO 19 C WRITE OUT NEXT CARD 20 J=1 IF(LPRINT.GT.1)GO TO 90 C TEST FOR + COMMENT 25 IF(KSTP.EQ.2)GO TO 18 C PLACE STATEMENT IN CHAINED STORE CALL CELL(N1,0,0) N2=N1 MSP=N1 35 DO 40 I=J,72 K=KRUSH(KARD(I)) IF(KHASH(K).NE.isp)MSP=N2 40 CALL CELL(N2,-1,KHASH(K)) J=7 READ(LURD,100)KARD 45 CALL IDENT(ISTP) IF(KPRNT.NE.LPRINT)GO TO 45 IF(ISTP.NE.5)GO TO 55 IF(LPRINT.GT.1)GO TO 90 GO TO 35 C STATEMENT IS FINISHED - ADD TO STORED MACRO 55 ISTORE(NODE)=N1 NODE=N1 C FIND LABEL IF *-STATEMENT IPT=IPTR(N1) IF(ISTORE(IPT).NE.42)GO TO 70 LABEL=0 DO 60 I=1,4 IPT=IPTR(IPT) IF(IPT.EQ.0)GO TO 65 K=ISTORE(IPT) IF(K.NE.isp)LABEL=LABEL*50+K 60 CONTINUE C TEST FOR NO LABEL 65 IF(LABEL.EQ.0)GO TO 70 I=IPTR(KEPT) CALL CELL(I,1,NODE) CALL CELL(I,1,LABEL) IPTR(KEPT)=I C TRIM OFF SURPLUS SPACES AT END OF STATEMENT 70 MSP=IPTR(MSP) MSP=IPTR(MSP) IF(MSP.EQ.0)GO TO 75 I=IPTR(MSP) CALL FREE(I,N2) IPTR(MSP)=0 N2=MSP C TEST FOR * END 75 IF(KSTP.EQ.3)GO TO 80 KSTP=ISTP GO TO 20 80 IF(LPRINT.GT.1)NLINE=LTLINE+1 RETURN C WRITE OUT CARD 90 NLINE=NLINE+1 IF(NLINE.GT.LTLINE)CALL OUTPUT(4) WRITE(LUWR,200)KARD 105 IF(J.EQ.1)GO TO 25 GO TO 35 END SUBROUTINE STRING(IPT,INIT,IFIN) C C ON ENTRY, IPT POINTS TO THE BEGINNING APOSTROPHE OF A STRING C HELD IN CHAINED STORE C INIT IS SET TO POINT TO THE START OF A COPY OF THIS STRING C IFIN IS SET TO POINT TO THE END OF A COPY OF THIS STRING C IPT IS SET TO POINT TO THE FIRST CHARACTER AFTER THE STRING C DIMENSION KARD(72),KHASH(51),KARS(51),KTYPE(51),IPTR(5000),ISTORE( C5000),NOMEN(4,199),ITAB(15,4),IOP(11),KEY(41),IFOP(2,6),KEND(4),IP CRNT(4) COMMON /INFO/ LURD,LUWR,LUPCH,NLINE,LTLINE,NPAGE,MAMP,KPRNT,MACLEV C ,KSP,KAMP,KP,KC,KZERO,KAST,LAVS1,LAVS2,IST1,IST2,NCARD,LPRINT,KEN CD,IPRNT,IFOP,IOP,ITAB,KARD ,KHASH,KARS,KTYPE,KEY,NOMEN,IPTR,ISTORE * ,isp,nchar INIT=0 C SKIP FIRST APOSTROPHE (FIRST TIME ROUND) OR MOVE TO NEXT CHAR 10 IPT=IPTR(IPT) IF(IPT.EQ.0)GO TO 60 C TEST FOR APOSTROPHE K=ISTORE(IPT) IF(K.NE.47)GO TO 20 C APOSTROPHE FOUND - TEST FOR ANOTHER IPT=IPTR(IPT) IF(IPT.EQ.0)RETURN IF(ISTORE(IPT).NE.47)RETURN C ADD CHARACTER TO COPY OF STRING - TEST FOR FIRST TIME 20 IF(INIT.NE.0)GO TO 30 C FIRST CHARACTER TO BE COPIED CALL CELL(IFIN,0,K) INIT=IFIN GO TO 10 C NOT FIRST CHARACTER 30 CONTINUE CALL CELL(IFIN,-1,K) GO TO 10 C NO FINAL APOSTROPHE 60 CALL ERROR(IPT,3) RETURN END SUBROUTINE TYPE DIMENSION KARD(72),KHASH(51),KARS(51),KTYPE(51),IPTR(5000),ISTORE( C5000),NOMEN(4,199),ITAB(15,4),IOP(11),KEY(41),IFOP(2,6),KEND(4),IP CRNT(4) COMMON /INFO/ LURD,LUWR,LUPCH,NLINE,LTLINE,NPAGE,MAMP,KPRNT,MACLEV C ,KSP,KAMP,KP,KC,KZERO,KAST,LAVS1,LAVS2,IST1,IST2,NCARD,LPRINT,KEN CD,IPRNT,IFOP,IOP,ITAB,KARD ,KHASH,KARS,KTYPE,KEY,NOMEN,IPTR,ISTORE * ,isp,nchar DATA MACPTK,MACSTK/2*0/ 5 IPT=IPTR(IST1) C MOVE PAST LABEL 10 DO 11 I=1,6 IPT=IPTR(IPT) IF(IPT.NE.0)GO TO 11 NPT=IPT GO TO 990 11 CONTINUE C TEST FOR KEYWORD 20 KEEP=0 L=0 NKEY=0 21 NPT=IPT NKEY=NKEY+1 KEEP=KEEP+L+1 N=KEEP L=KEY(N) IF(L.EQ.0)GO TO 25 DO 24 I=1,L N=N+1 22 IF(NPT.EQ.0)GO TO 21 IF(ISTORE(NPT).NE.isp)GO TO 23 NPT=IPTR(NPT) GO TO 22 23 IF(ISTORE(NPT).NE.KEY(N))GO TO 21 24 NPT=IPTR(NPT) C MATCH FOUND - TEST FOR OTHER CONDITIONS 25 GO TO (30,40,40,1400,1500,30,40,30),NKEY C CALL / MACRO / ASSIGNMENT 30 LPT=IPT C FIND FIRST SPECIAL 31 L=0 315 IF(LPT.EQ.0)GO TO 35 K=ISTORE(LPT) IF(K.EQ.isp)GO TO 33 IF(KTYPE(K)-4)32,34,1800 32 L=1 33 LPT=IPTR(LPT) GO TO 315 C TEST FOR ( AT BEGINNING OF STATEMENT 34 IF(L.EQ.0)GO TO 1800 35 IF(NKEY.LT.8)GO TO 60 NPT=IPT GO TO 1100 C TEST FOR EOS - END / CONTINUE / RETURN 40 IF(NPT.EQ.0)GO TO 60 IF(ISTORE(NPT).NE.isp)GO TO 41 NPT=IPTR(NPT) GO TO 40 41 NKEY=8 GO TO 30 C COMPUTED GO TO - EXECUTE STATEMENT 60 GO TO (1100,2000,1700,1400,1500,1600,1700,1800),NKEY C C CALL CALL CALL CALL CALL CALL C 1100 CALL NAME(NPT,I) IF(NOMEN(3,I).NE.-3)GO TO 993 MACPT=I MACST=NOMEN(4,MACPT) MACST=ISTORE(MACST) MPAR=IPTR(MACST) MACST=ISTORE(MACST) MACLEV=MACLEV+1 C PUSH DOWN MACRO POINTER AND STATEMENT POINTER ON STACK CALL CELL(MACPTK,1,MACPT) CALL CELL(MACSTK,1,MACST) LARG1=0 C TEST FOR ARGUMENT LIST IF(NPT.EQ.0)GO TO 1130 C TEST FOR ( IF(ISTORE(NPT).NE.38)GO TO 990 C START LIST OF ARGUMENT VALUES CALL CELL(LARG1,0,0) LARG2=LARG1 C GET NEXT ARGUMENT VALUE 1110 NPT=IPTR(NPT) CALL EXPRN(NPT,INIT,IFIN) CALL CELL(LARG2,-1,INIT) CALL CELL(LARG2,-1,IFIN) IF(NPT.EQ.0)GO TO 990 C TEST FOR COMMA IF(ISTORE(NPT).EQ.45)GO TO 1110 IF(ISTORE(NPT).NE.39)GO TO 990 1115 NPT=IPTR(NPT) IF(NPT.EQ.0)GO TO 1120 IF(ISTORE(NPT).EQ.isp)GO TO 1115 GO TO 990 C TEST FOR DUMMY ARGUMENT 1120 NPT=IPTR(LARG1) 1125 IF(MPAR.EQ.0)GO TO 1140 NPAR=ISTORE(MPAR) K=IPTR(NPT) CALL CELL(NOMEN(4,NPAR),1,NOMEN(3,NPAR)) I=ISTORE(K) CALL CELL(L,0,I) NOMEN(3,NPAR)=L IPTR(L)=ISTORE(NPT) MPAR=IPTR(MPAR) NPT=IPTR(K) IF(NPT.GT.0)GO TO 1125 C ACTUAL ARGUMENTS ARE FINISHED - PUSH DOWN NULL STRING ON DUMMY ARGS 1130 IF(MPAR.EQ.0)GO TO 1150 NPAR=ISTORE(MPAR) CALL CELL(NOMEN(4,NPAR),1,NOMEN(3,NPAR)) CALL CELL(NOMEN(3,NPAR),0,0) MPAR=IPTR(MPAR) GO TO 1130 C DUMMY ARGUMENTS ARE FINISHED - FREE ACTUAL ARGUMENTS 1140 IF(NPT.EQ.0)GO TO 1150 K=IPTR(NPT) I=ISTORE(NPT) J=ISTORE(K) CALL FREE(I,J) NPT=IPTR(K) GO TO 1140 C BOTH LISTS OF ARGUMENTS FINISHED - FREE CHAIN 1150 IF(LARG1.GT.0)CALL FREE(LARG1,LARG2) GO TO 2005 C C GO TO GO TO GO TO GO TO GO TO GO TO C 1400 IF(MACLEV.EQ.0)GO TO 991 C GET LABEL TO GO TO NGOTO=0 1405 IF(NPT.EQ.0)GO TO 1408 K=ISTORE(NPT) IF(K.NE.isp)NGOTO=NGOTO*50+K NPT=IPTR(NPT) GO TO 1405 1408 LABL=NOMEN(4,MACPT) C GET LIST OF LABELS 1410 LABL=IPTR(LABL) IF(LABL.EQ.0)GO TO 1430 IF(ISTORE(LABL).EQ.NGOTO)GO TO 1420 LABL=IPTR(LABL) GO TO 1410 C LABEL FOUND - GET NODE 1420 LABL=IPTR(LABL) MACST=ISTORE(LABL) GO TO 2005 C LABEL NOT FOUND 1430 CALL ERROR(0,11) GO TO 2000 C C IF( IF( IF( IF( IF( IF( C C GET FIRST EXPRESSION 1500 CALL EXPRN(NPT,INIT1,IFIN1) C TEST FOR . IF(NPT.EQ.0)GO TO 990 IF(ISTORE(NPT).NE.44)GO TO 990 C IDENTIFY RELATIONAL OPERATOR DO 1530 NIF=1,6 JPT=NPT DO 1520 I=1,3 1510 JPT=IPTR(JPT) IF(JPT.EQ.0)GO TO 990 K=ISTORE(JPT) IF(K.EQ.isp)GO TO 1510 IF(I.EQ.3)GO TO 1540 IF(K.NE.IFOP(I,NIF))GO TO 1530 1520 CONTINUE 1530 CONTINUE GO TO 990 C TEST FOR FINAL . 1540 IF(ISTORE(JPT).NE.44)GO TO 990 NPT=IPTR(JPT) C GET SECOND EXPRESSION CALL EXPRN(NPT,INIT2,IFIN2) C TEST FOR FINAL ) IF(NPT.EQ.0)GO TO 990 IF(ISTORE(NPT).NE.39)GO TO 990 IPT=IPTR(NPT) ITRUE=1 KEEP1=INIT1 KEEP2=INIT2 1550 IF(KEEP1+2)1552,1553,1554 1551 IFIN1=IFIN2 C MACRO NAME USED IN IF 1552 CALL ERROR(IFIN1,6) GO TO 1554 1553 CALL CONV(INIT1,IFIN1,0) 1554 IF(KEEP2+2)1551,1555,1556 1555 CALL CONV(INIT2,IFIN2,0) C TEST FOR NUMERIC OR ALPHABETIC COMPARISON 1556 IF(INIT1)1560,1575,1578 1560 IF(INIT2)1562,1570,1582 C NUMERIC COMPARISON 1562 KOMP=IFIN1-IFIN2 C BRANCH ON 1ST OPND LESS THAN, EQUAL TO, OR GREATER THAN, 2ND OPND 1564 IF(KOMP)1566,1568,1570 1566 IF(MOD(NIF,4).GE.2)GO TO 1574 GO TO 1572 1568 IF(MOD(NIF,2).EQ.1)GO TO 1574 GO TO 1572 1570 IF(NIF.GE.4)GO TO 1574 1572 ITRUE=0 1574 IF(KEEP1.NE.-2)CALL FREE(INIT1,IFIN1) IF(KEEP2.NE.-2)CALL FREE(INIT2,IFIN2) IF(ITRUE)20,2000,20 C FIRST OPERAND IS NULL CHAR STRING 1575 IF(INIT2)1566,1568,1566 C FIRST OPERAND IS CHAR 1578 IF(INIT2)1580,1570,1584 1580 CALL CONV(INIT2,IFIN2,1) GO TO 1584 1582 CALL CONV(INIT1,IFIN1,1) C COMPARE CHARACTER STRINGS 1584 I1=INIT1 I2=INIT2 1586 IF(I1.GT.0)GO TO 1588 IF(I2.EQ.0)GO TO 1568 GO TO 1566 1588 IF(I2.EQ.0)GO TO 1570 IF(ISTORE(I1)-ISTORE(I2))1566,1590,1570 1590 I1=IPTR(I1) I2=IPTR(I2) GO TO 1586 C C MACRO MACRO MACRO MACRO MACRO MACRO C 1600 IF(MACLEV.NE.0)GO TO 992 CALL STASH(NPT) RETURN C C END END END END END END C C RETURN RETURN RETURN RETURN RETURN RETURN C 1700 IF(MACLEV.EQ.0)STOP C POP PARAMETER VALUES IPAR=NOMEN(4,MACPT) IPAR=ISTORE(IPAR) 1710 IPAR=IPTR(IPAR) IF(IPAR.EQ.0)GO TO 1720 INT=ISTORE(IPAR) C FREE CURRENT VALUE K=NOMEN(3,INT) I=IPTR(K) J=ISTORE(K) CALL FREE(I,J) CALL FREE(K,K) K=NOMEN(4,INT) NOMEN(3,INT)=ISTORE(K) CALL FREE(K,NOMEN(4,INT)) GO TO 1710 C REDUCE MACRO LEVEL 1720 MACLEV=MACLEV-1 C POP STACK OF MACRO POINTERS AND STATEMENT POINTERS CALL FREE(MACPTK,MACPTK) CALL FREE(MACSTK,MACSTK) IF(MACLEV.EQ.0)RETURN MACPT=ISTORE(MACPTK) MACST=ISTORE(MACSTK) GO TO 2005 C C EXPRESSIONEXPRESSIONEXPRESSIONEXPRESSIONEXPRESSIONEXPRESSION C 1800 NPT=IPT CALL EXPRN(NPT,I,J) IF(NPT.EQ.0)GO TO 2000 C ERROR IN STATEMENT 990 CALL ERROR(NPT,4) IF(NKEY.EQ.1)GO TO 1130 GO TO 2000 C GO TO NOT IN A MACRO 991 CALL ERROR(NPT,8) GO TO 2000 C MACRO STATEMENT ENCOUNTERED IN A MACRO 992 CALL ERROR(0,12) GO TO 2000 C MACRO NOT DEFINED 993 CALL ERROR(0,5) C C CONTINUE CONTINUE CONTINUE CONTINUE CONTINUE CONTINUE C C GET NEXT STATEMENT 2000 IF(MACLEV.EQ.0)RETURN C FREE CURRENT STATEMENT 2005 CALL FREE(IST1,IST2) C GET NEXT STATEMENT M=MACST MACST=ISTORE(MACST) ISTORE(MACSTK)=MACST C BUILD UP NEW STATEMENT CALL CELL(IST1,0,0) IST2=IST1 GO TO 2020 2010 I=ISTORE(M) CALL CELL(IST2,-1,I) 2020 M=IPTR(M) IF(M.NE.0)GO TO 2010 C TEST FOR COMMENT IPT=IPTR(IST1) MAMP=0 IF(ISTORE(IPT).EQ.13)GO TO 2030 C REPLACE &-FUNCTIONS CALL AMPERS IPT=IPTR(IST1) C TEST FOR + STATEMENT IF(ISTORE(IPT).EQ.40)GO TO 2005 C TEST FOR *-STATEMENT IF(ISTORE(IPT).NE.42)GO TO 2030 IF(LPRINT.GE.5)CALL OUTPUT(1) GO TO 5 C NOT A *-STATEMENT 2030 N=2 IF(LPRINT.GE.4)N=3 CALL OUTPUT(N) GO TO 2005 END