SUBROUTINE MUNGPR IMPLICIT INTEGER(A-Z) CHARACTER*16 FIDCHR LOGICAL*1 NAME(14,6),UNREF(6),REFIT(6),LINE(140),LEX(140) COMPLEX COMMAND(17),OPTIONS(56),S DIMENSION OPTVAL(56),CLASS(56),CLASSCT(9),KEYS(5) DIMENSION BUFFER(600),F1BUFF(256),F2BUFF(256) DIMENSION HKEY(60),HAUX(60) LOGICAL*1 HNAME(14,60),HREFIT(60),HUNREF(60) EQUIVALENCE (HKEY,BUFFER), (HAUX,BUFFER(61)), (HNAME,BUFFER(121)) EQUIVALENCE (HREFIT,BUFFER(541)), (HUNREF,BUFFER(571)) LOGICAL*1 SEP,TAB,TROUBLE,LIST,LISTED,XREF,REFDEF(9),FID(16) COMMON /STRINGS/ NAME,LEX,COMMAND,OPTIONS,LINE, + NCLASS, SEP, UNREF, TAB, FID COMMON /UNITS/ INUNIT,TABLESIZE COMMON /VALUES/ KEYS, AUXVAL, LINEX, LINEND, KEY, CLASS, + NEXTOBJECT, NEXTPLACE, NEXTTEXT, NEXTVERB, NEXTVAR, + NEXTINIT, NEXTLABEL, NEXTREPEAT, SYMCNT, + CLASSCT, NEXTNULL, TROUBLE, LIST, REFIT, + OPTVAL, NREC, REFDEF, LISTED, XREF COMMON /F2DATA/ F2BLK,F2BYTE,F2BUFF,BUFFER COMMON /F1DATA/ F1BLK,F1BYTE,F1BUFF COMMON /FIX1/ OCNT COMMON /FIX2/ XCNT COMMON /LSTFX1/ PAGE,PLINE,CMCODE,OLDBP,WRDLST(50),WRDCNT COMMON /LSTFX2/ LSTBLK,LSTBYT COMMON /FIX11/ SKEY COMMON /FIX15/ BP COMMON /FIX20/ I1,I3 EXTERNAL INRANGE,CEQUAL LOGICAL*1 INRANGE,PARSE,FLUSH,FIRST C OCNT = 0 PAGE = 0 WRDCNT = 0 XCNT = 0 TYPE 10 10 FORMAT (' Listing File: ',$) ACCEPT 11, FIDCHR OPEN (UNIT=7, FILE=FIDCHR, TYPE='NEW') 11 FORMAT (A16) TYPE 12 12 FORMAT (' Input File: ',$) ACCEPT 11, FIDCHR OPEN (UNIT=1, FILE=FIDCHR, TYPE='OLD', READONLY) TYPE 13 13 FORMAT (' Output Text File: ',$) ACCEPT 11, FIDCHR OPEN (UNIT=2, FILE=FIDCHR, TYPE='NEW', ACCESS='DIRECT', 1 RECORDSIZE=128, ASSOCIATEVARIABLE=I3) TYPE 14 14 FORMAT (' Output Instruction File: ',$) ACCEPT 11, FIDCHR OPEN (UNIT=3, FILE=FIDCHR, TYPE='NEW', ACCESS='DIRECT', 1 RECORDSIZE=128, ASSOCIATEVARIABLE=I3) TYPE 15 15 FORMAT (' Record Index File: ',$) ACCEPT 11, FIDCHR OPEN (UNIT=9, FILE=FIDCHR, TYPE='NEW', ACCESS='DIRECT', 1 RECORDSIZE=2, ASSOCIATEVARIABLE=I3) TYPE 16 16 FORMAT (' Hash Table Size: ',$) ACCEPT 17, TABLESIZE 17 FORMAT (I5) OPEN (UNIT=10, FILE='MUNGEHASH.TMP', TYPE='SCRATCH', 1 ACCESS='DIRECT', RECORDSIZE=5, ASSOCIATEVARIABLE=I1, 2 MAXREC=TABLESIZE) NEXTINIT=0 NEXTOBJECT=1000 NEXTPLACE=2000 NEXTVERB=3000 NEXTTEXT=4000 NEXTLABEL=5000 NEXTREPEAT=6000 NEXTVAR = 7000 NEXTNULL = 8000 TAB = 9 F1BLK = 1 F2BLK = 1 INUNIT=1 DO 19, I=1,56 OPTVAL(I)=I 19 CONTINUE DO 23 I=1, 55 K = I DO 22 J=I+1, 56 IF (CEQUAL(OPTION(J),OPTION(K),4) .NE. 0) GOTO 21 WRITE (7,20,ERR=9999,END=9999) OPTION(J), OPTION(K) 20 FORMAT (' Undistinguishable options: ',2A4,' AND ',2A4) CALL SCOPY('ZZZZ',OPTION(K),4) 21 IF (CEQUAL(OPTION(J),OPTION(K),4) .LT. 0) K=J 22 CONTINUE IF (I .EQ. K) GOTO 23 S=OPTION(I) OPTION(I)=OPTION(K) OPTION(K)=S J = OPTVAL(I) OPTVAL(I) = OPTVAL(K) OPTVAL(K) = J 23 CONTINUE FID(1) = 0 CALL STRPAD(FID,15) NAME(1,1) = ' ' DO 24 I= 1, TABLESIZE 24 CALL WRITEVIRTUAL(1,I) LISTED = .TRUE. C C INITIAL LOOP C 100 FLUSH = .FALSE. ASSIGN 300 TO CONTINUE ASSIGN 400 TO NEW C C GET A LINE - GO WHEREVER WE SHOULD C 200 IF (LIST) CALL SNAPIT 201 LINEX = -1 LISTED = .FALSE. NREC = NREC + 1 LINE(1) = 0 CALL STRPAD(LINE,139) READ (INUNIT,202,END=203) (LINE(I),I=1,140) 202 FORMAT (140A1) OLDBP = BP CALL SCOPY(LINE,LINE,139) CALL TRIM(LINE) LINEX = 1 LINEND = ZLEN(LINE) IF (NREC.LT.0) NREC=0 IF (LINE(1) .EQ. '*') GOTO 204 IF (LINE(1) .NE. 0) GOTO 206 LINE(1) = ' ' LINE(2) = 0 206 IF (CMPSEP(LINE(1)) .NE. 0) GOTO NEW GOTO CONTINUE 203 LISTED = .TRUE. GOTO NEW 204 IF (LIST) CALL SNAPIT GOTO 201 C C 300 FLUSH = .TRUE. GOTO 200 C C 400 IF (LINEX.GT.0) GOTO 405 IF (INUNIT.EQ.1) GOTO 9000 INUNIT= 1 NREC = SNREC CALL CLOSE(4) FID(1)=0 CALL STRPAD(FID,15) PLINE = 100 GOTO 200 405 IF (LINEX .LT. 0) GOTO 9000 ASSIGN 300 TO CONTINUE ASSIGN 400 TO NEW IF (PARSE(I)) GOTO 200 DO 410 CODE=1,17 410 IF (CEQUAL(LEX,COMMAND(CODE),3).EQ. 0) GOTO 420 IF (FIND(LEX) .GE. 0) GOTO 2905 415 CALL SNAPIT PLINE = PLINE + 1 WRITE (7,2,ERR=9999,END=9999) (LEX(I),I=1,10) 2 FORMAT (' $ --Bad command: $',10A1) TROUBLE = .TRUE. GOTO 100 C C 420 CONTINUE CMCODE = CODE GOTO (2000,2100,2200,2300,2400,2500,2600, + 2800,2900,3500,2700,3600,3700,3800,3900,4000,4200),CODE C C 1000 ASSIGN 1300 TO CONTINUE LSTBLK = F1BLK LSTBYT = F1BYTE WRDCNT = 0 SKEY = 0 CALL WF4(KEY,SKEY,OCNT) IF (PARSE(I)) GOTO 200 CALL DEFINE(LEX, KEY,0,0) SMELCH=FIND(LEX) IF (SEP .NE. ',') GOTO 200 1300 IF (CMPSEP(LINE(LINEX)) .NE. 0) GOTO 1301 LINEX = LINEX + 1 GOTO 1300 1301 IF (LINEX .GT. LINEND) GOTO 1350 IF (LINE(LINEX) .EQ. '/') GOTO 1320 IF (LINE(LINEX) .NE. '%') GOTO 1350 SKEY = SKEY + 1 WRDCNT = 0 LSTBLK = F1BLK LSTBYT = F1BYTE CALL WF4(KEY,SKEY,OCNT) 1320 LINEX = LINEX + 1 IF (LINEND .LT. LINEX) LINEND = LINEX 1350 CALL WRITE(KEY,SKEY,LINE(LINEX)) AUXVAL=SKEY CALL WRITEVIRTUAL(1,SMELCH) C C For objects, AUXVAL will be set equal to the number of states C that the object has defined (not including in-hand status) and C may be fetched via the @name construct. C GOTO 200 C C 2000 CALL SETUP(KEY, NEXTTEXT) GOTO 1000 C C 2100 CALL SETUP(KEY, NEXTOBJECT) GOTO 1000 C C 2200 CALL SETUP(KEY, NEXTPLACE) GOTO 1000 C C 2300 FIRST=.TRUE. CALL SETUP(KEY, NEXTVERB) WRDCNT = 1 WRDLST(1) = KEY 2310 IF (PARSE(I)) GOTO 100 I = 0 IF (FIRST) I=1 CALL DEFINE(LEX, KEY,I,0) IF (FIRST) GOTO 2320 I = FIND(LEX) UNREF(1)=' ' CALL WRITEVIRTUAL(1,I) 2320 FIRST=.FALSE. GOTO 2310 C C 2400 CALL SETUP(KEY, NEXTINIT) GOTO 2601 C C 2500 IF (PARSE(I)) GOTO 415 CALL DEFINE(LEX, NEXTLABEL,1,0) CALL SETUP(KEY, NEXTLABEL) GOTO 2601 C 2600 CALL SETUP(KEY, NEXTREPEAT) 2601 BP = 1 SKEY = 1 GOTO 2950 C C 2700 WRDCNT = 0 2701 IF (PARSE(I)) GOTO 100 WRDCNT = WRDCNT + 1 WRDLST(WRDCNT) = NEXTVAR CALL DEFINE(LEX, NEXTVAR,1,0) NEXTVAR = NEXTVAR + 1 GOTO 2701 C C 2800 IF (PARSE(I)) GOTO 415 WHERE = FIND(LEX) IF (WHERE .LT. 0) GOTO 2802 IF (AUXVAL .LT. 1) AUXVAL = 1 IF (INRANGE(2000, KEYS(1), 3000)) GOTO 2920 2802 CALL SNAPIT PLINE = PLINE + 1 WRITE (7,2805,ERR=9999,END=9999) (LEX(I), I=1,ZLEN(LEX)) 2805 FORMAT (' --That''s no place: ',50A1) TROUBLE = .TRUE. GOTO 100 C C 2900 IF (PARSE(I)) GOTO 415 2905 WHERE = FIND(LEX) IF (WHERE .GE. 0) GOTO 2910 CALL DEFINE(LEX, NEXTVERB,1,0) CALL SNAPIT PLINE = PLINE + 1 WRITE (7,3,ERR=9999,END=9999) 3 FORMAT (' $ >> Verb defined by default <<$') NEXTVERB = NEXTVERB + 1 GOTO 2905 2910 IF (INRANGE(3000, KEYS(1), 4000)) GOTO 2925 IF (INRANGE(1000, KEYS(1), 2000)) GOTO 2920 CALL SNAPIT PLINE = PLINE + 1 WRITE (7,4,ERR=9999,END=9999) (LEX(I), I=1,ZLEN(LEX)) 4 FORMAT (' $ --That''s not a verb or object: $',50A1) TROUBLE = .TRUE. GOTO 100 2920 CONTINUE 2925 KEY = KEYS(1) AUXVAL = AUXVAL + 1 SKEY = AUXVAL CALL WRITEVIRTUAL(1,WHERE) BP = 1 2928 IF (PARSE(I)) GOTO 2950 WHERE = EVAL(LEX) 2930 BUFFER(BP) = 1 BUFFER(BP + 1) = WHERE BP = BP + 2 2940 GOTO 2928 2950 ASSIGN 3000 TO CONTINUE CALL WF4(KEY,-SKEY,OCNT) ASSIGN 3100 TO NEW GOTO 200 3000 IF (PARSE(I)) GOTO 200 3005 LOW = 1 HIGH = 56 3006 ISAM = (LOW + HIGH) / 2 IF (CEQUAL(LEX,OPTION(ISAM),4) .EQ. 0) GOTO 3020 IF (LOW .GE. HIGH) GOTO 3015 IF (CEQUAL(LEX,OPTION(ISAM),4) .GT. 0) GOTO 3007 HIGH = ISAM - 1 GOTO 3006 3007 LOW = ISAM + 1 GOTO 3006 3015 CALL SNAPIT PLINE = PLINE + 1 WRITE (7,5,ERR=9999,END=9999) (LEX(I),I=1,ZLEN(LEX)) 5 FORMAT (' $ --Bad option: $',50A1) TROUBLE = .TRUE. GOTO 200 3016 CALL SNAPIT PLINE = PLINE + 1 WRITE (7,6,ERR=9999,END=9999) 6 FORMAT (' $--Missing required parameter$') TROUBLE = .TRUE. GOTO 200 3020 OPT = OPTVAL(ISAM) IF (CLASS(OPT) .GE. 0) GOTO 3050 3025 IF (PARSE(I)) GOTO 200 WHERE = EVAL(LEX) BUFFER(BP) = OPT BUFFER(BP + 1) = WHERE BP = BP + 2 3030 GOTO 3025 3050 BUFFER(BP) = OPT IF (CLASS(OPT) .EQ. 0) GOTO 3062 DO 3060 I=1,CLASS(OPT) IF (PARSE(I)) GOTO 3016 BUFFER(BP + I) = EVAL(LEX) 3060 CONTINUE 3062 BP = BP + 1 + CLASS(OPT) GOTO 200 3100 IF (BP.LT.2) GOTO 400 BP = BP - 1 CALL BUFFWRITE(F2BYTE,F2BUFF,F2BLK,BUFFER,KEY,SKEY,BP) BP = 0 GOTO 400 3500 IF (PARSE(I)) GOTO 415 VALUE = EVAL(LEX) WRDCNT = 1 WRDLST(1) = VALUE 3505 IF (PARSE(I)) GOTO 100 CALL DEFINE(LEX, VALUE,0,0) I = FIND(LEX) UNREF(1)=' ' CALL WRITEVIRTUAL(1,I) GOTO 3505 C C 3600 WRDCNT = 1 WRDLST(1) = NEXTNULL 3601 IF (PARSE(I)) GOTO 100 CALL DEFINE(LEX,NEXTNULL,1,0) GOTO 3601 C C 3700 IF (LIST) GOTO 3701 PLINE = 100 3701 LIST = .TRUE. GOTO 100 C C 3800 LIST = .FALSE. GOTO 100 C C 3900 WRDCNT = 0 3901 IF (PARSE(I)) GOTO 100 I = FIND(LEX) WRDCNT = WRDCNT + 1 WRDLST(WRDCNT) = KEYS(1) IF (I .GE. 0) GOTO 3910 CALL SNAPIT PLINE = PLINE + 1 WRITE (7,7,ERR=9999,END=9999) (LEX(I),I=1,12) 7 FORMAT (' $ --Undefined symbol: $',12A1) GOTO 3901 3910 REFIT(1) = .TRUE. CALL WRITEVIRTUAL(1,I) GOTO 3901 C C 4000 IF (INUNIT.NE.4) GOTO 4010 CALL SNAPIT PLINE = PLINE + 1 WRITE (7,8,ERR=9999,END=9999) 8 FORMAT (' $ INCLUDEs may not be nested.$') GOTO 100 4010 IF (PARSE(I)) GOTO 415 CALL SCOPY(LEX,FID,15) CALL STRPAD(FID,15) CALL SCOPY(FID,FIDCHR,15) OPEN (UNIT=4, FILE=FIDCHR, TYPE='OLD', READONLY) CALL STPAGE(FID,LIST,1) LISTED = .TRUE. SNREC = NREC NREC = 0 INUNIT=4 GOTO 100 4200 IF (XREF) GOTO 100 TYPE 4210 4210 FORMAT (' XREF File Name: ',$) ACCEPT 11,FIDCHR OPEN (UNIT=8, FILE=FIDCHR, TYPE='SCRATCH', ACCESS='DIRECT', 1 RECORDSIZE=7, ASSOCIATEVARIABLE=I3) XREF=.TRUE. GOTO 100 C C 9000 CONTINUE CLOSE(UNIT=1) CALL F2WRIT CLOSE(UNIT=3) CALL FASTWR(F1BYTE,F1BUFF,F1BLK,0,0,'END OF DATA') CALL F1WRIT CLOSE(UNIT=2) CALL DEFINE('NOBJ', MOD(NEXTOBJECT, 1000),0,1) CALL DEFINE('NPLACE', MOD(NEXTPLACE, 1000),0,1) CALL DEFINE('NREP', MOD(NEXTREPEAT, 1000),0,1) CALL DEFINE('NINIT', MOD(NEXTINIT, 1000),0,1) CALL DEFINE('NVARS', MOD(NEXTVAR, 1000),0,1) SYMCNT = 0 SAVEC = 0 DO 9005 I=1, TABLESIZE CALL READVIRTUAL(1,I) IF (NAME(1,1) .EQ. ' ') GOTO 9005 IF (SAVEC .LT. 60) GOTO 9002 CALL OSAVE(SAVEC) CALL READVIRTUAL(1,I) 9002 SAVEC = SAVEC + 1 CALL SCOPY(NAME(1,1),HNAME(1,SAVEC),12) HAUX(SAVEC) = AUXVAL HREFIT(SAVEC) = REFIT(1) HKEY(SAVEC) = KEYS(1) HUNREF(SAVEC) = UNREF(1) 9005 CONTINUE IF (SAVEC .GT. 0) CALL OSAVE(SAVEC) RETURN 9999 STOP 'Listing File Error' END SUBROUTINE OSAVE(SAVEC) IMPLICIT INTEGER(A-Z) LOGICAL*1 NAME(14,6),UNREF(6),REFIT(6),LINE(140),LEX(140) COMPLEX COMMAND(17),OPTIONS(56),S DIMENSION OPTVAL(56),CLASS(56),CLASSCT(9),KEYS(5) DIMENSION BUFFER(600),F2BUFF(256) DIMENSION HKEY(60),HAUX(60) LOGICAL*1 HNAME(14,60),HREFIT(60),HUNREF(60) EQUIVALENCE (HKEY,BUFFER), (HAUX,BUFFER(61)), (HNAME,BUFFER(121)) EQUIVALENCE (HREFIT,BUFFER(541)), (HUNREF,BUFFER(571)) LOGICAL*1 SEP,TAB,TROUBLE,LIST,LISTED,XREF,REFDEF(9),FID(16) COMMON /STRINGS/ NAME,LEX,COMMAND,OPTIONS,LINE, + NCLASS, SEP, UNREF, TAB, FID COMMON /UNITS/ INUNIT,TABLESIZE COMMON /VALUES/ KEYS, AUXVAL, LINEX, LINEND, KEY, CLASS, + NEXTOBJECT, NEXTPLACE, NEXTTEXT, NEXTVERB, NEXTVAR, + NEXTINIT, NEXTLABEL, NEXTREPEAT, SYMCNT, + CLASSCT, NEXTNULL, TROUBLE, LIST, REFIT, + OPTVAL, NREC, REFDEF, LISTED, XREF COMMON /F2DATA/ F2BLK,F2BYTE,F2BUFF,BUFFER DO 10, I=1,SAVEC CALL SCOPY(HNAME(1,I),NAME(1,1),12) AUXVAL = HAUX(I) REFIT(1) = HREFIT(I) UNREF(1) = HUNREF(I) KEYS(1) = HKEY(I) SYMCNT = SYMCNT + 1 CALL WRITEVIRTUAL(1,SYMCNT) 10 CONTINUE SAVEC = 0 RETURN END SUBROUTINE PRINTTABLE IMPLICIT INTEGER(A-Z) LOGICAL*1 NAME(14,6),UNREF(6),REFIT(6),LINE(140),LEX(140) COMPLEX COMMAND(17),OPTIONS(56) DIMENSION OPTVAL(56),CLASS(56),CLASSCT(9),KEYS(5) LOGICAL*1 SEP, TAB,TROUBLE,LIST,LISTED,XREF,REFDEF(9),FID(16) COMMON /STRINGS/ NAME,LEX,COMMAND,OPTIONS,LINE, + NCLASS, SEP, UNREF, TAB, FID COMMON /VALUES/ KEYS, AUXVAL, LINEX, LINEND, KEY, CLASS, + NEXTOBJECT, NEXTPLACE, NEXTTEXT, NEXTVERB, NEXTVAR, + NEXTINIT, NEXTLABEL, NEXTREPEAT, SYMCNT, + CLASSCT, NEXTNULL, TROUBLE, LIST, REFIT, + OPTVAL, NREC, REFDEF, LISTED, XREF COMMON /FIX10/ LINE1 COMMON /LSTFX1/ PAGE,PLINE,CMCODE,OLDBP,WRDLST(50),WRDCNT COMMON /LSTFX2/ LSTBLK,LSTBYT LOGICAL*1 LINE1(20) C DO 100, K=1,SYMCNT,5 I = K+4 IF (I .GT. SYMCNT) I=SYMCNT DO 200, J=K,I CALL READVIRTUAL(J-K+1,J) 200 CONTINUE PLINE = PLINE + 1 IF (PLINE .LT. 58) GOTO 150 CALL STPAGE(LINE1,LIST,0) 150 WRITE (7,9111,ERR=10,END=10) (KEYS(J),UNREF(J), + (NAME(I1,J),I1=1,12),J=1,I-K+1) 100 CONTINUE 9111 FORMAT (5(1X,I4,A1,12A1,3X)) RETURN 10 STOP 'Listing File Error' END SUBROUTINE READVIRTUAL (I,J) IMPLICIT INTEGER(A-Z) LOGICAL*1 NAME(14,6),UNREF(6),REFIT(6),LINE(140),LEX(140) COMPLEX COMMAND(17),OPTIONS(56) DIMENSION OPTVAL(56),CLASS(56),CLASSCT(9),KEYS(5) LOGICAL*1 SEP,TAB,TROUBLE,LIST,LISTED,XREF,REFDEF(9),FID(16) COMMON /STRINGS/ NAME,LEX,COMMAND,OPTIONS,LINE, + NCLASS, SEP, UNREF, TAB, FID COMMON /VALUES/ KEYS, AUXVAL, LINEX, LINEND, KEY, CLASS, + NEXTOBJECT, NEXTPLACE, NEXTTEXT, NEXTVERB, NEXTVAR, + NEXTINIT, NEXTLABEL, NEXTREPEAT, SYMCNT, + CLASSCT, NEXTNULL, TROUBLE, LIST, REFIT, + OPTVAL, NREC, REFDEF, LISTED, XREF C READ (10'J) (NAME(I1,I),I1=1,14),AUXVAL,KEYS(I),UNREF(I),REFIT(I) RETURN END SUBROUTINE WRITEVIRTUAL (I,J) IMPLICIT INTEGER(A-Z) LOGICAL*1 NAME(14,6),UNREF(6),REFIT(6),LINE(140),LEX(140) COMPLEX COMMAND(17),OPTIONS(56) DIMENSION OPTVAL(56),KEYS(5),CLASSCT(9),CLASS(56) LOGICAL*1 SEP, TAB,TROUBLE,LIST,LISTED,XREF,REFDEF(9),FID(16) COMMON /STRINGS/ NAME,LEX,COMMAND,OPTIONS,LINE, + NCLASS, SEP, UNREF, TAB, FID COMMON /VALUES/ KEYS, AUXVAL, LINEX, LINEND, KEY, CLASS, + NEXTOBJECT, NEXTPLACE, NEXTTEXT, NEXTVERB, NEXTVAR, + NEXTINIT, NEXTLABEL, NEXTREPEAT, SYMCNT, + CLASSCT, NEXTNULL, TROUBLE, LIST, REFIT, + OPTVAL, NREC, REFDEF, LISTED, XREF C WRITE (10'J,ERR=10) (NAME(I1,I),I1=1,14), + AUXVAL,KEYS(I),UNREF(I),REFIT(I) RETURN 10 STOP 'Virtual Memory Overflow' END SUBROUTINE WF4(KEY10,SKEY,OCNT) IMPLICIT INTEGER (A-Z) LOGICAL*1 NAME(14,6),UNREF(6),REFIT(6),LINE(140),LEX(140) COMPLEX COMMAND(17),OPTIONS(56),S DIMENSION OPTVAL(56),CLASS(56),CLASSCT(9),KEYS(5) DIMENSION BUFFER(600),F1BUFF(256),F2BUFF(256) DIMENSION HKEY(60),HAUX(60) LOGICAL*1 HNAME(14,60),HREFIT(60),HUNREF(60) EQUIVALENCE (HKEY,BUFFER), (HAUX,BUFFER(61)), (HNAME,BUFFER(121)) EQUIVALENCE (HREFIT,BUFFER(541)), (HUNREF,BUFFER(571)) LOGICAL*1 SEP,TAB,TROUBLE,LIST,LISTED,XREF,REFDEF(9),FID(16) COMMON /STRINGS/ NAME,LEX,COMMAND,OPTIONS,LINE, + NCLASS, SEP, UNREF, TAB, FID COMMON /UNITS/ INUNIT,TABLESIZE COMMON /VALUES/ KEYS, AUXVAL, LINEX, LINEND, KEY, CLASS, + NEXTOBJECT, NEXTPLACE, NEXTTEXT, NEXTVERB, NEXTVAR, + NEXTINIT, NEXTLABEL, NEXTREPEAT, SYMCNT, + CLASSCT, NEXTNULL, TROUBLE, LIST, REFIT, + OPTVAL, NREC, REFDEF, LISTED, XREF COMMON /F2DATA/ F2BLK,F2BYTE,F2BUFF,BUFFER COMMON /F1DATA/ F1BLK,F1BYTE,F1BUFF COMMON /LSTFX1/ PAGE,PLINE,CMCODE,OLDBP,WRDLST(50),WRDCNT COMMON /LSTFX2/ LSTBLK,LSTBYT C K = 1 I = F2BLK J = F2BYTE IF (SKEY .LT. 0) GOTO 10 IF (SKEY .GT. 0) K = 0 I = F1BLK J = F1BYTE 10 OCNT = OCNT + 1 WRITE (9'OCNT,ERR=20,END=20) KEY10,SKEY,I,J IF (K .EQ. 0) RETURN IF (.NOT. LIST) RETURN IF (PLINE .LT. 55) GOTO 15 CALL STPAGE(FID,LIST,1) 15 WRITE (7,12,ERR=9,END=9) KEY10,SKEY PLINE = PLINE + 3 12 FORMAT(/,8X,'Record:',I5,4X,'Subkey:',I4) WRITE (7,13,ERR=9,END=9) 13 FORMAT (1X) RETURN 9 STOP 'Error on Listing File' 20 STOP 'Record Index File Error' END SUBROUTINE STPAGE(FID1,LIST,FLAG) IMPLICIT INTEGER (A-Z) LOGICAL*1 PAGEL(100),DAT(10),LIST,FID1(16),FID(22) COMMON /LSTFX1/ PAGE,PLINE,CMCODE,OLDBP,WRDLST(50),WRDCNT COMMON /LSTFX2/ LSTBLK,LSTBYT PAGE = PAGE + 1 PLINE = 0 IF (FLAG .NE. 0) GOTO 5 CALL SCOPY(FID1,FID,20) CALL STRPAD(FID,20) GOTO 7 5 CALL SCOPY(FID1,FID,16) CALL TRIM(FID) IF (ZLEN(FID) .EQ. 0) CALL SCOPY('.MAIN PROG.',FID) CALL STRPAD(FID,15) 7 CALL SCOPY('Munges - Database Compiler ',PAGEL) CALL TIME(DAT) CALL SCOPY(DAT,PAGEL(34)) CALL DATE(DAT) CALL SCOPY(' on ',PAGEL(42)) CALL SCOPY(DAT,PAGEL(47),9) IF (FLAG .EQ. 0) GOTO 10 CALL SCOPY(' File = ',PAGEL(56)) CALL SCOPY(FID,PAGEL(69),14) GOTO 20 10 CALL SCOPY(' ',PAGEL(56)) CALL SCOPY(FID,PAGEL(63),20) 20 CALL SCOPY(' PAGE ',PAGEL(83)) CALL ONUMB(PAGE,PAGEL(95),4) WRITE (7,1,END=2,ERR=2) (PAGEL(I),I=1,ZLEN(PAGEL)) 1 FORMAT('1',100A1) WRITE (7,3,END=2,ERR=2) 3 FORMAT (1X) RETURN 2 STOP 'Listing File Error' END SUBROUTINE SNAPIT IMPLICIT INTEGER(A-Z) LOGICAL*1 NAME(14,6),UNREF(6),REFIT(6),LINE(140),LEX(140) COMPLEX COMMAND(17),OPTIONS(56) DIMENSION OPTVAL(56),CLASS(56),CLASSCT(9),KEYS(5) LOGICAL*1 SEP, TAB,TROUBLE,LIST,LISTED,XREF,REFDEF(9),FID(16) COMMON /STRINGS/ NAME,LEX,COMMAND,OPTIONS,LINE, + NCLASS, SEP, UNREF, TAB, FID COMMON /UNITS/ INUNIT,TABLESIZE COMMON /VALUES/ KEYS, AUXVAL, LINEX, LINEND, KEY, CLASS, + NEXTOBJECT, NEXTPLACE, NEXTTEXT, NEXTVERB, NEXTVAR, + NEXTINIT, NEXTLABEL, NEXTREPEAT, SYMCNT, + CLASSCT, NEXTNULL, TROUBLE, LIST, REFIT, + OPTVAL, NREC, REFDEF, LISTED, XREF COMMON /LSTFX1/ PAGE,PLINE,CMCODE,OLDBP,WRDLST(50),WRDCNT COMMON /LSTFX2/ LSTBLK,LSTBYT COMMON /FIX11/ SKEY COMMON /FIX15/ BP DIMENSION F1BUFF(256),F2BUFF(256),BUFFER(600),LARGS(4) COMMON /F1DATA/ F1BLK,F1BYTE,F1BUFF COMMON /F2DATA/ F2BLK,F2BYTE,F2BUFF,BUFFER LOGICAL*1 OLINE(130) C IF (LISTED) RETURN IF (PLINE .LT. 57) GOTO 5 CALL STPAGE(FID,LIST,1) 5 PLINE = PLINE + 1 OLINE(1) = 0 CALL STRPAD(OLINE,129) CALL SCOPY(LINE,OLINE(41),88) CALL ONUMB(NREC,OLINE(1),5) IF (CMPSEP(LINE(1)).EQ.0) GOTO 7 IF (LINE(1).EQ.'*') GOTO 10 OLDBP = BP IF ((CMCODE.EQ.4).OR.(CMCODE.EQ.15)) GOTO 40 IF ((CMCODE.LT.10).OR.(CMCODE.GT.12)) GOTO 10 7 IF (LINE(2).NE.0) GOTO 8 IF (CMCODE.GE.4) GOTO 10 8 IF (CMCODE .EQ. 0) GOTO 10 IF (CMCODE .LT. 4) GOTO 20 IF (CMCODE .LT. 10) GOTO 30 IF (CMCODE .LT. 13) GOTO 40 IF (CMCODE .NE. 15) GOTO 10 40 LARGC = 4 LARGS(1) = 13 LARGS(2) = 20 LARGS(3) = 27 LARGS(4) = 34 CALL OARGS(OLINE,WRDLST,LARGC,LARGS,WRDCNT) GOTO 10 30 CALL ONUMB(OLDBP,OLINE(8),3) CALL ONUMB(BUFFER(OLDBP),OLINE(15),2) OLDBP = OLDBP + 1 I = BP - OLDBP IF (I .EQ. 0) GOTO 10 LARGC=3 LARGS(1) = 20 LARGS(2) = 27 LARGS(3) = 34 CALL OARGS(OLINE,BUFFER(OLDBP),LARGC,LARGS,I) OLDBP = BP GOTO 10 20 IWRD = (F1BLK-LSTBLK)*512+(F1BYTE-LSTBYT) ILEN = IWRD-WRDCNT CALL ONUMB(SKEY,OLINE(8),3) CALL ONUMB(WRDCNT,OLINE(13),4) CALL ONUMB(ILEN,OLINE(21),4) WRDCNT = IWRD 10 LISTED = .TRUE. WRITE (7,1,ERR=2,END=2) (OLINE(I),I=1,ZLEN(OLINE)) 1 FORMAT (1X,130A1) RETURN 2 STOP 'Listing File Error' END SUBROUTINE OARGS(OLINE,WRDL,LARGC,LARGS,WRDC) IMPLICIT INTEGER(A-Z) LOGICAL*1 NAME(14,6),UNREF(6),REFIT(6),LINE(140),LEX(140) COMPLEX COMMAND(17),OPTIONS(56) DIMENSION OPTVAL(56),CLASS(56),CLASSCT(9),KEYS(5),WRDL(50) LOGICAL*1 SEP, TAB,TROUBLE,LIST,LISTED,XREF,REFDEF(9),FID(16) COMMON /STRINGS/ NAME,LEX,COMMAND,OPTIONS,LINE, + NCLASS, SEP, UNREF, TAB, FID COMMON /UNITS/ INUNIT,TABLESIZE COMMON /VALUES/ KEYS, AUXVAL, LINEX, LINEND, KEY, CLASS, + NEXTOBJECT, NEXTPLACE, NEXTTEXT, NEXTVERB, NEXTVAR, + NEXTINIT, NEXTLABEL, NEXTREPEAT, SYMCNT, + CLASSCT, NEXTNULL, TROUBLE, LIST, REFIT, + OPTVAL, NREC, REFDEF, LISTED, XREF COMMON /LSTFX1/ PAGE,PLINE,CMCODE,OLDBP,WRDLST(50),WRDCNT COMMON /LSTFX2/ LSTBLK,LSTBYT DIMENSION F1BUFF(256),F2BUFF(256),BUFFER(600),LARGS(4) COMMON /F1DATA/ F1BLK,F1BYTE,F1BUFF COMMON /F2DATA/ F2BLK,F2BYTE,F2BUFF,BUFFER LOGICAL*1 OLINE(130) C IPTR = 1 ICNT = 1 10 IF (ICNT .GT. WRDC) GOTO 20 CALL ONUMB(WRDL(ICNT),OLINE(LARGS(IPTR)),5) ICNT = ICNT + 1 IPTR = IPTR + 1 IF (IPTR .LE. LARGC) GOTO 10 IPTR = 1 IF (ICNT .GT. WRDC) GOTO 20 WRITE (7,1,ERR=2,END=2) (OLINE(I),I=1,ZLEN(OLINE(1))) 1 FORMAT (1X,130A1) OLINE(1) = 0 CALL STRPAD(OLINE(1),50) PLINE = PLINE + 1 IF (PLINE .LT. 58) GOTO 10 CALL STPAGE(FID,LIST,1) PLINE = 1 GOTO 10 20 RETURN 2 STOP 'Listing File Error' END LOGICAL FUNCTION PARSE(I1) IMPLICIT INTEGER(A-Z) LOGICAL*1 NAME(14,6),UNREF(6),REFIT(6),LINE(140),LEX(140) COMPLEX COMMAND(17),OPTIONS(56) DIMENSION OPTVAL(56),CLASS(56),CLASSCT(9),KEYS(5) LOGICAL*1 SEP,TAB,TROUBLE,LIST,LISTED,XREF,REFDEF(9),FID(16) COMMON /STRINGS/ NAME,LEX,COMMAND,OPTIONS,LINE, + NCLASS, SEP, UNREF, TAB, FID COMMON /VALUES/ KEYS, AUXVAL, LINEX, LINEND, KEY, CLASS, + NEXTOBJECT, NEXTPLACE, NEXTTEXT, NEXTVERB, NEXTVAR, + NEXTINIT, NEXTLABEL, NEXTREPEAT, SYMCNT, + CLASSCT, NEXTNULL, TROUBLE, LIST, REFIT, + OPTVAL, NREC, REFDEF, LISTED, XREF LOGICAL*1 CHR C LEX(1) = 0 CALL STRPAD(LEX,139) DO 10 I=LINEX,LINEND CHR = LINE(I) PARSE = .TRUE. IF (CHR .EQ. '*') RETURN IF (CHR .EQ. '(' .OR. CHR .EQ. '{') RETURN 10 IF (CMPSEP(CHR) .NE. 0) GOTO 15 RETURN 15 DO 20 J=I,LINEND + 1 SEP = LINE(J) 20 IF (CMPSEP(SEP) .EQ. 0 .OR. SEP .EQ. ',' ) GOTO 25 J = LINEND + 1 25 CALL SCOPY (LINE(I),LEX,J-I) LINEX = J + 1 PARSE = .FALSE. RETURN END INTEGER FUNCTION EVAL(TEXT) IMPLICIT INTEGER(A-Z) LOGICAL*1 NAME(14,6),UNREF(6),REFIT(6),LINE(140),LEX(140) COMPLEX COMMAND(17),OPTIONS(56) DIMENSION OPTVAL(56),CLASS(56),CLASSCT(9),KEYS(5) LOGICAL*1 SEP,TAB,TROUBLE,LIST,LISTED,XREF,REFDEF(9),FID(16) COMMON /STRINGS/ NAME,LEX,COMMAND,OPTIONS,LINE, + NCLASS, SEP, UNREF, TAB, FID COMMON /VALUES/ KEYS, AUXVAL, LINEX, LINEND, KEY, CLASS, + NEXTOBJECT, NEXTPLACE, NEXTTEXT, NEXTVERB, NEXTVAR, + NEXTINIT, NEXTLABEL, NEXTREPEAT, SYMCNT, + CLASSCT, NEXTNULL, TROUBLE, LIST, REFIT, + OPTVAL, NREC, REFDEF, LISTED, XREF LOGICAL*1 TEXT(80),DIGITS(10),TEMP(14),BITPHRASE COMMON /LSTFX1/ PAGE,PLINE,CMCODE,OLDBP,WRDLST(50),WRDCNT COMMON /LSTFX2/ LSTBLK,LSTBYT DATA DIGITS /'0','1','2','3','4','5','6','7','8','9'/ C EVAL = 0 START = 1 BITPHRASE = .FALSE. SIGN = 1 IF (TEXT(1) .NE. '&') GOTO 5 BITPHRASE = .TRUE. START = 2 5 IF (START .GT. ZLEN(TEXT)) GOTO 999 NEXTSIGN = 1 TERM = 0 I = START IF (TEXT(I) .EQ. '-') GOTO 200 DO 10 I=START,ZLEN(TEXT) 10 IF (TEXT(I) .EQ. '+' .OR. TEXT(I) .EQ. '-') GOTO 20 I = ZLEN(TEXT) + 1 20 J = I-START IF (J .GT. 13) J=13 CALL SCOPY(TEXT(START),TEMP,J) CALL STRPAD(TEMP,13) TERM = FIND(TEMP) IF (TERM .LT. 0) GOTO 50 UNREF(1) = ' ' CALL WRITEVIRTUAL(1,TERM) IF (TEXT(START) .EQ. '@') GOTO 25 TERM = KEYS(1) GOTO 200 25 TERM = AUXVAL GOTO 200 50 TERM = 0 IF (DIGITS(1) .GT. TEXT(START) .OR. + DIGITS(10) .LT. TEXT(START)) GOTO 100 DO 70 J=START, I - 1 IF (CMPSEP(TEXT(J)) .EQ. 0) GOTO 200 DO 60 K=1, 10 60 IF (TEXT(J) .EQ. DIGITS(K)) GOTO 65 CALL SNAPIT PLINE = PLINE + 1 WRITE (7,1,ERR=9999,END=9999) (TEMP(I1),I1=1,12) 1 FORMAT (' $ --Bad number: $ ',12A1,'$--$') TROUBLE = .TRUE. TERM = 0 GOTO 200 65 TERM = 10 * TERM + K - 1 70 CONTINUE GOTO 200 100 CALL SNAPIT PLINE = PLINE + 1 WRITE (7,2,ERR=9999,END=9999) (TEMP(I1),I1=1,12) 2 FORMAT (' $ --Undefined symbol: $ ',12A1,'$--$') TROUBLE = .TRUE. 200 START = I + 1 IF (I .GT. ZLEN(TEXT)) GOTO 205 IF (TEXT(I) .EQ. '-') NEXTSIGN = -1 205 CONTINUE IF (BITPHRASE) TERM = ISL(1,TERM) EVAL = EVAL + TERM * SIGN SIGN = NEXTSIGN GOTO 5 999 CONTINUE RETURN 9999 STOP 'Listing File Error' END INTEGER FUNCTION FIND(TEXT) IMPLICIT INTEGER(A-Z) LOGICAL*1 TEXT(14),TEXAN(14),NAME(14,6),UNREF(6) LOGICAL*1 REFIT(6),LINE(140),LEX(140) COMPLEX COMMAND(17),OPTIONS(56) DIMENSION OPTVAL(56),CLASS(56),CLASSCT(9),KEYS(5) LOGICAL*1 SEP,TAB,TROUBLE,LIST,LISTED,XREF,REFDEF(9),FID(16) COMMON /STRINGS/ NAME,LEX,COMMAND,OPTIONS,LINE, + NCLASS, SEP, UNREF, TAB, FID COMMON /UNITS/ INUNIT,TABLESIZE COMMON /VALUES/ KEYS, AUXVAL, LINEX, LINEND, KEY, CLASS, + NEXTOBJECT, NEXTPLACE, NEXTTEXT, NEXTVERB, NEXTVAR, + NEXTINIT, NEXTLABEL, NEXTREPEAT, SYMCNT, + CLASSCT, NEXTNULL, TROUBLE, LIST, REFIT, + OPTVAL, NREC, REFDEF, LISTED, XREF REAL*4 FLOAT C IF (TEXT(1) .EQ. '@') GOTO 6 CALL SCOPY(TEXT,TEXAN,12) GOTO 7 6 CALL SCOPY(TEXT(2),TEXAN,12) 7 CALL STRPAD(TEXAN,12) FIND = 0 DO 8, J=1,12 FIND = FIND * 2 + TEXAN(J) 8 CONTINUE IF (FIND .LT. 0) FIND = - (FIND + 1) IF (XREF) CALL XOUT(TEXAN,FID,NREC) 10 FIND = MOD(FIND, TABLESIZE) + 1 CALL READVIRTUAL(1,FIND) IF (NAME(1,1) .EQ. ' ') GOTO 99 IF (CEQUAL(NAME(1,1),TEXAN,12).EQ. 0) RETURN GOTO 10 99 FIND = -1 RETURN END SUBROUTINE DEFINE(TEXT, VAL, FLAG,FLAG1) IMPLICIT INTEGER(A-Z) LOGICAL*1 NAME(14,6),UNREF(6),REFIT(6),LINE(140),LEX(140) COMPLEX COMMAND(17),OPTIONS(56) DIMENSION OPTVAL(56),KEYS(5),CLASSCT(9),CLASS(56) LOGICAL*1 SEP,TAB,TROUBLE,LIST,LISTED,XREF,REFDEF(9),FID(16) COMMON /STRINGS/ NAME,LEX,COMMAND,OPTIONS,LINE, + NCLASS, SEP, UNREF, TAB, FID COMMON /UNITS/ INUNIT,TABLESIZE COMMON /VALUES/ KEYS, AUXVAL, LINEX, LINEND, KEY, CLASS, + NEXTOBJECT, NEXTPLACE, NEXTTEXT, NEXTVERB, NEXTVAR, + NEXTINIT, NEXTLABEL, NEXTREPEAT, SYMCNT, + CLASSCT, NEXTNULL, TROUBLE, LIST, REFIT, + OPTVAL, NREC, REFDEF, LISTED, XREF LOGICAL*1 TEXT(12),TEXAN(14) COMMON /LSTFX1/ PAGE,PLINE,CMCODE,OLDBP,WRDLST(50),WRDCNT COMMON /LSTFX2/ LSTBLK,LSTBYT REAL*4 FLOAT C CALL SCOPY (TEXT,TEXAN,12) CALL STRPAD (TEXAN,12) I = 0 DO 5, J=1,12 I = I * 2 + TEXAN(J) 5 CONTINUE IF (I .LT. 0) I = -(I + 1) IF (FLAG .EQ. 0) GOTO 10 IF (XREF) CALL XOUT(TEXAN,FID,NREC) 10 DO 100, J=1, TABLESIZE I = MOD(I, TABLESIZE) + 1 CALL READVIRTUAL(1,I) IF (CEQUAL(NAME(1,1),TEXAN,12) .EQ. 0) GOTO 900 IF (NAME(1,1) .EQ. ' ') GOTO 200 100 CONTINUE STOP 'Symbol table overflow - recompile' 200 CALL SCOPY (TEXAN,NAME(1,1),12) KEYS(1) = VAL AUXVAL = 0 REFIT(1) = REFDEF(VAL / 1000 + 1).OR.(FLAG1.EQ.1) UNREF(1) = '*' CALL WRITEVIRTUAL(1,I) RETURN 900 CALL SNAPIT PLINE = PLINE + 1 WRITE (7,2,ERR=9999,END=9999) 2 FORMAT (' $ -- Duplicate symbol$') TROUBLE = .TRUE. RETURN 9999 STOP 'Listing File Error' END LOGICAL FUNCTION INRANGE(I, J, K) INRANGE = (I .LE. J) .AND. (J .LT. K) RETURN END SUBROUTINE SETUP(I, J) I = J J = J + 1 RETURN END SUBROUTINE WRITE(IOKEY, KEY2, TEXT) IMPLICIT INTEGER(A-Z) LOGICAL*1 NAME(14,6),UNREF(6) LOGICAL*1 REFIT(6),LINE(140),LEX(140),TEXT(140) COMPLEX COMMAND(17),OPTIONS(56) DIMENSION OPTVAL(56),CLASS(56),CLASSCT(9),KEYS(5) LOGICAL*1 SEP,TAB,TROUBLE,LIST,LISTED,XREF,REFDEF(9),FID(16) COMMON /STRINGS/ NAME,LEX,COMMAND,OPTIONS,LINE, + NCLASS, SEP, UNREF, TAB, FID COMMON /VALUES/ KEYS, AUXVAL, LINEX, LINEND, KEY, CLASS, + NEXTOBJECT, NEXTPLACE, NEXTTEXT, NEXTVERB, NEXTVAR, + NEXTINIT, NEXTLABEL, NEXTREPEAT, SYMCNT, + CLASSCT, NEXTNULL, TROUBLE, LIST, REFIT, + OPTVAL, NREC, REFDEF, LISTED, XREF COMMON /F1DATA/ F1BLK,F1BYTE,F1BUFF C IF (TEXT(1).EQ.'*'.OR.(CEQUAL(TEXT,'>$<',3).EQ.0)) GOTO 20 L = ZLEN(TEXT) IF (L .LE. 80) GOTO 10 CALL SNAPIT WRITE (7,1,ERR=30,END=30) 1 FORMAT (' $ --String too long$') 10 CONTINUE CALL FASTWRITE(F1BYTE,F1BUFF,F1BLK,IOKEY, KEY2, TEXT) 20 CONTINUE RETURN 30 STOP 'Listing File Error' END INTEGER FUNCTION CMPSEP(CHAR) LOGICAL*1 CHAR C CMPSEP = 0 IF (CHAR .EQ. 9) RETURN IF (CHAR .EQ. ' ') RETURN CMPSEP = 1 RETURN END