'HEAD'  RELOCATABLE OBJECT FORMATTING
C     EDIT DATE   18JAN79  21:55
C     SOURCE FILE OBJECTAJH.FS
C     AUTHOR      A. J. HOWARD
C     CLUSTER     10
      'OUTFILE'   OBJECTAJH.FR
C     EDIT DATE   18JAN79  21:55
C     SOURCE FILE OBJECTAJH.FR
C     AUTHOR      A. J. HOWARD
N     OVERLAY     OLOBJ
      SUBROUTINE  PNCHO
C     FORMAT THE RELOCATABLE OBJECT FILE FOR THE LOADER
      'INCLUDE'   OBJECTAJH.IN,P
C     END OF OBJECTAJH.IN
      'INCLUDE'   CODE1FTM.IN,
      'INCLUDE'   CTRLAJH.IN,
      'INCLUDE'   LCFUNCAJH.IN,
      'INCLUDE'   OBDATAJHP.IN,
      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   NLARAYFTM.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   NLNAMEFTM.IN,
      'INCLUDE'   PRTCOMFTM.IN,
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   XNAMEAJH.IN,
      'EJECT'
      INTEGER     TS, LOCTS, LCSTEP
      INTEGER     OWVER (256), BCNAME (8), OBFILE (16), SRFILE (16)
C     EXTERNAL FUNCTIONS
      INTEGER     SNMLST, ENCNAM, REORG, OBJEXT, NLOPS, GDICT, OBJSYM
      INTEGER     GCHAR
      EXTERNAL    REORG, OBJEXT, OBJSYM
N     EXTERNAL    OLOB2, OLOB3
      LOGICAL     NLTEST
      'INCLUDE'   SSNAMES.IN,P
      DATA  BCNAME/ 'X.BLANK.COMMON. '/
C        0, 1, 2, 3, 4, 5, 6, 7, 8, 9, A, B, C, D, E, F
      DATA  OWVER /^
         1, 2, 0, 0, 0, 2, 2, 0, 1, 2, 1, 0, 0, 3, 3, 0,^ // 0X
         2, 2, 0, 0, 0, 2, 2, 0, 1, 3, 0, 0, 0, 3, 3, 0,^ // 1X
         3, 2, 0, 0, 2, 2, 2, 0, 1, 2, 1, 0, 3, 3, 3, 0,^ // 2X
         2, 2, 0, 0, 0, 2, 2, 0, 1, 3, 0, 0, 0, 3, 3, 0,^ // 3X
         1, 2, 0, 0, 0, 2, 2, 0, 1, 2, 1, 0, 3, 3, 3, 0,^ // 4X
         2, 2, 0, 0, 0, 2, 2, 0, 1, 3, 0, 0, 0, 3, 3, 0,^ // 5X
         1, 2, 0, 0, 0, 2, 2, 0, 1, 2, 1, 0, 3, 3, 3, 0,^ // 6X
         2, 2, 0, 0, 0, 2, 2, 0, 1, 3, 0, 0, 0, 3, 3, 0,^ // 7X
         0, 2, 0, 0, 2, 2, 2, 0, 1, 0, 1, 0, 3, 3, 3, 0,^ // 8X
         2, 2, 0, 0, 2, 2, 2, 0, 1, 3, 1, 0, 0, 3, 0, 0,^ // 9X
         2, 2, 2, 0, 2, 2, 2, 0, 1, 2, 1, 0, 3, 3, 3, 0,^ // AX
         2, 2, 0, 0, 2, 2, 2, 0, 1, 3, 1, 0, 3, 3, 3, 0,^ // BX
         2, 2, 0, 0, 2, 2, 2, 0, 1, 2, 1, 0, 3, 3, 3, 0,^ // CX
         2, 2, 0, 0, 0, 2, 2, 0, 1, 3, 0, 0, 0, 3, 3, 0,^ // DX
         2, 2, 0, 0, 2, 2, 2, 0, 1, 2, 1, 0, 3, 3, 3, 0,^ // EX
         2, 2, 0, 0, 0, 2, 2, 0, 1, 3, 0, 0, 0, 3, 3, 0/  // FX
      DATA  OBFILE /16*0/
      'EJECT'
C     CLOSE THE SOURCE FILE
C     REWIND THE SRCATCH FILES
      CALL REW (SS, SCR1)
      CALL REW (SS2, SCR2)
      CALL RDSEQ (SS2, SRFILE, 30, ERRFLG)
C     GET THE OBJECT FILE NAME AND CREATE IT
      CALL CLOSF(PI,SRFILE)
      CALL RDSEQ  (SS2, OBFILE, 30, ERRFLG)
P     CALL DEVICE (OBFILE)    // SUBSTITUTE DEFAULT DEVICE IF NEEDED
      CALL OPENN  (BO, OBFILE, ERRFLG)
CN     CALL OVLOD  (OLOB2)
CN     CALL OVLOD  (OLOB3)

C     PUNCH ELEMENT DESCRIPTOR
C     MODULE START
      BTYPE = 1
      RBITS = 0
      CALL MOVE (TTL, BCARD (2), 8)
      TWI = 10
      CALL WRC
C     MODULE ID
      BTYPE = 4
      RBITS = 0
      CALL SET (XBBL, BCARD (2), 40)
      'DOLOOP' K = 1, 30
         TS = GCHAR (SRFILE, K)
         'IF' (TS .EQ. 0 .OR. TS .EQ. 13)
            'BREAK'
            'ENDIF'
         CALL PCHAR (BCARD, K+2, TS)
         'END'
      CALL QQDATE (BCARD (18))
      CALL QQTIME (BCARD (23))
      CALL EST  (CHEAD, BCARD, 57, 72)
      TWI = 42
      CALL WRC
      'EJECT'
C     CONTROL SECTIONS
      EXTDX = 1
      CALL SETDI (ABSLC,  0)
      CALL SETDI (NOUNLC, 1)
      CALL SETDI (DATALC, 2)
      CALL SETDI (ZREL,   3)
      CALL SETDI (CODE,   4)
C     DEFINE COMMON BLOCKS
      'IF' (LCTAB (COMLOC) .NE. 0)
C        MAKE A NAME FOR BLANK COMMON ".BLANK.COMMON."
         CALL MOVE (BCNAME, NAME, 8)
         CALL PCHAR (NAME, 1,  14)
         CBTAB (COMLOC) = SNMLST (DUMMY)
         NLOC (NLX) = 0
         'ENDIF'
      CBX = CBX - 1
      'DOLOOP' K = COMLOC, CBX
         'IF' (LCTAB (K) .NE. 0)
            BTYPE = 6
            RBITS = 1      // COMMON BLOCKS ARE NOUNS
            AREAID (K) = EXTDX
            BCARD (2) = EXTDX
            BCARD (3) = LCTAB (K)
            TWI = 4
            N = CBTAB (K)
            TS = ENCNAM (N)
            EXTDX = EXTDX + 1
            CALL WRC
            'ENDIF'
         'END'
      CALL NLSCAN (REORG, N)
      CALL NLSCAN (OBJEXT, N)
      'IF' (XNX .GT. 0)
         'DOLOOP' I = 1, XNX, 2
            N = XNAME (I+1)
            'IF' (NLTEST (N, EXTBIT))
               L = XNAME (I)
               NLOC (L) = NLOC (N)
               'ENDIF'
            'END'
         'ENDIF'
      ADDR = 0
      LCI = -1
      GO TO 300            // FAKE A WORD FLAG 3
      'EJECT'
C     WORD FLAG 1, SINGLE ABSOLUTE BYTE OF DATA
100   CALL PCHAR (RWORD, 1, OW)
C     PUT OUT A LOADER RECORD
110   'IF' (NEWLCI .NE. LCI .OR. LOCTS .NE. LC)
C        CHANGE LOCATION COUNTER FOR THIS RECORD
         CALL PUSH (BTYPE, TWI, RBITS)
         BTYPE = 14           // SET LOCATION TYPE
         RBITS = 0
         LCI = NEWLCI
         BCARD (2) = AREAID (LODLCI)
         BCARD (3) = LODLCV
         TWI = 4
         CALL WRC             // WRITE RECORD TO FILE
         CALL POP (BTYPE, TWI, RBITS)
         'ENDIF'
      CALL MOVE (RWORD, BCARD (TWI), RCT)
      TWI = RCT + TWI
      CALL WRC                // WRITE RECORD TO FILE
      OFFSET = 0
C     ADJUST LOCATION COUNTER VALUES
      LC = LC + LCSTEP
      LOCTS = LC
      LODLCV = LODLCV + LCSTEP
C     GET THE NEXT OBJECT WORD/WORD FLAG PAIR
140   RCT = 1
      RBITS = 1
      BTYPE = 10              // ABSOLUTE DATA
      LCSTEP = 1
      RWORD1 = 0
      CALL NOW                // GET NEXT OW, WF
      GO TO ( 100,  200,  300,  400,  500, ^
              600,  700,  800,  900, 1000, ^
             1100, 1200, 1300, 1400, 1500, ^
             1600, 1700), WF
      'EJECT'
C     WORD FLAG 2, SET LOCATION COUNTER VALUE
200   LC = OW + ADDR
      GO TO 140

C     WORD FLAG 3, NEW FLOWCHART
300   NRFCH = NRFCH - 1
      IF (NRFCH .LT. 0) GO TO 3000     // FINISH OBJECT DECK
C     READ THE TRANSFER LIST FILE
      CALL RDSEQ (SS, TL, 256, ERRFLG)
      WOPTR = 65              // WILL NEED NEW OW/WF RECORD
      GO TO 140

C     WORD FLAG 4, 1 BYTE ABSOLUTE INSTRUCTION
400   IF (OFFSET .NE. 0) CALL OBJFLT (3)
      IF (OWVER (OW+1) .NE. 1) CALL OBJFLT (2)
      GO TO 100
      'EJECT'
C     WORD FLAG 5, INSTRUCTION + 1 BYTE ADDRESS
500   BTYPE = 12              // ABS BYTE + DATA
      RCT = 3
      LCSTEP = 2
      RWORD2 = OW
      IF (OWVER (OW+1) .NE. 2) CALL OBJFLT (2)
C     GET ANY OFFSETS TO ADDRESS
      'DO'
         CALL NOW             // NEXT OW/WF
         'WHILE' (WF .EQ. WF6)
            OFFSET = OFFSET + OW
            'END'
C     WORD FLAG MUST BE 7, 9, 12, 13
      'IF' (IAND (LINSTR (2*RWORD2+1), 768) .EQ. 512)
C        BRANCH INSTRUCTION, SETUP RELATIVE ADDRESSING
         'IF' (WF .EQ. WF9)
C           TRANSFER LIST INDEX
            OFFSET = OFFSET + TL (OW) - LC
            'ELSE'
            'IF' (WF .EQ. WF7)
               TS = NLOPS (NLXLCI, OW)
               OFFSET = OFFSET + NLOC (OW)
               'IF' (TS .NE. ABSLC)
                  'IF' (TS .EQ. NEWLCI)
                     OFFSET = OFFSET - LC
                     'ELSE'
                     OFFSET = 200  // FORCE FAULT 40
                     'ENDIF'
                  'ENDIF'
               'ELSE'
               CALL OBJFLT (4)
               'ENDIF'
            'ENDIF'
         OFFSET = OFFSET - 2   // RELATIVE TO NEXT INSTRUCTION
         'IF' (OFFSET .LT. -128 .OR. OFFSET .GT. 127)
C           ADDRESS OUT OF RANGE ERROR
            CALL OBJFLT (5)
            OFFSET = 0
            'ENDIF'
         OW = NULLX
         WF = WF7
         'ENDIF'
      'EJECT'
      'IF' (WF .NE. WF7 .AND. WF .NE. WF12 .AND. WF .NE. WF13)
C        ILLEGAL WF SEQUENCE
         CALL OBJFLT (1)
         GO TO 140
         'ENDIF'
      'IF' (NLOPS (NAMCON, OW) .NE. 0)
         OW = NLOC (OW)       // NAMED CONSTANT DEFINED AFTER USE
         'ENDIF'
      'IF' (WF .EQ. WF13)
         RBITS = 2
         'ELSE'
         RBITS = 3
         'ENDIF'
      RWORD1 = GDICT (OW)
      RWORD3 = OFFSET
      GO TO 110
C     WORD FLAG 6, ADDRESS OFFSET
600   OFFSET = OFFSET + OW
      GO TO 140
C     WORD FLAG 7, 2 BYTE ADDRESS
700   'IF' (NLOPS (NAMCON, OW) .NE. 0)
         OW = NLOC (OW)
         'ENDIF'
      BTYPE = 11              // RELOCATABLE DATA
      RBITS = 1               // 2 BYTES LO/HI
      LCSTEP = 2
      RCT = 2
      RWORD1 = GDICT (OW)
      RWORD2 = OFFSET
      GO TO 110
      'EJECT'
C     WORD FLAG 8, COMMAND + 2 BYTE ADDRESS
800   BTYPE = 12
      RBITS = 1
      LCSTEP = 3
      RCT = 3
      RWORD2 = OW          // COMMAND
      IF (OWVER (OW+1) .NE. 3) CALL OBJFLT (2)
      'DO'
         CALL NOW             // NEXT OW/WF
         'WHILE' (WF .EQ. WF6)
            OFFSET = OFFSET + OW
            'END'
C     CHECK TRANSFER LIST WITH NAME LIST INDEX
      'IF' (WF .EQ. WF9)
         'IF' (TL (OW) .LT. 0)
            OW = -TL (OW)
            WF = WF7
            'ENDIF'
         'ENDIF'
C     SET DICTIONARY ID
      'IF' (WF .EQ. WF9)
         RWORD1 = AREAID (NEWLCI)
         'ELSE'
         'IF' (WF .NE. WF7)
C           ILLEGAL WORD FLAG SEQUENCE
            CALL OBJFLT (1)
            GO TO 140
            'ENDIF'
         'IF' (NLOPS (NAMCON, OW) .NE. 0)
            OW = NLOC (OW)
            'ENDIF'
         'IF' (NLTEST (OW, EXTBIT))
            RWORD1 = NLOC (OW)
            OW = NULLX
            'ELSE'
            TS = NLOPS (NLXLCI, OW)
            RWORD1 = AREAID (TS)
            'ENDIF'
         'ENDIF'
C     SET ADDRESS
      'IF' (WF .EQ. WF7)
         RWORD3 = NLOC (OW) + OFFSET
         'ELSE'
         RWORD3 = TL (OW) + OFFSET
         'ENDIF'
      GO TO 110
      'EJECT'
C     WORD FLAG 9, TRANSFER LIST ENTRY CAN'T STAND ALONE
900   GO TO 1300
C     WORD FLAG 10, SET LOAD LOCATION COUNTER
1000  NEWLCI = OW
      GO TO 140
C     WORD FLAG 11, NOT USED
1100  CONTINUE
C     WORD FLAG 12, NOT USED ALONE
1200  CONTINUE
C     WORD FLAG 13, NOT USED ALONE
1300  CONTINUE
      CALL OBJFLT (1)
      GO TO 140
      'EJECT'
C     WORD FLAG 14, SET LOAD LOCATION COUNTER
1400  LODLCI = OW
      GO TO 140
C     WORD FLAG 15, SET LOAD LOCATION COUNTER VALUE
1500  LODLCV = OW + ADDR
      GO TO 140
C     WORD FLAG 16, ADDRESS DIFFERENCE FOR LOADER
1600  BTYPE = 13
      RBITS = 1
      LCSTEP = 2
      RCT = 3
      RWORD2 = GDICT (OW)
      OFFSET = -OFFSET
      'DO'
         CALL NOW
         'WHILE' (WF .EQ. WF6)
            OFFSET = OFFSET + OW
            'END'
      'IF' (WF .NE. WF7)
C        ILLEGAL WORD FLAG SEQUENCE
         CALL OBJFLT (1)
         OW = NULLX
         'ENDIF'
      RWORD1 = GDICT (OW)
      RWORD3 = OFFSET
      GO TO 110
C     ADJUST LOCATION COUNTER VALUE
1700  BTYPE = 15
      RBITS = 0
      RWORD1 = OW
      GO TO 110
      'EJECT'
C     FINISH OBJECT DECK
3000  'DOLOOP' I = 1, ZREL
         'IF' (LCTAB (I) .NE. 0)
            BTYPE = 14
            RBITS = 0
            BCARD (2) = AREAID (I)
            BCARD (3) = LCTAB (I)
            TWI = 4
            CALL WRC
            'ENDIF'
         'END'
C     PUNCH SYMBOLS
      'IF' (SYMFLG .NE. 0)
         CALL NLSCAN (OBJSYM, N)
         'ENDIF'
C     SET START ADDRESS
      'IF' (TNAME .NE. 0)
         BTYPE = 17
         RBITS = 0
         I = NLOPS (NLXLCI, TNAME)
         BCARD (2) = AREAID (I)
         BCARD (3) = NLOC (TNAME)
         TWI = 4
         CALL WRC
         'ENDIF'
      BTYPE = 2
      RBITS = 0
      TWI = 2
      CALL WRC
      CALL CLOSF (BO, OBFILE)
      RETURN
      END
      'OUTFILE'   ENCNAMAJH.FR
C     EDIT DATE   18JAN79  21:55
C     SOURCE FILE ENCNAMAJH.FR
C     AUTHOR      A. J. HOWARD
      INTEGER FUNCTION ENCNAM (INDEX)
      INTEGER     INDEX, NTS, NRCHAR
      INTEGER     CLOCN
      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   NLNAMEFTM.IN,
      'INCLUDE'   OBJECTAJH.IN,
      'INCLUDE'   XNAMEAJH.IN,
      NTS = N
      ENCNAM = 0
      'IF' (XNX .GT. 0)
         'DOLOOP' I = 1, XNX, 2
            'IF' (XNAME (I) .EQ. N)
               NTS = XNAME (I+1)
               ENCNAM = NTS
               'BREAK'
               'ENDIF'
            'END'
         'ENDIF'
      NRCHAR = CLOCN (NTS)
      N = NTS
      CALL MOVE (NAME, BCARD (TWI), 8)
      TWI = TWI + 8
      RETURN
      END
      'OUTFILE'   GDICTAJH.FR
C     EDIT DATE   18JAN79  21:55
C     SOURCE FILE GDICTAJH.FR
C     AUTHOR      A. J. HOWARD
      INTEGER FUNCTION GDICT (INDEX)
      'INCLUDE'   OBJECTAJH.IN,
      'INCLUDE'   NLARAYFTM.IN,
      'INCLUDE'   NLISTCFTM.IN,
      INTEGER     INDEX, TS
      INTEGER     NLOPS
      LOGICAL     NLTEST
      'IF' (NLTEST (INDEX, EXTBIT))
C        EXTERNAL REFERENCE
         GDICT = NLOC (INDEX)
         'ELSE'
C        NOT EXTERNAL, SET AREA ID AND OFFSET
         TS = NLOPS (NLXLCI, INDEX)
         TS = AREAID (TS)
         OFFSET = OFFSET + NLOC (INDEX)
         GDICT = TS
         'ENDIF'
      RETURN
      END
      'OUTFILE'   NOWAJH.FR
C     EDIT DATE   18JAN79  21:55
C     SOURCE FILE NOWAJH.FR
C     AUTHOR      A. J. HOWARD
      SUBROUTINE  NOW
C     GET NEXT OBJECT WORD/WORD FLAG PAIR FROM PASS 1 FILE
      'INCLUDE'   OBJECTAJH.IN,
      'INCLUDE'   CODE1FTM.IN,
      'INCLUDE'   CTRLAJH.IN,
      'INCLUDE'   PRTCOMFTM.IN,
      'DO'
         'IF' (WOPTR .GE. 65)
            WOPTR = 1
            CALL RDSEQ (SS2, WO, 128, ERRFLG)
            'ENDIF'
         WF = WO (WOPTR)
         OW = WO (WOPTR+1)
         WOPTR = WOPTR + 2
         'WHILE' (WF .LT. 1 .OR. WF .GT. 17)
C           ILLEGAL WORD FLAG IN FILE
            CALL OBJFLT (1)
            'END'
C
C     DEBUG OUTPUT
C
      'IF' (DUMFLG .NE. 0)
         CALL EST ('NOW ', LBUF, 1, 4)
         CALL ESP (WF, LBUF, 4, 8)
         CALL EHX (OW, LBUF, 10, 13)
         CALL SGLPRT
         'ENDIF'
      RETURN
      END
      'OUTFILE'   OBJEXTAJH.FR
N     OVERLAY     OLOB2
C     EDIT DATE   18JAN79  21:55
C     SOURCE FILE OBJEXTAJH.FR
C     AUTHOR      A. J. HOWARD
      SUBROUTINE  OBJEXT
      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   OBJECTAJH.IN,
      'INCLUDE'   NLARAYFTM.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   XNAMEAJH.IN,
      INTEGER     EXTYPE, TS, NLTS
      INTEGER     NLOPS, ENCNAM
      LOGICAL     NLTEST
      NLTS = NLIST (N)
      'IF' (NLTEST (N, EXDBIT))
         'IF' (.NOT. NLTEST (N, USEBIT))
C           NOT USED, IGNORE IT
            RETURN
            'ENDIF'
         NLIST (N) = EXDBIT + EXTBIT
         EXTYPE = 1
         'ELSE'
         'IF' (NLOPS (DFINED, N) .NE. 0 ^
            .OR. NLTEST (N, CBIT) ^
            .OR. .NOT. NLTEST (N, USEBIT))
C           DEFINED, CONSTANT OR NOT USED; CLEAR EXTBIT
            NLIST (N) = IAND (NLTS, NOT (EXTBIT))
            RETURN
            'ENDIF'
         NLIST (N) = EXTBIT
         EXTYPE = 2
         'ENDIF'
      'IF' (XNX .GT. 0)
         'DOLOOP' I = 1, XNX, 2
            'IF' (XNAME (I) .EQ. N)
               RETURN
               'ENDIF'
            'END'
         'ENDIF'
      BTYPE = 9
      RBITS = 0
      NLOC (N) = EXTDX
      BCARD (2) = EXTDX
      EXTDX = EXTDX + 1
      TWI = 3
      TS = ENCNAM (N)
      CALL WRC
      RETURN
      END
      'OUTFILE'   OBJSYMAJH.FR
C     EDIT DATE   18JAN79  21:55
C     SOURCE FILE OBJSYMAJH.FR
C     AUTHOR      A. J. HOWARD
      SUBROUTINE  OBJSYM
C     PUT THE SYMBOL TABLE INTO THE OUTPUT FILE
      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   OBJECTAJH.IN,
      'INCLUDE'   NLARAYFTM.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   NLNAMEFTM.IN,
C     'INCLUDE'   PRTCOMFTM.IN,   // DEBUG ONLY
      INTEGER     TS, NLTS
      INTEGER     NLOPS, ENCNAM, GCHAR, CLOCN
      LOGICAL     NLTEST
      NLTS = NLIST (N)
      'IF' (.NOT. NLTEST (N, CBIT + EXTBIT) ^
         .AND. NLTEST (N, USEBIT))
         TS = CLOCN (N)               // CONVERT NAME TEXT
         TS = GCHAR (NAME, 1)         // GET THE FIRST CHARACTER
C
C        DEBUG CODE
C
C        CALL EHX (NLTS, LBUF, 1, 4)
C        CALL ESP (TS, LBUF, 5, 9)
C        CALL EST (NAME, LBUF, 11, 26)
C        CALL SGLPRT
C
C        END DEBUG OUTPUT
C
         'IF' ((TS .GE. 65 .AND. TS .LE. 90) .OR. TS .EQ. 47)
C           FIRST CHARACTER IS ALPHA OR PERIOD
            BTYPE = 18
            RBITS = 0
            TS = NLOPS (NLXLCI, N)
            'IF' (.NOT. NLTEST (N, PBIT))
               BCARD (2) = AREAID (TS)
               BCARD (3) = NLOC (N)
               TWI = 4
               'IF' (ENCNAM (N) .EQ. 0)
C                 ONLY INCLUDE INTERNAL SPELLINGS
                  CALL WRC
                  'ENDIF'
               'ENDIF'
            'ENDIF'
         'ENDIF'
      RETURN
      END
      'OUTFILE'   REORGAJH.FR
C     EDIT DATE   18JAN79  21:56
C     SOURCE FILE REORGAJH.FR
C     AUTHOR      A. J. HOWARD
      SUBROUTINE  REORG
      'INCLUDE'   OBJECTAJH.IN,
      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   LCFUNCAJH.IN,
      'INCLUDE'   NLARAYFTM.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   XNAMEAJH.IN,
      INTEGER     TS
      INTEGER     NLOPS, ENCNAM
      LOGICAL     NLTEST
10    'IF' (NLTEST (N, EPBIT))
C        ENTRY POINT DEFINITION
         'IF' (N .EQ. OVNLX)
            BTYPE = 8
            BCARD (3) = AREAID (CODE)
            BCARD (4) = 0
            'ELSE'
            BTYPE = 7
            TS = NLOPS (NLXLCI, N)
            BCARD (3) = AREAID (TS)
            BCARD (4) = NLOC (N)
            'ENDIF'
         RBITS = 0
         BCARD (2) = EXTDX
         EXTDX = EXTDX + 1
         TWI = 5
         TS = ENCNAM (N)
         'IF' (TS .NE. 0)
C           DEFINE LOADER SPELLING OF NAME
            NLIST (TS) = IAND (NLIST (N), NOT (EPBIT)) ^
               + IAND (NLIST (TS), EPBIT)
            NLOC (TS) = NLOC (N)
            'ENDIF'
         CALL WRC
         'ELSE'
         'IF' (NLOPS (DFINED, N) .NE. 0 .AND. XNX .GT. 0)
            'DOLOOP' I = 1, XNX, 2
               'IF' (XNAME (I) .EQ. N)
                  CALL OBJFLT (6)
                  CALL NLSET (N, EPBIT)
                  GO TO 10
                  'ENDIF'
               'END'
            'ENDIF'
         'ENDIF'
      RETURN
      END
      'OUTFILE'   SETDIAJH.FR
C     EDIT DATE   18JAN79  21:56
C     SOURCE FILE SETDIAJH.FR
C     AUTHOR      A. J. HOWARD
      SUBROUTINE  SETDI (LC, AREA)
      'INCLUDE'   OBJECTAJH.IN,
      'INCLUDE'   LCFUNCAJH.IN,
      INTEGER     LC, AREA
      INTEGER     ANAMES (40)
      DATA  ANAMES   / '.A','BS','OL','UT','E.','  ','  ','  ', ^
                       '.N','OU','NS','. ','  ','  ','  ','  ', ^
                       '.D','AT','A.','  ','  ','  ','  ','  ', ^
                       '.Z','RE','L.','  ','  ','  ','  ','  ', ^
                       '.C','OD','E.','  ','  ','  ','  ','  '/
      BTYPE = 5
      RBITS = AREA
      AREAID (LC) = EXTDX
      BCARD  ( 2) = EXTDX
      BCARD  ( 3) = LCTAB (LC)
      EXTDX = EXTDX + 1
      CALL MOVE (ANAMES (8*AREA+1), BCARD (4), 8)
      TWI = 12
      CALL WRC
      RETURN
      END
      'OUTFILE'   WCARDAJH.FR
C     EDIT DATE   18JAN79  21:56
C     SOURCE FILE WCARDAJH.FR
C     AUTHOR      A. J. HOWARD
N     OVERLAY     OLOB3
      SUBROUTINE  WRC
C     WRITE RECORD TO OBJECT FILE
      'INCLUDE'   OBJECTAJH.IN,
      'INCLUDE'   CTRLAJH.IN,
      'INCLUDE'   PRTCOMFTM.IN,
      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   CODE1FTM.IN,
C     DEBUG ONLY
      INTEGER     TS, WRCI, WRCS (20)
      DATA        WRCS /2,0,0,2,4,4,5,5,3,0,0,0,0,0,0,0,0,4,0,0/
      TWI = TWI - 1
      'IF' (DUMFLG .NE. 0)               // DEBUG OUTPUT
         CALL EST ('WRC ', LBUF, 1, 4)
         CALL EHX (LC, LBUF, 6, 9)
         CALL EHX (BTYPE, LBUF, 11, 12)
         CALL ESP (RBITS, LBUF, 13, 15)
         TS = 17
         'DOLOOP' WRCI = 2, TWI
            CALL EHX (BCARD (WRCI), LBUF, TS, TS+3)
            TS = TS + 5
            'IF' (TS .GT. 115)
               CALL SGLPRT
               TS = 17
               'ENDIF'
            'END'
         CALL SGLPRT
         WRCI = WRCS (BTYPE)
         'IF' (WRCI .NE. 0)
            CALL EST ('ALPHA-', LBUF, 11, 16)
            CALL EST (BCARD (WRCI), LBUF, 17, (TWI-WRCI)*2+18)
            CALL SGLPRT
            'ENDIF'
         CALL SGLPRT
         'ENDIF'
      CALL PCHAR (BCARD, 1, BTYPE)
      CALL PCHAR (BCARD, 2, RBITS)
C     CONVERT TWI TO BYTE COUNT
      CALL WRSEQ (BO, BCARD, TWI+TWI)
      CALL SET (0, BCARD, TWI)
      TWI = 2
      RETURN
      END