'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,DUMMY 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 = QQMOD (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' (.NOT.OWRITE) 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