SUBFILE: CODE1F.FS @15:59 23-MAY-1979 <055> (679) 'HEAD' PASS 1 CODE GENERATION C EDIT DATE 18JAN79 21:41 C SOURCE FILE CODE1FTM.FS C AUTHOR F. T. MICKEY C CLUSTER 21 'OUTFILE' BLDBLKFTM.FR SUBROUTINE BLDBLK (OBWORD, WFLAG) 'INCLUDE' LOGOSAJH.IN, 'INCLUDE' WFLAGSJHP.IN, 'INCLUDE' CODE1FTM.IN, 'INCLUDE' NLISTCFTM.IN, 'INCLUDE' LCONSTAJH.IN, INTEGER OBWORD, OW, WFLAG, WF, PRIORS INTEGER WFSTEP (17) LOGICAL NLTEST C 1 1 1 1 1 1 1 1 C 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 DATA WFSTEP / 1,0,0,1,2,0,0,3,0,0,0,0,0,0,0,0,0 / DATA PRIORS / 0/ OW = OBWORD WF = WFLAG 'IF' (WF .EQ. WF7 .OR. WF .EQ. WF12 ^ .OR. WF .EQ. WF13 .OR. WF .EQ. WF16) C NAME LIST INDEX 'IF' (OW .NE. 0) N = IAND (OW, 32767) 'IF' (NLTEST (N, REGBIT)) CALL FAULTP (35) // "ILLEGAL REGISTER USE" OW = NULLX 'ENDIF' 'IF' (N .EQ. STPTRX) CALL FAULTP (70) OW = NULLX 'ENDIF' CALL NLSET (N, USEBIT) 'ELSE' CALL FAULTP (10) // "MISSING NAME (OPERAND)" OW = NULLX 'ENDIF' 'ENDIF' 'EJECT' 'IF' (WF .NE. WF6 .OR. OW .NE. 0) WO (WOPTR) = WF WO (WOPTR+1) = OW WOPTR = WOPTR + 2 IF (WOPTR .GE. 64) CALL WRITWO CALL LIST (LOWWF, OW, WF) 'IF' (WF .EQ. WF5 .OR. WF .EQ. WF8) PRIORS = WFSTEP (WF) 'ELSE' 'IF' (WF .NE. WF6) IF (WF .EQ. WF7 .AND. PRIORS .EQ. 0) PRIORS = 2 LC = LC + WFSTEP (WF) + PRIORS PRIORS = 0 'ENDIF' 'ENDIF' 'ENDIF' IF (TLI .GE. 125) ^ CALL FAULTP (89) // "FLOWCHART TOO COMPLEX" RETURN END 'OUTFILE' WRITWOFTM.FR C C WRITE A BLOCK TO THE DISC SCRATCH FILE C SUBROUTINE WRITWO 'INCLUDE' CODE1FTM.IN, CALL WRSEQ (SS2, WO, 128) WOPTR = 1 RETURN END 'OUTFILE' WRBLOKFTM.FR C C WRITES THE LAST BLOCK TO SCRATCH, FOLOWED BY THE C TRANSFER LIST. C SUBROUTINE WRBLOK 'INCLUDE' WFLAGSJHP.IN, 'INCLUDE' CODE1FTM.IN, NRFCH = NRFCH + 1 CALL BLDBLK (0, WF3) IF (WOPTR .NE. 1) CALL WRITWO C WRITE TRANSFER LIST CALL WRSEQ (SS, TL, 256) TLI = 1 RETURN END 'OUTFILE' BLDOPFTM.FR SUBROUTINE BLDOP (OPIN, WF, BIAS, NLX, NLXWF) 'INCLUDE' WFLAGSJHP.IN, INTEGER OPIN, WF, BIAS, NLX, NLXWF CALL BLDBLK (BIAS, WF6) CALL BLDBLK (OPIN, WF) IF (WF .NE. WF4) CALL BLDBLK (NLX, NLXWF) RETURN END \\\\\ SUBFILE: SUTILF.FS @15:59 23-MAY-1979 <055> (1375) 'HEAD' STACK UTILITIES C EDIT DATE 10DEC78 20:26 C SOURCE FILE SUTILFTM.FS C AUTHOR A. J. HOWARD C CLUSTER 22 'OUTFILE' MSTAKFTM.FR SUBROUTINE MSTAK (INROW, OUTROW) INTEGER INROW, OUTROW INTEGER I 'INCLUDE' STKDEFA.IN, 'DOLOOP' I = 1, 13 STK (OUTROW, I) = STK (INROW, I) 'END' RETURN END 'OUTFILE' CLRSTKFTM.FR SUBROUTINE CLRSTK (ROW) INTEGER ROW INTEGER I 'INCLUDE' STKDEFA.IN, C CLEAR A STACK ROW 'DOLOOP' I = 1, 13 STK (ROW, I) = 0 'END' RETURN END 'OUTFILE' GENERFTM.FR SUBROUTINE GENER (FUNC) C PARAMETERS ARE PASSED IN 'ADDR' AND 'NAME' AS NEEDED. 'INCLUDE' LOGOSAJH.IN, 'INCLUDE' STKDEFA.IN, 'INCLUDE' STKDEFB.IN, 'INCLUDE' NLISTCFTM.IN, 'INCLUDE' REGSJHP.IN, 'INCLUDE' GENCOMFTM.IN, INTEGER TS, AS INTEGER FUNC LOGICAL NLTEST EXTERNAL OLSAV C SWITCH TABLE FOR GENERATE - FUNCTION IS PERFORMED, C AND GENERATE THEN EXITS TO CALLER. GENRET = 1 GO TO (10, ^ // TEST STACK 20, ^ // DO SWAP 30, ^ // DO TOP DP 40, ^ // DO NEXT DP 50, ^ // DO TOP SP 60, ^ // DO NEXT SP 70, ^ // DO SAVE FOR CALL 80, ^ // DO OUT 90, ^ // GET STACK POINTER 100, ^ // SET MODEX 110, ^ // SETX 120) ^ // CONVERT (SPTR) TO DP FUNC 'EJECT' C TEST STACK FOR REGISTER OR ACTIVE 10 TS = NAMEX (SPTR) IF (NLTEST (TS, REGBIT)) ^ RETURN CALL REGSRC (2, NAMEX (SPTR), MODE (SPTR), ^ SUBX (SPTR), SUBXM (SPTR), ^ BIAS (SPTR), GENRET) IF (GENRET .NE. AREG) GENRET = 0 RETURN C EXCHANGE TOP AND NEXT 20 TS = TOPX TOPX = NEXTX NEXTX = TS GOTO 110 // CALL SETX C TOP TO DP 30 RETURN C NEXT TO DP 40 RETURN C TOP TO SP 50 SPTR = TOPX GOTO 601 C NEXT TO SP 60 SPTR = NEXTX 601 MODE (SPTR) = SPMODE RETURN 'EJECT' C SAVE CT FOR SUBROUTINE CALL 70 CALL OVLOD (OLSAV) CALL GSAVE RETURN C OUT: SET STATUS AND STACK ENTRY TO REGISTER 80 'IF' (ACTHI .NE. 0) TS = AREG 'ELSE' TS = ACTLO 'ENDIF' 'IF' (TS .NE. 0) STATUS (TS) = OPX - 1 NAMEX (OPX - 1) = REGS (TS) SUBX (OPX - 1) = 0 BIAS (OPX - 1) = 0 'ENDIF' RETURN 90 RETURN C SET MODE INDEXES 100 RAWMDX = 2*MODE (TOPX) + MODE (NEXTX) + 1 MODEX = RAWMDX - (RAWMDX/3) RETURN C SETX 110 IF (TOPX .NE. 0) OPTOPX = NAMEX (TOPX) IF (NEXTX .NE. 0) OPNXTX = NAMEX (NEXTX) RETURN 120 RETURN END 'OUTFILE' GSAVEFTM.FR N OVERLAY OLSAV SUBROUTINE GSAVE C SAVE REGISTERS AND CT LOCATIONS FOR PROCEDURE CALL 'INCLUDE' STKDEFA.IN, 'INCLUDE' STKDEFB.IN, 'INCLUDE' LCFUNCAJH.IN, 'INCLUDE' NLNAMEFTM.IN, 'INCLUDE' NLISTCFTM.IN, 'INCLUDE' REGSJHP.IN, 'INCLUDE' TEMPSFTM.IN, 'INCLUDE' WFLAGSJHP.IN, INTEGER TS, AS, THIS, OTHER, TIMES, STKX INTEGER STAXY (3) INTEGER INDNAM DATA STAXY / 141, 142, 140/ 'IF' (ACTHI .NE. 0) // SAVE 'DP' AREG 'IF' (ACTHI .EQ. AREG) THIS = 1 OTHER = 0 'ELSE' THIS = 0 OTHER = 1 'ENDIF' N NAME (1) = 810 // <3>* P NAME (1) = 10755 // <3>* NLX = INDNAM (DTX, NOUNLC, 2) CALL BLDOP (141, WF8, THIS, NLX, WF7) // STAABS TS = ACTREG (OTHER+1) IF (TS .EQ. XREG) ^ CALL BLDOP (142, WF8, OTHER, NLX, WF7) // STXABS 'IF' (TS .GT. YREG) CALL BLDOP (165, WF5, OTHER, REGS (TS), WF7) // LDAZP CALL BLDOP (141, WF8, OTHER, NLX, WF7) // STAABS 'ENDIF' STKX = STATUS (AREG) NAMEX (STKX) = NLX STATUS (AREG) = 0 STATUS (TS) = 0 ACTHI = 0 'ENDIF' 'EJECT' // SAVE A, X, Y 'DOLOOP' AS = AREG, YREG STKX = STATUS (AS) 'IF' (STKX .NE. 0) N NAME (1) = 803 // <3># P NAME (1) = 8963 // <3># NLX = INDNAM (STX, NOUNLC, 1) CALL BLDOP (STAXY (AS), WF8, 0, NLX, WF7) STATUS (AS) = 0 NAMEX (STKX) = NLX 'ENDIF' 'END' ACTLO = 0 // SAVE COMPILER TEMPS 'DOLOOP' AS = 4, NRREGS STKX = STATUS (AS) 'IF' (STKX .NE. 0) 'IF' (MODE (STKX) .EQ. DPMODE) TIMES = 2 N NAME (1) = 810 // <3>* P NAME (1) = 10755 // <3>* NLX = INDNAM (DTX, NOUNLC, 2) 'ELSE' TIMES = 1 N NAME (1) = 803 // <3># P NAME (1) = 8963 // <3># NLX = INDNAM (STX, NOUNLC, 1) 'ENDIF' 'DOLOOP' THIS = 1, TIMES CALL BLDOP (165, WF8, THIS - 1, REGS (AS), WF7) // LDAZP CALL BLDOP (141, WF8, THIS - 1, NLX, WF7) // STAABS 'END' STATUS (AS) = 0 NAMEX (STKX) = NLX 'ENDIF' 'END' RETURN END \\\\\ SUBFILE: NLISTF.FS @15:59 23-MAY-1979 <055> (2927) 'HEAD' NAME LIST PROCESSING C EDIT DATE 11DEC78 16:29 C SOURCE FILE NLISTFTM.FS C AUTHOR F. T. MICKEY C CLUSTER 23 'OUTFILE' SNMLSTFTM.FR C INTEGER FUNCTION SNMLST C C SEARCH THE NAMELIST FOR AN ENTRY MATCHING THE CONTENTS C OF 'NAME'; IF FOUND, RETURN INDEX TO ENTRIES IN NLX. C IF NOT FOUND, RETURN INDEX OF EMPTY LIST ENTRY FOR USE C IN DEFINING NEW ENTRY. C INTEGER FUNCTION SNMLST (DUM) 'INCLUDE' NLNAMEFTM.IN, 'INCLUDE' NLISTCFTM.IN, 'INCLUDE' NLARAYFTM.IN, 'INCLUDE' LOGOSAJH.IN, INTEGER GETTX, ENTNUM, GCHAR, NLOPS INTEGER TS, DUM CALL SEARCH C SEE IF THIS IS FIRST HASH ADDRESS 'IF' (FNLX .EQ. 0) C YES, SAVE IT FNLX = NLX 'ENDIF' C IS IT A CONSTANT? CFLAG = IAND (NLIST (NLX), CBIT) 'IF' (CFLAG .NE. 0 .AND. GCHAR (NAME (1), 2) .GT. 1 ^ .AND. NLOC (NLX) .NE. -1) C IT MUST BE DEFINED, FLAG IT AS USED CALL NLSET (NLX, USEBIT) NLX = NLOC (NLX) TS = GETTX (NLX) 'IF' (GCHAR (NTEXT (TS), 2) .LE. 3) NUMBER = NLOPS (CVALUE, NLX) NLX = ENTNUM (DUMMY) 'ENDIF' 'ENDIF' SNMLST = NLX RETURN END 'OUTFILE' SOPLSTFTM.FR C INTEGER FUNCTION SOPLST C C SEARCH NAME LIST FOR LOGOS OPERATOR C INTEGER FUNCTION SOPLST (DUM) 'INCLUDE' LOGOSAJH.IN, 'INCLUDE' NLNAMEFTM.IN, 'INCLUDE' NLISTCFTM.IN, 'INCLUDE' NLARAYFTM.IN, 'INCLUDE' OPERSAJH.IN, INTEGER NLXTS, TS, DUM INTEGER GCHAR NLXTS = NLX C SET OP BIT IN NAME, THEN SEARCH NAME LIST TS = GCHAR (NAME, 1) TS = TS + OPBIT CALL PCHAR (NAME, 1, TS) 'IF' (PSYMB .NE. GIZZY) C "ILLEGAL 'XXX' OPERATOR" CALL FAULTP (9) 'ENDIF' CALL SEARCH SOPLST = NLOC (NLX) 'IF' (SOPLST .EQ. -1) C NOT A DEFINED OPERATOR CALL FAULTP (9) SOPLST = COMMA 'ENDIF' NLX = NLXTS RETURN END 'OUTFILE' SLISTFTM.FR C SUBROUTINE SLIST C C GIVEN INITIAL HASH INDEX, FIND NAME TEXT MATCH OR EMPTY ENTRY C SUBROUTINE SLIST 'INCLUDE' NLNAMEFTM.IN, 'INCLUDE' NLISTCFTM.IN, 'INCLUDE' NLARAYFTM.IN, INTEGER SRCHF, TS, ITS INTEGER GETTX SRCHF = 0 C GET NAME TEXT INDEX FOR THIS ENTRY 1 TS = GETTX (NLX) 'IF' (TS .NE. 0) C COMPARE TARGET NAME TO NAME TEXT 'DOLOOP' ITS = 1, NLWRDS 'IF' (NTEXT (TS) .NE. NAME (ITS)) C NO MATCH, NEXT ENTRY NLX = NLX + 1 'IF' (NLX .LT. NLSTOP) C STILL BELOW TOP OF NAMELIST IF (SRCHF .EQ. 0 .OR. NLX .LT. SRCHST) GO TO 1 C CALL FATAL (19) 'ELSE' C TOP OF NAME LIST, START AGAIN FROM BOTTOM SRCHF = SRCHF + 1 NLX = NLSTRT GO TO 1 'ENDIF' 'ELSE' C MATCH SO FAR, KEEP COMPARING NAMES TS = TS + 1 'ENDIF' 'END' 'ENDIF' C NAME MATCH, RETURN INDEX IN NLX RETURN END 'OUTFILE' SEARCHFTM.FR C SUBROUTINE SEARCH C C CALCULATE INITIAL HASH INDEX, THEN CALL SLIST; C IF NAME NOT DEFINED, ENTER IT IN EMPTY SLOT C RETURNED BY SLIST. C SUBROUTINE SEARCH 'INCLUDE' NLNAMEFTM.IN, 'INCLUDE' NLISTCFTM.IN, 'INCLUDE' NLARAYFTM.IN, 'INCLUDE' LOGOSAJH.IN, INTEGER ITS, KTS, NTEMP INTEGER GCHAR, MODTXT, CLOCN LOGICAL NLTEST ITS = I KTS = K NTEMP = GCHAR (NAME, 1) 'IF' ((PARFLG .NE. 0 .OR. SPARFL .NE. 0) ^ .AND. IAND (OPBIT, NTEMP) .EQ. 0) C NOT IDENTIFIED AS PARAMETER OR OPERATOR, CHECK FOR C LOCAL PARAMETER DEFINITION FIRST NTEMP = NTEMP + PARBIT CALL PCHAR (NAME, 1, NTEMP) 'ENDIF' NLWRDS = ISHFT (IAND (NTEMP, 31), -1) + 1 'DO' C CALCULATE HASH ADDRESS NLX = 0 'DOLOOP' I = 1, NLWRDS NLX = NLX + IAND (NAME (I), 16191) // = 03F3F 'END' NLX = IAND (ISHFT (NLX, -8) + ISHFT (NLX, 8), 32767) NLX = MOD (NLX, NLSIZE) + 1 SRCHST = NLX CALL SLIST 'IF' (NTEXTX (NLX) .EQ. 0) C NOT IN NAMELIST YET, ENTER IT 'WHILE' (SPARFL .NE. 0 .AND. IAND (NTEMP, PARBIT) .NE. 0) C LOCAL NAME NOT FOUND, TRY GLOBAL NAME NTEMP = NTEMP - PARBIT CALL PCHAR (NAME, 1, NTEMP) 'END' NTEXTX (NLX) = NTSTRT TX = NTSTRT NTSTRT = TX + NLWRDS C 'IF' (NTSTRT .GE. NTSTOP) C NAME TEXT OVERFLOW C NTEXTX (NLX) = -1 C TX = MODTXT (DUMMY) C 'ENDIF' IF (NTSTRT .GE. NTSTOP) CALL FATAL (19) NLENO = NLENO + 1 CALL MOVE (NAME, NTEXT (TX), NLWRDS) NLIST (NLX) = ISHFT (STDMD, MSHIFT) NLOC (NLX) = -1 'ELSE' IF (NLTEST (NLX, REGBIT)) ^ REGCNT = REGCNT + 1 'IF' (PARFLG .NE. 0 .AND. IAND (NTEMP, OPBIT) .EQ. 0) C PARAMETER ERROR FNLX = NLX CALL FAULTP (18) 'ENDIF' 'ENDIF' I = ITS K = KTS RETURN END 'OUTFILE' ENTNUMFTM.FR C INTEGER FUNCTION ENTNUM C C DEFINE THE BINARY VALUE OF 'NUMBER' AS NAME IN NAME LIST C INTEGER FUNCTION ENTNUM (DUM) 'INCLUDE' NLISTCFTM.IN, 'INCLUDE' NLNAMEFTM.IN, 'INCLUDE' LOGOSAJH.IN, INTEGER DUM C SET LENGTH = 3 CHARACTERS, CHAR 1 = 01 CALL PCHAR (NAME, 1, 3) CALL PCHAR (NAME, 2, 1) ENFLAG = 0 NAME (2) = NUMBER 'IF' (NUMBER .LT. 0 .OR. NUMBER .GT. 255 ^ .OR. SPECMD .EQ. DPMODE) C CONSTANT MUST BE DOUBLE PRECISION ENFLAG = DPBIT 'ENDIF' CALL SEARCH 'IF' (ENFLAG .NE. 0) C MODE NEEDS TO BE SET CALL NLVAL (NLX, ENFLAG, MDMASK) 'ENDIF' CFLAG = CBIT CALL NLSET (NLX, CBIT) 'IF' (FNLX .EQ. 0) C SET INDEX OF FIRST NAME LIST ENTRY FNLX = NLX 'ENDIF' ENTNUM = NLX RETURN END 'OUTFILE' NLOPSFTM.FR C INTEGER FUNCTION NLOPS C C ACCEPTS A FUNCTION CODE FOR THE FOLLOWING FUNCTIONS: C DFINED 1 DEFINED C CVALUE 2 CVALUE C NLXLCI 3 NLX LCI C ENEXDT 4 ENTER EXTD C NAMAT0 5 NAME AT ZERO C NAMCON 6 NAME CONSTANT C NLMODE 7 NL MODE C NAMLOC 8 NAME LOCATION C REGNUM 9 REGISTER NUMBER C C THE NAME LIST INDEX IS EXPLICITLY PASSED AS THE SECOND C PARAMETER. ENEXTD RETURNS NO FUNCTION VALUE; ALL OTHER C FUNCTIONS EXCEPT NLMODE PLACE THE VALUE RETURNED IN ENFLAG. C INTEGER FUNCTION NLOPS (FUNC, INDEX) 'INCLUDE' NLISTCFTM.IN, 'INCLUDE' NLARAYFTM.IN, INTEGER FUNC, INDEX, TS INTEGER GETTX, GCHAR LOGICAL NLTEST C CHOOSE FUNCTION GO TO (100, 200, 300, 400, 500, 600, 700, 800, 900) FUNC C DFINED 100 'IF' (NLOC (INDEX) .EQ. -1 ^ .AND. IAND (NLIST (INDEX), LCMASK) .EQ. 0) NLOPS = 0 'ELSE' NLOPS = 1 'ENDIF' RETURN C CVALUE 200 NLOPS = GETTX (INDEX) + 1 NLOPS = NTEXT (NLOPS) RETURN C NLXLCI 300 NLOPS = IAND (NLIST (INDEX), LCMASK) RETURN C ENEXTD 400 CALL NLSET (INDEX, EXDBIT) RETURN 'EJECT' C NAMAT0 500 'IF' (IAND (NLIST (INDEX), LCMASK + PBIT) .EQ. LCMASK) NLOPS = NLOC (INDEX) 'ELSE' NLOPS = 1 'ENDIF' RETURN C NAMCON 600 TS = GETTX (INDEX) TS = GCHAR (NTEXT (TS), 2) 'IF' (NLTEST (INDEX, CBIT) .AND. TS .GT. 3) NLOPS = 1 'ELSE' NLOPS = 0 'ENDIF' RETURN C NLMODE 700 NLOPS = ISHFT (IAND (NLIST (INDEX), MDMASK), -MSHIFT) RETURN C LOCATION OR REGISTER NUMBER 800 CONTINUE 900 NLOPS = NLOC (INDEX) RETURN END 'OUTFILE' GETTXFTM.FR C SUBROUTINE GETTX C C ACCEPTS AN EXPLICIT NAME LIST INDEX AND, IF THE NAME TEXT C FOR THAT ENTRY RESIDES ON DISC, RETRIEVES THE TEXT FOR C USE. C INTEGER FUNCTION GETTX (INDEX) 'INCLUDE' NLISTCFTM.IN, 'INCLUDE' NLARAYFTM.IN, INTEGER INDEX TX = NTEXTX (INDEX) C*****IF TEXT IS ON DISC, CALL 'TEXT FROM FILE' GETTX = TX RETURN END 'OUTFILE' CLOCNFTM.FR C INTEGER FUNCTION CLOCN C C ACCEPTS AN EXPLICIT NAME LIST INDEX AND CONVERTS THE NAME C (OR, FOR CONSTANTS, THE VALUE) INTO ASCII IN ARRAY 'NAME'. C THE RETURN VALUE IS THE CHARACTER COUNT. C INTEGER FUNCTION CLOCN (INDEX) 'INCLUDE' NLISTCFTM.IN, 'INCLUDE' NLARAYFTM.IN, 'INCLUDE' NLNAMEFTM.IN, 'INCLUDE' LOGOSAJH.IN, INTEGER II, ITX, INDEX INTEGER GETTX, GCHAR, NLOPS CALL SET (XBBL, NAME, 9) ITX = GETTX (INDEX) CLOCN = IAND (GCHAR (NTEXT (ITX), 1), 31) 'IF' (GCHAR (NTEXT (ITX), 2) .GT. 3) C NAME, CONVERT ASCII 'DOLOOP' II = 1, CLOCN CALL PCHAR (NAME, II, GCHAR (NTEXT (ITX), II+1)) 'END' 'ELSE' CALL EHX (NLOPS (CVALUE, INDEX), NAME, 1, 6) CLOCN = 6 'ENDIF' RETURN END 'OUTFILE' MODTXTFTM.FR C INTEGER FUNCTION MODTXT C C DUMMY FOR NOW C INTEGER FUNCTION MODTXT (INDEX) 'INCLUDE' NLISTCFTM.IN, 'INCLUDE' NLARAYFTM.IN, INTEGER INDEX MODTXT = NTEXTX (INDEX) TX = MODTXT RETURN END 'OUTFILE' NLSCANFTM.FR SUBROUTINE NLSCAN (PROG, INDEX) 'INCLUDE' NLISTCFTM.IN, 'INCLUDE' NLARAYFTM.IN, INTEGER NLEND, TS INTEGER GETTX, GCHAR LOGICAL NLTEST INTEGER INDEX NLEND = NLSTOP 'DOLOOP' INDEX = NLSTRT, NLEND TS = GETTX (INDEX) 'IF' (TS .NE. 0) TS = GCHAR (NTEXT (TS), 1) 'IF' (NTEXTX (INDEX) .NE. 0 ^ .AND. .NOT. NLTEST (INDEX, REGBIT) ^ .AND. IAND (TS, OPBIT) .EQ. 0) CALL PROG 'ENDIF' 'ENDIF' 'END' RETURN END 'OUTFILE' NDEFNFTM.FR C SUBROUTINE NDEFN C C CHECKS FOR PRIOR USE OF NAME AT TIME OF DEFINITION C SUBROUTINE NDEFN 'INCLUDE' LOGOSAJH.IN, 'INCLUDE' OPERSAJH.IN, 'INCLUDE' NLISTCFTM.IN, 'INCLUDE' NLARAYFTM.IN, 'INCLUDE' BLDPOAJH.IN, 'INCLUDE' LCONSTAJH.IN, INTEGER NTEMP INTEGER NLOPS 'IF' (NLOPS (DFINED, NLX) .NE. 0) C NAME HAS BEEN DEFINED 'IF' (NLOC (NLX) .EQ. LC ^ .AND. IAND (NLIST (NLX), LCMASK) .EQ. LCI) C ENTRY POINT CALL NLSET (NLX, EPBIT) 'ELSE' CALL FAULTP (18) 'ENDIF' 'ELSE' CALL PUSH (NLX, TX, TX) NLX = FNLX IF (NLOPS (NAMCON, NLX) .NE. 0) CALL FAULTP (18) CALL POP (NLX, TX, TX) CALL LIST (LLNAME, NLX, 0) NTEMP = NLIST (NLX) 'IF' (DEFMOD .NE. STDMD ^ .AND. IAND (NTEMP, MDMASK + STRBIT) ^ .EQ. ISHFT (STDMD, MSHIFT)) C STANDARD MODE, CHECK FOR ILLICIT USE 'IF' (DEFMOD .EQ. DPMODE ^ .AND. IAND (NTEMP, IOBIT + ARBIT) .NE. 0 ^ .OR. DEFMOD .GT. DPMODE ^ .AND. IAND (NTEMP, IOBIT) .NE. 0) C "NAME USED BEFORE DEFINITION" CALL FAULTP (17) 'ENDIF' 'ENDIF' NLIST (NLX) = IOR (ISHFT (DEFMOD, MSHIFT) + LCI + TPFLAG, ^ IAND (NTEMP, NOT (MDMASK + EXDBIT))) IF (IOTYPE .EQ. ST) ^ CALL NLSET (NLX, STRBIT) NLOC (NLX) = LC 'ENDIF' RETURN END \\\\\ SUBFILE: NLINIT.FS @15:59 23-MAY-1979 <055> (862) 'HEAD' NAME LIST INITIALIZATION C EDIT DATE 10DEC78 20:42 C SOURCE FILE NLINITFTM.FS C AUTHOR F. T. MICKEY C CLUSTER 23 'OUTFILE' NLINITFTM.FR N OVERLAY OLNLI C SUBROUTINE NLINIT C C INITIALIZE THE NAME LIST WITH REGISTER AND C OPERATOR DEFINITIONS. C SUBROUTINE NLINIT 'INCLUDE' LOGOSAJH.IN, 'INCLUDE' BRACEFTM.IN, 'INCLUDE' REGSJHP.IN, 'INCLUDE' NLISTCFTM.IN, 'INCLUDE' NLARAYFTM.IN, 'INCLUDE' NLNAMEFTM.IN, INTEGER GCHAR, SNMLST INTEGER TS, PTR, COUNT, OP, REG, II, RETRN INTEGER NAMIN (179) DATA NAMIN /4, 'AREG', 1, 4, 'XREG', 2, ^ 4, 'YREG', 3, 6, 'STKPTR', 4, ^ 9, 'REMAINDER', -1, ^ 3, 'CT0', -1, 3, 'CT1', -1, ^ 3, 'CT2', -1, 3, 'CT3', -1, ^ 3, 'CT4', -1, 3, 'CT5', -1, ^ 3, 'CT6', -1, ^ 3, 'FL0', -1, 3, 'FL1', -1, ^ 3, 'FL2', -1, 3, 'FL3', -1, ^ 3, 'FL4', -1, 3, 'FL5', -1, ^ 7, '.NULLX.', 0, ^ 3, 'FOR', 6, 2, 'DO', 7, ^ 5, 'WHILE', 8, 3, 'END', 9, ^ 3, 'RBR', 9, 3, 'LBR', 10, ^ 6, 'RETURN', 11, 3, 'MOD', 28, ^ 2, 'OR', 29, 3, 'AND', 30, ^ 3, 'XOR', 32, 3, 'DEC', 42, ^ 2, 'LS', 34, 2, 'RS', 35, ^ 2, 'LC', 36, 2, 'RC', 37, ^ 3, 'ALS', 38, 3, 'ARS', 39, ^ 3, 'COM', 43, 3, 'LOC', 44, ^ 4, 'ZREL', 47, 2, 'TP', 48, ^ 2, 'SP', 49, 2, 'DP', 50, ^ 2, 'ST', 51, 3, 'HEX', 52, ^ 0/ 'EJECT' C DEFINE AREG, XREG, YREG PTR = 1 ASSIGN 100 TO RETRN OP = 0 REGBIT = ISHFT (1, 15) REG = REGBIT 'DOLOOP' TS = 1, 3 GOTO 1000 100 REGS (TS) = NLX 'END' REG = 0 C DEFINE THE NAME LIST INDEX TO THE STACK POINTER 'STK PTR' ASSIGN 200 TO RETRN GO TO 1000 200 STPTRX = NLX C DEFINE THE NAME LIST INDEX TO 'REMAINDER' ASSIGN 210 TO RETRN GO TO 1000 210 REMNLX = NLX C PUT THE CT NAMES IN THE LIST ASSIGN 300 TO RETRN 'DOLOOP' TS = 4, 10 REG = DPBIT + EXDBIT GO TO 1000 300 REGS (TS) = NLX 'END' NRREGS = 10 // MAXIMUM AVAILABLE C PUT THE FL NAMES IN THE NAME LIST ASSIGN 400 TO RETRN 'DOLOOP' TS = 1, 6 REG = DPBIT + EXDBIT GO TO 1000 400 FLS (TS) = NLX 'END' C DEFINE A NAME AT ABSOLUTE 0 REG = LCMASK ASSIGN 500 TO RETRN GO TO 1000 500 NULLX = SNMLST (TS) C PUT THE OPERATORS IN THE NAME LIST OP = OPBIT REG = 0 ASSIGN 600 TO RETRN 'DO' 'WHILE' (NAMIN (PTR) .NE. 0) GOTO 1000 600 CONTINUE 'END' RETURN 'EJECT' 1000 COUNT = NAMIN (PTR) PTR = PTR + 1 'DOLOOP' II = 1, COUNT CALL PCHAR (NAME, II+1, GCHAR (NAMIN (PTR), II)) 'END' CALL PCHAR (NAME, COUNT+2, XBBL) CALL PCHAR (NAME, 1, IOR (COUNT, OP)) PTR = PTR + (COUNT + 1)/2 II = SNMLST (II) NLIST (NLX) = IOR (NLIST (NLX), REG) NLOC (NLX) = NAMIN (PTR) PTR = PTR + 1 GOTO RETRN END \\\\\ SUBFILE: NLTEST.FS @15:59 23-MAY-1979 <055> (436) 'HEAD' NAME LIST FLAG TEST C EDIT DATE 14JAN79 09:16 C SOURCE FILE NLTESTAJH.FS C AUTHOR A. J. HOWARD C CLUSTER 23 'OUTFILE' NLTESTAJH.FR LOGICAL FUNCTION NLTEST (INDEX, FLAG) INTEGER INDEX, FLAG 'INCLUDE' NLARAYFTM.IN, NLTEST = IAND (NLIST (INDEX), FLAG) .NE. 0 RETURN END 'OUTFILE' NLSETAJH.FR SUBROUTINE NLSET (INDEX, FLAG) INTEGER INDEX, FLAG 'INCLUDE' NLARAYFTM.IN, IF (INDEX .NE. 0) ^ NLIST (INDEX) = IOR (NLIST (INDEX), FLAG) RETURN END 'OUTFILE' NLVALAJH.FR SUBROUTINE NLVAL (INDEX, VALUE, MASK) INTEGER INDEX, VALUE, MASK 'INCLUDE' NLARAYFTM.IN, IF (INDEX .NE. 0) ^ NLIST (INDEX) = IOR (IAND (NLIST (INDEX), NOT (MASK) ), ^ VALUE) RETURN END 'OUTFILE' INDNAMFTM.FR C SUBROUTINE INDNAM C C FORMS A TWO-LETTER NAME EXTENSION FOR COMPILER C TEMPORARY LABELS, BASED ON INDEX; THE BASE IS C 'AA'. C INTEGER FUNCTION INDNAM (INDEX, DEFLC, SIZE) 'INCLUDE' NLISTCFTM.IN, 'INCLUDE' NLNAMEFTM.IN, 'INCLUDE' LCFUNCAJH.IN, 'INCLUDE' LCONSTAJH.IN, 'INCLUDE' LOGOSAJH.IN, INTEGER INDEX, DEFLC, SIZE INTEGER TS, ITS, AS INTEGER SNMLST DATA AS /'AA'/ CALL RBOTH (DEFLC) ITS = MOD (INDEX, 26) TS = INDEX/26 INDEX = INDEX + 1 NAME (2) = ISHFT (ITS, 8) + TS + AS FNLX = SNMLST (DUMMY) CALL NDEFN INDNAM = NLX 'IF' (SIZE .NE. 0) CALL LIST (LBSS, SIZE, 0) LC = LC + SIZE CALL RBOTH (CODE) 'ENDIF' RETURN END \\\\\ SUBFILE: PRINTF.FS @15:59 23-MAY-1979 <055> (409) 'HEAD' PRINT ROUTINES C EDIT DATE 12DEC78 13:10 C SOURCE FILE PRINTFTM.FS C AUTHOR F. T. MICKEY C CLUSTER 24 'OUTFILE' SGLPRTFTM.FR C C PRINT THE CONTENTS OF LBUF TO THE PRINTER, SINGLE-SPACED C SUBROUTINE SGLPRT 'INCLUDE' LOGOSAJH.IN, 'INCLUDE' CTRLAJH.IN, 'INCLUDE' PRTCOMFTM.IN, INTEGER II, MAXLIN DATA MAXLIN /58/ 'IF' (PRINTF .NE. 0) 'FOR' (II = 66; II .GT. 1; II = II - 1) 'IF' (LBUF (II) .EQ. XBBL) // STRIP OFF TRAILING SPACES 'END' 'ENDIF' CALL WRLIN (LO, LBUF, 2*II) LCOUNT = LCOUNT + 1 'IF' (LCOUNT .GE. MAXLIN) CALL NPAGE 'ENDIF' 'ENDIF' CALL SET (XBBL, LBUF, 66) RETURN END 'OUTFILE' NPAGEFTM.FR C C STARTS NEW PAGE AND PRINTS HEADER C SUBROUTINE NPAGE 'INCLUDE' CTRLAJH.IN, 'INCLUDE' LOGOSAJH.IN, 'INCLUDE' PRTCOMFTM.IN, INTEGER FORM, BLINE, PAGE (2) DATA FORM /3072/ // '<0>' DATA BLINE /' '/ DATA PAGE /'PAGE'/ 'IF' (PRINTF .NE. 0) PGECNT = PGECNT + 1 CALL SET (XBBL, LBUF, 66) CALL WRLIN (LO, FORM, 2) CALL EST (PAGE, LBUF, 1, 4) CALL ESP (PGECNT, LBUF, 1, 9) CALL EST (UHEAD, LBUF, 19, 48) CALL EST (CHEAD, LBUF, 72, 87) CALL DATE (LBUF (45)) CALL TIME (LBUF (53)) CALL WRLIN (LO, LBUF, 114) CALL WRLIN (LO, BLINE, 2) // BLANK LINE LCOUNT = 1 CALL SET (XBBL, LBUF, 66) 'ENDIF' RETURN END \\\\\ SUBFILE: FAULTF.FS @15:59 23-MAY-1979 <055> (1994) 'HEAD' ERROR PROCESSING C EDIT DATE 18JAN79 21:02 C SOURCE FILE FAULTFTM.FS C AUTHOR F. T. MICKEY C CLUSTER 25 'OUTFILE' FAULTPFTM.FR SUBROUTINE FAULTP (FAULT) 'INCLUDE' CTRLAJH.IN, 'INCLUDE' FAULTSFTM.IN,P INTEGER FAULT EXTERNAL OLFLT 'IF' (CTLUSE .NE. 0) CTLERR = FAULT 'ELSE' FLTNR = FAULT CALL OVLOD (OLFLT) CALL OFAULT EXFLT = 0 'ENDIF' RETURN END 'OUTFILE' FATALFTM.FR SUBROUTINE FATAL (ERROR) INTEGER ERROR 'INCLUDE' CTRLAJH.IN, EXTERNAL OLPS2 CTLUSE = 0 CALL FAULTP (ERROR) CALL OVLOD (OLPS2) CALL QUIT STOP END 'OUTFILE' OBJFLTAJH.FR SUBROUTINE OBJFLT (FAULT) 'INCLUDE' LOGOSAJH.IN, 'INCLUDE' OBJECTAJH.IN, 'INCLUDE' PRTCOMFTM.IN, INTEGER FAULT INTEGER MSGS (16, 6) DATA MSGS / ^ 'SEE SYSTEMS PROGRAMMING **1** ',^ // 1 'ILLEGAL INSTRUCTION FORMAT ',^ // 2 'SEE SYSTEMS PROGRAMMING **3** ',^ // 3 'BRANCH ADDRESSING ERROR ',^ // 4 'ADDRESS OUT OF RANGE (PASS 2) ',^ // 5 'MISSING ENTRY POINT DEFINITION '/ // 6 CALL EHX (LC, LBUF, 1, 4) // LOCATION COUNTER VALUE CALL EHX (NEWLCI, LBUF, 6, 9) // LOCATION COUNTER CALL EHX (OW, LBUF, 11, 14) // OBJECT WORD CALL ESP (WF, LBUF, 1, 20) // WORD FLAG CALL EHX (RWORD1, LBUF, 22, 25) // OUTPUT BLOCK 1, 2, 3 CALL EHX (RWORD2, LBUF, 27, 30) CALL EHX (RWORD3, LBUF, 32, 35) CALL WRLIN (CO, LBUF, 36) CALL SGLPRT CALL EST ('**ERROR**', LBUF, 1, 9) CALL EST (MSGS (1, FAULT), LBUF, 11, 42) CALL WRLIN (CO, LBUF, 43) CALL SGLPRT CALL SGLPRT FLTCNT = FLTCNT + 1 RETURN END 'OUTFILE' OFLTAPB.FR N OVERLAY OLFLT SUBROUTINE OFAULT INTEGER PFLTS 'INCLUDE' LOGOSAJH.IN, 'INCLUDE' PRTCOMFTM.IN, 'INCLUDE' CTRLAJH.IN, 'INCLUDE' SRCDFSFTM.IN, 'INCLUDE' FAULTSFTM.IN, 'INCLUDE' FLMSGAPB.IN, PFLTS = PRINTF 'IF' (PFLTS .EQ. 0) C PRINT THE LINE IN ERROR CALL ESP (PGECNT, LBUF, 1, 4) CALL ESP (FLINCT (PI), LBUF, 1, 8) CALL EST (RECORD, LBUF, 11, 90) PRINTF = 1 CALL SGLPRT 'ENDIF' C PRINT THE ERROR MESSAGE CALL SGLPRT CALL EST ('**ERROR**', LBUF, 1, 9) CALL EST (MSGS (1, FLTNR), LBUF, 11, 42) IF (EXFLT .NE. 0) ^ CALL ESP (EXFLT, LBUF, 1, 54) CALL WRLIN (CO, LBUF, 55) CALL SGLPRT CALL SGLPRT FLTCNT = FLTCNT + 1 PRINTF = PFLTS RETURN END 'OUTFILE' FMSGDATA.FR BLOCK DATA 'INCLUDE' FLMSGAPB.IN,P 'EJECT' DATA MSG01/^ ' ',^ ' ',^ 'MISSING OPERATOR AFTER ) ',^ 'ILLEGAL NOUN LIST CONSTRUCTION ',^ 'ILLEGAL USE OF NAME ',^ 'SEE SYSTEMS PROGRAMMING **6** ',^ 'TOO MANY RELATIONALS (30) ',^ 'ILLEGAL OPERATOR PAIR ',^ 'ILLEGAL XXX OPERATOR ',^ 'MISSING NAME (OPERAND) '/ DATA MSG11/^ 'CONSTANT EXPRESSION REQUIRED ',^ 'MISSING RIGHT BRACE(S) ',^ 'TOO MANY EQUIVALENT NAMES (50) ',^ 'EXTRA RIGHT BRACES ',^ 'DP ARS/ALS NOT IMPLEMENTED ',^ 'ILLEGAL MODE/TYPE OPERATOR USE ',^ 'NAME USED BEFORE DEFINITION ',^ 'MULTIPLE NAME DEFINITION ',^ 'TOO MANY NAMES (499) ',^ 'ILLEGAL OPERATOR AFTER NAME '/ DATA MSG21/^ ' ',^ 'MISSING ASM ; ',^ 'STORE INTO/INCREMENT A CONSTANT ',^ 'MISSING OPERATOR AFTER STRING ',^ 'MISSING COMPARISON TERMINATORS ',^ 'MISSING OPERATOR AFTER NUMBER ',^ 'ILLEGAL ASM OP CODE ',^ 'STRING TOO LONG (200 CHARS) ',^ ' ',^ 'MISSING INITIAL VALUE '/ DATA MSG31/^ 'ILLEGAL SUBSCRIPT ',^ 'MISSING OPERATOR AFTER SUBSCRIPT',^ 'MISSING COLON IN I/O STATEMENT ',^ 'ILLEGAL RELATIONAL OPERATOR ',^ 'ILLEGAL REGISTER USE ',^ 'ILLEGAL & OR OR CONNECTOR ',^ 'TOO MANY COMPARISONS (9) ',^ ' ',^ 'SP LSS 0 OR GEQ 0 ',^ ' '/ DATA MSG41/^ 'MISSING SUBSCRIPT OPERAND ',^ 'ILLEGAL SP INDIRECT JUMP ',^ 'ILLEGAL LT,GT IN QUOTE ',^ ' ',^ 'STACK OVERFLOW (FATAL) ',^ 'STACK UNDERFLOW (FATAL) ',^ ' ',^ 'NAME TEXT OVERFLOW (3000 CHARS) ',^ 'MISSING SUBSCRIPT WITH TP ',^ 'EXTRA OPERAND '/ 'EJECT' DATA MSG51/^ ' ',^ 'TOO MANY PARAMETERS DEFINED (6) ',^ 'INTERNAL ERROR-- BRACE STACK ',^ 'ILLEGAL NESTED FUNCTION ',^ 'TOO MANY LABELS IN FUNCTION (10)',^ ' ',^ 'TOO MANY COMMON BLOCKS (9) ',^ 'MISSING LEFT BRACE ',^ 'TOO MANY LEFT BRACES (10) ',^ 'MISSING ) OR ] '/ DATA MSG61/^ 'EXTRA ] ',^ 'EXTRA ) ',^ 'EXTRA ; ',^ 'JUMP OR CALL TO A CONSTANT ',^ 'SUBSCRIPTED CONSTANT ',^ 'ILLEGAL USE OF LOC OPERATOR ',^ 'ILLEGAL USE OF RETURN OPERATOR ',^ 'ILLEGAL USE OF ZREL OPERATOR ',^ 'NO FREE REGISTER (FATAL) ',^ 'ILLEGAL STKPTR USAGE '/ DATA MSG71/^ 'ILLEGAL CONTROL DIRECTIVE NAME ',^ 'ERROR WITHIN CONTROL DIRECTIVE ',^ 'INVALID ORG DIRECTIVE ',^ 'USE FILE DOES NOT EXIST ',^ 'ILLEGAL CRUTCH FORMAT ',^ ' ',^ ' ',^ ' ',^ 'UNEXPECTED FLOWCHART END ',^ 'UNEXPECTED END DIRECTIVE '/ DATA MSG81/^ '... ERROR IN SCAN (FATAL) ',^ 'UNEXPECTED EOF ',^ ' ',^ ' ',^ ' ',^ 'NUMBER TOO LARGE ',^ 'WARNING OF INCOMPATIBILITY ',^ 'ILLEGAL SOURCE CHARACTER ',^ 'FLOWCHART TOO COMPLEX ',^ ' '/ END 'OUTFILE' SCANAJH.FR SUBROUTINE SCAN (MATCH, LOW, HIGH) INTEGER MATCH, LOW, HIGH EXTERNAL OLSCN CALL OVLOD (OLSCN) CALL OSCAN (MATCH, LOW, HIGH) RETURN END 'OUTFILE' OSCANAJH.FR N OVERLAY OLSCN SUBROUTINE OSCAN (MATCH, LOW, HIGH) INTEGER MATCH, LOW, HIGH 'INCLUDE' LOGOSAJH.IN, 'INCLUDE' OPERSAJH.IN, 'INCLUDE' SRCXDFFTM.IN, SCFLAG = 1 // PRINT ////ES//// ON LINES 'DO' 'IF' (PSYMB .EQ. PERIOD) CALL PEEK IF (PEEKS .EQ. PERIOD) ^ CALL FATAL (81) // CAN'T COPE WITH FC END 'ENDIF' 'IF' ( (PSYMB .EQ. MATCH) ^ .OR. (LOW .LT. PSYMB .AND. PSYMB .LT. HIGH)) C FOUND A GOOD PLACE TO STOP SCFLAG = 0 CUROP = COMMA NEXTOP = PSYMB 'BREAK' 'ENDIF' 'IF' (PSYMB .EQ. QUOTE) 'DO' // SKIP OVER A QUOTE STRING CALL FNZS 'WHILE' (PSYMB .NE. QUOTE) 'END' 'ENDIF' CALL FNZS 'END' RETURN END \\\\\ SUBFILE: PSHPOP.FS @15:59 23-MAY-1979 <055> (230) 'HEAD' PUSH AND POP ROUTINES C EDIT DATE 10DEC78 21:04 C SOURCE FILE PSHPOPFTM.FS C AUTHOR F. T. MICKEY C CLUSTER 26 'OUTFILE' PUSHFTM.FR C SUBROUTINE PUSH C C SAVES THREE VALUES ON A LIFO STACK, TO BE RETRIEVED C LATER BY POP. PARAMETERS FOR PUSH AND POP MUST BE C IN THE SAME ORDER. C SUBROUTINE PUSH (A, B, C) 'INCLUDE' PSHCOMFTM.IN, INTEGER A, B, C IF (PX .GT. PEND) CALL FATAL (45) PSTACK (PX) = A PSTACK (PX+1) = B PSTACK (PX+2) = C PX = PX + 3 RETURN END 'OUTFILE' POPFTM.FR C SUBROUTINE POP C C RETRIEVES VALUES STACKED BY PUSH. C SUBROUTINE POP (A, B, C) 'INCLUDE' PSHCOMFTM.IN, INTEGER A, B, C PX = PX - 3 IF (PX .LE. 0) CALL FATAL (46) A = PSTACK (PX) B = PSTACK (PX+1) C = PSTACK (PX+2) RETURN END \\\\\ SUBFILE: CDIAGA.FS @15:59 23-MAY-1979 <055> (2719) 'HEAD' EXPLODED LIST ROUTINES C EDIT DATE 10DEC78 21:05 C SOURCE FILE CDIAGAJH.FS C AUTHOR A. J. HOWARD/J.H.PERINE C CLUSTER 27 'OUTFILE' LISTAJH.FR SUBROUTINE LIST (FUNC, ARG1, ARG2) INTEGER FUNC, ARG1, ARG2 'INCLUDE' CTRLAJH.IN, EXTERNAL OLLST 'IF' (LISTF .NE. 0 .AND. PRINTF .NE. 0) CALL OVLOD (OLLST) CALL OLIST (FUNC, ARG1, ARG2) 'ENDIF' RETURN END 'OUTFILE' OLISTAJH.FR N OVERLAY OLLST SUBROUTINE OLIST (FUNC, ARG1, ARG2) INTEGER FUNC, ARG1, ARG2 INTEGER CONST (2), LISTA (2), LISTX (3), LISTY (3) INTEGER FCEND (2), RREF (2) INTEGER CLOCN, NLOPS EXTERNAL CLOCN, NLOPS 'INCLUDE' LOGOSAJH.IN, 'INCLUDE' LISTCMAJH.IN, 'INCLUDE' LSDATAJHP.IN, 'INCLUDE' NLNAMEFTM.IN, 'INCLUDE' NLISTCFTM.IN, 'INCLUDE' PRTCOMFTM.IN, 'INCLUDE' SRCXDFFTM.IN, 'INCLUDE' WFLAGSJHP.IN, 'INCLUDE' CRUCOMJHP.IN, LOGICAL NLTEST DATA CONST / '"X" '/ DATA LISTA / 'AREG' / DATA LISTX / ', XREG' / DATA LISTY / ', YREG' / DATA FCEND / '....' / DATA RREF / '****' / ASSIGN 1 TO LRET C SWITCH ON FUNCTION CODE GO TO (100, 200, 250, 300, 350, 400, 450, 500), FUNC C COMMON EXIT 1 RETURN 'EJECT' C LIST OBJECT WORD (ARG1) AND WORD FLAG (ARG2) 100 'IF' (ARG2 .LE. 0) C BAD WORD FLAG ARG2 = 1 CALL EST (RREF, LINE, 31, 34) LINEX = 35 GO TO 1490 'ENDIF' GO TO (1100, 1200, 1300, 1400, 1400, ^ 1500, 1600, 1400, 1700, 1, ^ 1, 1800, 1900, 1, 1, ^ 1, 1), ARG2 C CONSTANT VALUE, WORD FLAG 1 1100 'IF' (NOTINQ .OR. ARG1 .EQ. 0) CALL EST ('00', LINE, 27, 27) CALL EHX (ARG1, LINE, 28, 29) 'ELSE' CALL PCHAR (CONST, 2, ARG1) CALL EST (CONST, LINE, 27, 29) 'ENDIF' GO TO 1490 C TEST LABEL, WORD FLAG 2 1200 IF (LENTER) GO TO 350 GO TO 1 C FLOWCHART END, WORD FLAG 3 1300 CALL EST (FCEND, LINE, 19, 22) GO TO 900 'EJECT' C ENTER FUNCTION CODE, WORD FLAG 4, 5, 8 1400 CALL EHX (ARG1, LINE, 19, 21) C GET ASCII OP CODE & MISC INFO LX = ARG1 * 2 + 1 TABNR = ISHFT (LINSTR (LX), -8) TABX = IAND (LINSTR (LX), 255) LMODE = LINSTR (LX+1) LTIME = IAND (LMODE, 127) IF ( TABX .LE. 0 ) GO TO 1450 IF ( TABNR .LE. 0 .OR. TABNR .GT. 4 ) GO TO 1450 GO TO (1410, 1420, 1430, 1440), TABNR C IMPLIED 1410 CALL EST (IMPLID (TABX), LINE, 23, 26) GO TO 1460 C RELATIVE 1420 CALL EST (RELTIV (TABX), LINE, 23, 26) GO TO 1460 C GROUP1 1430 CALL EST (GROUP1 (TABX), LINE, 23, 26) GO TO 1450 C OTHERS 1440 CALL EST (OTHERS (TABX), LINE, 23, 26) IF ( IAND (LMODE, 16384) .NE. 0) CALL EST (LISTA,LINE,31,34) C SET FLAGS & MISC 1450 'IF' ( IAND (LMODE, 1024) .NE. 0 ) INDXFL = 1 'ELSE' 'IF' ( IAND (LMODE, 512) .NE. 0 ) INDXFL = 2 'ELSE' INDXFL = 0 'ENDIF' 'ENDIF' 'IF' ( IAND (LMODE, 4096) .NE. 0 ) CALL EST ('ZP', LINE, 65, 66) 'ELSE' 'IF' ( IAND (LMODE, 2048) .NE. 0 ) CALL EST ('AB', LINE, 65, 66) 'ELSE' 'IF' ( IAND (LMODE, 8192) .NE. 0) CALL EST ('IM', LINE, 65, 66) CALL EST (' =', LINE, 29, 30) 'ENDIF' 'ENDIF' 'ENDIF' 'IF' ( IAND (LMODE, 256) .NE. 0 ) CALL EST (' @', LINE, 29, 30) CALL EST ('IN', LINE, 69, 70) 'ENDIF' C CYCLES 1460 CALL ESP (LTIME, LINE, 58, 58) IF ( IAND (LMODE, 128) .NE. 0 ) CALL EST ('* ',LINE,59,60) IF (ARG2 .NE. WF4) GO TO 1 IF ( LINEX .LT. 31 ) LINEX = 31 C FINISH THE LINE FOR MULTI-PART OPCODES 1490 'IF' (OFFSET .LT. 0) CALL ESP (OFFSET, LINE, LINEX, LINEX+5) LINEX = LINEX + 6 'ELSE' 'IF' (OFFSET .GT. 0) CALL EST ('+ ', LINE, LINEX, LINEX) CALL ESP (OFFSET, LINE, LINEX+1, LINEX+5) LINEX = LINEX + 6 'ENDIF' 'ENDIF' 'IF' ( INDXFL .EQ. 1 ) CALL EST (LISTX, LINE, LINEX, LINEX+5) 'ELSE' 'IF' ( INDXFL .EQ. 2 ) CALL EST (LISTY, LINE, LINEX, LINEX+5) 'ENDIF' 'ENDIF' IF ( INDXFL .NE. 0 ) LINEX = LINEX + 2 INDXFL = 0 OFFSET = 0 GO TO 900 'EJECT' C CONSTANT OFFSET, WORD FLAG 6 1500 OFFSET = OFFSET + ARG1 GO TO 1 C NAME LIST REFERENCE, WORD FLAG 7 1600 IF (ARG1 .LT. 0) CALL EST (' @', LINE, 29, 30) LN = IAND (ARG1, 32767) IF (NLTEST (LN, CBIT)) CALL EST (' =', LINE, 29, 30) 1620 LINEX = CLOCN (LN) + 30 CALL EST (NAME, LINE, 31, LINEX) LINEX = LINEX + 1 GO TO 1490 C TRANSFER LIST REFERENCE, WORD FLAG 9 1700 CALL EHX (ARG1, LINE, 31, 33) CALL EST ('TL', LINE, 34, 35) LINEX = 36 GO TO 1490 C WORD FLAG 12 C (' <', LINE, 29, 30) 1800 CALL EST (8252, LINE, 29, 30) LN = ARG1 GO TO 1620 C WORD FLAG 13 1900 CALL EST (' >', LINE, 29, 30) LN = ARG1 GO TO 1620 'EJECT' C TRANSFER LIST LABEL 200 ASSIGN 210 TO LRET IF (LENTER) GO TO 350 210 LENTER = .TRUE. CALL EHX (ARG1, LINE, 1, 3) CALL EST ('TL', LINE, 4, 5) GO TO 1 C LIT POOL START 250 GO TO 1 C LABEL DEFINITION 300 ASSIGN 310 TO LRET IF (LENTER) GO TO 350 310 LENTER = .TRUE. LN = CLOCN (ARG1) CALL EST (NAME, LINE, 1, LN) GO TO 1 C MOVE PRINT 350 CALL EST ('.BLK', LINE, 19, 22) CALL EST ('0 ', LINE, 31, 31) GO TO 900 C LIST BSS 400 CALL EST ('.BLK', LINE, 19, 22) CALL ESP (ARG1, LINE, 31, 35) GO TO 900 'EJECT' C LIST EXTERNAL EQUATE 450 ASSIGN 460 TO LRET IF (LENTER) GO TO 350 460 LN = CLOCN (ARG1) CALL EST (NAME, LINE, 1, LN) IF (ARG2 .NE. 0) LN = CLOCN (ARG2) CALL EST ('= ', LINE, 19, 20) ASSIGN 1 TO LRET GO TO 800 C CONSTANT EQUIVALANCE 500 ASSIGN 510 TO LRET IF (LENTER) GO TO 350 510 LN = CLOCN (ARG1) CALL EST (NAME, LINE, 1, LN) CALL EST ('= ', LINE, 19, 20) LN = NLOPS (CVALUE, ARG2) CALL ESP (LN, LINE, 31, 36) CALL EHX (LN, LINE, 38, 42) ASSIGN 1 TO LRET GO TO 900 C LIST UTILITY 800 CALL EST (NAME, LINE, 31, 46) C MOVE LINE SUBROUTINE 900 CALL EHX (LC, LBUF, 1, 4) CALL EST (',,', LBUF, 5, 5) CALL EHX (LCI, LBUF, 6, 6) CALL EST (LINE, LBUF, 9, 88) CALL SET (' ', LINE, 40) LENTER = .FALSE. LINEX = 31 CALL SGLPRT GO TO LRET END 'HEAD' DUMP STACK FOR BUILD POLISH 'OUTFILE' DUMSTFTM.FR SUBROUTINE DUMST (CALLER) 'INCLUDE' CTRLAJH.IN, INTEGER CALLER (2) EXTERNAL OLDUM IF (DUMFLG .EQ. 0 .OR. CTLUSE .NE. 0) RETURN CALL OVLOD (OLDUM) CALL ODUMS (CALLER) RETURN END 'OUTFILE' ODUMSFTM.FR N OVERLAY OLDUM SUBROUTINE ODUMS (CALLER) 'INCLUDE' LOGOSAJH.IN, 'INCLUDE' REGSJHP.IN, 'INCLUDE' STKDEFA.IN, 'INCLUDE' STKDEFB.IN, 'INCLUDE' STKDEFC.IN, 'INCLUDE' STKDEFD.IN, 'INCLUDE' STKDEFE.IN, 'INCLUDE' STKDEFF.IN, 'INCLUDE' NLNAMEFTM.IN, 'INCLUDE' PRTCOMFTM.IN, INTEGER CALLER (2) INTEGER DSS, DSX, DSM (7), DSO (45) INTEGER II, JJ, NOSTR (6), ACTSTR (4), ASTSTR INTEGER CLOCN DATA NOSTR /' NEXT OP '/ DATA ACTSTR /' ACTIVE'/ DATA ASTSTR /'**'/ DATA DSM /'SPDPSTHX '/ DATA DSO /' , ; . :FODOWH', ^ 'RBLBRE $ ( ) [ ] = # >>=', ^ 8252, ^ // ' <' 15421, ^ // '<=' '-> + - * /MDR!R&ORXO &LSRSLCRCALARNE', ^ 8286, ^ // ' ^' 'DECOLO'/ CALL ESP (OPX, LBUF, 1, 6) CALL ESP (NEXTX, LBUF, 7, 12) CALL ESP (TOPX, LBUF, 13, 18) CALL EST (CALLER, LBUF, 30, 33) CALL SGLPRT II = 1 'DOLOOP' DSX = 1, NRREGS CALL ESP (STATUS (DSX), LBUF, II, II + 5) II = II + 6 'END' CALL SGLPRT CALL EST (NOSTR, LBUF, 1, 11) CALL EST (DSO (NEXTOP + 1), LBUF, 12, 13) CALL EST (ACTSTR, LBUF, 15, 21) CALL ESP (ACTLO, LBUF, 23, 28) CALL ESP (ACTHI, LBUF, 30, 35) CALL SGLPRT 'EJECT' 'DOLOOP' DSX = 1, STKSIZ N = NAMEX (DSX) 'IF' (N .EQ. 0) 'NEXT' 'ENDIF' CALL ESP (DSX, LBUF, 1, 2) IF (DSX .EQ. OPX ) CALL EST ('XX', LBUF, 3, 3) IF (DSX .EQ. NEXTX) CALL EST ('NN', LBUF, 4, 4) IF (DSX .EQ. TOPX ) CALL EST ('TT', LBUF, 5, 5) JJ = CLOCN (N) CALL EST (NAME, LBUF, 7, 21) N = SUBX (DSX) 'IF' (N .NE. 0) JJ = CLOCN (N) CALL EST (NAME, LBUF, 23, 38) 'ENDIF' CALL ESP (BIAS (DSX), LBUF, 40, 44) JJ = MODE (DSX) + 1 CALL EST (DSM (JJ), LBUF, 46, 47) IF (LOCFLG (DSX) .NE. 0) ^ CALL EST ('LL', LBUF, 48, 48) JJ = SUBXM (DSX) + 1 CALL EST (DSM (JJ), LBUF, 50, 51) JJ = IAND (OSTACK (DSX), 63) + 1 CALL EST (DSO (JJ), LBUF, 53, 54) CALL EHX (OPCODE (DSX), LBUF, 56, 58) CALL ESP (WFOP (DSX), LBUF, 60, 62) CALL ESP (WFOPND (DSX), LBUF, 64, 66) CALL EHX (SUBOP (DSX), LBUF, 68, 70) CALL ESP (WFSOP (DSX), LBUF, 71, 73) CALL ESP (SUBXB (DSX), LBUF, 75, 79) CALL SGLPRT 'END' CALL SGLPRT RETURN END 'OUTFILE' REGOUTAPB.FR C EDIT DATE 10DEC78 21:07 C SOURCE FILE REGAPB.FS C AUTHOR A.P. BUCHALTER C CLUSTER C PRINT OUT THE REGISTER CONTENTS SUBROUTINE REGDMP (FLAG) 'INCLUDE' NLNAMEFTM.IN, 'INCLUDE' RMCOMJHP.IN, 'INCLUDE' CTRLAJH.IN, 'INCLUDE' PRTCOMFTM.IN, INTEGER FLAG INTEGER CLOCN INTEGER REG, L IF (DUMFLG .EQ. 0) RETURN CALL EST('REGDMP', LBUF, 1, 6) CALL ESP (FLAG, LBUF, 1, 12) CALL SGLPRT 'DOLOOP' REG = 1, 11 'IF' (ACADDR(REG) .NE. 0) CALL ESP(REG, LBUF, 1, 2) L = CLOCN(ACADDR(REG)) CALL EST(NAME, LBUF, 4, 19) CALL ESP(ACTYPE(REG), LBUF, 21, 23) 'IF' (ACSUBS(REG) .NE. 0) L = CLOCN(ACSUBS(REG)) CALL EST(NAME, LBUF, 26, 41) CALL ESP(ACSBTY(REG), LBUF, 43, 45) 'ENDIF' CALL ESP(ACBIAS(REG), LBUF, 47, 50) CALL SGLPRT 'ENDIF' 'END' END \\\\\ SUBFILE: LSDATA.FS @15:59 23-MAY-1979 <055> (94) 'HEAD' DATA FOR LIST OUTPUT C EDIT DATE 17AUG78 12:40 C SOURCE FILE LSDATAJHP.FS C AUTHOR J.H.PERINE 'OUTFILE' LSDATAJHP.FR BLOCK DATA 'INCLUDE' LSDATAJHP.IN,P 'INCLUDE' LSOBJJHP.IN,P END 'OUTFILE' OBDATAJHP.FR BLOCK DATA 'INCLUDE' OBDATAJHP.IN,P 'INCLUDE' LSOBJJHP.IN, END \\\\\ SUBFILE: UTILSF.FS @16:3 23-MAY-1979 <055> (2401) 'HEAD' GENERAL UTILITIES C EDIT DATE 18JAN79 21:27 C SOURCE FILE UTILSFTM.FS C AUTHOR F. T. MICKEYM C CLUSTER 28 'OUTFILE' GCHAR.FR C SUBROUTINE GCHAR (BUFFER, CHARACTER INDEX) C C RETURNS AS INTEGER FUNCTION VALUE THE CHARACTER POINTED C TO BY CHARACTER INDEX, WITH THE LEFT-HAND CHARACTER OF C BUFFER (1) DEFINED AS CHARACTER 1. CHARACTERS ARE RIGHT ADJUS- C TED, WITH A LEADING NULL BYTE. C C *************** C PDP-11/70 ONLY* C *************** INTEGER FUNCTION GCHAR (BUF, INDEX) INTEGER BUF (66), I, INDEX I = ISHFT (INDEX+1, -1) 'IF' (IAND (INDEX, 1) .EQ. 0) GCHAR = ISHFT (BUF (I), -8) 'ELSE' GCHAR = IAND (BUF (I), 255) 'ENDIF' RETURN END 'OUTFILE' PCHAR.FR C SUBROUTINE PCHAR (BUFFER, CHARACTER INDEX, CHARACTER) C C PLACES CHARACTER INTO BUFFER AT POSITION POINTED TO BY C CHARACTER POINTER. C C *************** C PDP-11/70 ONLY* C *************** SUBROUTINE PCHAR (BUF, INDEX, CHAR) INTEGER BUF (66), INDEX, CHAR INTEGER I I = ISHFT (INDEX+1, -1) 'IF' (IAND (INDEX, 1) .EQ. 0) BUF (I) = IAND (BUF (I), 255) + ISHFT (CHAR, 8) 'ELSE' BUF (I) = IAND (BUF (I), -256) + IAND (CHAR, 255) 'ENDIF' RETURN END 'OUTFILE' SET.FR C SUBROUTINE SET (VALUE, BUFFER, COUNT) C C SETS 'COUNT' WORDS FROM START OF BUFFER TO VALUE C SUBROUTINE SET (VALUE, BUFFER, COUNT) INTEGER VALUE, COUNT, BUFFER (COUNT), I 'DOLOOP' I = 1, COUNT BUFFER (I) = VALUE 'END' RETURN END 'OUTFILE' MOVE.FR C SUBROUTINE MOVE (FROM, TO, COUNT) C C MOVES 'COUNT' WORDS FROM 'FROM' TO 'TO' C SUBROUTINE MOVE (FROMB, TOB, COUNT) INTEGER COUNT, FROMB (COUNT), TOB (COUNT), I 'DOLOOP' I = 1, COUNT TOB (I) = FROMB (I) 'END' RETURN END 'HEAD' OUTPUT FORMATTING ROUTINES 'OUTFILE' ESPJHP.FR C NAME ESP C PURPOSE CONVERT SINGLE PRECISION NUMBER TO ASCII C (SIGNED DECIMAL, RIGHT ADJUST) C (UNUSED FIELD POSITIONS ARE NOT MODIFIED) C CALL CALL ESP (WORD, BUF, LEFT, RIGHT) C WORD DATA TO BE CONVERTED C BUF OUTPUT BUFFER C LEFT LEFTMOST CHARACTER POSITION (1-N) C RIGHT RIGHT CHARACTER POSITION C ERRORS NO ERROR INDICATIONS C RETURN IF: C CONVERSION COMPLETE C FIELD FULL SUBROUTINE ESP (WORD, BUF, LEFT, RIGHT) INTEGER WORD, BUF, LEFT, RIGHT INTEGER CHAR, MFLAG, WORK, XMINUS, XZERO, COL DATA XMINUS / 45 / DATA XZERO / 48 / C INITIALIZE 'IF' (WORD .LT. 0) WORK = - WORD MFLAG = 1 'ELSE' WORK = WORD MFLAG = 0 'ENDIF' COL = RIGHT 'DO' 'WHILE' (COL .GE. LEFT) CHAR = MOD (WORK, 10) + XZERO WORK = WORK / 10 CALL PCHAR (BUF, COL, CHAR) COL = COL - 1 'IF' (WORK .LE. 0) 'BREAK' 'ENDIF' 'END' IF (MFLAG .NE. 0 .AND. COL .GE. LEFT) ^ CALL PCHAR (BUF, COL, XMINUS) RETURN END 'OUTFILE' ESTJHP.FR C NAME EST C PURPOSE MOVE STRING INTO BUFFER FIELD C CALL CALL EST (STR, BUF, LEFT, RIGHT) C STR INPUT STRING C BUF OUTPUT BUFFER C LEFT LEFT CHARACTER POSITION IN BUF (1-N) C RIGHT RIGHTMOST CHARACTER POSITION C ERROR NO ERROR INDICATIONS SUBROUTINE EST (STR, BUF, LEFT, RIGHT) INTEGER STR, BUF, LEFT, RIGHT INTEGER GETX, PUTX INTEGER GCHAR GETX = 1 PUTX = LEFT 'DO' 'WHILE' (PUTX .LE. RIGHT) CALL PCHAR (BUF, PUTX, GCHAR (STR, GETX)) GETX = GETX + 1 PUTX = PUTX + 1 'END' RETURN END 'OUTFILE' EHXJHP.FR C NAME EHX C PURPOSE CONVERT A WORD TO ASCII IN HEX FORMAT C (RIGHT ADJUSTED, ZERO FILLED) C CALL CALL EHX (WORD, BUF, LEFT, RIGHT) C WORD INPUT DATA C BUF BUFFER TO RECEIVE DATA C LEFT LEFT CHARACTER POSITION IN BUF (1-N) C RIGHT RIGHTMOST CHARACTER POSITION C ERRORS NO ERROR INDICATIONS C RETURN IF: C FIELD FULL SUBROUTINE EHX (WORD, BUF, LEFT, RIGHT) INTEGER WORD, BUF, LEFT, RIGHT INTEGER WORK, CHAR, COL, XZERO, XLETA, MASK, BIAS DATA XZERO / 48 / DATA XLETA / 55 / DATA MASK / 15 / COL = RIGHT WORK = WORD 'DO' 'WHILE' (COL .GE. LEFT) CHAR = IAND (WORK, MASK) 'IF' (CHAR .GE. 10) BIAS = XLETA 'ELSE' BIAS = XZERO 'ENDIF' CALL PCHAR (BUF, COL, CHAR + BIAS) WORK = ISHFT (WORK, -4) COL = COL - 1 'END' RETURN END 'HEAD' SHELL SORT 'OUTFILE' SORTAJH.FR SUBROUTINE SORT (LIST, COUNT, ARRAY, COMP) C C SHELL SORT, DESCRIBED AS "PROGRAM C" IN "AN EMPIRICAL STUDY C OF MINIMAL STORAGE SORTING" BY T. N. HUBBARD, CACM VOL 5, C NO 5, (MAY 1963) PP. 206-216 C C INPUT: C LIST = ARRAY OF INDEXES TO ITEMS IN 'ARRAY' C COUNT = NUMBER OF ITEMS TO BE SORTED C ARRAY = ITEMS TO BE SORTED C COMP = FUNCTION TO COMPARE ITEMS FOR SORTING C C OUTPUT: C LIST = SORTED INDEXES TO 'ARRAY' C INTEGER COUNT, LIST (COUNT), ARRAY (COUNT) INTEGER CT, STEP, COMP INTEGER I, J, K, L, M, N 'EJECT' K = COUNT IF (K .LE. 1) RETURN CT = K STEP = 1 'DO' K = ISHFT (K, -1) 'WHILE' (K .NE. 0) STEP = STEP + STEP 'END' STEP = STEP - 1 'DO' K = 1 'DO' L = K I = L + STEP J = I N = LIST (I) 'DO' M = LIST (L) 'IF' (COMP (ARRAY (N), ARRAY (M)) .LT. 0) LIST (J) = M J = L L = J - STEP 'IF' (L .GE. 1) 'END' 'ENDIF' 'ENDIF' LIST (J) = N K = K + 1 'WHILE' (K + STEP .LE. CT) 'END' STEP = ISHFT (STEP, -1) 'WHILE' (STEP .NE. 0) 'END' RETURN END 'HEAD' RSX INTERFACE ROUTINES 'OUTFILE' RSXINTFCE.FR SUBROUTINE OPENF (CHAN, FILE, ERROR) C OPEN AN EXISTING FILE INTEGER CHAN, FILE (15), ERROR OPEN (UNIT = CHAN, NAME = FILE, SHARED, ^ TYPE = 'OLD', ERR = 100) ERROR = 1 RETURN 100 ERROR = -1 RETURN END SUBROUTINE OPENN (CHAN, FILE, ERROR) C OPEN A NEW OUTPUT FILE INTEGER CHAN, FILE (15), ERROR OPEN (UNIT = CHAN, NAME = FILE, TYPE = 'NEW', ERR = 100) ERROR = 1 RETURN 100 ERROR = -1 RETURN END 'EJECT' SUBROUTINE CLOSF (CHAN, ERROR) C CLOSE AN OPEN FILE, DON'T DELETE IT INTEGER CHAN, ERROR CLOSE (UNIT = CHAN, ERR = 100) ERROR = 1 RETURN 100 ERROR = -1 RETURN END SUBROUTINE DELETE (CHAN, FILE) C DELETE A FILE INTEGER CHAN, FILE (15) CLOSE (UNIT = CHAN, DISP = 'DELETE') RETURN END SUBROUTINE REW (CHAN, FILE) C REWIND A FILE INTEGER CHAN, FILE (15) REWIND CHAN RETURN END 'EJECT' SUBROUTINE RDLIN (CHAN, BUFFER, MAX, ERROR) C READ AN ASCII LINE (MAX CHARACTERS) INTEGER CHAN, BUFFER (40), MAX, ERROR INTEGER WORDS WORDS = (MAX + 1)/2 READ (CHAN, 1000, END = 100) (BUFFER (I), I = 1, WORDS) ERROR = 1 RETURN 100 ERROR = 9 RETURN 1000 FORMAT (40A2) END SUBROUTINE WRLIN (CHAN, BUFFER, CHARS) C WRITE ASCII CHARACTERS INTEGER CHAN, BUFFER (66), CHARS INTEGER WORDS WORDS = (CHARS + 1)/2 WRITE (CHAN, 1000) (BUFFER (I), I = 1, WORDS) RETURN 1000 FORMAT (1X, 66A2) END 'EJECT' SUBROUTINE RDSEQ (CHAN, BUFFER, COUNT, ERROR) C READ BIANRY CHARACTERS INTEGER CHAN, COUNT, BUFFER (COUNT), ERROR INTEGER WORDS WORDS = (COUNT + 1)/2 READ (CHAN, 1000, END = 100) (BUFFER (I), I = 1, WORDS) ERROR = 1 RETURN 100 ERROR = 9 RETURN 1000 FORMAT (1A2) END SUBROUTINE WRSEQ (CHAN, BUFFER, COUNT) C WRITE BINARY CHARACTERS INTEGER CHAN, COUNT, BUFFER (COUNT) INTEGER WORDS WORDS = (COUNT + 1)/2 WRITE (CHAN, 1000) (BUFFER (I), I = 1, WORDS) RETURN 1000 FORMAT (1A2) END 'OUTFILE' DEVICEFTM.FR SUBROUTINE DEVICE (FILE) C INSERT "SY0:" AT THE START OF A FILE NAME IF THERE IS C NO DEVICE SPECIFIED C REQUIRED FOR THE PDP/11 INTEGER FILE (16), DEV(2), COLON, I, GCHAR DATA COLON /58/, DEV /'SY0:'/ 'DOLOOP' I = 1, 4 'IF' (GCHAR (FILE, I) .NE. COLON) 'END' 'FOR' (I = 13; I .GE. 1; I = I - 1) FILE (I+2) = FILE (I) 'END' FILE (1) = DEV (1) FILE (2) = DEV (2) 'ENDIF' FILE (16) = 0 // NULL FOR PDP/11 NAME TERMINATION RETURN END \\\\\ SUBFILE: LINKER.FS @16:1 23-MAY-1979 <055> (553) 'HEAD' LINKER FOR 6502 LOGOS C EDIT DATE 26JAN79 09:35 C SOURCE FILE LINKERGAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 1 'OUTFILE' LINKERGAK.FR 'INCLUDE' IODEFNGAK.IN, 'INCLUDE' IOFILEGAK.IN, N EXTERNAL OLPS0, OLPS1, OLPS2, OLPS3 C LINKER :: X CALL OPEN (DBCHAN, DBFILE, 0, ECODE) X IF (ECODE.NE.1) STOP 99999 N CALL OVOPN (OVCHAN, OVFILE) N CALL OVLOD (OLPS0) CALL INITLZ X WRITE (DBCHAN, 1) X1 FORMAT (' LINKER INITIALIZATION COMPLETED') CALL ASKQES X WRITE (DBCHAN, 2) X2 FORMAT (' LINKER ASK QUESTIONS COMPLETED') CALL TOPAGE CALL LTIME N CALL OVLOD (OLPS1) CALL PASS1 X WRITE (DBCHAN, 3) X3 FORMAT (' LINKER PASS ONE COMPLETED') X CALL LTIME N CALL OVLOD (OLPS2) CALL PASS2 X WRITE (DBCHAN, 4) X4 FORMAT (' LINKER PASS TWO COMPLETED') N CALL OVLOD (OLPS3) CALL MAPPER X WRITE (DBCHAN, 5) X5 FORMAT (' LINKER MAPPER COMPLETED') CALL LTIME CALL FINISH STOP END 'OUTFILE' LTIMEGAK.FR SUBROUTINE LTIME C EDIT DATE 26JAN79 09:35 C SOURCE FILE LINKERGAK.FS C AUTHOR GARY A. KUDIS 'INCLUDE' IODEFNGAK.IN, 'INCLUDE' LDATAXGAK.IN, INTEGER LINE (21) INTEGER HLINE (10), HTIME (6), HDATE (5) COMMON /LIN/ LINE EQUIVALENCE (LINE ( 1), HLINE (1)) EQUIVALENCE (LINE (11), HTIME (1)) EQUIVALENCE (LINE (17), HDATE (1)) DATA HLINE /'LINKER VERSION 2.0 '/ DATA HTIME /'00:00:00 '/ DATA HDATE /'DD-MMM-YY '/ C LTIME : CALL TIME (HTIME) CALL DATE (HDATE) CALL ESP (VERS, HLINE, 16, 18) CALL WRLIN (MPCHAN, LINE, 42) CALL WRLIN (MPCHAN, ' ', 2) RETURN END N 'OUTFILE' PS0OL.FR N OVERLAY OLPS0 N SUBROUTINE PS0OL N RETURN N END N 'OUTFILE' PS1OL.FR N OVERLAY OLPS1 N SUBROUTINE PS1OL N RETURN N END N 'OUTFILE' PS2OL.FR N OVERLAY OLPS2 N SUBROUTINE PS2OL N RETURN N END N 'OUTFILE' PS3OL.FR N OVERLAY OLPS3 N SUBROUTINE PS3OL N RETURN N END \\\\\ SUBFILE: DATADF.FS @16:1 23-MAY-1979 <055> (1823) 'HEAD' DATA DEFINITIONS FOR LINKER C EDIT DATE 16JAN79 15:17 C SOURCE FILE DATADFGAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 0 C 0.00 /BITDFN/ BIT DEFINITIONS C 0.01 /CHARAC/ CHARACTER DEFINITIONS C 0.02 /DARRAY/ DICTIONARY ARRAY C 0.03 /ERRDFN/ ERROR DEFINITIONS C 0.04 /IODEFN/ IO CHANNEL DEFINITIONS C 0.05 /LDATAX/ LINKER DATA C 0.06 /MEMORY/ MEMORY USE MAP C 0.07 /NTABLE/ NAME LIST TABLE C 0.08 /PNAMES/ PRINT NAME LIST DATA STRUCTURES C 0.09 /QUESTS/ QUESTIONS TO USER C 0.10 /RECORD/ INPUT RECORD DEFINITIONS C 0.11 /STACKS/ LINKER STACK AREAS 'OUTFILE' BITDFNGAK.FR BLOCK DATA 'INCLUDE' BITDFNGAK.IN,P DATA BIT00 /1/ DATA BIT01 /2/ DATA BIT02 /4/ DATA BIT03 /8/ DATA BIT04 /16/ DATA BIT05 /32/ DATA BIT06 /64/ DATA BIT07 /128/ DATA BIT08 /256/ DATA BIT09 /512/ DATA BIT10 /1024/ DATA BIT11 /2048/ DATA BIT12 /4096/ DATA BIT13 /8192/ DATA BIT14 /16384/ END 'OUTFILE' CHARACGAK.FR BLOCK DATA 'INCLUDE' CHARACGAK.IN,P DATA CHMASK /127/ DATA CR, LF /13, 10/ DATA CRLF /3338/ DATA BLANK /32/, PERIOD /46/ DATA BLANKS,DASHES,COLONS,SLASHS /8224,11565,14906,12079/ DATA ACH, BCH, CCH, DCH, ECH, FCH /65,66,67,68,69,70/ DATA GCH, HCH, ICH, JCH, KCH, LCH /71,72,73,74,75,76/ DATA MCH, NCH, OCH, PCH, QCH, RCH /77,78,79,80,81,82/ DATA SCH, TCH, UCH, VCH, WCH, XCH /83,84,85,86,87,88/ DATA YCH, ZCH /89,90/ DATA LBRACE, RBRACE /91, 93/ DATA LBRACK, RBRACK /40, 41/ END 'OUTFILE' DARRAYGAK.FR BLOCK DATA 'INCLUDE' DARRAYGAK.IN,P DATA DTSTOP /400/ END 'OUTFILE' ERRDFNGAK.FR BLOCK DATA 'INCLUDE' ERRDFNGAK.IN,P 'EJECT' DATA EMAX /17/ DATA EPROC(1)/1/, ECOUNT(1)/0/, ELIMIT(1)/0/ DATA EMSG1 /'INVALID ERROR CODE '/ DATA EPROC(2)/2/, ECOUNT(2)/0/, ELIMIT(2)/0/ DATA EMSG2 /'ERROR COUNT EXCEEDED'/ DATA EPROC(3)/3/, ECOUNT(3)/0/, ELIMIT(3)/2/ DATA EMSG3 /'IO ERROR, FORT CODE '/ DATA EPROC(4)/4/, ECOUNT(4)/0/, ELIMIT(4)/1/ DATA EMSG4 /'INVALID RB RECORD '/ DATA EPROC(5)/5/, ECOUNT(5)/0/, ELIMIT(5)/10/ DATA EMSG5 /'NAME LIST OVERFLOW :'/ DATA EPROC(6)/6/, ECOUNT(6)/0/, ELIMIT(6)/10/ DATA EMSG6 /'NAME TEXT OVERFLOW :'/ DATA EPROC(7)/7/, ECOUNT(7)/0/, ELIMIT(7)/2/ DATA EMSG7 /'FAILURE IN RB FILE '/ DATA EPROC(8)/8/, ECOUNT(8)/0/, ELIMIT(8)/0/ DATA EMSG8 /'LINKER SOFTWARE ERR '/ DATA EPROC(9)/9/, ECOUNT(9)/0/, ELIMIT(9)/3/ DATA EMSG9 /'CHECKSUM IN RB FILE '/ DATA EPROC(10)/10/, ECOUNT(10)/0/, ELIMIT(10)/0/ DATA EMSG10 /'MISSING DICT ID '/ DATA EPROC(11)/11/, ECOUNT(11)/0/, ELIMIT(11)/100/ DATA EMSG11 /'OVERWRITE ERROR AT '/ DATA EPROC(12)/12/, ECOUNT(12)/0/, ELIMIT(12)/0/ DATA EMSG12 /'DICTIONARY OVERFLOW '/ DATA EPROC(13)/13/, ECOUNT(13)/0/, ELIMIT(13)/0/ DATA EMSG13 /'MULTIPLE DICT ID '/ DATA EPROC(14)/14/, ECOUNT(14)/0/, ELIMIT(14)/20/ DATA EMSG14 /'RB FILE NAME ERROR '/ DATA EPROC(15)/15/, ECOUNT(15)/0/, ELIMIT(15)/50/ DATA EMSG15 /'MULTIPLE START ADDR '/ DATA EPROC(16)/16/, ECOUNT(16)/0/, ELIMIT(16)/50/ DATA EMSG16 /'COMMON SIZE ERROR '/ DATA EPROC(17)/17/, ECOUNT(16)/0/, ELIMIT(17)/32767/ DATA EMSG17 /'RAM INITIALIZATION '/ END 'OUTFILE' IODEFNGAK.FR BLOCK DATA 'INCLUDE' IODEFNGAK.IN,P DATA CMCHAN /1/ DATA RBCHAN /2/ DATA OBCHAN /3/ DATA MPCHAN /4/ P DATA TTYIN /5/ N DATA TTYIN /11/ P DATA TTYOUT /5/ N DATA TTYOUT /10/ N DATA OVCHAN /0/ DATA DBCHAN /5/ END 'OUTFILE' IOFILEGAK.FR BLOCK DATA 'INCLUDE' IOFILEGAK.IN,P N DATA OVFILE /'LINKER.OL'/ N DATA TIFILE /'$TTI', 0/ N DATA TOFILE /'$TTO', 0/ P DATA TIFILE /'TI: ', 0/ DATA DBFILE /'DEBUG.LST ', 11*0/ END 'OUTFILE' LDATAXGAK.FR BLOCK DATA 'INCLUDE' LDATAXGAK.IN,P DATA MPFLAG /.FALSE./ DATA OVMODE /.FALSE./ DATA LBMODE /.FALSE./ DATA LOADRB /.FALSE./ DATA SFLAG /.FALSE./ DATA VERS /2/ DATA ZLOC, ZSTR, ZMAX, ZLIMIT /0,0,0,255/ DATA CLOC, CSTR, CMAX, CLIMIT /512,512,512,-1/ DATA NLOC, NSTR, NMAX, NLIMIT /512,512,512,-1/ DATA DLOC, DSTR, DMAX, DLIMIT /512,512,512,-1/ END 'OUTFILE' MEMORYGAK.FR BLOCK DATA 'INCLUDE' MEMORYGAK.IN,P DATA MEMORY /4096*0/ DATA ROM /64*0/ END 'OUTFILE' NTABLEGAK.FR BLOCK DATA 'INCLUDE' NTABLEGAK.IN,P DATA NTITLE /0/ DATA NFLAGS /512*0/ DATA NADDRS /512*0/ DATA NPOSIT /512*0/ DATA NDATA /512*0/ DATA NTEXTX /512*0/ DATA NTEXT /1000*0/ DATA NLSTRT/1/, NLSTOP/512/ DATA TXSTRT/1/, TXSTOP/1000/ DATA NTXBTS/15/ DATA USEBIT/16/ DATA COMBIT/32/ DATA OVLBIT/64/ DATA EPTBIT/128/ DATA LDMBIT/256/ DATA MODBIT/512/ DATA MLTBIT/1024/ DATA RLSBIT/2048/ DATA GDFBIT/4096/ C DATA TYPBTS/BIT15+BIT14+BIT13/ END 'OUTFILE' PNAMESGAK.FR BLOCK DATA 'INCLUDE' PNAMESGAK.IN,P DATA LSTOP /512/ END 'OUTFILE' QUESTSGAK.FR BLOCK DATA 'INCLUDE' QUESTSGAK.IN,P DATA CMQUES /'INPUT COMMAND FILE? '/ DATA OBQUES /'OUTPUT OBJECT FILE? '/ DATA MPQUES /'OUTPUT XR-MAP FILE? '/ END 'OUTFILE' RECORDGAK.FR BLOCK DATA 'INCLUDE' RECORDGAK.IN,P DATA RTMAX /20/ DATA RSZMAX /41/ DATA RSIZES(1) /9/ DATA RSIZES(2) /1/ DATA RSIZES(3) /2/ DATA RSIZES(4) /41/ DATA RSIZES(5) /11/ DATA RSIZES(6) /11/ DATA RSIZES(7) /12/ DATA RSIZES(8) /12/ DATA RSIZES(9) /10/ DATA RSIZES(10) /0/ DATA RSIZES(11) /3/ DATA RSIZES(12) /4/ DATA RSIZES(13) /4/ DATA RSIZES(14) /3/ DATA RSIZES(15) /2/ DATA RSIZES(16) /2/ DATA RSIZES(17) /3/ DATA RSIZES(18) /11/ DATA RSIZES(19) /1/ DATA RSIZES(20) /1/ END 'OUTFILE' STACKSGAK.FR BLOCK DATA 'INCLUDE' STACKSGAK.IN,P DATA MX /1/ DATA MSTKSZ /30/ END 'OUTFILE' TXTCOMGAK.FR BLOCK DATA 'INCLUDE' TXTCOMGAK.IN,P DATA TEXT ^ /' NOUN = XXXX, DATA = XXXX, ZREL = XXXX, CODE = XXXX'/ DATA LEFT / 12, 25, 38, 51/ DATA RIGHT / 15, 28, 41, 54/ END \\\\\ SUBFILE: ASKQES.FS @16:1 23-MAY-1979 <055> (610) 'HEAD' LINKER, ASK QUESTIONS C EDIT DATE 16JAN79 07:31 C SOURCE FILE ASKQESGAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 3 'OUTFILE' ASKQESGAK.FR SUBROUTINE ASKQES 'INCLUDE' QUESTSGAK.IN, 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' IODEFNGAK.IN, 'INCLUDE' IOFILEGAK.IN, 'INCLUDE' CHARACGAK.IN, INTEGER GCHAR INTEGER OBEND, MPEND DATA OBEND /'OB'/, MPEND /'MP'/ C ASKQES :: X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER ASKQES') CALL ASK (CMQUES) CALL MOVE (ANSWER, CMFILE, 14) P CALL DEVICE (CMFILE) CALL OPENF (CMCHAN, CMFILE, ECODE) IF (ECODE. NE. 1) CALL ERROR (3) CALL ASK (OBQUES) CHAR = GCHAR (ANSWER, 1) 'IF' ((CHAR.EQ.0).OR.(CHAR.EQ.BLANK).OR.(CHAR.EQ.CR)) CALL DFAULT (OBEND) 'ENDIF' CALL MOVE (ANSWER, OBFILE, 14) P CALL DEVICE (OBFILE) CALL OPENN (OBCHAN, OBFILE, ECODE) IF (ECODE .NE. 1) CALL ERROR (3) CALL ASK (MPQUES) CHAR = GCHAR (ANSWER, 1) 'IF' ((CHAR.EQ.0).OR.(CHAR.EQ.BLANK).OR.(CHAR.EQ.CR)) CALL DFAULT (MPEND) 'ENDIF' CALL MOVE (ANSWER, MPFILE, 14) P CALL DEVICE (MPFILE) CALL OPENN (MPCHAN, MPFILE, ECODE) IF (ECODE .NE. 1) CALL ERROR (3) IF (ECODE.EQ.1) MPFLAG = .TRUE. X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT ASKQES') RETURN END 'OUTFILE' ASKGAK.FR SUBROUTINE ASK (QUEST) 'INCLUDE' QUESTSGAK.IN, 'INCLUDE' IODEFNGAK.IN, INTEGER QUEST (10) C ASK : CALL WRLIN (TTYOUT, QUEST, 20) CALL RDLIN (TTYIN, ANSWER, 30, ECODE) X WRITE (TTYOUT, 3) ANSWER X3 FORMAT (' ANSWER IS = ', 10A2) RETURN END 'OUTFILE' DFAULTGAK.FR SUBROUTINE DFAULT (APPEND) INTEGER APPEND 'INCLUDE' CHARACGAK.IN, 'INCLUDE' IOFILEGAK.IN, 'INCLUDE' QUESTSGAK.IN, INTEGER GCHAR INTEGER I C DFAULT : (APPEND) I = 1 'DO' CHAR = GCHAR (CMFILE, I) 'WHILE' ((CHAR.NE.0).AND.(CHAR.NE.BLANK).AND. ^ (CHAR.NE.PERIOD).AND.(CHAR.NE.CR)) CALL PCHAR (ANSWER, I, CHAR) I = I + 1 'IF' (I.GE.24) 'BREAK' 'ENDIF' 'END' CALL PCHAR (ANSWER, I, PERIOD) CHAR = GCHAR (APPEND, 1) CALL PCHAR (ANSWER, I+1, CHAR) CHAR = GCHAR (APPEND, 2) CALL PCHAR (ANSWER, I+2, CHAR) RETURN END \\\\\ SUBFILE: FINISH.FS @16:1 23-MAY-1979 <055> (155) 'HEAD' LINKER, FINISH UP C EDIT DATE 10JAN79 09:53 C SOURCE FILE FINISHGAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 7 'OUTFILE' FINISHGAK.FR SUBROUTINE FINISH 'INCLUDE' IODEFNGAK.IN, C FINISH :: X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER FINISH') CALL CLOSF (CMCHAN, ECODE) IF (ECODE.NE.1) CALL ERROR (3) CALL CLOSF (OBCHAN, ECODE) IF (ECODE.NE.1) CALL ERROR (3) N CALL CLOSF (MPCHAN, ECODE) N IF (ECODE.NE.1) CALL ERROR (3) P CALL SPOOL (MPCHAN, ECODE) X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT FINISH') RETURN END \\\\\ SUBFILE: UTILIT.FS @16:1 23-MAY-1979 <055> (5098) 'HEAD' LINKER, UTILITY ROUTINES C EDIT DATE 26JAN79 09:35 C SOURCE FILE UTILITGAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 10 C THIS CLUSTER CONTAINS THE FOLLOWING ROUTINES : C AREADF - AREA DEFINITION ADDRESS RESOLUTION C CHCKER - CHECKSUM CURRENT RECORD C DNAMES - DELETE NAMES FROM 'NTABLE' C ENPTDF - ENTRY POINT ADDRESS RESOLUTION C ENTER - ENTER 'NAME' INTO 'NTABLE' C ERROR (N) - ERROR MSG FORMAT AND OUTPUT C GETFL (ERX, EOF) - GET NEXT RB FILE NAME C GRCORD (ERX, EOF) - GET NEXT RB RECORD C GWORD (ERX, EOF) - GET NEXT RB WORD C GNAME (I) - GET NAME C HASH (NAME, NRWDS) - CALCULATE NAME HASH CODE C ISWAP (DATA) - SWAP HALFS OF INPUT DATA C KEYWD (DUMMY) - TEST FOR KEY WORD IN RB FILENAME C LNAMES - LOAD NAMES IN 'NTABLE' C PUNCH (DATA, ADDR, NBYTES) - OUTPUT OBJECT DATA C PUSHMD - PUSH MODULE DATA C POPMD - POP MODULE DATA C SEARCH - SEARCH FOR 'NAME' IN 'NTABLE' C SETKEY - SET GROUP ADDRESS ACCORDING TO KEY C UPDATE (LOC, NBYTES, MAX) - UPDATE LOAD ADDR. C USEMEM (ADDR, NBYTES) - MARK MEMORY AS USED 'OUTFILE' AREADFGAK.FR SUBROUTINE AREADF C RESOLVES NAME TABLE (NTABLE) ENTRY ADDRESS (NADDRS) C FOR AN AREA DEFINITION (EITHER GROUP DEFINITION OR C COMMON AREA). 'INCLUDE' RECORDGAK.IN, 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' NTABLEGAK.IN, INTEGER I INTEGER ADDR C AREADF :: 'IF' ((RSTYPE.LT.0).OR.(RSTYPE.GT.4)) CALL ERROR (4) 'ELSE' 'IF' (IAND(NFLAGS(NLX),RLSBIT).NE.0) NFLAGS(NLX) = IOR (NFLAGS(NLX),MLTBIT) RETURN 'ENDIF' I = RSTYPE + 1 GOTO (100,200,300,400,500) I C ABSOLUTE DATA AREA 100 ADDR = 0 GOTO 1000 C NOUN DEFINITION AREA 200 ADDR = NLOC CALL UPDATE (NLOC, RECORD(3), NMAX) GOTO 1000 C DATA DEFINITION AREA 300 ADDR = DLOC CALL UPDATE (DLOC, RECORD(3), NMAX) GOTO 1000 C ZERO PAGE DATA AREA 400 ADDR = ZLOC CALL UPDATE (ZLOC, RECORD(3), ZMAX) GOTO 1000 C NORMAL RELOCATABLE DATA AREA 500 ADDR = CLOC CALL UPDATE (CLOC, RECORD(3), CMAX) 1000 CONTINUE NADDRS(NLX) = ADDR NDATA (NLX) = RECORD(3) NFLAGS (NLX) = IOR (NFLAGS(NLX), RLSBIT) NFLAGS(NLX) = NFLAGS(NLX) + ISHFT (RSTYPE, 13) 'ENDIF' RETURN END 'OUTFILE' CHCKERGAK.FR SUBROUTINE CHCKER C CHECKSUM CALCULATION OF CURRENT RB RECORD 'INCLUDE' RECORDGAK.IN, 'INCLUDE' LDATAXGAK.IN, INTEGER I C CHCKER :: 'DOLOOP' I = 1, RSIZE CKSUM = IEOR (CKSUM, RECORD(I)) 'END' RETURN END 'OUTFILE' DNAMESGAK.FR SUBROUTINE DNAMES C DELETES ALL ENTRIES IN NAME TABLE (NTABLE) WHICH DO C NOT HAVE THE LOAD MODULE BIT (LDMBIT) SET. THIS IS C CALLED AFTER SCANNING A -.RB, WITHIN A LIBRARY, C THAT WILL NOT BE LOADED. 'INCLUDE' NTABLEGAK.IN, INTEGER FLAGS, MASK, I C DNAMES :: MASK = GDFBIT + COMBIT + EPTBIT + OVLBIT 'DOLOOP' I = 1,NLSTOP FLAGS = NFLAGS(I) 'IF' (NTEXTX (I) .GE. TXSTRT) NFLAGS(I) = 0 NTEXTX(I) = 0 NADDRS(I) = 0 'ENDIF' 'END' RETURN END 'OUTFILE' ENPTDFGAK.FR SUBROUTINE ENPTDF C RESOLVES NAME TABLE (NTABLE) ENTRY ADDRESS (NADDRS) C FOR ENTRY POINT DEFINITIONS (ENTRY POINTS OR OVER- C LAY IDS). 'INCLUDE' DARRAYGAK.IN, 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' RECORDGAK.IN, INTEGER MAPX C ENPTDF :: MAPX = DICT (RECORD(3)) 'IF' (MAPX.LE.0) CALL ERROR(10) 'ELSE' 'IF' (IAND(NFLAGS(NLX),RLSBIT).NE.0) NFLAGS(NLX) = IOR (NFLAGS(NLX),MLTBIT) 'ELSE' NADDRS(NLX) = NADDRS(MAPX) + RECORD(4) NFLAGS(NLX) = IOR (NFLAGS(NLX),RLSBIT) IF (OLDNAM) LOADRB = .TRUE. 'ENDIF' 'ENDIF' RETURN END 'OUTFILE' ENTERGAK.FR SUBROUTINE ENTER C ENTER 'NAME' INTO NAME LIST TABLE (NTABLE) 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' DARRAYGAK.IN, 'INCLUDE' IODEFNGAK.IN, INTEGER SEARCH, DUMMY C ENTER :: X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER ENTER') NLX = SEARCH (DUMMY) 'IF' (NLX.EQ.0) C NAME LIST OVERFLOW CALL ERROR(5) 'ELSE' 'IF' (NFLAGS(NLX).EQ.0) 'IF' (TXSTRT+NSIZE .GT. TXSTOP) C NAME TEXT OVERFLOW CALL ERROR(6) 'ELSE' C OK ENTER NAME HERE OLDNAM = .FALSE. CALL MOVE (NAME, NTEXT(TXSTRT), NSIZE) NTEXTX (NLX) = TXSTRT TXSTRT = TXSTRT + NSIZE NFLAGS(NLX) = USEBIT + NSIZE 'ENDIF' 'ELSE' C NAME ALREADY EXITS IN TABLE. OLDNAM = .TRUE. 'ENDIF' 'IF' (ID.GT.0) 'IF' (ID.GT.DTSTOP) CALL ERROR(12) 'ELSE' 'IF' (DICT(ID).NE.0) CALL ERROR(13) 'ELSE' DICT(ID) = NLX 'ENDIF' 'ENDIF' 'ENDIF' 'ENDIF' X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT ENTER') RETURN END 'OUTFILE' ERRORGAK.FR SUBROUTINE ERROR (N) INTEGER N C ERROR MESSAGE FORMAT AND OUTPUT ROUTINE INTEGER PROC INTEGER NSAVE INTEGER ETEXT (36) 'INCLUDE' ERRDFNGAK.IN, 'INCLUDE' IODEFNGAK.IN, 'INCLUDE' IOFILEGAK.IN, 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' RECORDGAK.IN, 'INCLUDE' CHARACGAK.IN, 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' MEMORYGAK.IN, INTEGER I C ERROR (N) :: X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER ERROR') NSAVE = N IF (N.GT.EMAX) N = 1 50 CONTINUE CALL SET (BLANKS, ETEXT, 36) ECOUNT(N) = ECOUNT(N) +1 PROC = EPROC(N) X WRITE (DBCHAN, 2) PROC, N X2 FORMAT (' IN ERROR BEFORE GOTO; PROC=', I5, ' N= ', I5) GOTO (100,200,300,400,500,600,700,800,900,1000,1100,^ 1200,1300,1400,1500,1600,1700,1800,1900,2000) ^ PROC 100 CONTINUE CALL ESP (NSAVE, ETEXT, 21, 26) GOTO 5000 200 CONTINUE CALL ESP (ECOUNT(NSAVE), ETEXT, 21, 25) GOTO 5000 300 CONTINUE CALL ESP (ECODE, ETEXT, 21, 25) GOTO 5000 400 CONTINUE CALL ESP (RTYPE, ETEXT, 21, 25) CALL ESP (RSTYPE, ETEXT, 26, 30) GOTO 5000 500 CONTINUE CALL MOVE (NAME, ETEXT(11), NSIZE) GOTO 5000 600 CONTINUE CALL MOVE (NAME, ETEXT(11), NSIZE) GOTO 5000 700 CONTINUE CALL MOVE (RBFILE, ETEXT(11), 10) GOTO 5000 800 CONTINUE GOTO 5000 900 CONTINUE GO TO 700 1000 CONTINUE CALL EHX (RECORD(1), ETEXT, 21,24) CALL EHX (RECORD(2), ETEXT, 26,29) CALL EHX (RECORD(3), ETEXT, 31,34) GOTO 5000 1100 CONTINUE CALL EHX (MEMLOC, ETEXT, 21, 24) GOTO 5000 1200 CONTINUE GOTO 1000 1300 CONTINUE GOTO 1000 1400 CONTINUE GOTO 700 1500 CONTINUE CALL EHX (START, ETEXT, 21, 24) GOTO 5000 1600 CONTINUE CALL MOVE (NAME, ETEXT(11), NSIZE) CALL ESP (NDATA(NLX), ETEXT(27), 1,4) CALL ESP (RECORD(3), ETEXT(30), 1,4) GOTO 5000 1700 CONTINUE CALL EHX (MEMLOC, ETEXT, 21,24) GOTO 5000 1800 CONTINUE 1900 CONTINUE 2000 CONTINUE 5000 CONTINUE X WRITE (DBCHAN, 3) X3 FORMAT (' IN ERROR AT 5000') CALL MOVE (EMSG(10*N-9), ETEXT, 10) CALL WRLIN (TTYOUT, ETEXT, 72) CALL WRLIN (MPCHAN, ETEXT, 72) 'IF' (N.EQ.2) P CALL SPOOL (MPCHAN, ECODE) STOP 'ENDIF' 'IF' (ECOUNT(N).GE.ELIMIT(N)) N = 2 GOTO 50 'ENDIF' X WRITE (DBCHAN, 4) X4 FORMAT (' EXIT ERROR') RETURN END 'OUTFILE' GETFLGAK.FR SUBROUTINE GETFL (ERX, EOF) LOGICAL ERX, EOF C GET NEXT RELOCATABLE INPUT FILE NAME LOGICAL EOFFLG INTEGER CMLINE (40), CMX INTEGER RBX INTEGER GCHAR 'INCLUDE' IODEFNGAK.IN, 'INCLUDE' IOFILEGAK.IN, 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' CHARACGAK.IN, INTEGER I DATA EOFFLG /.FALSE./ C GETFL (ERX, EOF) :: X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER GETFL') RBX = 1 'IF' (EOFFLG) EOFFLG = .FALSE. GOTO 9999 'ENDIF' CALL RDLIN (CMCHAN, CMLINE, 80, ECODE) IF (ECODE .NE. 1) GO TO 9999 CMX = 1 CALL SET (BLANKS, RBFILE, 14) 'DO' CHAR = GCHAR (CMLINE, CMX) CMX = CMX + 1 X WRITE (DBCHAN, 2) CHAR X2 FORMAT (' IN GETFL AFTER RDSEQ; CHAR=', I5) IF (IAND(CHAR,CHMASK).EQ.0) CHAR = ISHFT (CHAR,-8) CHAR = IAND (CHAR, CHMASK) 'IF' ((CHAR.EQ.0).OR.(CHAR.EQ.CR).OR.(CHAR.EQ.LF)) CHAR = BLANK 'ENDIF' X WRITE (DBCHAN, 3) CHAR X3 FORMAT (' IN GETFL AFTER TRANSLATION; CHAR=', I5) 'IF' ((RBX.NE.1).AND.(CHAR.EQ.BLANK)) 'BREAK' 'ENDIF' 'IF' ((CHAR.NE.BLANK).AND.(CHAR.NE.CR).AND.(CHAR.NE.LF)) 'IF' ((CHAR.EQ.RBRACK).OR.(CHAR.EQ.LBRACK)) 'IF' (CHAR.EQ.LBRACK) IF (OVMODE) CALL ERROR (14) OVMODE = .TRUE. 'ELSE' IF (.NOT.OVMODE) CALL ERROR (14) OVMODE = .FALSE. 'ENDIF' 'IF' (RBX.NE.1) 'BREAK' 'ENDIF' 'ELSE' 'IF' (RBX.LT.28) CALL PCHAR (RBFILE, RBX, CHAR) RBX = RBX + 1 'ENDIF' 'ENDIF' 'ENDIF' 'END' 9997 CONTINUE X WRITE (DBCHAN, 4) RBFILE X4 FORMAT (' ', 10A2) X WRITE (DBCHAN, 5) X5 FORMAT (' EXIT GETFL') ERX = .FALSE. EOF = .FALSE. RETURN 9999 CONTINUE 'IF' (RBX.NE.1) EOFFLG = .TRUE. GOTO 9997 'ENDIF' X WRITE (DBCHAN, 4) RBFILE X WRITE (DBCHAN, 7) X7 FORMAT (' EXIT GETFL AT 9999') ERX = .FALSE. EOF = .TRUE. RETURN END 'OUTFILE' GRCORDGAK.FR SUBROUTINE GRCORD (ERX, EOF) LOGICAL ERX, EOF C GET NEXT LOGICAL RECORD OF RB DATA LOGICAL ERX2, EOF2 INTEGER GCHAR 'INCLUDE' RECORDGAK.IN, 'INCLUDE' DARRAYGAK.IN, 'INCLUDE' IODEFNGAK.IN, INTEGER I C GRCORD :: (ERX, EOF) X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER GRCORD') 'DO' CALL RDSEQ (RBCHAN, RECORD, 2, ECODE) IF (ECODE .NE. 1) GO TO 9999 X WRITE (DBCHAN, 2) RECORD(1) X2 FORMAT (' IN GRCORD WITH RECORD(1)=', I5) RTYPE = GCHAR (RECORD, 1) RSTYPE = GCHAR (RECORD, 2) RCOUNT = RCOUNT + 1 'WHILE' ((RTYPE.GT.RTMAX).OR.(RTYPE.LE.0)) 'IF' (RTYPE.NE.0) CALL ERROR(4) 'ENDIF' 'END' RSIZE = RSIZES (RTYPE) IF (RSIZE.EQ.0) RSIZE = (RSTYPE+1)/2 + 1 'IF' ((RSIZE.EQ.0).OR.(RSIZE.GT.RSZMAX)) CALL ERROR (4) 'ENDIF' X WRITE (DBCHAN, 3) RSIZE X3 FORMAT (' IN GRCORD WITH RSIZE=', I5) 'IF' (RSIZE.GT.1) CALL RDSEQ (RBCHAN, RECORD (2), 2*(RSIZE - 1), ECODE) IF (ECODE .NE. 1) GO TO 9999 'ENDIF' ID = RECORD(2) X WRITE (DBCHAN, 4) X4 FORMAT (' EXIT GRCORD') ERX = .FALSE. EOF = .FALSE. RETURN 9999 ERX = .FALSE. EOF = .TRUE. RETURN END 'OUTFILE' GNAMEGAK.FR SUBROUTINE GNAME (I) INTEGER I C GET NAME OUT OF CURRENT RB RECORD INTEGER GCHAR, J 'INCLUDE' CHARACGAK.IN, 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' RECORDGAK.IN, C GNAME :: (I) NSIZE = 0 CALL SET (BLANKS, NAME, 16) 'DOLOOP' J = 1, 16 CHAR = GCHAR (RECORD(I), J) 'IF' ((CHAR.EQ.BLANK).OR.(CHAR.EQ.0)) 'BREAK' 'ENDIF' CALL PCHAR (NAME, J, CHAR) NSIZE = NSIZE + 1 'END' NSIZE = (NSIZE+1)/2 RETURN END 'OUTFILE' HASHGAK.FR INTEGER FUNCTION HASH (DUMMY) C CALCULATE HASH CODE OF INPUT NAME 'INCLUDE' NTABLEGAK.IN, INTEGER I C HASH :: (DUMMY) HASH = 0 'DOLOOP' I = 1, NSIZE HASH = HASH + IAND (NAME(I), 32639) 'END' HASH = IAND (ISHFT(HASH,-8) + ISHFT(HASH,8), 32767) HASH = MOD (HASH, NLSTOP) + 1 RETURN END 'OUTFILE' ISWAPGAK.FR INTEGER FUNCTION ISWAP (WORD) INTEGER WORD C SWAP HALFS OF INPUT DATA WORD INTEGER GCHAR, BYTEA, BYTEB, TEMP C ISWAP :: (WORD) BYTEA = GCHAR (WORD, 1) BYTEB = GCHAR (WORD, 2) CALL PCHAR (TEMP, 1, BYTEB) CALL PCHAR (TEMP, 2, BYTEA) ISWAP = TEMP RETURN END 'OUTFILE' KEYWDGAK.FR LOGICAL FUNCTION KEYWD (DUMMY) INTEGER DUMMY C TESTS RB FILE FOR KEY WORD. 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' IOFILEGAK.IN, INTEGER GCHAR INTEGER I, KEYS(10) INTEGER EQUALS DATA EQUALS /61/ DATA KEYS /'NOUNDATAZRELCODERAMX'/ C KEYWD :: (DUMMY) KEYWD = .FALSE. KEY = 0 'DOLOOP' I = 1,10,2 'IF' ((RBFILE(1).EQ.KEYS(I)).AND. ^ (RBFILE(2).EQ.KEYS(I+1)).AND. ^ (GCHAR(RBFILE,5).EQ.EQUALS)) KEY = (I+1)/2 KEYWD = .TRUE. 'BREAK' 'ENDIF' 'END' RETURN END 'OUTFILE' LNAMESGAK.FR SUBROUTINE LNAMES C MARKS ALL ENTRIES IN NAME TABLE (NTABLE) WITH C LOAD MODULE BIT (LDMBIT). 'INCLUDE' NTABLEGAK.IN, INTEGER I C LNAMES :: 'DOLOOP' I = 1,NLSTOP 'IF' (NFLAGS(I).NE.0) NFLAGS(I) = IOR (NFLAGS(I),LDMBIT) 'ENDIF' 'END' RETURN END 'OUTFILE' PUNCHGAK.FR SUBROUTINE PUNCH (CODE, ADDR, NBYTES) INTEGER CODE, ADDR, NBYTES C PUNCH DATA IN ASCII FORMAT OUT TO OBJECT CHANNEL. 'INCLUDE' CHARACGAK.IN, 'INCLUDE' IODEFNGAK.IN, INTEGER GCHAR INTEGER OBJECT (136) INTEGER SUM, DBYTE, SEMI, I, TEMP DATA SEMI /59/ C PUNCH :: (CODE, ADDR, NBYTES) X WRITE (DBCHAN, 1) CODE, ADDR, NBYTES X1 FORMAT (' ENTER PUNCH WITH ', 3I5) 'IF' (NBYTES.GT.255) CALL ERROR (8) RETURN 'ENDIF' CALL SET (BLANKS, OBJECT, 136) CALL PCHAR (OBJECT, 1, SEMI) CALL EHX (NBYTES, OBJECT, 2,3) 'IF' (NBYTES.LE.0) CALL WRLIN (OBCHAN, OBJECT, 4) RETURN 'ENDIF' CALL EHX (ADDR, OBJECT, 4,7) SUM = NBYTES SUM = SUM + GCHAR (ADDR, 1) SUM = SUM + GCHAR (ADDR, 2) 'DOLOOP' I = 1, NBYTES DBYTE = GCHAR (CODE, I) CALL EHX (DBYTE, OBJECT, 2*I+6, 2*I+7) SUM = SUM + DBYTE 'END' CALL EHX (SUM, OBJECT, 2*NBYTES+8, 2*NBYTES+11) CALL WRLIN (OBCHAN, OBJECT, 2*NBYTES + 12) CALL USEMEM (ADDR, NBYTES) X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT PUNCH') RETURN END 'OUTFILE' PUSHMDGAK.FR SUBROUTINE PUSHMD C PUSH CURRENT MODULE DATA INTO STACK 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' STACKSGAK.IN, C PUSHMD :: IF (MX.GT.MSTKSZ) CALL ERROR(8) MSTACK (MX) = NLOC MSTACK (MX+1) = NMAX MSTACK (MX+2) = DLOC MSTACK (MX+3) = DMAX MSTACK (MX+4) = ZLOC MSTACK (MX+5) = ZMAX MSTACK (MX+6) = CLOC MSTACK (MX+7) = CMAX MSTACK (MX+8) = OLOC MSTACK (MX+9) = OMAX MSTACK (MX+10) = OSET MSTACK (MX+11) = TXSTRT MX = MX + 12 RETURN END 'OUTFILE' POPMDGAK.FR SUBROUTINE POPMD C POP PRIOR MODULE DATA FROM STACK 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' STACKSGAK.IN, C POPMD :: MX = MX - 12 IF (MX.LT.1) CALL ERROR(8) 'IF' (.NOT.LOADRB) NLOC = MSTACK (MX) NMAX = MSTACK (MX+1) DLOC = MSTACK (MX+2) DMAX = MSTACK (MX+3) ZLOC = MSTACK (MX+4) ZMAX = MSTACK (MX+5) CLOC = MSTACK (MX+6) CMAX = MSTACK (MX+7) OLOC = MSTACK (MX+9) OMAX = MSTACK (MX+9) OSET = MSTACK (MX+10) TXSTRT = MSTACK (MX+11) 'ENDIF' RETURN END 'OUTFILE' SEARCHGAK.FR INTEGER FUNCTION SEARCH (DUMMY) C SEARCH NAME LIST TABLE (NTABLE) FOR 'NAME' 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' IODEFNGAK.IN, INTEGER TEST, SSIZE, STX, I, J INTEGER HASH, DUMMY C SEARCH :: X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER SEARCH') SEARCH = 0 TEST = HASH (DUMMY) 'DOLOOP' I = 1, NLSTOP 'IF' (NFLAGS(TEST).EQ.0) SEARCH = TEST 'BREAK' 'ENDIF' SSIZE = IAND (NFLAGS(TEST), NTXBTS) STX = NTEXTX (TEST) 'IF' (SSIZE.EQ.NSIZE) 'DOLOOP' J = 1, SSIZE 'IF' (NTEXT(STX).NE.NAME(J)) GOTO 1 'ENDIF' STX = STX + 1 'END' SEARCH = TEST 'BREAK' 'ENDIF' 1 CONTINUE TEST = TEST + 1 IF (TEST.GT.NLSTOP) TEST = 1 'END' X WRITE (DBCHAN, 2) SEARCH X2 FORMAT (' EXIT SEARCH = ', I5) RETURN END 'OUTFILE' SETKEYGAK.FR SUBROUTINE SETKEY C SET GROUP AREA LOCATIONS ACCORDING TO KEY 'INCLUDE' CHARACGAK.IN, 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' IOFILEGAK.IN, 'INCLUDE' MEMORYGAK.IN, INTEGER VALUE, VALUE2, I, GCHAR C SETKEY :: IF ((KEY.LT.1).OR.(KEY.GT.5)) RETURN VALUE = 0 VALUE2 = 0 'DOLOOP' I = 1,4 CHAR = GCHAR (RBFILE, I+5) CHAR = IAND (CHAR, CHMASK) IF ((CHAR.GE.ACH).AND.(CHAR.LE.FCH)) CHAR = CHAR - 7 VALUE = ISHFT (VALUE, 4) + (CHAR - 48) CHAR = GCHAR (RBFILE, I+10) CHAR = IAND (CHAR, CHMASK) IF ((CHAR.GE.ACH).AND.(CHAR.LE.FCH)) CHAR = CHAR - 7 VALUE2 = ISHFT (VALUE2, 4) + (CHAR-48) 'END' GOTO (100,200,300,400,500) KEY 100 NSTR = VALUE NLOC = VALUE CALL UPDATE (NLOC, 0, NMAX) GOTO 1000 200 DSTR = VALUE DLOC = VALUE CALL UPDATE (DLOC, 0, DMAX) GOTO 1000 300 ZSTR = VALUE ZLOC = VALUE CALL UPDATE (ZLOC, 0, ZMAX) GOTO 1000 400 CSTR = VALUE CLOC = VALUE CALL UPDATE (CLOC, 0, CMAX) GOTO 1000 500 ONEK = ISHFT (VALUE, -10) + 1 ENDK = ISHFT (VALUE2, -10) + 1 'DOLOOP' I = ONEK, ENDK ROM (I) = 1 'END' 1000 CONTINUE RETURN END 'OUTFILE' UPDATEGAK.FR SUBROUTINE UPDATE (LOC, NBYTES, MAX) INTEGER LOC, NBYTES, MAX INTEGER TS C UPDATE :: (LOC, NBYTES, MAX) LOC = LOC + NBYTES TS = ISHFT (LOC, -1) - ISHFT (MAX, -1) 'IF' (TS .GT. 0) MAX = LOC 'ELSE' 'IF' (TS .EQ. 0 .AND. IAND (LOC, 1) .NE. 0) MAX = LOC 'ENDIF' 'ENDIF' RETURN END 'OUTFILE' USEMEMGAK.FR SUBROUTINE USEMEM (ADDR, NBYTES) INTEGER ADDR, NBYTES C MARK MEMORY BYTES AS USED 'INCLUDE' BITDFNGAK.IN, 'INCLUDE' DARRAYGAK.IN, 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' MEMORYGAK.IN, 'INCLUDE' IODEFNGAK.IN, INTEGER I LOGICAL OWRITE C USEMEM :: (ADDR, NBYTES) X WRITE (DBCHAN, 1) ADDR, NBYTES X1 FORMAT (' ENTER USEMEM WITH', 2I5) OWRITE = .FALSE. MEMLOC = ADDR 'DOLOOP' I = 1, NBYTES MEMX = ISHFT (MEMLOC,-4) + 1 BITNO = IAND (MEMLOC, 15) + 1 BIT = BITS (BITNO) 'IF' (IAND(MEMORY(MEMX),BIT).NE.0) 'IF' (OWRITE.EQ..FALSE.) OWRITE = .TRUE. NLX = DICT (CID) IF (IAND(NFLAGS(NLX),TYPBTS+COMBIT).NE.0) ^ CALL ERROR(11) 'ENDIF' 'ELSE' OWRITE = .FALSE. MEMORY(MEMX) = MEMORY(MEMX) + BIT 'ENDIF' ONEK = ISHFT (MEMLOC,-10) + 1 'IF' (ROM(ONEK).EQ.1) CALL ERROR (17) 'ENDIF' MEMLOC = MEMLOC + 1 'END' X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT USEMEM') RETURN END \\\\\ SUBFILE: INITLZ.FS @16:1 23-MAY-1979 <055> (152) 'HEAD' LINKER, INITIALIZATION C EDIT DATE 11JAN79 09:33 C SOURCE FILE INITLZGAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 2 'OUTFILE' INITLZGAK.FR SUBROUTINE INITLZ 'INCLUDE' BITDFNGAK.IN, 'INCLUDE' IODEFNGAK.IN, 'INCLUDE' IOFILEGAK.IN, 'INCLUDE' NTABLEGAK.IN, C INITLZ :: X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER INITLZ') BIT15 = ISHFT (BIT14,1) TYPBTS = BIT15 + BIT14 + BIT13 CALL OPENF (TTYIN, TIFILE, ECODE) N CALL OPENF (TTYOUT, TOFILE, ECODE) X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT INITLZ') RETURN END \\\\\ SUBFILE: MAKLIB.FS @16:1 23-MAY-1979 <055> (177) 'HEAD' MAKE LIBRARY BLOCKS C EDIT DATE 11JAN79 10:02 C SOURCE FILE MAKLIBAJH.FS C AUTHOR A. J. HOWARD 'OUTFILE' MAKLIBAJH.FR INTEGER STFILE (16), ENFILE (16) INTEGER LSTART, LSTOP, ERROR DATA STFILE /'LIBSTART.OBJ', 10*0/ DATA ENFILE /'LIBEND.OBJ', 11*0/ DATA LSTART /0/ DATA LSTOP /0/ CALL PCHAR (LSTART, 1, 19) CALL PCHAR (LSTOP, 1, 20) P CALL DEVICE (STFILE) CALL OPENN (1, STFILE, ERROR) CALL WRSEQ (1, LSTART, 2) CALL CLOSF (1, ERROR) P CALL DEVICE (ENFILE) CALL OPENN (1, ENFILE, ERROR) CALL WRSEQ (1, LSTOP, 2) CALL CLOSF (1, ERROR) STOP END \\\\\ SUBFILE: LISTRB.FS @16:1 23-MAY-1979 <055> (1173) 'HEAD' LIST 6502 RB FILES C EDIT DATE 01FEB79 17:54 C SOURCE FILE LISTRBGAK.FS C AUTHOR GARY A. KUDIS 'OUTFILE' LISTRBGAK.FR INTEGER GCHAR 'INCLUDE' CHARACGAK.IN, 'INCLUDE' IODEFNGAK.IN, 'INCLUDE' IOFILEGAK.IN, INTEGER RBQUES (7) INTEGER LSQUES (4) INTEGER ANSWER (16) INTEGER DFAULT (5) DATA RBQUES /'RB FILE NAME? '/ DATA LSQUES /'LS FILE?'/ DATA DFAULT /'LISTRB.LST'/ 'EJECT' C LISTRB :: CALL OPENF (TTYIN, TIFILE, ECODE) N CALL OPENF (TTYOUT, TOFILE, ECODE) 'DO' CALL SET (BLANKS, ANSWER, 14) CALL SET (BLANKS, RBFILE, 14) CALL WRLIN (TTYOUT, RBQUES, 14) CALL RDLIN (TTYIN, ANSWER, 30, ECODE) IF (ECODE .NE. 1) STOP CHAR = GCHAR (ANSWER, 1) IF (CHAR.EQ.0) CHAR = BLANK 'IF' ((CHAR.EQ.BLANK).OR.(CHAR.EQ.CR)) 'BREAK' 'ENDIF' CALL MOVE (ANSWER, RBFILE, 14) P CALL DEVICE (RBFILE) CALL OPENF (RBCHAN, RBFILE, ECODE) 'IF' (ECODE.NE.1) CALL ERROR(3) 'BREAK' 'ENDIF' CALL SET (BLANKS, ANSWER, 14) CALL WRLIN (TTYOUT, LSQUES, 8) CALL RDLIN (TTYIN, ANSWER, 30, ECODE) IF (ECODE .NE. 1) STOP CHAR = GCHAR (ANSWER, 1) 'IF' ((CHAR.EQ.BLANK).OR.(CHAR.EQ.CR)) CALL MOVE (DFAULT, ANSWER, 5) 'ENDIF' CALL MOVE (ANSWER, MPFILE, 14) P CALL DEVICE (RBFILE) CALL OPENN (MPCHAN, MPFILE, ECODE) CALL WRLIN (MPCHAN, RBFILE, 30) CALL FMTRB CALL CLOSF (RBCHAN, ECODE) 'IF' (ECODE.NE.1) CALL ERROR(3) 'BREAK' 'ENDIF' N CALL CLOSF (MPCHAN, ECODE) N 'IF' (ECODE.NE.1) N CALL ERROR(3) N 'BREAK' N 'ENDIF' P CALL SPOOL (MPCHAN, ECODE) 'END' STOP END 'OUTFILE' FMTRBGAK.FR SUBROUTINE FMTRB 'INCLUDE' RECORDGAK.IN, 'INCLUDE' IODEFNGAK.IN, 'INCLUDE' CHARACGAK.IN, LOGICAL ERX, EOF INTEGER RBTEXT (82) INTEGER GCHAR INTEGER LINES INTEGER I, J C FMTRB : 'DO' CALL SET (DASHES, RBTEXT, 20) CALL WRLIN (MPCHAN, RBTEXT, 40) CALL SET (BLANKS, RBTEXT, 82) LINES = 1 CALL GRCORD (ERX, EOF) IF (ERX) GO TO 9998 IF (EOF) GO TO 9999 GO TO (100,200,300,400,500,600,700,800,900,^ 1000,1100,1200,1300,1400,1500,1600,1700,^ 1800,1900,2000) RTYPE 100 CONTINUE CALL MOVE (RECORD(2), RBTEXT(3), 8) GO TO 5000 200 CONTINUE LINES = 0 GO TO 5000 300 CONTINUE CALL EHX (RECORD(2), RBTEXT, 5,8) GO TO 5000 400 CONTINUE LINES = 2 CALL MOVE (RECORD(2), RBTEXT(3), 40) GO TO 5000 500 CONTINUE CALL EHX (RECORD(2), RBTEXT, 5,8) CALL EHX (RECORD(3), RBTEXT, 9,12) CALL MOVE (RECORD(4), RBTEXT(7), 8) GO TO 5000 600 CONTINUE GO TO 500 700 CONTINUE CALL EHX (RECORD(2), RBTEXT, 5,8) CALL EHX (RECORD(3), RBTEXT, 9,12) CALL EHX (RECORD(4), RBTEXT, 13,16) CALL MOVE (RECORD(5), RBTEXT(9), 8) GO TO 5000 800 CONTINUE GO TO 700 900 CONTINUE CALL EHX (RECORD(2), RBTEXT, 5,8) CALL MOVE (RECORD(3), RBTEXT(5), 8) GO TO 5000 1000 CONTINUE LINES = (RSTYPE+19)/20 'DOLOOP' I = 1, RSTYPE CALL EHX (RECORD(I+1), RBTEXT(2*I+1), 1,4) 'END' GO TO 5000 1100 CONTINUE CALL EHX (RECORD(2), RBTEXT, 5,8) CALL EHX (RECORD(3), RBTEXT, 9,12) GO TO 5000 1200 CONTINUE CALL EHX (RECORD(2), RBTEXT, 5,8) CALL EHX (RECORD(3), RBTEXT, 9,12) CALL EHX (RECORD(4), RBTEXT, 13,16) GO TO 5000 1300 CONTINUE GO TO 1200 1400 CONTINUE GO TO 1100 1500 CONTINUE CALL EHX (RECORD(2), RBTEXT, 5,8) GO TO 5000 1600 CONTINUE GO TO 1500 1700 CONTINUE GO TO 1100 1800 CONTINUE GO TO 500 1900 CONTINUE 2000 CONTINUE LINES = 0 5000 CONTINUE CALL EHX (RTYPE, RBTEXT, 1, 2) CALL EHX (RSTYPE, RBTEXT, 3, 4) CALL WRLIN (MPCHAN, RBTEXT, 4) IF (LINES .NE. 0) CALL WRLINE (MPCHAN, RBTEXT (3), 40) IF (LINES .EQ. 2) CALL WRLINE (MPCHAN, RBTEXT (23), 40) 'END' 9998 CONTINUE 9999 CONTINUE RETURN END \\\\\ SUBFILE: LPASS1.FS @16:1 23-MAY-1979 <055> (3193) 'HEAD' LINKER, PASS 1 C EDIT DATE 01FEB79 17:26 C SOURCE FILE LPASS1GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 4 'OUTFILE' LPASS1GAK.FR SUBROUTINE PASS1 'INCLUDE' RECORDGAK.IN, 'INCLUDE' IODEFNGAK.IN, 'INCLUDE' IOFILEGAK.IN, LOGICAL ERX, EOF, KEYWD INTEGER I, DUMMY C PASS1 :: X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER PASS1') 'DO' CALL GETFL (ERX, EOF) IF (ERX) GO TO 9998 IF (EOF) GO TO 9999 'IF' (KEYWD(DUMMY)) CALL SETKEY 'NEXT' 'ENDIF' P CALL DEVICE (RBFILE) CALL OPENF (RBCHAN, RBFILE, ECODE) 'IF' (ECODE.NE.1) CALL ERROR(3) 'NEXT' 'ENDIF' X WRITE (DBCHAN, 2) (RBFILE(I),I=1,7) X2 FORMAT (' IN PASS1 AFTER OPEN ', 7A2) 'DO' CALL GRCORD (ERX, EOF) IF (ERX) GO TO 9996 IF (EOF) GO TO 9997 IF (RTYPE .NE. 3) CALL CHCKER X WRITE (DBCHAN, 3) RTYPE, RSTYPE X3 FORMAT (' IN PASS1; RTYPE= ', I6, ' RSTYPE= ', I6) GOTO (100,200,300,400,500,600,700,800,900,^ 1000,1100,1200,1300,1400,1500,1600,1700,^ 1800,1900,2000) RTYPE 100 CALL T01P1 'NEXT' 200 CALL T02P1 'NEXT' 300 CALL T03P1 'NEXT' 400 CALL T04P1 'NEXT' 500 CALL T05P1 'NEXT' 600 CALL T06P1 'NEXT' 700 CALL T07P1 'NEXT' 800 CALL T08P1 'NEXT' 900 CALL T09P1 'NEXT' 1000 CALL T10P1 'NEXT' 1100 CALL T11P1 'NEXT' 1200 CALL T12P1 'NEXT' 1300 CALL T13P1 'NEXT' 1400 CALL T14P1 'NEXT' 1500 CALL T15P1 'NEXT' 1600 CALL T16P1 'NEXT' 1700 CALL T17P1 'NEXT' 1800 CALL T18P1 'NEXT' 1900 CALL T19P1 'NEXT' 2000 CALL T20P1 'END' 9996 CONTINUE CALL ERROR (7) 9997 CONTINUE CALL CLOSF (RBCHAN, ECODE) IF (ECODE.NE.1) CALL ERROR (3) 'END' 9998 CONTINUE 9999 CONTINUE X WRITE (DBCHAN, 4) X4 FORMAT (' EXIT PASS1') RETURN END 'OUTFILE' T01P1GAK.FR SUBROUTINE T01P1 C EDIT DATE 01FEB79 17:26 C SOURCE FILE LPASS1GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 4.01 C PASS 1 RECORD TYPE 01 'MODULE START' PROCESS 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' DARRAYGAK.IN, 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' IODEFNGAK.IN, INTEGER I INTEGER TITLE DATA TITLE /'$$'/ C T01P1 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T01P1') NTITLE = NTITLE + 1 CALL GNAME (2) NAME (1) = TITLE CALL EHX (NTITLE, NAME, 3, 6) NSIZE = 3 ID = 0 CALL PUSHMD CALL ENTER 'IF' (IAND(NFLAGS(NLX), RLSBIT).EQ.0) NFLAGS(NLX) = IOR (NFLAGS(NLX),MODBIT+RLSBIT) 'ELSE' NFLAGS(NLX) = IOR (NFLAGS(NLX),MLTBIT) 'ENDIF' X WRITE (DBCHAN, 2) NLX, (NAME(I), I=1,NSIZE) X2 FORMAT (' ', I5, ' ', 16A2) MODNLX = NLX CALL SET (0, DICT, DTSTOP) CKSUM = 0 'IF' (LBMODE) LOADRB = .FALSE. 'ELSE' LOADRB = .TRUE. NFLAGS(NLX) = IOR (NFLAGS(NLX),LDMBIT) 'ENDIF' X WRITE (DBCHAN, 3) X3 FORMAT (' EXIT T01P1') RETURN END 'OUTFILE' T02P1GAK.FR SUBROUTINE T02P1 C EDIT DATE 01FEB79 17:26 C SOURCE FILE LPASS1GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 4.02 C PASS 1 RECORD TYPE 2 'MODULE END' PROCESS 'INCLUDE' IODEFNGAK.IN, 'INCLUDE' LDATAXGAK.IN, C T02P1 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T02P1') CALL POPMD 'IF' (LBMODE .AND. .NOT. LOADRB) CALL DNAMES 'ELSE' CALL LNAMES 'ENDIF' X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T02P1') RETURN END 'OUTFILE' T03P1GAK.FR SUBROUTINE T03P1 C EDIT DATE 01FEB79 17:26 C SOURCE FILE LPASS1GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 4.03 C PASS 1 RECORD TYPE 3 'CHECKSUM' PROCESS 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' RECORDGAK.IN, 'INCLUDE' IODEFNGAK.IN, C T03P1 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T03P1') IF (RECORD(2).NE.CKSUM) CALL ERROR(9) CKSUM = 0 X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T03P1') RETURN END 'OUTFILE' T04P1GAK.FR SUBROUTINE T04P1 C EDIT DATE 01FEB79 17:26 C SOURCE FILE LPASS1GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 4.04 C PASS 1 RECORD TYPE 4 'MODULE ID' PROCESS 'INCLUDE' IODEFNGAK.IN, C T04P1 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T04P1') X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T04P1') RETURN END 'OUTFILE' T05P1GAK.FR SUBROUTINE T05P1 C EDIT DATE 01FEB79 17:26 C SOURCE FILE LPASS1GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 4.05 C PASS 1 RECORD TYPE 5 'GROUP DEFINITION' PROCESS 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' DARRAYGAK.IN, 'INCLUDE' IODEFNGAK.IN, C T05P1 : X WRITE (DBCHAN, 1) X1 FORMAT (' INTER T05P1') CALL GNAME(4) 'IF'(NSIZE.GT.0) CALL EHX (NTITLE, NAME(NSIZE+1), 1,4) CALL EHX (ID, NAME(NSIZE+3), 1,4) NSIZE = NSIZE + 4 CALL ENTER CALL AREADF NFLAGS (NLX) = IOR (NFLAGS(NLX), GDFBIT) 'ENDIF' X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T05P1') RETURN END 'OUTFILE' T06P1GAK.FR SUBROUTINE T06P1 C EDIT DATE 01FEB79 17:26 C SOURCE FILE LPASS1GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 4.06 C PASS 1 RECORD TYPE 6 'COMMON DEFINITION' PROCESS 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' RECORDGAK.IN, 'INCLUDE' IODEFNGAK.IN, C T06P1 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T06P1') CALL GNAME(4) 'IF' (NSIZE.GT.0) CALL ENTER 'IF' (IAND(NFLAGS(NLX),RLSBIT).EQ.0) CALL AREADF NFLAGS(NLX) = IOR(NFLAGS(NLX),COMBIT) 'ELSE' IF (NDATA(NLX).NE.RECORD(3)) CALL ERROR(16) 'ENDIF' 'ENDIF' X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T06P1') RETURN END 'OUTFILE' T07P1GAK.FR SUBROUTINE T07P1 C EDIT DATE 01FEB79 17:26 C SOURCE FILE LPASS1GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 4.07 C PASS 1 RECORD TYPE 7 'ENTRY POINT DEFINITION' PROCESS 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' IODEFNGAK.IN, C T07P1 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T07P1') CALL GNAME(5) 'IF' (NSIZE.GT.0) CALL ENTER CALL ENPTDF NFLAGS (NLX) = IOR (NFLAGS(NLX), EPTBIT) 'ENDIF' X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T07P1') RETURN END 'OUTFILE' T08P1GAK.FR SUBROUTINE T08P1 C EDIT DATE 01FEB79 17:26 C SOURCE FILE LPASS1GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 4.08 C PASS 1 RECORD TYPE 8 'OVERLAY ID' PROCESS 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' IODEFNGAK.IN, C T08P1 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T08P1') CALL GNAME(5) 'IF' (NSIZE.GT.0) CALL ENTER CALL ENPTDF NFLAGS (NLX) = IOR (NFLAGS(NLX), OVLBIT) 'ENDIF' X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T08P1') RETURN END 'OUTFILE' T09P1GAK.FR SUBROUTINE T09P1 C EDIT DATE 01FEB79 17:26 C SOURCE FILE LPASS1GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 4.09 C PASS 1 RECORD TYPE 9 'EXTERNAL NAME' PROCESS 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' IODEFNGAK.IN, C T09P1 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T09P1') CALL GNAME(3) 'IF' (NSIZE.NE.0) CALL ENTER 'ENDIF' X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T09P1') RETURN END 'OUTFILE' T10P1GAK.FR SUBROUTINE T10P1 C EDIT DATE 01FEB79 17:26 C SOURCE FILE LPASS1GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 4.10 C PASS 1 RECORD TYPE 10 'ABSOLUTE DATA' PROCESS 'INCLUDE' IODEFNGAK.IN, C T10P1 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T10P1') X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T10P1') RETURN END 'OUTFILE' T11P1GAK.FR SUBROUTINE T11P1 C EDIT DATE 01FEB79 17:26 C SOURCE FILE LPASS1GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 4.11 C PASS 1 RECORD TYPE 11 'RELOCATABLE DATA (1 OR 2 BYTES)' PROCESS 'INCLUDE' RECORDGAK.IN, 'INCLUDE' IODEFNGAK.IN, INTEGER ISWX, NBYTES C T11P1 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T11P1') ISWX = RSTYPE + 1 X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T11P1') RETURN END 'OUTFILE' T12P1GAK.FR SUBROUTINE T12P1 C EDIT DATE 01FEB79 17:26 C SOURCE FILE LPASS1GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 4.12 C PASS 1 RECORD TYPE 12 'RELOCATABLE DATA (2 OR 3 BYTES)' PROCESS 'INCLUDE' RECORDGAK.IN, 'INCLUDE' IODEFNGAK.IN, INTEGER ISWX, NBYTES C T12P1 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T12P1') ISWX = RSTYPE + 1 X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T12P1') RETURN END 'OUTFILE' T13P1GAK.FR SUBROUTINE T13P1 C EDIT DATE 01FEB79 17:27 C SOURCE FILE LPASS1GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 4.13 C PASS 1 RECORD TYPE 13 'COMPUTATION' PROCESS 'INCLUDE' RECORDGAK.IN, 'INCLUDE' IODEFNGAK.IN, INTEGER ISWX, NBYTES C T13P1 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T13P1') ISWX = RSTYPE + 1 X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T13P1') RETURN END 'OUTFILE' T14P1GAK.FR SUBROUTINE T14P1 C EDIT DATE 01FEB79 17:27 C SOURCE FILE LPASS1GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 4.14 C PASS 1 RECORD TYPE 14 'SET LOCATION' PROCESS RETURN END 'OUTFILE' T15P1GAK.FR SUBROUTINE T15P1 C EDIT DATE 01FEB79 17:28 C SOURCE FILE LPASS1GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 4.15 C PASS 1 RECORD TYPE 15 'ADJUST LOCATION' PROCESS 'INCLUDE' IODEFNGAK.IN, C T15P1 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T15P1') X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T15P1) RETURN END 'OUTFILE' T16P1GAK.FR SUBROUTINE T16P1 C EDIT DATE 01FEB79 17:28 C SOURCE FILE LPASS1GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 4.16 C PASS 1 RECORD TYPE 16 'CHANGE GROUP' PROCESS 'INCLUDE' IODEFNGAK.IN, C T16P1 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T16P1') X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T16P1') RETURN END 'OUTFILE' T17P1GAK.FR SUBROUTINE T17P1 C EDIT DATE 01FEB79 17:28 C SOURCE FILE LPASS1GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 4.17 C PASS 1 RECORD TYPE 17 'ESTABLISH RUN ADDRESS' PROCESS 'INCLUDE' IODEFNGAK.IN, C T17P1 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T17P1') X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T17P1') RETURN END 'OUTFILE' T18P1GAK.FR SUBROUTINE T18P1 C EDIT DATE 01FEB79 17:28 C SOURCE FILE LPASS1GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 4.18 C PASS 1 RECORD TYPE 18 'LOCAL NAME DEFINITION' PROCESS 'INCLUDE' IODEFNGAK.IN, C T18P1 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T18P1') X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T18P1') RETURN END 'OUTFILE' T19P1GAK.FR SUBROUTINE T19P1 C EDIT DATE 01FEB79 17:28 C SOURCE FILE LPASS1GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 4.19 C PASS 1 RECORD TYPE 19 'LIBRARY START' PROCESS 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' IODEFNGAK.IN, C T19P1 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T19P1') LBMODE = .TRUE. X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T19P1') RETURN END 'OUTFILE' T20P1GAK.FR SUBROUTINE T20P1 C EDIT DATE 01FEB79 17:28 C SOURCE FILE LPASS1GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 4.20 C PASS 1 RECORD TYPE 20 'LIBRARY END' PROCESS 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' IODEFNGAK.IN, C T20P1 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T20P1') LBMODE = .FALSE. X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T20P1') RETURN END \\\\\ SUBFILE: LPASS2.FS @16:1 23-MAY-1979 <055> (4451) 'HEAD' LINKER, PASS 2 C EDIT DATE 26JAN79 09:29 C SOURCE FILE LPASS2GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 5 'OUTFILE' LPASS2GAK.FR SUBROUTINE PASS2 'INCLUDE' RECORDGAK.IN, 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' IODEFNGAK.IN, 'INCLUDE' IOFILEGAK.IN, LOGICAL ERX, EOF, KEYWD INTEGER I, DUMMY C PASS2 :: X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER PASS2') CALL I2PASS 'DO' CALL GETFL (ERX, EOF) IF (ERX) GO TO 9998 IF (EOF) GO TO 9999 'IF' (KEYWD(DUMMY)) CALL WRLIN (MPCHAN, RBFILE, 28) 'NEXT' 'ENDIF' P CALL DEVICE (RBFILE) CALL OPENF (RBCHAN, RBFILE, ECODE) 'IF' (ECODE.NE.1) CALL ERROR(3) 'NEXT' 'ENDIF' X WRITE (DBCHAN, 2) (RBFILE(I), I=1,7) X2 FORMAT (' IN PASS2 AFTER OPEN ', 7A2) 'DO' CALL GRCORD (ERX, EOF) IF (ERX) GO TO 9996 IF (EOF) GO TO 9997 'IF' (RTYPE.NE.1 .AND. RTYPE.NE.2 .AND. .NOT.LOADRB) 'NEXT' 'ENDIF' IF (RTYPE.NE.3) CALL CHCKER X WRITE (DBCHAN, 3) RTYPE, RSTYPE X3 FORMAT (' IN PASS2; RTYPE= ', I6, ' RSTYPE= ', I6) GOTO (100,200,300,400,500,600,700,800,900,^ 1000,1100,1200,1300,1400,1500,1600,1700,^ 1800,1900,2000) RTYPE 100 CALL T01P2 'NEXT' 200 CALL T02P2 'NEXT' 300 CALL T03P2 'NEXT' 400 CALL T04P2 'NEXT' 500 CALL T05P2 'NEXT' 600 CALL T06P2 'NEXT' 700 CALL T07P2 'NEXT' 800 CALL T08P2 'NEXT' 900 CALL T09P2 'NEXT' 1000 CALL T10P2 'NEXT' 1100 CALL T11P2 'NEXT' 1200 CALL T12P2 'NEXT' 1300 CALL T13P2 'NEXT' 1400 CALL T14P2 'NEXT' 1500 CALL T15P2 'NEXT' 1600 CALL T16P2 'NEXT' 1700 CALL T17P2 'NEXT' 1800 CALL T18P2 'NEXT' 1900 CALL T19P2 'NEXT' 2000 CALL T20P2 'END' 9996 CALL ERROR (7) 9997 CALL CLOSF (RBCHAN, ECODE) IF (ECODE.NE.1) CALL ERROR (3) 'END' 9998 CONTINUE 9999 CONTINUE CALL PUNCH (0, 0, 0) X WRITE (DBCHAN, 4) X4 FORMAT (' EXIT PASS2') RETURN END 'OUTFILE' T01P2GAK.FR SUBROUTINE T01P2 C EDIT DATE 26JAN79 09:29 C SOURCE FILE LPASS2GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 5.01 C PASS 2 RECORD TYPE 01 'MODULE START' PROCESS 'INCLUDE' IODEFNGAK.IN, 'INCLUDE' DARRAYGAK.IN, 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' NTABLEGAK.IN, INTEGER SEARCH, DUMMY INTEGER I INTEGER TITLE DATA TITLE /'$$'/ C T01P2 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T01P2') NTITLE = NTITLE + 1 NAME (1) = TITLE CALL EHX (NTITLE, NAME, 3, 6) NSIZE = 3 NLX = SEARCH (DUMMY) MODNLX = NLX CALL SET (0, DICT, DTSTOP) CKSUM = 0 CALL GNAME (2) 'IF' (IAND(NFLAGS(NLX),LDMBIT).EQ.0) LOADRB = .FALSE. 'ELSE' LOADRB = .TRUE. CALL WRLIN (MPCHAN, NAME, 2*NSIZE) 'ENDIF' X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T01P2') RETURN END 'OUTFILE' T02P2GAK.FR SUBROUTINE T02P2 C EDIT DATE 26JAN79 09:32 C SOURCE FILE LPASS2GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 5.02 C PASS 2 RECORD TYPE 2 'MODULE END' PROCESS 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' DARRAYGAK.IN, 'INCLUDE' IODEFNGAK.IN, 'INCLUDE' TXTCOMGAK.IN, INTEGER I C T02P2 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T02P2') 'IF' (LOADRB) CALL WRLIN (MPCHAN, TEXT, 54) 'ENDIF' LOADRB = .FALSE. 'DOLOOP' I = 1, DTSTOP 'IF' (DICT(I).NE.0) X WRITE (DBCHAN, 2) I, DICT(I) X2 FORMAT (' ', I5, ' ', I5) 'ELSE' 'BREAK' 'ENDIF' 'END' X WRITE (DBCHAN, 3) X3 FORMAT (' EXIT T02P2') RETURN END 'OUTFILE' T03P2GAK.FR SUBROUTINE T03P2 C EDIT DATE 26JAN79 09:32 C SOURCE FILE LPASS2GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 5.03 C PASS 2 RECORD TYPE 3 'CHECKSUM' PROCESS 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' RECORDGAK.IN, 'INCLUDE' IODEFNGAK.IN, C T03P2 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T03P2') IF (RECORD(2).NE.CKSUM) CALL ERROR(9) CKSUM = 0 X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T03P2') RETURN END 'OUTFILE' T04P2GAK.FR SUBROUTINE T04P2 C EDIT DATE 26JAN79 09:32 C SOURCE FILE LPASS2GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 5.04 C PASS 2 RECORD TYPE 4 'MODULE ID' PROCESS 'INCLUDE' RECORDGAK.IN, 'INCLUDE' IODEFNGAK.IN, INTEGER I C T04P2 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T04P2') CALL WRLIN (MPCHAN, RECORD, 80) X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T04P2') RETURN END 'OUTFILE' T05P2GAK.FR SUBROUTINE T05P2 C EDIT DATE 26JAN79 09:32 C SOURCE FILE LPASS2GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 5.05 C PASS 2 RECORD TYPE 5 'GROUP DEFINITION' PROCESS 'INCLUDE' DARRAYGAK.IN, 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' IODEFNGAK.IN, 'INCLUDE' RECORDGAK.IN, 'INCLUDE' TXTCOMGAK.IN, INTEGER SEARCH, DUMMY C T05P2 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T05P2') CALL GNAME(4) 'IF' (NSIZE.GT.0) CALL EHX (NTITLE, NAME(NSIZE+1), 1,4) CALL EHX (ID, NAME(NSIZE+3), 1,4) NSIZE = NSIZE + 4 NLX = SEARCH (DUMMY) 'IF' ((NLX.NE.0).AND.(NFLAGS(NLX).NE.0)) DICT (ID) = NLX 'IF' (RSTYPE .NE. 0) CALL EHX (NADDRS (NLX), TEXT, LEFT (RSTYPE), ^ RIGHT (RSTYPE)) 'ENDIF' 'ENDIF' 'ENDIF' X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T05P2') RETURN END 'OUTFILE' T06P2GAK.FR SUBROUTINE T06P2 C EDIT DATE 26JAN79 09:32 C SOURCE FILE LPASS2GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 5.06 C PASS 2 RECORD TYPE 6 'COMMON DEFINITION' PROCESS 'INCLUDE' DARRAYGAK.IN, 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' IODEFNGAK.IN, INTEGER SEARCH, DUMMY C T06P2 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T06P2') CALL GNAME(4) 'IF' (NSIZE.GT.0) NLX = SEARCH (DUMMY) 'IF' ((NLX.NE.0).AND.(NFLAGS(NLX).NE.0)) DICT (ID) = NLX 'ENDIF' 'ENDIF' X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T06P2') RETURN END 'OUTFILE' T07P2GAK.FR SUBROUTINE T07P2 C EDIT DATE 26JAN79 09:32 C SOURCE FILE LPASS2GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 5.07 C PASS 2 RECORD TYPE 7 'ENTRY POINT DEFINITION' PROCESS 'INCLUDE' DARRAYGAK.IN, 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' IODEFNGAK.IN, INTEGER SEARCH, DUMMY C T07P2 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T07P2') CALL GNAME(5) 'IF' (NSIZE.GT.0) NLX = SEARCH (DUMMY) 'IF' ((NLX.NE.0).AND.(NFLAGS(NLX).NE.0)) DICT (ID) = NLX 'ENDIF' 'ENDIF' X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T07P2') RETURN END 'OUTFILE' T08P2GAK.FR SUBROUTINE T08P2 C EDIT DATE 26JAN79 09:32 C SOURCE FILE LPASS2GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 5.08 C PASS 2 RECORD TYPE 8 'OVERLAY ID' PROCESS 'INCLUDE' DARRAYGAK.IN, 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' IODEFNGAK.IN, INTEGER SEARCH, DUMMY C T08P2 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T08P2') CALL GNAME(5) 'IF' (NSIZE.GT.0) NLX = SEARCH (DUMMY) 'IF' ((NLX.NE.0).AND.(NFLAGS(NLX).NE.0)) DICT (ID) = NLX 'ENDIF' 'ENDIF' X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T08P2') RETURN END 'OUTFILE' T09P2GAK.FR SUBROUTINE T09P2 C EDIT DATE 26JAN79 09:32 C SOURCE FILE LPASS2GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 5.09 C PASS 2 RECORD TYPE 9 'EXTERNAL NAME' PROCESS 'INCLUDE' DARRAYGAK.IN, 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' IODEFNGAK.IN, INTEGER SEARCH, DUMMY C T09P2 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T09P2') CALL GNAME(3) 'IF' (NSIZE.GT.0) NLX = SEARCH (DUMMY) 'IF' ((NLX.NE.0).AND.(NFLAGS(NLX).NE.0)) DICT (ID) = NLX 'ENDIF' 'ENDIF' X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T09P2') RETURN END 'OUTFILE' T10P2GAK.FR SUBROUTINE T10P2 C EDIT DATE 26JAN79 09:32 C SOURCE FILE LPASS2GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 5.10 C PASS 2 RECORD TYPE 10 'ABSOLUTE DATA' PROCESS 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' IODEFNGAK.IN, 'INCLUDE' RECORDGAK.IN, C T10P2 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T10P2') CALL PUNCH (RECORD(2), LOADAD, RSTYPE) LOADAD = LOADAD + RSTYPE X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T10P2') RETURN END 'OUTFILE' T11P2GAK.FR SUBROUTINE T11P2 C EDIT DATE 26JAN79 09:32 C SOURCE FILE LPASS2GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 5.11 C PASS 2 RECORD TYPE 11 'RELOCATABLE DATA (1 OR 2 BYTES)' PROCESS 'INCLUDE' DARRAYGAK.IN, 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' RECORDGAK.IN, 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' IODEFNGAK.IN, INTEGER ISWAP INTEGER OBDATA, OBSIZE, ISWX C T11P2 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T11P2') NLX = DICT (ID) 'IF' (NLX.LE.0) CALL ERROR(10) 'ELSE' OBDATA = NADDRS (NLX) + RECORD(3) OBSIZE = 2 'IF' ((RSTYPE.LT.0).OR.(RSTYPE.GT.3)) CALL ERROR(4) RETURN 'ENDIF' ISWX = RSTYPE + 1 GOTO (100,200,300,400) ISWX 100 GO TO 1000 200 OBDATA = ISWAP (OBDATA) GOTO 1000 300 OBDATA = ISWAP (OBDATA) OBSIZE = 1 GOTO 1000 400 OBSIZE = 1 1000 CALL PUNCH (OBDATA, LOADAD, OBSIZE) LOADAD = LOADAD + OBSIZE 'ENDIF' X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T11P2') RETURN END 'OUTFILE' T12P2GAK.FR SUBROUTINE T12P2 C EDIT DATE 26JAN79 09:32 C SOURCE FILE LPASS2GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 5.12 C PASS 2 RECORD TYPE 12 'RELOCATABLE DATA (2 OR 3 BYTES)' PROCESS 'INCLUDE' DARRAYGAK.IN, 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' RECORDGAK.IN, 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' IODEFNGAK.IN, INTEGER ISWAP INTEGER OBDATA(2), OBSIZE, ISWX C T12P2 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T12P2') NLX = DICT (ID) 'IF' (NLX.LE.0) CALL ERROR(10) 'ELSE' OBDATA(1) = IAND (RECORD(3), 255) OBDATA(2) = NADDRS(NLX) + RECORD(4) OBSIZE = 3 'IF' ((RSTYPE.LT.0) .OR. (RSTYPE.GT.3)) CALL ERROR(4) RETURN 'ENDIF' ISWX = RSTYPE + 1 GOTO (100,200,300,400) ISWX 100 GOTO 1000 200 OBDATA(2) = ISWAP (OBDATA(2)) GOTO 1000 300 OBSIZE = 2 GOTO 1000 400 OBDATA(2) = ISWAP (OBDATA(2)) OBSIZE = 2 1000 CALL PCHAR (OBDATA(1), 1, OBDATA(1)) CALL PCHAR (OBDATA(1), 2, ISHFT(OBDATA(2), -8)) CALL PCHAR (OBDATA(1), 3, IAND(OBDATA(2), 255)) CALL PUNCH (OBDATA, LOADAD, OBSIZE) LOADAD = LOADAD + OBSIZE 'ENDIF' X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T12P2') RETURN END 'OUTFILE' T13P2GAK.FR SUBROUTINE T13P2 C EDIT DATE 26JAN79 09:32 C SOURCE FILE LPASS2GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 5.13 C PASS 2 RECORD TYPE 13 'COMPUTATION' PROCESS 'INCLUDE' DARRAYGAK.IN, 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' RECORDGAK.IN, 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' IODEFNGAK.IN, INTEGER OBDATA, OBSIZE, ISWX, NLX2 INTEGER ISWAP C T13P2 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T13P2') NLX = DICT (ID) NLX2 = RECORD (3) NLX2 = DICT (NLX2) 'IF' ((NLX.LE.0).OR.(NLX2.LE.0)) CALL ERROR(10) 'ELSE' OBDATA = NADDRS(NLX) - NADDRS(NLX2) + RECORD(4) OBSIZE = 2 'IF' ((RSTYPE.LT.0).OR.(RSTYPE.GT.3)) CALL ERROR(4) RETURN 'ENDIF' ISWX = RSTYPE + 1 GOTO (100,200,300,400) ISWX 100 GOTO 1000 200 OBDATA = ISWAP (OBDATA) GOTO 1000 300 OBSIZE = 1 GOTO 1000 400 OBDATA = ISWAP (OBDATA) OBSIZE = 1 1000 CALL PUNCH (OBDATA, LOADAD, OBSIZE) LOADAD = LOADAD + OBSIZE 'ENDIF' X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T13P2') RETURN END 'OUTFILE' T14P2GAK.FR SUBROUTINE T14P2 C EDIT DATE 26JAN79 09:32 C SOURCE FILE LPASS2GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 5.14 C PASS 2 RECORD TYPE 14 'SET LOCATION' PROCESS 'INCLUDE' DARRAYGAK.IN, 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' RECORDGAK.IN, 'INCLUDE' IODEFNGAK.IN, C T14P2 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T14P2') NLX = DICT (ID) 'IF' (NLX.LE.0) CALL ERROR(10) 'ELSE' CID = ID LOADAD = NADDRS(NLX) + RECORD(3) NPOSIT(NLX) = LOADAD 'ENDIF' X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T14P2') RETURN END 'OUTFILE' T15P2GAK.FR SUBROUTINE T15P2 C EDIT DATE 26JAN79 09:32 C SOURCE FILE LPASS2GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 5.15 C PASS 2 RECORD TYPE 15 'ADJUST LOCATION' PROCESS 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' RECORDGAK.IN, 'INCLUDE' IODEFNGAK.IN, C T15P2 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T15P2') LOADAD = LOADAD + RECORD(2) X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T15P2') RETURN END 'OUTFILE' T16P2GAK.FR SUBROUTINE T16P2 C EDIT DATE 26JAN79 09:32 C SOURCE FILE LPASS2GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 5.16 C PASS 2 RECORD TYPE 16 'CHANGE GROUP' PROCESS 'INCLUDE' DARRAYGAK.IN, 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' IODEFNGAK.IN, INTEGER I C T16P2 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T16P2') NLX = DICT (ID) 'IF' (NLX.LE.0) CALL ERROR(10) 'ELSE' C SAVE LOAD ADDRESS WITHIN CURRENT GROUP I = DICT (CID) NPOSIT(I) = LOADAD C ESTABLISH NEW LOAD ADDRESS AND GROUP CID = ID LOADAD = NPOSIT(NLX) 'ENDIF' X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T16P2') RETURN END 'OUTFILE' T17P2GAK.FR SUBROUTINE T17P2 C EDIT DATE 26JAN79 09:32 C SOURCE FILE LPASS2GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 5.17 C PASS 2 RECORD TYPE 17 'ESTABLISH RUN ADDRESS' PROCESS 'INCLUDE' DARRAYGAK.IN, 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' RECORDGAK.IN, 'INCLUDE' IODEFNGAK.IN, C T17P2 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T17P2') NLX = DICT(ID) 'IF' (NLX.LE.0) CALL ERROR(10) 'ELSE' IF (SFLAG) CALL ERROR(15) SFLAG = .TRUE. START = NADDRS(NLX) + RECORD(3) 'ENDIF' X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T17P2') RETURN END 'OUTFILE' T18P2GAK.FR SUBROUTINE T18P2 C EDIT DATE 26JAN79 09:32 C SOURCE FILE LPASS2GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 5.18 C PASS 2 RECORD TYPE 18 'LOCAL NAME DEFINITION' PROCESS 'INCLUDE' IODEFNGAK.IN, C T18P2 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T18P2') X WRITE (DBCHAN, 1) X1 FORMAT (' EXIT T18P2') RETURN END 'OUTFILE' T19P2GAK.FR SUBROUTINE T19P2 C EDIT DATE 26JAN79 09:32 C SOURCE FILE LPASS2GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 5.19 C PASS 2 RECORD TYPE 19 'LIBRARY START' PROCESS 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' IODEFNGAK.IN, C T19P2 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T19P2') LBMODE = .TRUE. X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T19P2') RETURN END 'OUTFILE' T20P2GAK.FR SUBROUTINE T20P2 C EDIT DATE 26JAN79 09:32 C SOURCE FILE LPASS2GAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 5.20 C PASS 2 RECORD TYPE 20 'LIBRARY END' PROCESS 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' IODEFNGAK.IN, C T20P2 : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER T20P2') LBMODE = .FALSE. X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT T20P2') RETURN END 'OUTFILE' I2PASSGAK.FR SUBROUTINE I2PASS C EDIT DATE 26JAN79 09:32 C SOURCE FILE LPASS2GAK.FS C AUTHOR GARY A. KUDIS C INITIALIZE PASS 2 'INCLUDE' IODEFNGAK.IN, 'INCLUDE' IOFILEGAK.IN, 'INCLUDE' NTABLEGAK.IN, C I2PASS : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER I2PASS') CALL REW (CMCHAN, CMFILE) NTITLE = 0 X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT I2PASS') RETURN END \\\\\ SUBFILE: MAPPER.FS @16:1 23-MAY-1979 <055> (1660) 'HEAD' LINKER, CROSS REFERENCE MAP C EDIT DATE 26JAN79 09:33 C SOURCE FILE MAPPERGAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 6 'OUTFILE' MAPPERGAK.FR SUBROUTINE MAPPER 'INCLUDE' LDATAXGAK.IN, 'INCLUDE' IODEFNGAK.IN, INTEGER SMSGS (12) INTEGER NMSGS (12) DATA SMSGS /'STARTING ADDRESS IS 0000'/ DATA NMSGS /'NO STARTING ADDRESS ????'/ C MAPPER :: X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER MAPPER') CALL WRLIN (MPCHAN, ' ', 2) CALL WRLIN (MPCHAN, ' ', 2) CALL WRLIN (MPCHAN, ' ', 2) 'IF' (SFLAG) CALL EHX (START, SMSGS, 21, 24) CALL WRLIN (MPCHAN, SMSGS, 24) 'ELSE' CALL WRLIN (MPCHAN, NMSGS, 20) 'ENDIF' CALL TOPAGE CALL LTIME CALL ALPHA CALL TOPAGE CALL LTIME CALL NUMER X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT MAPPER') RETURN END 'OUTFILE' ALPHAGAK.FR SUBROUTINE ALPHA C EDIT DATE 26JAN79 09:33 C SOURCE FILE MAPPERGAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 6.01 C LIST NAME TABLE SORTED BY ALPHABETIC METHOD INTEGER ACOMP EXTERNAL ACOMP 'INCLUDE' PNAMESGAK.IN, 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' IODEFNGAK.IN, INTEGER I C ALPHA : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER ALPHA') NCOUNT = 1 CALL SET (0, NAMES, LSTOP) 'DOLOOP' I = 1, LSTOP LIST(I) = I 'END' 'DOLOOP' I = 1, NLSTOP 'IF' (IAND (NFLAGS(I), USEBIT) .NE. 0 ^ .AND. IAND (NFLAGS (I), MODBIT) .EQ. 0) NAMES (NCOUNT) = I NCOUNT = NCOUNT + 1 'ENDIF' 'END' 'IF' (NCOUNT.GT.1) NCOUNT = NCOUNT -1 CALL SORT (LIST, NCOUNT, NAMES, ACOMP) 'ENDIF' 'DOLOOP' I = 1, NCOUNT CALL PRINTN (NAMES(LIST(I))) 'END' X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT ALPHA') RETURN END 'OUTFILE' NUMERGAK.FR SUBROUTINE NUMER C EDIT DATE 26JAN79 09:34 C SOURCE FILE MAPPERGAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 6.02 C LIST NAME TABLE SORTED BY NUMBERIC METHOD INTEGER NCOMP EXTERNAL NCOMP INTEGER I 'INCLUDE' PNAMESGAK.IN, 'INCLUDE' IODEFNGAK.IN, C NUMER : X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER NUMER') 'DOLOOP' I = 1, LSTOP LIST(I) = I 'END' CALL SORT (LIST, NCOUNT, NAMES, NCOMP) 'DOLOOP' I = 1, NCOUNT CALL PRINTN (NAMES(LIST(I))) 'END' X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT NUMER') RETURN END 'OUTFILE' ACOMPGAK.FR INTEGER FUNCTION ACOMP (NXX1, NXX2) INTEGER NXX1, NXX2 C EDIT DATE 26JAN79 09:34 C SOURCE FILE MAPPERGAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 6.03 C ALPHABETIC COMPARISON ROUTINE 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' IODEFNGAK.IN, INTEGER GCHAR INTEGER SLIMIT INTEGER NX1, NSZ1, NX2, NSZ2, I C ACOMP : (NXX1, NXX2) X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER ACOMP') ACOMP = -1 'IF' ((NXX1.GT.0).AND.(NXX2.GT.0)) NX1 = NTEXTX (NXX1) NSZ1 = IAND (NFLAGS(NXX1), NTXBTS) NX2 = NTEXTX (NXX2) NSZ2 = IAND (NFLAGS(NXX2), NTXBTS) 'IF' ((NSZ1.GT.0).AND.(NSZ2.GT.0)) SLIMIT = 2 * NSZ1 IF (NSZ2.LT.NSZ2) SLIMIT = 2 * NSZ2 'DOLOOP' I = 1, SLIMIT ACOMP = GCHAR (NTEXT(NX1),I) - GCHAR (NTEXT(NX2),I) 'IF' (ACOMP.NE.0) 'BREAK' 'ENDIF' 'END' 'ENDIF' 'ENDIF' X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT ACOMP') RETURN END 'OUTFILE' NCOMPGAK.FR INTEGER FUNCTION NCOMP (NXX1, NXX2) INTEGER NXX1, NXX2 C EDIT DATE 26JAN79 09:34 C SOURCE FILE MAPPERGAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 6.04 C ADDRESS (NUMBERIC) COMPARISON ROUTINE 'INCLUDE' NTABLEGAK.IN, C NCOMP : (NXX1, NXX2) 'IF' (IAND(NFLAGS(NXX1),RLSBIT).EQ.0) 'IF' (IAND(NFLAGS(NXX2),RLSBIT).EQ.0) NCOMP = 0 'ELSE' NCOMP = +1 'ENDIF' 'ELSE' 'IF' (IAND(NFLAGS(NXX2),RLSBIT).EQ.0) NCOMP = -1 'ELSE' NCOMP = ISHFT (NADDRS (NXX1), -1) ^ - ISHFT (NADDRS (NXX2), -1) 'IF' (NCOMP .EQ. 0) NCOMP = IAND (NADDRS (NXX1), 1) ^ - IAND (NADDRS (NXX2), 1) 'ENDIF' 'ENDIF' 'ENDIF' RETURN END 'OUTFILE' PRINTNGAK.FR SUBROUTINE PRINTN (NX) INTEGER NX C EDIT DATE 26JAN79 09:34 C SOURCE FILE MAPPERGAK.FS C AUTHOR GARY A. KUDIS C CLUSTER 6.05 C PRINT NAME LIST ENTRY 'INCLUDE' IODEFNGAK.IN, 'INCLUDE' NTABLEGAK.IN, 'INCLUDE' CHARACGAK.IN, INTEGER GCHAR INTEGER MPTEXT(40) INTEGER FLAGS INTEGER AREAS(3) INTEGER QMARKS(2) INTEGER I DATA AREAS /'ANDZR '/ DATA QMARKS /'????'/ C PRINTN : (NX) X WRITE (DBCHAN, 1) X1 FORMAT (' ENTER PRINTN') FLAGS = NFLAGS (NX) 'IF' (IAND(FLAGS,GDFBIT).NE.0) X GOTO 100 RETURN 'ENDIF' X100 CONTINUE CALL SET (BLANKS, MPTEXT, 40) IF (IAND(FLAGS,GDFBIT).NE.0) CALL PCHAR (MPTEXT, 1, GCH) IF (IAND(FLAGS,MLTBIT).NE.0) CALL PCHAR (MPTEXT, 2, MCH) IF (IAND(FLAGS,MODBIT).NE.0) CALL PCHAR (MPTEXT, 3, TCH) IF (IAND(FLAGS,EPTBIT).NE.0) CALL PCHAR (MPTEXT, 4, ECH) IF (IAND(FLAGS,OVLBIT).NE.0) CALL PCHAR (MPTEXT, 5, OCH) IF (IAND(FLAGS,COMBIT).NE.0) CALL PCHAR (MPTEXT, 6, CCH) 'IF' (IAND(FLAGS,GDFBIT).NE.0) ATYPE = ISHFT (FLAGS, -13) + 1 CHAR = GCHAR (AREAS, ATYPE) CALL PCHAR (MPTEXT, 7, CHAR) 'ENDIF' NSIZE = IAND (FLAGS, NTXBTS) CALL MOVE (NTEXT(NTEXTX(NX)), MPTEXT(6), NSIZE) 'IF' (IAND(FLAGS,RLSBIT).NE.0) CALL EHX (NADDRS(NX), MPTEXT, 45, 48) 'ELSE' CALL EST (QMARKS, MPTEXT, 45, 48) 'ENDIF' CALL WRLIN (MPCHAN, MPTEXT, 50) X WRITE (DBCHAN, 2) X2 FORMAT (' EXIT PRINTX') RETURN END 'OUTFILE' TOPAGEGAK.FR SUBROUTINE TOPAGE C EDIT DATE 26JAN79 09:34 C AUTHOR GARY A. KUDIS C CLUSTER 6.06 C TOP OF PAGE OUTPUT 'INCLUDE' IODEFNGAK.IN, INTEGER FORM DATA FORM / 3072/ // '<0>' C TOPAGE :: CALL WRLIN (MPCHAN, FORM, 2) RETURN END \\\\\ SUBFILE: STMAIN.FS @16:3 23-MAY-1979 <055> (64) 'HEAD' MAIN PROCESSING LOOP C EDIT DATE 03JAN79 10:03 C SOURCE FILE STMAIN.FS C AUTHOR F. T. MICKEY C CLUSTER 100.000 'OUTFILE' STMAINFTM.FR 'DO' CALL INIT CALL PARSE 'END' END \\\\\ SUBFILE: STRANI.FS @16:3 23-MAY-1979 <055> (345) 'HEAD' STRAN INCLUDE FILE PRINT C EDIT DATE 25MAY78 09:27 C SOURCE FILE STRANIN.FS C AUTHOR F. T. MICKEY 'OUTFILE' STRANDATA.FR BLOCK DATA 'INCLUDE' STRAN.IN,P 'EJECT' DATA MAXTAB /10/ DATA MAXLIN /55/ DATA IFMAX /10/ DATA MAXLEV /5/ DATA TABS / 7, 10, 13, 16, 19, 22, 25, 28, 31, 72/ DATA FFILE /0/ DATA EOF /-1/ DATA LETTER /1000/ DATA DIGIT /1001/ DATA TAB /9/ DATA EOL /13/ DATA BLANK /32/ DATA BBLANK /8224/ DATA QUOTE /34/ DATA GIZZY /39/ DATA LPAREN /40/ DATA RPAREN /41/ DATA AST /42/ DATA COMMA /44/ DATA PERIOD /46/ DATA SLASH /47/ DATA CHAR0 /48/ DATA CHAR1 /49/ DATA CHAR9 /57/ DATA SEMI /59/ DATA EQUAL /61/ DATA CHARA /65/ DATA CHARZ /90/ DATA UPAROW /94/ DATA DOOP /100/ DATA WHILE /101/ DATA ENDOP /102/ DATA FOR /103/ DATA DOLOOP /104/ DATA BREAK /105/ DATA NEXT /106/ DATA IFOP /107/ DATA ELSE /108/ DATA ENDIF /109/ DATA DEFINE /110/ DATA HEAD /111/ DATA EJECT /112/ DATA INCLUD /113/ DATA OUTFIL /114/ END \\\\\ SUBFILE: STPARS.FS @16:3 23-MAY-1979 <055> (4040) 'HEAD' PARSING AND STRAN FUNCTIONS C EDIT DATE 15JAN79 10:14 C SOURCE FILE STPARSE.FS C AUTHOR F. T. MICKEY 'OUTFILE' CTYPEFTM.FR INTEGER FUNCTION CTYPE (ICHAR) 'INCLUDE' STRAN.IN, INTEGER ICHAR 'IF' (ICHAR .GE. CHAR0 .AND. ICHAR .LE. CHAR9) CTYPE = DIGIT 'ELSE' 'IF' (ICHAR .GE. CHARA .AND. ICHAR .LE. CHARZ) CTYPE = LETTER 'ELSE' CTYPE = ICHAR 'ENDIF' 'ENDIF' RETURN END 'OUTFILE' LSTARTFTM.FR SUBROUTINE LSTART 'INCLUDE' STRAN.IN, 'IF' (OUTPTR .GT. 7) CALL PUTC (EOL) 'ENDIF' OUTPTR = 7 RETURN END 'OUTFILE' PLNFTM.FR SUBROUTINE PLN (DUMMY) 'INCLUDE' STRAN.IN, INTEGER DUMMY, TS, GCHAR IF (OUTPTR .GT. 7) CALL PUTC (EOL) CALL SET (BBLANK, NAME, 3) CALL ESP (LN, NAME, 1, 5) 'DOLOOP' TS = 1, 5 CALL PUTC (GCHAR (NAME, TS)) 'END' OUTPTR = 7 RETURN END 'OUTFILE' PSTRFTM.FR SUBROUTINE PSTR (STR) 'INCLUDE' STRAN.IN, INTEGER STR(80), III, GCHAR 'DOLOOP' III = 1, 80 CHAR = GCHAR (STR, III) 'IF' (CHAR .NE. SLASH) 'IF' (CHAR .EQ. SEMI) CALL PUTC (EOL) 'ELSE' CALL PUTC (CHAR) 'ENDIF' 'END' 'ENDIF' RETURN END 'OUTFILE' GOLNFTM.FR SUBROUTINE GOLN (DUMMY) 'INCLUDE' STRAN.IN, INTEGER DUMMY, GOMSG (4), GCHAR DATA GOMSG /'GO TO /'/ CALL PSTR (GOMSG) CALL SET (BBLANK, NAME, 3) CALL ESP (LN, NAME, 1, 5) 'DOLOOP' II = 1, 5 CALL PUTC (GCHAR (NAME, II)) 'END' CALL PUTC (EOL) RETURN END 'OUTFILE' LNCONTFTM.FR SUBROUTINE LNCONT (DUMMY) 'INCLUDE' STRAN.IN, INTEGER DUMMY CALL PLN (LN) CALL PSTR ('CONTINUE;/') RETURN END 'OUTFILE' CPARENFTM.FR SUBROUTINE CPAREN 'INCLUDE' STRAN.IN, INTEGER PCOUNT, GETC PCOUNT = 1 'DO' CHAR = GETC (CHAR) 'WHILE' (CHAR .NE. LPAREN) 'IF' (CHAR .EQ. EOL) CALL REMARK ('INVALID STRAN SYNTAX.') RETURN 'ENDIF' 'END' 'DO' CALL PUTC (CHAR) 'WHILE' (PCOUNT .GT. 0) CHAR = GETC (CHAR) 'IF' (CHAR .EQ. RPAREN) PCOUNT = PCOUNT - 1 'ELSE' 'IF' (CHAR .EQ. LPAREN) PCOUNT = PCOUNT + 1 'ELSE' 'IF' (CHAR .EQ. EOL) 'FOR' (; PCOUNT .GT. 0; PCOUNT = PCOUNT - 1) CALL PUTC (RPAREN) 'END' CALL REMARK ('UNBALANCED PARENS.') CALL PUTBAK (EOL) RETURN 'ENDIF' 'ENDIF' 'ENDIF' 'END' RETURN END 'OUTFILE' LABGENFTM.FR INTEGER FUNCTION LABGEN (NUM) C RESERVES K LABELS, PASSES BACK FIRST LABEL 'INCLUDE' STRAN.IN, INTEGER LABEL, NUM DATA LABEL /13000/ LABGEN = LABEL LABEL = LABEL + NUM RETURN END 'OUTFILE' PARSEFTM.FR SUBROUTINE PARSE 'INCLUDE' STRAN.IN, INTEGER LEX, LEXTMP, LABGEN, INLEN INTEGER CHARC, CHARD, CHARP, CHARX, CHARN INTEGER GCHAR, GETC INTEGER EXTN (5) DATA CHARC /67/, CHARD /68/, CHARP /80/, CHARX /88/ DATA CHARN /78/ DATA EXTN /'.FR/NOTR '/ IFSP = 1 LPSP = 1 10 'DO' LEXVAL = LEX (CHAR) 'WHILE' (CHAR .NE. EOF) 'IF' (CHAR .EQ. EOL) 'NEXT' 'ENDIF' 'IF' (LEXVAL .EQ. LETTER) 'IF' (INPTR .EQ. 2) 'IF' (CHAR .EQ. CHARX .OR. CHAR .EQ. CHARD) N CALL PUTC (CHARX) P CALL PUTC (CHARD) 'NEXT' 'ENDIF' 'IF' (CHAR .EQ. CHARN) P CALL IGNORE 'NEXT' 'ENDIF' 'IF' (CHAR .EQ. CHARP) N CALL IGNORE 'NEXT' 'ENDIF' 'ENDIF' CALL PUTBAK (CHAR) 'IF' (CHAR .NE. CHARC .OR. INPTR .NE. 2) CALL LSTART CALL ENDLIN 'ELSE' CALL IGNORE 'ENDIF' 'NEXT' 'ENDIF' 'IF' (LEXVAL .EQ. DIGIT) CALL COPYLN 'NEXT' 'ENDIF' LEXTMP = LEXVAL - 99 'IF' (LEXTMP .GT. 0 .AND. LEXTMP .LT. 16) GOTO (100, 100, 200, 100, 100, 300, 300, ^ 400, 500, 600, 700, 800, 900, 1000, ^ 1100) LEXTMP 'ELSE' 700 CALL IGNORE 'ENDIF' 'END' IF (LEVEL .NE. 1) GOTO 1050 'IF' (IFSP .NE. 1) CALL REMARK ('IF STACK NOT CLEARED.') 'ENDIF' 'IF' (LPSP .NE. 1) CALL REMARK ('LOOP STACK NOT CLEARED.') 'ENDIF' 'IF' (IAND (PAGE, 1) .NE. 0) CALL SET (BBLANK, IBUF, 40) CLINE = MAXLIN + 1 CALL PRINT 'ENDIF' RETURN 30 CALL ENDLIN GOTO 10 'EJECT' C LOOP CONSTRUCTION PROCESSING - C 'FOR' 'DOLOOP' 'DO'-'WHILE' 100 'IF' (LEXVAL .EQ. WHILE) 'IF' (LPST (LPSP) .EQ. DOOP) 'DO' CALL LSTART LPST (LPSP) = WHILE LPST (LPSP + 2) = 1 CALL PSTR ('IF (.NOT./') CALL CPAREN CALL PSTR (')/') LN = LPST (LPSP + 1) + 1 CALL GOLN (LN) GOTO 30 'ELSE' CALL REMARK ('WHILE WITHOUT DO.') CALL LSTART LPSP = LPSP + 3 CALL PSTR ('CONTINUE;/') LN = LABGEN (2) CALL LNCONT (LN) LPST (LPSP + 1) = LN 'END' 'ENDIF' 'ENDIF' LPSP = LPSP + 3 'IF' (LEXVAL .EQ. FOR) KK = 1 CALL COPYTO (NAME, KK, LPAREN) CALL SKIPBL CALL LSTART CALL COPYTO (OUTBUF, OUTPTR, SEMI) CALL PUTC (EOL) LN = LABGEN (3) + 2 CALL PLN (LN) CALL PSTR ('IF (.NOT.(/') CALL SKIPBL CALL COPYTO (OUTBUF, OUTPTR, SEMI) CALL PSTR ('))/') LN = LN - 1 CALL GOLN (LN) KK = LPSP*2 - 1 CALL SKIPBL CALL COPYTO (LPST, KK, RPAREN) LPSP = LPSP + (SLEN + 1)/2 LPST (LPSP) = SLEN LPSP = LPSP + 1 LN = LN - 1 'ELSE' 'IF' (LEXVAL .EQ. DOLOOP) LN = LABGEN (2) CALL LSTART CALL PSTR ('DO /') CALL ESP (LN, OUTBUF, OUTPTR, OUTPTR + 5) OUTPTR = OUTPTR + 6 'ELSE' 'IF' (LEXVAL .EQ. DOOP) CALL LSTART LN = LABGEN (2) CALL PSTR ('CONTINUE;/') CALL LNCONT (LN) 'ENDIF' 'ENDIF' 'ENDIF' LPST (LPSP) = LEXVAL LPST (LPSP + 1) = LN LPST (LPSP + 2) = 0 GOTO 30 'EJECT' C END PROCESSING FOR LOOPS C 200 'IF' (LPSP .EQ. 1) CALL REMARK ('MISPLACED END OF LOOP.') GOTO 30 'ENDIF' 'IF' (LPST (LPSP) .EQ. DOOP .OR. LPST (LPSP) .EQ. WHILE) LN = LPST (LPSP + 1) CALL LSTART CALL GOLN (LN) 'IF' (LPST (LPSP + 2) .NE. 0) C BREAK ENCOUNTERED LN = LN + 1 CALL LNCONT (LN) 'ENDIF' LPSP = LPSP - 3 GOTO 30 'ENDIF' 'IF' (LPST (LPSP) .EQ. FOR) LN = LPST (LPSP + 1) 'IF' (LPST (LPSP + 2) .EQ. 1) C NEXT ENCOUNTERED CALL PLN (LN) 'ENDIF' CALL LSTART SLEN = LPST (LPSP - 1) LPSP = LPSP - (SLEN + 1)/2 - 1 KK = LPSP*2 - 1 'DOLOOP' JJ = 1, SLEN II = GCHAR (LPST, KK) CALL PUTC (II) KK = KK + 1 'END' CALL PUTC (EOL) CALL LSTART LN = LN + 2 CALL GOLN (LN) LN = LN - 1 CALL LNCONT (LN) 'ELSE' LN = LPST (LPSP + 1) CALL LNCONT (LN) 'IF' (LPST (LPSP + 2) .EQ. 1) LN = LN + 1 CALL LNCONT (LN) 'ENDIF' 'ENDIF' LPSP = LPSP - 3 IF (LEXVAL .NE. OUTFIL) GOTO 30 GOTO 1100 // RETURN TO OUTFILE PROCESSOR 'EJECT' C BREAK AND NEXT PROCESSING 300 'IF' (LPSP .EQ. 1) CALL REMARK ('MISPLACED BREAK OR NEXT.') GOTO 30 'ENDIF' KK = LPSP + 1 LN = LPST (KK) 'IF' (LEXVAL .EQ. BREAK) LN = LN + 1 'IF' (LPST (LPSP) .NE. FOR) KK = LPSP + 2 LPST (KK) = 1 'ENDIF' 'ELSE' 'IF' (LPST (LPSP) .EQ. FOR) KK = LPSP + 2 LPST (KK) = 1 'ENDIF' 'ENDIF' CALL LSTART CALL GOLN (LN) GOTO 30 'EJECT' C IF PROCESSOR 400 'IF' (IFSP .GE. IFMAX) CALL REMARK ('IF STACK OVERFLOW.') CALL IGNORE GOTO 10 'ENDIF' IFSP = IFSP + 1 IFST (IFSP) = IFOP IFSP = IFSP + 1 LN = LABGEN (2) IFST (IFSP) = LN CALL LSTART CALL PSTR ('IF (.NOT. /') CALL CPAREN CALL PSTR (')/') CALL GOLN (LN) GOTO 30 'EJECT' C ELSE PROCESSOR 500 'IF' (IFSP .EQ. 1) 510 CALL REMARK ('ELSE WITHOUT IF.') CALL IGNORE GOTO 10 'ENDIF' JJ = IFSP 'DO' 'WHILE' (JJ .GT. 1) KK = JJ - 1 'IF' (IFST (KK) .EQ. IFOP) IFST (KK) = ELSE LN = IFST (JJ) + 1 CALL LSTART CALL GOLN (LN) LN = LN - 1 CALL LNCONT (LN) 'ELSE' JJ = JJ - 2 'END' GOTO 510 'ENDIF' GOTO 30 'EJECT' C ENDIF PROCESSOR 600 'IF' (IFSP .EQ. 1) CALL REMARK ('ENDIF WITHOUT IF.') CALL IGNORE GOTO 10 'ENDIF' KK = IFSP - 1 'IF' (IFST (KK) .EQ. IFOP) LN = IFST (IFSP) 'ELSE' LN = IFST (IFSP) + 1 'ENDIF' CALL LNCONT (LN) IFSP = IFSP - 2 GOTO 30 'EJECT' C HEAD CARD PROCESSOR 800 CALL SKIPBL JJ = 1 CALL COPYTO (HBUF, JJ, EOL) 'DOLOOP' II = JJ, 80 CALL PCHAR (HBUF, II, BLANK) 'END' FIRST = .FALSE. SKIPFL = .TRUE. CALL PUTBAK (EOL) GOTO 30 'EJECT' C EJECT CODE 900 IF (POFF) GOTO 30 SKIPFL = .TRUE. CLINE = 1000 GOTO 30 'EJECT' C INFILE PROCESSOR 1000 INCHAN = INCHAN - 1 LSAVE (LEVEL) = LINENO PSAVE (LEVEL) = POFF LEVEL = LEVEL + 1 CALL SKIPBL INLEN = 1 P CALL SET (0, NAME, 22) CALL COPYTO (NAME, INLEN, COMMA) CALL PCHAR (NAME, INLEN, 0) CALL PRINT CHAR = GETC (CHAR) 'IF' (CHAR .EQ. CHARP) SKIPFL = .TRUE. POFF = .FALSE. 'ELSE' POFF = .TRUE. 'ENDIF' 'IF' (CHAR .NE. EOL) CALL COPYTO (NAME, INLEN, EOL) 'ENDIF' CALL PUTBAK (EOL) LINENO = 0 CALL OPENF (INCHAN, NAME, KK) 'IF' (KK .NE. 1) CALL REMARK ('INCLUDE FILE OPEN ERROR.') CALL IGNORE GOTO 1050 'ENDIF' GOTO 30 'EJECT' C 'OUTFILE' PROCESSING 1100 'IF' (OUTCHN .EQ. -1) OUTCHN = 1 'ELSE' 'DO' 'WHILE' (IFSP .NE. 1) CALL REMARK ('MISSING ENDIF.') IFSP = IFSP - 2 'END' 'DO' 'WHILE' (LPSP .NE. 1) CALL REMARK ('MISSING LOOP END.') GOTO 200 'END' CALL CLOSF (OUTCHN, KK) 'ENDIF' CALL SKIPBL JJ = 1 CLINE = 1000 P CALL SET (0, NAME, 22) CALL COPYTO (NAME, JJ, EOL) CALL PCHAR (NAME, SLEN + 1, 0) CALL OPENN (OUTCHN, NAME, KK) 'IF' (KK .NE. 1) CALL REMARK ('FILE PROTECTED OR IN USE.') OUTCHN = -1 'ENDIF' 'IF' (PROCCN .NE. -1) P SLEN = SLEN - 3 P CALL SET (BBLANK, BUF, 40) P CALL EST (NAME, BUF, 1, SLEN) P JJ = SLEN + 1 P CALL PCHAR (BUF, JJ, COMMA) P CALL EST (NAME, BUF, JJ+1, JJ + SLEN) P JJ = JJ + SLEN + 1 P CALL PCHAR (BUF, JJ, EQUAL) P CALL EST (NAME, BUF, JJ+1, JJ + SLEN) P JJ = JJ + SLEN + 1 P CALL EST (EXTN, BUF, JJ, JJ+7) P CALL PCHAR (BUF, JJ + SLEN + 1, BLANK) P KK = JJ + 7 N CALL SET (BBLANK, BUF, 40) N CALL EST ('FORT/B/P ', BUF, 1, 9) N CALL EST (NAME, BUF, 10, SLEN + 9) N CALL EST (' FORTERR/E', BUF, SLEN + 10, SLEN + 19) N CALL PCHAR (BUF, SLEN + 20, EOL) N KK = SLEN + 20 CALL WRLIN (PROCCN, BUF, KK) 'ENDIF' NEWFIL = .TRUE. CALL PUTBAK (EOL) GOTO 30 'EJECT' 1050 CALL CLOSF (INCHAN, KK) LEVEL = LEVEL - 1 LINENO = LSAVE (LEVEL) POFF = PSAVE (LEVEL) INCHAN = INCHAN + 1 SKIPFL = .TRUE. GOTO 10 END 'OUTFILE' LEXFTM.FR INTEGER FUNCTION LEX (ICHAR) 'INCLUDE' STRAN.IN, INTEGER ICHAR, CTYPE, GETC, GCHAR, GETWRD INTEGER FPTR, FLIST (70) DATA FLIST ^ / 2, 'IF', 107, ^ 4, 'ELSE', 108, ^ 5, 'ENDIF', 109, ^ 2, 'DO', 100, ^ 5, 'WHILE', 101, ^ 3, 'END', 102, ^ 3, 'FOR', 103, ^ 6, 'DOLOOP',104, ^ 5, 'BREAK', 105, ^ 4, 'NEXT', 106, ^ 6, 'DEFINE',110, ^ 7, 'INCLUDE', 113, ^ 4, 'HEAD', 111, ^ 5, 'EJECT', 112, ^ 7, 'OUTFILE', 114, ^ 0, 0/ CALL SKIPBL CHAR = GETC (CHAR) LEXVAL = CTYPE (CHAR) 'IF' (LEXVAL .NE. GIZZY) LEX = LEXVAL RETURN 'ENDIF' SLEN = GETWRD (IBUF, INPTR, INMAX, NAME) FPTR = 1 'DO' 'WHILE' (FLIST (FPTR) .NE. 0) 'IF' (FLIST (FPTR) .EQ. SLEN) KK = FPTR*2 + 1 'DOLOOP' JJ = 1, SLEN 'IF' (GCHAR (FLIST, KK) .EQ. GCHAR (NAME, JJ)) KK = KK + 1 'END' FPTR = KK/2+1 LEX = FLIST (FPTR) RETURN 'ENDIF' 'ENDIF' FPTR = FPTR + (FLIST (FPTR) + 5)/2 'END' LEX = 0 RETURN END 'OUTFILE' ENDLINFTM.FR SUBROUTINE ENDLIN 'INCLUDE' STRAN.IN, INTEGER GETC, GCHAR, QCOUNT, CHARD, CHART, ICHAR LOGICAL QSEEN, QALLOW DATA CHARD /68/ , CHART /84/ QALLOW = .FALSE. QSEEN = .FALSE. 'DO' CHAR = GETC (CHAR) 'WHILE' (CHAR .NE. EOL) 'IF' (CHAR .EQ. CHARD) 'IF' (GCHAR (IBUF, INPTR) .EQ. CHARA ^ .AND. GCHAR (IBUF, INPTR+1) .EQ. CHART ^ .AND. GCHAR (IBUF, INPTR+2) .EQ. CHARA) QALLOW = .TRUE. 'ENDIF' 'ENDIF' 'IF' (QALLOW) 'IF' (CHAR .EQ. GIZZY) QCOUNT = -2 QSEEN = NOT (QSEEN) 'ELSE' 'IF' (QSEEN) QCOUNT = QCOUNT + 1 'IF' (QCOUNT .EQ. 0) QCOUNT = -1 CALL PUTC (CHAR) CHAR = GETC (CHAR) 'IF' (CHAR .NE. GIZZY) ICHAR = CHAR CALL PUTC (GIZZY) CALL PUTC (COMMA) CALL PUTC (GIZZY) CHAR = ICHAR 'ELSE' QSEEN = NOT (QSEEN) 'ENDIF' 'ENDIF' 'ENDIF' 'ENDIF' 'ENDIF' CALL PUTC (CHAR) 'END' CALL PUTC (EOL) RETURN END \\\\\ SUBFILE: STIO.FS @16:3 23-MAY-1979 <055> (2220) 'HEAD' INPUT/OUTPUT PRIMITIVES C EDIT DATE 15JAN79 08:35 C SOURCE FILE STIO.FS C AUTHOR F. T. MICKEY C CLUSTER 1 'OUTFILE' REMARKFTM.FR SUBROUTINE REMARK (STRING) 'INCLUDE' STRAN.IN, INTEGER STRING (66) INTEGER TS, GCHAR 'DOLOOP' I = 1, 4 CALL PCHAR (BUF, I, AST) 'END' 'DOLOOP' I = 5, 80 TS = GCHAR (STRING, I-4) 'IF' (TS .NE. PERIOD) CALL PCHAR (BUF, I, TS) 'END' 'ENDIF' CALL PCHAR (BUF, I, EOL) CALL WRLIN (TTOCHN, BUF, I) CALL WRLIN (LPTCHN, BUF, I) RETURN END 'OUTFILE' GETWRDFTM.FR INTEGER FUNCTION GETWRD (BUFIN, INX, MAXIN, BUFOUT) 'INCLUDE' STRAN.IN, INTEGER GCHAR, BUFIN, INX, MAXIN, BUFOUT INTEGER TS GETWRD = 1 'DO' 'WHILE' (INX .LE. MAXIN) TS = GCHAR (BUFIN, INX) INX = INX + 1 'IF' (TS .EQ. BLANK .OR. TS .EQ. TAB ^ .OR. TS .EQ. GIZZY .OR. TS .EQ. 0) 'BREAK' 'ENDIF' CALL PCHAR (BUFOUT, GETWRD, TS) GETWRD = GETWRD + 1 'END' CALL PCHAR (BUFOUT, GETWRD, BLANK) GETWRD = GETWRD - 1 RETURN END 'OUTFILE' GETLINFTM.FR INTEGER FUNCTION GETLIN (BUFFER, CHAN) 'INCLUDE' STRAN.IN, INTEGER GCHAR, BUFFER (40), CHAN INTEGER TS, ERROR GETLIN = -1 CALL SET (BBLANK, BUFFER, 40) P TS = 80 CALL RDLIN (CHAN, BUFFER, TS, ERROR) IF (ERROR .EQ. 9) RETURN 'FOR' (GETLIN = 36; GETLIN .GE. 1; GETLIN = GETLIN - 1) 'IF' (BUFFER (GETLIN) .EQ. BBLANK) 'END' 'ENDIF' GETLIN = GETLIN * 2 'DO' 'WHILE' (GETLIN .GE. 1) TS = GCHAR (BUFFER, GETLIN) 'IF' (TS .EQ. BLANK .OR. TS .EQ. TAB) GETLIN = GETLIN - 1 'END' 'ENDIF' GETLIN = GETLIN + 1 CALL PCHAR (BUFFER, GETLIN, EOL) RETURN END 'OUTFILE' PUTBAKFTM.FR SUBROUTINE PUTBAK (ICHAR) 'INCLUDE' STRAN.IN, INTEGER ICHAR ISP = ISP + 1 ICSTK (ISP) = ICHAR RETURN END 'OUTFILE' SKIPBLFTM.FR SUBROUTINE SKIPBL 'INCLUDE' STRAN.IN, INTEGER GETC 'DO' CHAR = GETC (CHAR) 'WHILE' (CHAR .EQ. BLANK .OR. CHAR .EQ. TAB) 'END' CALL PUTBAK (CHAR) RETURN END 'OUTFILE' IGNOREFTM.FR SUBROUTINE IGNORE 'INCLUDE' STRAN.IN, INTEGER GETC 'DO' CHAR = GETC (CHAR) 'WHILE' (CHAR .NE. EOL) 'END' CALL PUTBAK (CHAR) RETURN END 'OUTFILE' GETNUMFTM.FR INTEGER FUNCTION GETNUM (DUMMY) 'INCLUDE' STRAN.IN, INTEGER DUMMY INTEGER CTYPE, GETC GETNUM = 0 'DO' 'WHILE' (LEXVAL .EQ. DIGIT) GETNUM = GETNUM * 10 + CHAR - CHAR0 LEXVAL = CTYPE (GETC (CHAR)) 'END' CALL PUTBAK (CHAR) RETURN END 'OUTFILE' COPYLNFTM.FR SUBROUTINE COPYLN 'INCLUDE' STRAN.IN, INTEGER GETNUM LN = GETNUM (CHAR) CALL PLN (LN) RETURN END 'OUTFILE' COPYTOFTM.FR SUBROUTINE COPYTO (BUFOUT, OUTX, ICHAR) 'INCLUDE' STRAN.IN, INTEGER TS, GETC, BUFOUT, OUTX, ICHAR SLEN = 0 'DO' TS = GETC (CHAR) 'WHILE' (TS .NE. ICHAR) 'IF' (TS .EQ. EOL) CALL REMARK ('MISSING DELIMITER.') RETURN 'ENDIF' CALL PCHAR (BUFOUT, OUTX, TS) OUTX = OUTX + 1 SLEN = SLEN + 1 'END' RETURN END 'OUTFILE' GETC.FR INTEGER FUNCTION GETC (DUMMY) 'INCLUDE' STRAN.IN, INTEGER DUMMY, TS, GCHAR, GETLIN 'IF' (ISP .GT. 1) CHAR = ICSTK (ISP) ISP = ISP - 1 GOTO 10 'ENDIF' 'IF' (INPTR .EQ. INMAX) CHAR = EOL INPTR = INPTR + 1 10 GETC = CHAR RETURN 'ENDIF' 'DO' 'IF' (INPTR .LT. INMAX) CHAR = GCHAR (IBUF, INPTR) INPTR = INPTR + 1 'IF' (CHAR .EQ. TAB) TSEEN = .TRUE. CHAR = BLANK GOTO 10 'ENDIF' 'IF' (CHAR .EQ. SLASH) 'IF' (GCHAR (IBUF, INPTR) .EQ. SLASH) INPTR = INMAX + 1 CHAR = EOL GOTO 10 'ENDIF' 'ENDIF' CTEMP = CHAR IF (CTEMP .NE. UPAROW .AND. INPTR .LE. INMAX) GOTO 10 'ENDIF' CALL PRINT LINENO = LINENO + 1 INMAX = GETLIN (IBUF, INCHAN) INPTR = 1 'IF' (CTEMP .EQ. UPAROW) 'DO' TS = GCHAR (IBUF, INPTR) 'WHILE' (TS .EQ. BLANK .OR. TS .EQ. TAB) INPTR = INPTR + 1 'END' 'ENDIF' 'WHILE' (INMAX .NE. EOF) 'END' CHAR = EOF INPTR = INMAX + 1 SKIPFL = .TRUE. GOTO 10 END 'OUTFILE' PUTCFTM.FR SUBROUTINE PUTC (ICHAR) 'INCLUDE' STRAN.IN, INTEGER CONTL INTEGER ICHAR, TS 'IF' (OUTCHN .NE. -1) 'IF' (ICHAR .EQ. EOL) 'IF' (NEWFIL) NEWFIL = .FALSE. N CALL PSTR (' COMPILER NOSTACK;/') 'ENDIF' N CALL PCHAR (OUTBUF, OUTPTR, EOL) P CALL PCHAR (OUTBUF, OUTPTR, BLANK) TS = 72 OUTPTR = OUTPTR + 1 CALL WRLIN (OUTCHN, OUTBUF, TS) CALL INITOB CONTL = 0 RETURN 'ENDIF' 'IF' (OUTPTR .LE. 72) CALL PCHAR (OUTBUF, OUTPTR, ICHAR) OUTPTR = OUTPTR + 1 RETURN 'ENDIF' N CALL PCHAR (OUTBUF, 73, EOL) P CALL PCHAR (OUTBUF, 73, BLANK) TS = 72 CALL WRLIN (OUTCHN, OUTBUF, TS) CALL INITOB CALL PCHAR (OUTBUF, 6, CHAR1) CALL LSTART CALL PCHAR (OUTBUF, 7, ICHAR) OUTPTR = OUTPTR + 1 CALL SKIPBL CONTL = CONTL + 1 'IF' (CONTL .EQ. 20) CALL REMARK ('TOO MANY CONTINUATION LINES.') 'ENDIF' 'ENDIF' RETURN END 'OUTFILE' PRINTFTM.FR SUBROUTINE PRINT 'INCLUDE' STRAN.IN, INTEGER GCHAR, FORMF DATA FORMF /3084/ 'IF' ((.NOT. POFF) .AND. LPTCHN .GE. 0) 'IF' (.NOT. SKIPFL) 'IF' (TSEEN) 'DOLOOP' II = 1, 56 PBUF (II) = BBLANK 'END' II = 1 JJ = 1 'DO' 'WHILE' (II .LT. INMAX) CHAR = GCHAR (IBUF, II) 'IF' (CHAR .NE. TAB) CALL PCHAR (PBUF, JJ, CHAR) JJ = JJ + 1 'NEXT' 'ENDIF' 'DOLOOP' K = 1, MAXTAB 'IF' (JJ .GE. TABS (K)) 'END' CALL PCHAR (PBUF, JJ, CHAR) JJ = JJ + 1 'NEXT' 'ENDIF' TLIMIT = TABS (K) 'DOLOOP' JJ = JJ, TLIMIT CALL PCHAR (PBUF, JJ, BLANK) 'END' 'END' 'ENDIF' 'IF' (CLINE .GE. MAXLIN) 'IF' (FIRST) FIRST = .FALSE. 'DOLOOP' K = 1, 40 HBUF (K) = BBLANK 'END' 'ENDIF' PAGE = PAGE + 1 CALL SET (BBLANK, BUF, 60) CALL EST ('PAGE ', BUF, 1, 5) CALL ESP (PAGE, BUF, 6, 9) CALL EST (' ', BUF, 10, 13) CALL EST (HBUF, BUF, 14, 64) KK = 1 CALL WRLIN (LPTCHN, FORMF, KK) CALL PCHAR (BUF, 65, EOL) KK = 64 CALL WRLIN (LPTCHN, BUF, KK) N CALL PCHAR (BUF, 1, EOL) P BUF (1) = BBLANK KK = 1 CALL WRLIN (LPTCHN, BUF, KK) CLINE = 0 'ENDIF' 'ELSE' SKIPFL = .FALSE. RETURN 'ENDIF' 'IF' (LINENO .NE. 0) CALL SET (BBLANK, BUF, 5) CALL ESP (LINENO, BUF, 1, 4) 'IF' (TSEEN) TSEEN = .FALSE. CALL EST (PBUF, BUF, 9, 120) CALL PCHAR (BUF, 121, EOL) P KK = 120 'ELSE' CALL EST (IBUF, BUF, 9, 88) CALL PCHAR (BUF, 89, EOL) KK = 88 'ENDIF' CALL WRLIN (LPTCHN, BUF, KK) 'ENDIF' CLINE = CLINE + 1 'ENDIF' RETURN END \\\\\