SUBFILE: STINIT.FS @16:3 23-MAY-1979 <055> (623)
'HEAD'  INITIALIZATION FOR STRAN
C     EDIT DATE   17JAN79  12:31
C     SOURCE FILE STINIT.FS
C     AUTHOR      F. T. MICKEY
C     CLUSTER     100.100
      'OUTFILE' INITFTM.FR


      SUBROUTINE INIT

      'INCLUDE' STRAN.IN,

      INTEGER GETWRD, GCHAR
      INTEGER INMES (7)

      DATA  INMES /'INPUT FILE:',0/

      INCHAN = 10
      'IF' (FFILE .EQ. 0)
         OUTCHN = -1
         FFILE = 1
N        TTICHN = 2
N        TTOCHN = 3
P        TTICHN = 5     // USE PDP/11 DEFAULT FOR CONSOLE I/O
P        TTOCHN = 5
         PROCCN = 4
N        LPTCHN = 0
P        LPTCHN = 6
N        COMCHN = 11
P        COMCHN = 5     // SAME AS TTICHN FOR FORTRAN VERSION
N        CALL OPENF (TTOCHN, '$TTO ', KK)
N        CALL OPENF (LPTCHN, '$LPT ', KK)
N        CALL OPENF (COMCHN, '$TTI ', KK)
         'ELSE'
         CALL CLOSF (INCHAN, KK)
         CALL CLOSF (OUTCHN, KK)
P        CALL SPOOL (LPTCHN, KK)     // SPOOL PDP PRINTER OUTPUT
P        CALL CLOSF (LPTCHN, KK)
         OUTCHN = -1
         IF (PROCCN .NE. -1) CALL CLOSF (PROCCN, KK)
         'ENDIF'
      'DO'
         KK = 12
         CALL WRLIN (TTOCHN, INMES, KK)
N        CALL SET (BBLANK, BUF, 8)
P        CALL SET (0, BUF, 22)
P        KK = 30
         CALL RDLIN (COMCHN, BUF, KK, IERROR)
         'IF' (GCHAR (BUF,1) .EQ. EOL)
N           CALL CLOSF (COMCHN, KK)
N           CALL CLOSF (LPTCHN, KK)
N           CALL CLOSF (TTOCHN, KK)
P        OPEN (UNIT=LPTCHN, TYPE='NEW')
C           OPENS LIST FILE "FOR006.DAT" ON PDP/11
            'ENDIF'
         I = 1
         LEN = 14
         LEN = GETWRD (BUF, I, LEN, NAME)
P        CALL PCHAR (NAME, LEN+1, 0)
         CALL OPENF (INCHAN, NAME, KK)
         'WHILE' (KK .NE. 1)
            CALL REMARK ('SOURCE OPEN ERROR.')
            'END'
      'DOLOOP' II = 1, LEN
         'IF' (GCHAR (NAME, II) .NE. PERIOD)
            'END'
            II = II + 1
            'ENDIF'
P     CALL EST ('.CMD ', NAME, II, II+4)
N     CALL EST ('.PR ', NAME, II, II+3)
      PROCCN = 4
      CALL OPENN (PROCCN, NAME, KK)
      'IF' (KK .NE. 1)
         PROCCN = -1
         CALL REMARK ('COMMAND FILE OPEN ERROR.')
         'ENDIF'
      CALL INITOB
      CLINE = 1000
      LEVEL = 1
      INPTR = 1
      INMAX = 0
      PAGE = 0
      LINENO = 0
      ISP = 1
      FIRST = .TRUE.
      SKIPFL = .FALSE.
      POFF = .FALSE.
      NEWFIL = .TRUE.
      TSEEN = .FALSE.
      RETURN
      END
      'OUTFILE' INITOBFTM.FR
      SUBROUTINE INITOB

      'INCLUDE' STRAN.IN,

      CALL SET (BBLANK, OUTBUF, 40)
      OUTPTR = 1
      RETURN
      END



\\\\\


SUBFILE: LOGOSA.FS @15:58 23-MAY-1979 <055> (812)
'HEAD'  COMPILER CONTROL
C     EDIT DATE   05FEB79  14:02
C     SOURCE FILE LOGOSAJH.FS
C     AUTHOR      A. J. HOWARD
C     CLUSTER     1

C     INSTALLATION DATES
C
C        2.0C     31OCT78
C        2.0D     21NOV78
C        2.0E     13DEC78
C        2.0F     19JAN79/26JAN79
C        2.0G     06FEB79
      'OUTFILE'   LOGOSAJH.FR

      'INCLUDE'   LOGOSAJH.IN,

      EXTERNAL    OLINI, OLNOU, OLPVR, OLPS2

N     INTEGER     OVFILE (7)

N     DATA        OVFILE   /'LOGOS.OL      '/

N     CALL OVOPN (OVCHN, OVFILE)       // DG-NOVA REQUIRES OPEN OVERLAY
      CALL OVLOD (OLINI)
      CALL INITLO
      CONEND = .FALSE.
      'DO'
         CALL OVLOD (OLNOU)
         CALL DIMEN
         'WHILE' (.NOT. CONEND)
            CALL OVLOD (OLPVR)
            CALL PVERBL
            'END'
      CALL OVLOD (OLPS2)
      CALL PASS2
      STOP
      END
'HEAD' COMPILER INITIALIZATION
      'OUTFILE'   INITAJH.FR

N     OVERLAY     OLINI

      SUBROUTINE  INITLO

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   ATESTAJH.IN,
      'INCLUDE'   CODE1FTM.IN,
      'INCLUDE'   LCFUNCAJH.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFD.IN,
      'INCLUDE'   STUFFAJH.IN,

      INTEGER     TTI(3), TTO(3), LPT(3), INLINE (7)
      INTEGER     INFILE (16), OUTFIL (16), IERR
      INTEGER     OUTLIN (7), LEXT (5)
      INTEGER     CHAR, XBLANK, XCOLON

      EXTERNAL    OLCD2
      INTEGER     GCHAR

      'INCLUDE'   SSNAMES.IN,P

      DATA  INLINE   /'INPUT FILE:   '/
      DATA  OUTLIN   /'OUTPUT FILE:  '/
P     DATA  TTI      /'TI:', 0/
N     DATA  TTI      /'TTI ',0/
N     DATA  TTO      /'$TTO',0/
      DATA  LPT      /'LIST', 0/
      DATA  INFILE   /16*0/ , OUTFIL /16*0/
      DATA  LEXT     / 46, 76, 83, 84, 0/  //  ".LST<0>"
      DATA  XBLANK   / 32/
      DATA  XCOLON   / 58/

C     PURPOSE     OPEN FILES
C                 INITIALIZE VARIABLES AND TABLES
C
      'EJECT'
P     CALL PCHAR (SCR1, 12, 0)      // PDP-11 ONLY
P     CALL PCHAR (SCR2, 12, 0)      // PDP-11 ONLY
      CALL OPENN (SS, SCR1, IERR)
      CALL OPENN (SS2, SCR2, IERR)

      CALL OPENF (CI, TTI, IERR)
N     CALL OPENF (CO, TTO, IERR)      // DGC ONLY
      CALL OVLOD (OLCD2)
      'DO'
         CALL WRLIN (CO, INLINE, 13)
         CALL RDLIN (CI, INFILE, 30, IERR)
         IF (IERR .EQ. 9) STOP         // END OF FILE
P        CALL DEVICE (INFILE)          // INSERT "SY0:" IF NO DEVICE
         CALL OPENF (PI, INFILE, IERR)
         'WHILE' (IERR .NE. 1)
            'END'
      CALL WRSEQ (SS2, INFILE, 30)    // SOURCE FILE
      I = 30
      'DO'
         CHAR = GCHAR (INFILE, I)
         'WHILE' (CHAR .NE. LEXT (1) ^  // .
               .AND. CHAR .NE. XCOLON)
            I = I - 1
            'IF' (I .EQ. 0)
               CALL WRLIN (CO, 'ILLEGAL FILE NAME ', 18)
               STOP
               'ENDIF'
            'END'
      'DOLOOP' K = 1, 5
         CALL PCHAR (INFILE, I, LEXT (K))
         I = I + 1
         'END'
P     CALL OPENN (LO, INFILE, IERR)
N     CALL OPENF (LO, LPT, IERR)      // DGC ONLY
      CALL WRLIN (CO, OUTLIN, 13)
      CALL RDLIN (CI, OUTFIL, 30, IERR)
      IF (IERR .EQ. 9) STOP            // END OF FILE
      CALL WRSEQ (SS2, OUTFIL, 30)     // OBJECT FILE
      OPX = 2
      OSTACK (1) = 1026
      LCI = DATALC
      CALL RBOTH (CODE)
      CALL NLINIT
      ATEST = .FALSE.
      STUFFO = 0
      RETURN
      END



\\\\\


SUBFILE: DDEFFT.FS @15:58 23-MAY-1979 <055> (2850)
'HEAD'  INITIAL DATA VALUE DEFINITIONS
C     EDIT DATE   14JAN79  09:50
C     SOURCE FILE DDEFFTM.FS
C     AUTHOR      F. T. MICKEY

      'OUTFILE' BRACEDATA.FR

      BLOCK DATA

      'INCLUDE' BRACEFTM.IN,P

      DATA  BRACEX   /1/
      DATA  SELX     /1/
      DATA  LSX      /2/   WHSTRT   /30*0/
      DATA  SELXB    /1/
      DATA  NRFLS    /6/
      END
      'OUTFILE'   BLDPODATA.FR

      BLOCK DATA

      'INCLUDE'   BLDPOAJH.IN,P
      END
      'OUTFILE' CODE1DATA.FR

      BLOCK DATA

      'INCLUDE' CODE1FTM.IN,P

      DATA  WOPTR    /1/
      DATA  TLI      /1/
      DATA  BO       /3/
      DATA  SS       / 9/
      DATA  SS2      / 8/
      DATA  NRFCH    / 0/
      END
      'OUTFILE'   COMPDATA.FR

      BLOCK DATA

      'INCLUDE'   CPAREAJH.IN,P

      DATA     NESTX    / 1/
      DATA     PNESTX   / 1/
      DATA     CLX      / 2/
      DATA     BRCT     / 0/
      DATA     BROK     / 0/
      END
      'OUTFILE' CTRLDATA.FR

      BLOCK DATA

      'INCLUDE' CTRLAJH.IN,P

      DATA  LISTF, SNLPRT / 0, 1/
      DATA  SUMPRT   /0/
      DATA  SYMFLG   /0/
      DATA  PRINTF   /1/
      DATA  SKIP     /0/
      DATA  COMPFL   /2*0/
      DATA  LOCPRT   /1/
      DATA  USFLGS   /0/
      DATA  ORGFLG   /0/
      DATA  CTLUSE   /0/
      DATA  TTL      /'                '/
      DATA  DUMFLG   /0/
      END
      'OUTFILE'   CRUDATA.FR

      BLOCK DATA

      'INCLUDE'   CRUCOMJHP.IN,P
      END
      'OUTFILE' GENCDATA.FR

      BLOCK DATA

      'INCLUDE' GENCOMFTM.IN,P

      DATA  TSTSTK   /1/
      DATA  SWAP     /2/
      DATA  TOPDP    /3/
      DATA  NEXTDP   /4/
      DATA  TOPSP    /5/
      DATA  NEXTSP   /6/
      DATA  SAVCAL   /7/
      DATA  OUT      /8/
      DATA  GETSP    /9/
      DATA  SMODEX   /10/
      DATA  SETX     /11/
      END
      'OUTFILE' IODATA.FR

      BLOCK DATA

      'INCLUDE' IOCONFTM.IN,P

      DATA  IOFLAG   /0/
      DATA  IOINDX   /1/
C     DATA  IONAME   / '<7>ENTER', '<7>INTRP /
N     DATA  IONAME   / 1861, 'NTER',  1865, 'NTRP'/
P     DATA  IONAME   /17671, 'NTER', 18695, 'NTRP'/

      END
      'OUTFILE'   LCFNCDATA.FR

      BLOCK DATA

      'INCLUDE'   LCFUNCAJH.IN,P

      DATA        CODE   / 1/
      DATA        NOUNLC / 2/
      DATA        DATALC / 3/
      DATA        COMLOC / 4/
      DATA        FBLOCK / 5/
      DATA        ZREL   /14/
      DATA        ABSLC  /15/
      DATA        CBTAB  /15*0/
      DATA        CBX    /   5/
      DATA        LCTAB  /15*0/
      END
      'OUTFILE'   LEVELDATA.FR
      BLOCK DATA

      'INCLUDE'   LEVELSAJH.IN,P

      DATA  NLEVEL   /1/
      DATA  LLEVEL   /2/
      DATA  ILEVEL   /3/
      DATA  CLEVEL   /4/
      END
      'OUTFILE'   LISTCDATA.FR
      BLOCK DATA

      'INCLUDE'   LISTCMAJH.IN,P

      DATA  LINE  /40*8224/
      DATA  OFFSET   / 0/
      DATA  LENTER   / .FALSE. /
      END
      'OUTFILE'   LCNSTDATA.FR
      BLOCK DATA

      'INCLUDE'   LCONSTAJH.IN,P

      DATA  LOWWF    / 1/  // OBJECT WORD AND WORD FLAG
      DATA  LTLNA    / 2/  // TRANSFER LIST NAME
      DATA  LLPOOL   / 3/  // LITERAL POOL
      DATA  LLNAME   / 4/  // NAME DEFINITION
      DATA  LMOVEP   / 5/  // BSS 0
      DATA  LBSS     / 6/  // BSS N
      DATA  LEXEQU   / 7/  // EXTERNAL EQU
      DATA  LNLEQU   / 8/  // NAME: NUMBER
      END
      'OUTFILE' LOGOSDATA.FR

      BLOCK DATA

      'INCLUDE' LOGOSAJH.IN,P

      DATA     ADRFLG   /2/
      DATA     DPVFLG   /3/
      DATA     VALFLG   /1/
      DATA     PI       /4/
      DATA     XBBL     /'  '/
      DATA     XA       /65/
      DATA     XF       /70/
      DATA     XZERO    /48/
      DATA     LOCSUP   /0/
      DATA     LC       /0/
      DATA     LCI      /1/
      DATA     LODLCI   /1/
      DATA     LODLCV   /0/
      DATA     LDLCVO   /0/
      DATA     MAXLCV   /0/
      DATA     OVCHN    /0/
      DATA     LO       /12/
      DATA     CI       /10/
      DATA     CO       /11/
      DATA     LOGICF   /0/
      DATA     J        /81/
      DATA     CRUCNT   /0/
      DATA     FLTCNT   /0/
      END
      'OUTFILE' NLARADATA.FR

      BLOCK DATA

      'INCLUDE' NLARAYFTM.IN,P

      DATA     NLIST /500*0/ NTEXTX /500*0/ NLOC /500*0/
      END
      'OUTFILE' NLISTDATA.FR

      BLOCK DATA

      'INCLUDE' NLISTCFTM.IN,P

      DATA  NSIZE /16/
      DATA  NLX   /1/
      DATA  FNLX  /1/
      DATA  REMNLX   /1/
      DATA  NLSTRT   /1/
      DATA  NLSTOP   /499/
      DATA  NLSIZE   /499/
      DATA  SRCHST   /1/
      DATA  NTSTRT   /1/
      DATA  NTSTOP   /1500/
      DATA  NTSIZE   /1500/
      DATA  PARFLG   /0/
      DATA  SPARFL   /0/
      DATA  NLWRDS   /0/
      DATA  TX       /1/
      DATA  NLENO    /0/
      DATA  STDMD    /0/
      DATA  MSHIFT   /13/
      DATA  REGCNT   /0/
      DATA  NULLX    /0/
      DATA  SPMODE   /0/
      DATA  DPMODE   /1/
      DATA  DFINED   /1/
      DATA  CVALUE   /2/
      DATA  NLXLCI   /3/
      DATA  ENEXTD   /4/
      DATA  NAMAT0   /5/
      DATA  NAMCON   /6/
      DATA  NLMODE   /7/
      DATA  NAMLOC   /8/
      DATA  REGNUM   /9/
      DATA  PARBIT   /128/
      DATA  OPBIT    /64/
      DATA  LOCALB   /32/
      DATA  EXTBIT   /16384/
      DATA  STRBIT   /16384/
      DATA  DPBIT    /8192/
      DATA  CBIT     /2048/
      DATA  PBIT     /1024/
      DATA  EPBIT    /512/
      DATA  IOBIT    /256/
      DATA  ARBIT    /128/
      DATA  EXDBIT   /64/
      DATA  TPLBIT   /32/
      DATA  USEBIT   /16/
      DATA  LCMASK   /15/
      DATA  MDMASK   /12288/
      END
      'OUTFILE' OPERSDATA.FR

      BLOCK DATA

      'INCLUDE' OPERSAJH.IN,P

      DATA     NINE     /1/
      DATA     COMMA, SEMIC, PERIOD, COLON, FOR, DOOP, WHILE ^
               /   2,     3,      4,     5,   6,    7,     8/

      DATA     RBRACE, LBRACE, RETOP, CRUTCH ^
               /    9,     10,    11,     12/

      DATA     LPAREN, RPAREN, LBK, RBK ^
               /   13,     14,  15,  16/

      DATA     EQUAL, NEQUAL, GTR, GEQ, LESS, LESSEQ, ARROW ^
               /  17,     18,  19,  20,   21,     22,    23/

      DATA     PLUS, MINUS, MULT, DIVIDE, MODOP ^
               / 24,    25,   26,     27,    28/

      DATA     OROP, ANDOP, AOROP, XOROP, AANDOP ^
               / 29,    30,    31,    32,     33/

      DATA     LSHIFT, RSHIFT, LCYCLE, RCYCLE, ALSHFT, ARSHFT ^
               /   34,     35,     36,     37,     38,     39/

      DATA     NEG, UPARO, DNARO, COM ^
               /40,    41,    42,  43/

      DATA     LOC, GIZZY, QUOTE, ZRL, TEMPL ^
               /44,    45,    46,  47,    48/

      DATA     SP, DP, ST, HEX ^
              /49, 50, 51,  52/

      DATA     ATSIGN ^
              /    53/
      END
      'OUTFILE'   OPINXDATA.FR

      BLOCK DATA

      'INCLUDE'   OPINXJHP.IN,P
      'EJECT'
C     DATA VALUES PROVIDE INDEXING TO CRUTCH CODE TABLES

C     STRUCTURE:
C        LEFT HALF:  IDENTIFIES CRUTCH CODE TABLE
C                    1 (256)  IMPLID
C                    2 (512)  RELTIV
C                    3 (768)  GROUP1
C                    4 (1024) OTHERS
C        RIGHT HALF: INDEX INTO TABLE

      DATA  ADCINX   / 769/
      DATA  ANDINX   / 776/
      DATA  ASLINX   /1025/
      DATA  BITINX   /1036/
      DATA  CMPINX   / 775/
      DATA  CPXINX   /1047/
      DATA  CPYINX   /1058/
      DATA  DECINX   /1069/
      DATA  EORINX   / 778/
      DATA  INCINX   /1080/
      DATA  JMPINX   /1091/
      DATA  JSRINX   /1102/
      DATA  LDAINX   / 781/
      DATA  LDXINX   /1113/
      DATA  LDYINX   /1124/
      DATA  LSRINX   /1135/
      DATA  ORAINX   / 784/
      DATA  ROLINX   /1146/
      DATA  RORINX   /1157/
      DATA  SBCINX   / 787/
      DATA  STAINX   / 790/
      DATA  STXINX   /1168/
      DATA  STYINX   /1179/
      END
      'OUTFILE'   PNADATA.FR

      BLOCK DATA

      'INCLUDE'   PNACOMAJH.IN,P
      END
      'OUTFILE' PRTCMDATA.FR

      BLOCK DATA
      'INCLUDE' PRTCOMFTM.IN,P

      DATA     LBUF     /66*8224/  // '  '
      DATA     LCOUNT   /0/
      DATA     PGECNT   /0/
      DATA     UHEAD    /15*8224/  // '  '
      DATA     CHEAD    /'MOS LOGOS (2.0G)'/
      END
      'OUTFILE' PPCOMDATA.FR

      BLOCK DATA

      'INCLUDE' PSHCOMFTM.IN,P

      DATA  PX    /1/
      DATA  PEND  /10/     // PSTACK SIZE - 2
      END
      'OUTFILE' REGSDATA.FR

      BLOCK DATA


      'INCLUDE' REGSJHP.IN,P

      DATA  AREG  / 1 /
      DATA  XREG  / 2 /
      DATA  YREG  / 3 /
      DATA  NZREG /11/
      END
      'OUTFILE'   RMCDATA.FR

      BLOCK DATA

      'INCLUDE'   RMCODES.IN,P

      DATA  CLRACV   / 1 /
      DATA  CLRACX   / 2 /
      DATA  CLRSTA   / 3 /
      DATA  TRAREG   / 4 /
      DATA  SAVREG   / 5 /
      DATA  CTFREE   / 6 /
      DATA  SETREG   / 7 /

      END
      'OUTFILE'   SETDATA.FR
      BLOCK DATA

      'INCLUDE'   SETCOMJHP.IN,P

      DATA  LDAZP    /165/
      DATA  LDAABS   /173/
      DATA  LDAIMM   /169/
      DATA  LDAABY   /185/
      DATA  LDAINY   /177/
      DATA  LDYZP    /164/
      DATA  LDYABS   /172/
      DATA  LDYIMM   /160/
      DATA  SLEFT    / 19/
      DATA  SRIGHT   / 20/

      END
      'OUTFILE' SRCDFDATA.FR

      BLOCK DATA

      'INCLUDE' SRCDFSFTM.IN,P

      DATA     QUOTEX   /0/
      DATA     CONTRL   /10023/   // ''
      DATA     HEAD     /'HE'/
      DATA     EJECT    /'EJ'/
      DATA     BLANK    /32/
      DATA     SLASH    /47/
      DATA     CARDC    /0/
      DATA     EOCC     /13/
      DATA     ENDCRD   /10023, 'END '/
      DATA     SRCEND   /80/
      DATA     SLEN     /72/
      DATA     TF    /'TT', 'TT', 'FF'/
      END
      'OUTFILE' SRCXDDATA.FR

      BLOCK DATA

      'INCLUDE' SRCXDFFTM.IN,P

      DATA     FCHRTS   /1/
      DATA     SCFLAG   /0/
      DATA     QMODE    /0/
      DATA     NOTINQ   /.TRUE./
      DATA     LBIAS    /0/
      DATA     QINDEX   /0/
      END
      'OUTFILE'   STACKDATA.FR

      BLOCK DATA

      'INCLUDE'   STKDEFA.IN,P
      'INCLUDE'   STKDEFB.IN,P
      'INCLUDE'   STKDEFC.IN,P
      'INCLUDE'   STKDEFD.IN,P
      'INCLUDE'   STKDEFE.IN,P
      'INCLUDE'   STKDEFF.IN,P

      DATA     OCBIT    /256/   // 0100
      DATA     FUNBIT   / 64/   // 0040
      DATA     STKSIZ   / 20/
      END
      'OUTFILE' SYMDATA.FR

      BLOCK DATA

      'INCLUDE' SYMBOLFTM.IN,P

      DATA  SYMTBL   /0, 29, 46, 18, 12, -1, 30, 45, ^
                     13, 14, 26, 24,  2, 25,  4, 27, ^
                      1,  1,  1,  1,  1,  1,  1,  1, ^
                      1,  1,  5,  3, 21, 17, 19, -1, ^
                     53,  0,  0,  0,  0,  0,  0,  0, ^
                      0,  0,  0,  0,  0,  0,  0,  0, ^
                      0,  0,  0,  0,  0,  0,  0,  0, ^
                      0,  0,  0, 15, -1, 16, 41, -1, ^
                      9/
      END
      'OUTFILE' TEMPSDATA.FR
      BLOCK DATA

      'INCLUDE' TEMPSFTM.IN,P

      DATA     DTX    /0/
      DATA     STX    /0/
      END
      'OUTFILE' WFDATA.FR

      BLOCK DATA

      'INCLUDE' WFLAGSJHP.IN,P
      'EJECT'
      DATA  WF1   /  1 /
      DATA  WF2   /  2 /
      DATA  WF3   /  3 /
      DATA  WF4   /  4 /
      DATA  WF5   /  5 /
      DATA  WF6   /  6 /
      DATA  WF7   /  7 /
      DATA  WF8   /  8 /
      DATA  WF9   /  9 /
      DATA  WF10  / 10 /
      DATA  WF11  / 11 /
      DATA  WF12  / 12 /
      DATA  WF13  / 13 /
      DATA  WF14  / 14 /
      DATA  WF15  / 15 /
      DATA  WF16  / 16 /
      DATA  WF17  / 17 /
      END
      'OUTFILE'   XNAMEDATA.FR

      BLOCK DATA

      'INCLUDE'   XNAMEAJH.IN,P

      DATA     XNX      /    1/
      DATA     XNXMAX   /   99/
      DATA     XNAME    /100*0/
      END



\\\\\


SUBFILE: NOUNSA.FS @15:58 23-MAY-1979 <055> (3012)
'HEAD'  NOUN LIST PROCESSING
C     EDIT DATE   14JAN79  09:51
C     SOURCE FILE NOUNSAJH.FS
C     AUTHOR      A. J. HOWARD
C     CLUSTER     2

      'OUTFILE'   DIMENAJH.FR
N     OVERLAY     OLNOU
      SUBROUTINE  DIMEN
C     EDIT DATE   14JAN79  09:51
C     SOURCE FILE NOUNSAJH.FS
C     AUTHOR      A. J. HOWARD

      INTEGER     TS, IERR
      INTEGER     NBX, NBSTK (20)
      INTEGER     IOTS, IOTS1, INITLC
      INTEGER     MODETS, MTS1
      INTEGER     OLDMOD, OLDTPL
      INTEGER     REDEF
      INTEGER     FIRST, LAST, COUNT

      INTEGER     NLOPS, CQVAL, SNMLST
      LOGICAL     NLTEST
      EXTERNAL    OLCRU

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   STKDEFC.IN,
      'INCLUDE'   STKDEFD.IN,
      'INCLUDE'   LEVELSAJH.IN,
      'INCLUDE'   LCFUNCAJH.IN,
      'INCLUDE'   LCONSTAJH.IN,
      'INCLUDE'   BLDPOAJH.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   NLARAYFTM.IN,
      'INCLUDE'   SRCXDFFTM.IN,
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   XNAMEAJH.IN,
      'EJECT'
C     PROCESS NOUN LIST DRIVER
C
      FCHRTS = 1
      LOGICF = 0
      QVALUE = 0
      BIAS (OPX) = 0
      LEVELB = NLEVEL
      CALL RBOTH (NOUNLC)
      ENDOK = .TRUE.
1     NBX = 5
      NBSTK (NBX-4) = 0
      NBSTK (NBX-3) = STDMD
      NBSTK (NBX-2) = LODLCI
      NBSTK (NBX-1) = LCI
      OLDMOD = STDMD
      OLDTPL = 0

C     NOUN DEFINITION

2     TPFLAG = OLDTPL
      DEFMOD = OLDMOD
      FNLX = 0
      IOTYPE = 0
      CALL NEXP
      IF (CONEND) RETURN
      ENDOK = .FALSE.

C     TEST NEXT OP

3     IF (NEXTOP .EQ. EQUAL) GO TO 40
      IF (NEXTOP .GT. LBRACE) GO TO 80
      GO TO (99, ^
             10, ^ // ,
             10, ^ // ;
             85, ^ // .
             20, ^ // :
             80, ^ // 'FOR'
             80, ^ // 'DO'
             80, ^ // 'WHILE'
             10, ^ // 'RBR'
             30),^ // 'LBR'
         NEXTOP
      'EJECT'
C     DEFINE NOUN,  NEXTOP IS , ; 'RBR'
10    NLX = NAMEX (OPX)
      'IF' (NLX .NE. 0)
         CALL SMLCV
         CALL ADJLOC (BIAS (OPX))
         'ENDIF'

C     EXIT SWITCH
15    GO TO (99, ^
              2, ^ // ,
             90, ^ // ;
             99, ^ // .
             99, ^ // :
             99, ^ // 'FOR'
             80, ^ // 'DO'
             99, ^ // 'WHILE'
             60),^ // 'RBR'
         NEXTOP

C     DIMENSION ERROR
80    CALL FAULTP (4)
      GO TO 2

C     FC ERR
85    IF (NAMEX (OPX) .NE. 0) GO TO 80
      CALL FAULTP (79)

C     NOUN EXIT
90    'IF' (NBX .NE. 5)
         CALL FAULTP (12)
C     *********PUT IN SOME BRACES
         GOTO 1
         'ENDIF'
      'IF' (LCI .EQ. NOUNLC)
         CALL RBOTH (CODE)
         GO TO 1
         'ENDIF'
      IOTYPE = 0
      RETURN

99    CALL FATAL (6)
      RETURN
      'EJECT'
C
C     NOUN COLON

20    'IF' (NAMEX (OPX) .EQ. NULLX)

C     [NUMBER]: 'LBR'

         LCTAB (ABSLC) = BIAS (OPX)
         CALL RBOTH (ABSLC)
         CALL ADVAN
         IF (NEXTOP .NE. LBRACE) CALL FAULTP (58)
         GO TO 35
         'ENDIF'
      CALL PEEK
      'IF' (PEEKS .EQ. LBK)

C        NAME: [XAAAAA]       NAME RENAME FOR EXTERNAL

         CALL FNZS
         CALL FNZS
         NLX = 0
         'IF' (PSYMB .NE. RBK .AND. PSYMB .NE. MULT)
            CALL RDNAME (PERIOD)
            NLX = SNMLST (DUMMY)
            'ENDIF'
         TS = NAMEX (OPX)
         CALL NLVAL (TS, ISHFT (DEFMOD, MSHIFT), MDMASK)
         'IF' (IOTYPE .EQ. ST)
            CALL NLSET (TS, STRBIT)
            'ENDIF'
         NLOC (TS) = -1
         'IF' (NLX .NE. 0 .AND. NLX .NE. TS)
            XNAME (XNX) = TS
            XNAME (XNX+1) = NLX
            XNX = XNX + 2
            'IF' (XNX .GT. XNXMAX)
               CALL FAULTP (13)
               XNX = XNXMAX
               'ENDIF'
            'ENDIF'
         CALL LIST (LEXEQU, TS, NLX)
         'IF' (PSYMB .EQ. MULT)
            IF (NLX .NE. 0) CALL NLSET (NLX, EXDBIT)
            CALL FNZS
            CALL NLSET (NAMEX (OPX), EXDBIT)
            'ENDIF'
         CALL FNZS
         GO TO 2
         'ENDIF'
      'EJECT'
C     MORE NOUN COLON PROCESSING

C     SAVE THE REAL NAME LIST INDEX

      NAMEX (OPX) = FNLX
      OSTACK (OPX) = 1026
      OPX = OPX + 1
      REDEF = PEEKS
      IF (REDEF .EQ. COLON) CALL FNZS
      MODETS = DEFMOD
      DEFMOD = OLDMOD
      TPFLAG = OLDTPL
      IOTS = IOTYPE
      IOTYPE = 0
      CALL NEXP
      OPX = OPX - 1
      'IF' (NEXTOP .EQ. LBRACE)
C        COMMON BLOCK NAME
         'DOLOOP' I = FBLOCK, CBX
            'IF' (CBTAB (I) .EQ. NAMEX (OPX))
               CALL RBOTH (I)
               GO TO 35
               'ENDIF'
            'END'
         'IF' (CBX .GE. ZREL)
            CALL FAULTP (57)
            GO TO 35
            'ENDIF'
         CALL RBOTH (CBX)
         NLX = NAMEX (OPX)
         CBTAB (CBX) = NLX
         FNLX = NLX
         CBX = CBX + 1
         CALL NDEFN
         GO TO 35
         'ENDIF'
      'EJECT'
C
C     EQUIVALENCE PROCESSING
C

      MTS1 = DEFMOD
      DEFMOD = MODETS
      IOTS1 = IOTYPE
      IOTYPE = IOTS
      IF (BIAS (OPX) .EQ. 0) BIAS (OPX) = 1
      OPTOPX = NAMEX (OPX+1)
      IF (OPTOPX .EQ. 0) GO TO 80
      'IF' (NLTEST (OPTOPX, CBIT))
C        NAME: NUMBER
         NLX = NAMEX (OPX)
         'IF' ( NLOPS (DFINED, NLX) .NE. 0 .AND. REDEF .NE. COLON)
            CALL FAULTP (18)
            GO TO 2
            'ENDIF'
         NLOC (NLX) = OPTOPX
         CALL NLSET (NLX, ISHFT (DEFMOD, MSHIFT) + CBIT + LCMASK)
         'IF' (REDEF .NE. COLON)
C           PICKUP EQUATE AFTER USE
            IF (NLTEST (NLX, USEBIT)) CALL NLSET (OPTOPX, USEBIT)
            'ENDIF'
         CALL LIST (LNLEQU, NLX, OPTOPX)
         GO TO 15
         'ENDIF'

C     NAME: NAME

      NLX = NAMEX (OPX)
      CALL NDEFN
      'IF' (NAMEX (OPX) .NE. NAMEX (OPX+1))
         DEFMOD = MTS1
         IOTYPE = IOTS1
         'ENDIF'
      NAMEX (OPX) = NAMEX (OPX+1)
      SUBX  (OPX) = SUBX  (OPX+1)
      BIAS  (OPX) = BIAS  (OPX+1)
      GO TO 3
      'EJECT'
C     NOUN LEFT BRACE

30    'IF' (ZFLAG)
         CALL RBOTH (ZREL)
         ZFLAG = .FALSE.
         'ELSE'
         IF (.NOT. MSEEN) CALL RBOTH (COMLOC)
         'ENDIF'

C     STACK BRACE INFORMATION

35    IF (BIAS (OPX) .NE. 0) CALL FAULTP (5)
      NBX = NBX + 4
      NBSTK (NBX-4) = TPFLAG
      NBSTK (NBX-3) = DEFMOD
      NBSTK (NBX-2) = LODLCI
      NBSTK (NBX-1) = LCI
      OLDMOD = DEFMOD
      OLDTPL = TPFLAG
      GO TO 2
      'EJECT'
C     INIT NOUN
40    NLX = NAMEX (OPX)
      LABNLX = NLX
      'IF' (LABNLX .EQ. 0)
         CALL FAULTP (4)
         GO TO 2
         'ENDIF'
      CALL SMLCV
      TPFLAG = OLDTPL
      INITLC = LC
C
C     MORE INIT
C
41    QVALUE = 0
      DEFMOD = OLDMOD
      FNLX = 0
      CALL NEXP
      GO TO (99,  ^  // NUMBER
             42,  ^  // ,
             42,  ^  // ;
             85,  ^  // .
             43,  ^  // :
             50,  ^  // 'FOR'
             80,  ^  // 'DO'
             80,  ^  // 'WHILE'
             42,  ^  // 'RBR'
             43,  ^  // 'LBR'
             80,  ^  // 'RETURN'
             45,  ^  // $
             80,  ^  // (
             80,  ^  // )
             80,  ^  // [
             80,  ^  // ]
             43), ^  // =
         NEXTOP
'EJECT'

C     NOUN INIT
42    NLX = NAMEX (OPX)
      'IF' (NLX .NE. 0)
         'IF' (.NOT. NLTEST (NLX, CBIT) ^
               .AND. QVALUE .EQ. 0 ^
               .AND. LOCFLG (OPX) .EQ. 0)
C
C           INIT EXIT
43          IF (INITLC .EQ. LC) CALL FAULTP (30)
            TS = MAXLCV - LC
            'IF' (TS .NE. 0)
               NLX = LABNLX
               CALL ADJLOC (TS)
               'ENDIF'
            GO TO 3
            'ENDIF'
         'ENDIF'
C     CHECK LONG QUOTE
      IF (CQVAL (QVALUE) .GE. 0) CALL NVALUE

C     TEST LOCATION COUNTER VALUE FOR EXTENDED ARRAY
44    IF (LC .GT. MAXLCV) MAXLCV = LC
      IF (NEXTOP .EQ. COMMA) GO TO 41
      NAMEX (OPX) = 0
      GO TO 43

C     CRUTCH INITIAL VALUE
45    CALL CRUSYM
      GO TO 44
      'EJECT'
C     INIT FOR LOOP
C        'FOR' C 'LBR' C1, C2, ... , CN 'RBR'

C     GET THE LOOP COUNT
50    CALL NEXP
      FIRST = OPX
      IF (NEXTOP .NE. LBRACE) CALL FAULTP (58)
      NLX = NAMEX (OPX)
      'IF' (NLX .EQ. 0)
         CALL FAULTP (11)
         COUNT = 0
         'ELSE'
         'IF' (NLTEST (NLX, CBIT))
            COUNT = NLOPS (CVALUE, NLX)
            'ELSE'
            CALL FAULTP (11)
            COUNT = 0
            'ENDIF'
         'ENDIF'
      'DO'
         CALL NEXP
C        CHECK CONSTANT VALUE
         NLX = NAMEX (OPX)
         'IF' (NLX .NE. 0)
            'IF' (CQVAL (QVALUE) .LT. 0 .OR. (CFLAG .EQ. 0 ^
               .AND. LOCFLG (OPX) .EQ. 0))
               CALL FAULTP (11)
               NAMEX (OPX) = 0
               'ENDIF'
            'ENDIF'
         OPX = OPX + 1
         'WHILE' (NEXTOP .EQ. COMMA)
            'END'
      IF (NEXTOP .NE. RBRACE) CALL FAULTP (12)
      LAST = OPX - 1
      NEXTOP = COMMA
      'DO'
         'WHILE' (COUNT .NE. 0)
            'DOLOOP' OPX = FIRST, LAST
               CALL NVALUE
               'END'
            COUNT = COUNT - 1
            'END'
      OPX = FIRST
      'DO'
         CALL PEEK
         'WHILE' (PEEKS .EQ. COMMA)
            CALL FNZS
            'END'
      GO TO 44
      'EJECT'
C     TERMINATE BRACE GROUP

60    MSEEN = .FALSE.
      NBX = NBX - 4
      'IF' (NBX .LE. 1)
         CALL FAULTP (14)
         NBX = 5
         'ELSE'
C
C        RESTORE TO OUTER BRACE LEVEL

         OLDTPL = NBSTK (NBX-4)
         OLDMOD = NBSTK (NBX-3)
         LODLCI = NBSTK (NBX-2)
         CALL BLDBLK (LODLCI, WF14)
         CALL RLCI (NBSTK (NBX-1))
         'ENDIF'
      GO TO 2
      END
      'OUTFILE'   NVALUEAJH.FR
      SUBROUTINE  NVALUE
C     EDIT DATE   14JAN79  09:52
C     SOURCE FILE NVALUEAJH.FR
C     AUTHOR      A. J. HOWARD

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   STKDEFC.IN,
      'INCLUDE'   WFLAGSJHP.IN,

      INTEGER     NLOPS
      LOGICAL     NLTEST

      NLX = NAMEX (OPX)
      IF (NLX .EQ. 0) RETURN
      'IF' (LOCFLG (OPX) .NE. 0)
         CALL BLDBLK (BIAS (OPX), WF6)
         CALL BLDBLK (NAMEX (OPX), WF7)
         RETURN
         'ENDIF'
      NUMBER = NLOPS (CVALUE, NLX)
C     BUILD THE LOW BYTE
      CALL BLDBLK (IAND (NUMBER, 255), WF1)
      'IF' (NLTEST (LABNLX, DPBIT) ^
         .OR. MODE (OPX) .EQ. DPMODE)
C        BUILD THE HIGH BYTE
         CALL BLDBLK (ISHFT (NUMBER, -8), WF1)
         'ENDIF'
      RETURN
      END
      'OUTFILE'   CQVALAJH.FR
C     EDIT DATE   14JAN79  09:52
C     SOURCE FILE CQVALAJH.FR
C     AUTHOR      A. J. HOWARD

      INTEGER  FUNCTION CQVAL (VAL)

      INTEGER     VAL
      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   NLISTCFTM.IN,
      LOGICAL     NLTEST

C     CHECK LONG OR SHORT STRING AND USAGE PRIOR TO DEFINITION

      CQVAL = VAL
      'IF' (VAL .NE. 0)
         'IF' (.NOT. NLTEST (LABNLX, STRBIT))
            CALL NLSET (LABNLX, STRBIT)
            'IF' (NLTEST (LABNLX, IOBIT))
               CALL FAULTP (17)
               'ENDIF'
            'ENDIF'
         VAL = 0
         'ENDIF'
      RETURN
      END
      'OUTFILE'   SETMAXAJH.FR
C     EDIT DATE   14JAN79  09:52
C     SOURCE FILE SETMAXAJH.FR
C     AUTHOR      A. J. HOWARD

      SUBROUTINE  SMLCV

      'INCLUDE'   BLDPOAJH.IN,
      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,

C     SET THE (NOMINAL) SIZE OF AN ARRAY

      CALL NDEFN
      IOTYPE = 0
      IF (BIAS (OPX) .EQ. 0) BIAS (OPX) = 1
      IF (DEFMOD .EQ. DPMODE) BIAS (OPX) = BIAS (OPX)*2
      MAXLCV = LC + BIAS (OPX)
      RETURN
      END
      'OUTFILE'   ADJLOCAJH.FR
C     EDIT DATE   14JAN79  09:52
C     SOURCE FILE ADJLOCAJH.FR
C     AUTHOR      A. J. HOWARD

      SUBROUTINE  ADJLOC (ADJUST)

C     ADJUST THE LOCATION COUNTER TO THE END OF THE ARRAY


      'INCLUDE'   LCONSTAJH.IN,
      INTEGER     ADJUST

      'IF' (ADJUST .NE. 0)
         CALL LIST (LBSS, ADJUST, 0)
         CALL SETLCI
         'ENDIF'
      RETURN
      END



\\\\\


SUBFILE: PVERBL.FS @15:58 23-MAY-1979 <055> (2665)
'HEAD'  PROCESS VERB LIST
C     EDIT DATE   31JAN79  07:33
C     SOURCE FILE PVERBLFTM.FS
C     AUTHOR      F. T. MICKEY
C     CLUSTER     3

      'OUTFILE'   PVERBLFTM.FR
N     OVERLAY     OLPVR

C
C     THE BASIC VERB LIST PROCESSING LOOP -- THE TRANSFERS
C     DECK HAS BEEN INCLUDED TO SIMPLIFY CONTROL TRANSFER.
C
      SUBROUTINE  PVERBL

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   LEVELSAJH.IN,
      'INCLUDE'   PSHCOMFTM.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFD.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   CPAREAJH.IN,
      'INCLUDE'   BLDPOAJH.IN,
      'INCLUDE'   RMCODES.IN,
      'INCLUDE'   IOCONFTM.IN,

      INTEGER     TS

      EXTERNAL    OLLCO, OLSLL, OLIO, OLLAB, OLRBR, OLPV2
      'EJECT'
      LOGICF = 1
      LEVELB = LLEVEL
      NESTX = 1
1     'DO'
         PX = 1
         OPX = 2
         DEFMOD = STDMD
         CALL SET (0, NAMEX, 260)   // 20*13
         OSTACK (1) = 1026
         RELPAS = 0
         FNLX = 0
         CMPFLG = 0
         CALL REGMAN (CLRSTA, 0, 0)
         CALL BLDPO
         IF (IOFLAG .NE. 0) GO TO 90
         OPX = OPX - 1
         IF (OPX .LT. 2) OPX = 2
         CALL OVLOD (OLPV2)
         GO TO (99, ^
                10, ^   // ,
                20, ^   // ;
                30, ^   // .
                40, ^   // :
                99, ^   // 'FOR'
                50, ^   // 'DO'
                50, ^   // 'WHILE'
                60, ^   // 'RBR'
               199, ^   // 'LBR'
                70, ^   // 'RETURN'
                80  ^   // $
                  ), NEXTOP
5        IF (OPX .GT. 2) ^
            CALL FAULTP (60)
         'END'


99    CALL FATAL (6)

199   CALL FAULTP (8)
      CALL SCAN (RBRACE, NINE, FOR)
      GO TO 5
      'EJECT'
C     RETURN TRANSFER
10    'IF' (STOAC .NE. 0)
         STOAC = 0
         'IF' (IAND (OSTACK (OPX - 1), 63) .EQ. FOR)
            CALL OVLOD (OLSLL)
            CALL SETLL
            'ENDIF'
         'ELSE'
         CALL PVR2 (2, TS)        // SUBROUTINE CALL
         'ENDIF'
      GO TO 5


C     RELATION CONTROL
20    CALL PVR2 (2, TS)           // SUBROUTINE CALL
      'IF' (NESTX .NE. 1)
         CALL OVLOD (OLLCO)
         CALL LCOMP (3)           // CLOSE SIDE
         'ELSE'
         CALL FAULTP (63)         // EXTRA ;
         'ENDIF'
      GO TO 5


C     TRANSFER
30    'IF' (NAMEX (OPX) .EQ. 0)
         CALL PVR2 (1, TS)        // LOOK FOR ERRORS
         IF (TS .NE. 0) GO TO 1   // ERRORS
         RETURN
         'ENDIF'
      IF (CFLAG .NE. 0) CALL FAULTP (64)
      NEXTX = OPX
      CALL GENT (2)               // GENERATE JMP
      'IF' (NESTX .NE. 1)
         CALL OVLOD (OLLCO)
         CALL LCOMP (3)           // CLOSE SIDE
         'ENDIF'
      GO TO 5
'EJECT'
C     CONDITIONAL OR LABEL
40    'IF' (CMPFLG .NE. 0)
         CALL OVLOD (OLLCO)
         CALL LCOMP (2)           // CONDITIONAL STATEMENT
         'ELSE'
         CALL OVLOD (OLLAB)
         CALL LABEL
         'ENDIF'
      GO TO 5


C     SET WHILE,   'DO', 'WHILE'
50    CALL PVR2 (3, TS)
      GO TO 5

C     GEN EXIT ('RBR')
60    CALL PVR2 (2, TS)           // SUBROUTINE CALL
      CALL OVLOD (OLRBR)
      CALL PRBR
      GO TO 5


C     DO RETURN
70    IF (NAMEX (OPX) .NE. 0) CALL FAULTP (50)
      CALL BLDPO                  // GET RETURN VALUE IF THERE IS ONE
      CALL OVLOD (OLPV2)
      CALL PVR2 (4, TS)           // RETURN CODE
      'IF' (TS .NE. 0)
         CALL OVLOD (OLLCO)
         CALL LCOMP (3)           // CLOSE SIDE IF PERIOD
         'ENDIF'
      IF (NEXTOP .EQ. RBRACE) GO TO 60
      GO TO 5

C     DO CRUTCH
80    CALL CRUSYM
      GO TO 5


C     I/O PROCESSING
90    IOFLAG = 0
      CALL OVLOD (OLIO)
      CALL IO
      GO TO 5
      END
      'OUTFILE'   PVERB2FTM.FR
N     OVERLAY     OLPV2

      SUBROUTINE  PVR2 (INDEX, FLAG)
      INTEGER     INDEX, FLAG

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   CODE1FTM.IN,
      'INCLUDE'   LEVELSAJH.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   STKDEFC.IN,
      'INCLUDE'   CPAREAJH.IN,
      'INCLUDE'   SRCDFSFTM.IN,
      'INCLUDE'   BRACEFTM.IN,
      'INCLUDE'   BLDPOAJH.IN,
      'INCLUDE'   FAULTSFTM.IN,
      'INCLUDE'   OPINXJHP.IN,
      'INCLUDE'   RMCODES.IN,

      INTEGER     TS

      FLAG = 0
      GO TO (100, 10, 50, 70), INDEX
      'EJECT'
C     LOGIC EXIT -- INCLUDES HALT AND FAULT 12
100   LEVELB = LLEVEL
      'IF' (NESTX .NE. 1)
         EXFLT = 0
         'DOLOOP' I = 2, NESTX
            EXFLT = EXFLT + 3 - CNLSID (I-1)
            'END'
         CALL SET (59, SOURCE, EXFLT)        // ;
         CALL SET (46, SOURCE (EXFLT+1), 4)  // .
         SRCEND = EXFLT + 3
         CALL FAULTP (25)
         J = 1
         FLAG = 1
         'ELSE'
         'IF' (BRACEX .GT. 1)
            EXFLT = BRACEX - 1
            CALL SET (96, SOURCE, EXFLT)        // 'RBR'
            CALL SET (46, SOURCE (BRACEX), 4)   // .
            SRCEND = EXFLT + 4
            CALL FAULTP (12)
            J = 1
            FLAG = 1
            'ELSE'
            CALL WRBLOK
            J = SRCEND
            'ENDIF'
         'ENDIF'
      RETURN


C     RETURN TRANSFER
10    'IF' (NAMEX (OPX) .NE. 0 .AND. STOAC .EQ. 0)
         'IF' (LOCFLG (OPX) .NE. 0)
            IF (SUBX (OPX) .NE. 0) ^
               CALL FAULTP (31)
            CALL BLDBLK (BIAS (OPX), WF6)
            CALL BLDBLK (NAMEX (OPX), WF7)
            'ELSE'
            IF (CFLAG .NE. 0) ^
               CALL FAULTP (64)
            CALL GENT (1)  // GENERATE JSR
            'ENDIF'
         'ENDIF'
      NEXTX = OPX
      STOAC = 0
      RETURN
'EJECT'
C     SET WHILE,   'DO', 'WHILE'
50    LOOPF (LSX) = NEXTOP
      'IF' (NEXTOP .EQ. DOOP)
         CALL DEFTL (TLI)
         CALL REGMAN (CLRACV, 0, 0)
         CALL SET (0, FLSAVE, 6)
         WHSTRT (LSX) = TLI
         TLI = TLI + 1
         WHLOW (LSX) = - (NESTX + 1)
         BSTACK (BRACEX) = 0
         'IF' (BRACEX .EQ. 9)
            CALL FAULTP (59)
            'ELSE'
            BRACEX = BRACEX + 1
            'ENDIF'
         'ENDIF'
      LSX = LSX + 1
      RETURN


C     DO RETURN
70    OPX = OPX - 1
      NEXTX = OPX
      'IF' (NAMEX (NEXTX) .NE. 0)
C        RETURN A VALUE
         CALL MSTAK (NEXTX, NEXTX+2)
         CALL SETUP (LDAINX, NEXTX)
         CALL GEN (-1, NEXTX, -2)
         CALL GEN (COM + 1, NEXTX, NEXTX)
         CALL GEN (-1, -2, -2)
         'ENDIF'
      'DO'
         'WHILE' (NEXTOP .EQ. COMMA)
            CALL ADVAN
            IF (NAMEX (OPX) .NE. 0) CALL FAULTP (67)
            'END'
C     FIND PROCEDURE BRACE
      'FOR' (TS = BRACEX - 1; TS .GT. 0; TS = TS - 1)
         'IF' (BSTACK (TS) .GT. 0)
C           GENERATE EXIT CODE
            'IF' (NEXTOP .EQ. PERIOD)
               CALL BLDBLK (96, WF4)      // RTS
               IF (NESTX .NE. 1) FLAG = 1
               'ELSE'
               'IF' (NEXTOP .NE. RBRACE .OR. TS .NE. BRACEX - 1)
                  CALL FAULTP (67)
                  'ENDIF'
               STOAC = 1
               RETURN
               'ENDIF'
            'ELSE'
            'END'
            CALL FAULTP (67)
            'ENDIF'
      STOAC = 0
      RETURN
      END
      'OUTFILE'   GENTAJH.FR

      SUBROUTINE  GENT (FUNC)

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   GENCOMFTM.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   STKDEFC.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   BRACEFTM.IN,
      'INCLUDE'   OPINXJHP.IN,
      'INCLUDE'   RMCODES.IN,
      'INCLUDE'   REGSJHP.IN,
      'INCLUDE'   LABCOMFTM.IN,
      'INCLUDE'   CODE1FTM.IN,

      INTEGER     FUNC
      INTEGER     TS, RET, OPTS, JMPX, JMPWF, JMPOP, JMPB
      LOGICAL     NLTEST

      JMPX = NAMEX (OPX)
      JMPB = BIAS (OPX)
      JMPOP = 108           // NOMINAL JMP@
      GO TO (10, 30), FUNC
      'EJECT'
C     GENERATE JSR

10    'IF' (SUBX (OPX) .NE. 0 .OR. NLTEST (JMPX, PBIT))
         IF (JMPX .EQ. NULLX .OR. NLTEST (JMPX, PBIT)) JMPOP = 76
C        'LOC' A [I + K] -> CT1
         CALL REGMAN (CTFREE, TS, 2)       // WILL NEED 2 CT WORDS
         STATUS (TS) = -1
         TS = TS + 1                       // USE +1 FOR ADDRESS
         LOCFLG (OPX) = 1                  // NEED THE ADDRESS
         ASSIGN 11 TO RET
         GO TO 15
11       TS = TS - 1
         STATUS (TS) = 0
         CALL BLDOP (169, WF5, JMPOP, NULLX, WF7) // LDAIM JMP@
         CALL BLDOP (133, WF5, 1, REGS (TS), WF7) // STAZP
         JMPB = 1
         JMPX = REGS (TS)
         'ENDIF'
      CALL GENER (SAVCAL)
      CALL BLDOP (32, WF8, JMPB, JMPX, WF7)       // JSR
      CALL SET (0, FLSAVE, 6)
      CALL REGMAN (CLRACV, 0, 0)
      RETURN

15    TOPX = OPX + 1
      CALL CLRSTK (TOPX)
      NAMEX (TOPX) = REGS (TS)
      MODE (TOPX) = DPMODE
      STATUS (TS) = -1
      CALL SETUP (STAINX, TOPX)
      MODE (OPX) = DPMODE
      CALL SETUP (LDAINX, OPX)
      OPTS = NEXTOP
      NEXTOP = COMMA
      CALL GEN (ARROW, OPX, TOPX)
      IF (ACTHI .NE. 0) STATUS (ACTHI) = 0
      IF (ACTLO .NE. 0) STATUS (ACTLO) = 0
      ACTHI = 0
      ACTLO = 0
      STATUS (TS) = 0
      NEXTOP = OPTS
      GO TO RET
      'EJECT'
C     GENERATE JMP

30    'IF' (SUBX (OPX) .EQ. 0)
         JMPWF = WF7
         'IF' (NLTEST (JMPX, PBIT))
            IF (JMPB .NE. 0) GO TO 31   // USE SUBSCRIPTED CODE FOR P[K]
            'ELSE'
            JMPOP =  76    // JMP
C           LOOK FOR LOCAL JUMP
            'IF' (SPARFL .NE. 0)
               'DOLOOP' LLX = 1, 10
                  'IF' (LOCNLX (LLX) .EQ. JMPX)
C                    DEFINED LOCAL
                     JMPWF = WF9
                     JMPX  = LOCTLI (LLX)
                     'BREAK'
                     'ENDIF'
                  'IF' (LOCNLX (LLX) .EQ. 0)
C                    NO IN LIST YET, MAYBE LATER
C                    SET USE BIT IF IT TURNS OUT EXTERNAL
                     CALL NLSET (JMPX, USEBIT)
                     TL (TLI) = -JMPX
                     JMPWF = WF9
                     JMPX  = TLI
                     TLI = TLI + 1
                     'BREAK'
                     'ENDIF'
                  'END'
               'ENDIF'
            'ENDIF'
         CALL BLDOP (JMPOP, WF8, JMPB, JMPX, JMPWF)
         'ELSE'
         'IF' (JMPX .EQ. NULLX)
            IF (SUBXM (OPX) .EQ. SPMODE) CALL FAULTP (42)
            'IF' (NLTEST (JMPX, PBIT))
               NAMEX (OPX) = SUBX (OPX)
               MODE  (OPX) = SUBXM (OPX)
               SUBX  (OPX) = 0
               GO TO 31
               'ENDIF'
            CALL REGMAN (SAVREG, AREG, TS)
            JMPX = SUBX (OPX)
            'ELSE'
C           A [I + K] -> CTX
31          CALL REGMAN (CTFREE, TS, 1)
            ASSIGN 32 TO RET
            GO TO 15
32          JMPX = REGS (TS)
            JMPB = 0
            'ENDIF'
         CALL BLDOP (JMPOP, WF8, JMPB, JMPX, WF7) // JMP @
         'ENDIF'
      RETURN
      END



\\\\\


SUBFILE: PASS2A.FS @15:58 23-MAY-1979 <055> (509)
'HEAD'  PASS 2
C     EDIT DATE   09DEC78  15:15
C     SOURCE FILE PASS2AJH.FS
C     AUTHOR      A. J. HOWARD
C     CLUSTER     4

      'OUTFILE'   PASS2AJH.FR
N     OVERLAY     OLPS2

      SUBROUTINE  PASS2

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   LCFUNCAJH.IN,
      'INCLUDE'   XNAMEAJH.IN,

      INTEGER     IERR
      EXTERNAL    DEFLIT, OLPNA, OLOBJ
      LOGICAL     NLTEST

      CALL RBOTH  (DATALC)
      CALL NLSCAN (DEFLIT, NLX)
      CALL RBOTH  (CODE)
      CALL WRBLOK
      XNX = XNX - 2
      'IF' (XNX .GT. 0)
         'DOLOOP' I = 1, XNX, 2
            IF (NLTEST (XNAME (I), USEBIT)) ^
               CALL NLSET (XNAME (I+1), USEBIT)
            'END'
         'ENDIF'
      CALL OVLOD (OLPNA)
      CALL PNAMEL
      CALL OVLOD (OLOBJ)
      CALL PNCHO
      CALL QUIT
      RETURN
      END
      'OUTFILE'   DEFLITAJH.FR

      SUBROUTINE  DEFLIT

      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   WFLAGSJHP.IN,

      INTEGER     NUM
      EXTERNAL    NLOPS
      LOGICAL     NLTEST

      'IF' (NLOPS (DFINED, NLX) .EQ. 0)
         'IF' (NLTEST (NLX, CBIT) .AND. NLTEST (NLX, USEBIT))
            FNLX = NLX
            CALL NDEFN
            NUM = NLOPS (CVALUE, NLX)
            CALL BLDBLK (NUM, WF1)
            'IF' (NLTEST (NLX, DPBIT))
               CALL BLDBLK (ISHFT (NUM, -8), WF1)
               'ENDIF'
            'ENDIF'
         'ENDIF'
      RETURN
      END
      'OUTFILE'   QUITAJH.FR

      SUBROUTINE  QUIT

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   CODE1FTM.IN,
      'INCLUDE'   CTRLAJH.IN,
      'INCLUDE'   PRTCOMFTM.IN,
      'INCLUDE'   SSNAMES.IN,P

      'IF' (FLTCNT .EQ. 0)
         CALL EST ('NO', LBUF, 5, 6)
         'ELSE'
         CALL ESP (FLTCNT, LBUF, 1, 6)
         'ENDIF'
      CALL EST ('ERROR(S), COMPILATION COMPLETE', LBUF, 8, 37)
      CALL WRLIN (CO, LBUF, 38)
      CALL SGLPRT
      IF (PRINTF .NE. 0 .AND. IAND (PGECNT, 1) .NE. 0)CALL NPAGE
P     CALL SPOOL (LO, IERR)
      CALL DELETE (SS,  SCR1)
      CALL DELETE (SS2, SCR2)
      RETURN
      END



\\\\\


SUBFILE: CRUTCH.FS @15:58 23-MAY-1979 <055> (2922)
'HEAD'  CRUTCH SYMBOLIC
C     EDIT DATE   11DEC78  16:01
C     SOURCE FILE CRUTCHJHP.FS
C     AUTHOR      J.H.PERINE
C     CLUSTER     5

      'OUTFILE' CRDATAJHP.FR

      BLOCK DATA

      'INCLUDE' CRUCOMJHP.IN,P

C     IMPLIED ADDRESS INSTRUCTIONS
      DATA  IMPLID / 'BRK ',  0,'CLC ', 24,'CLD ',216,'CLI ', 88,^
                     'CLV ',184,'DEX ',202,'DEY ',136,'INX ',232,^
                     'INY ',200,'NOP ',234,'PHA ', 72,'PHP ',  8,^
                     'PLA ',104,'PLP ', 40,'RTI ', 64,'RTS ', 96,^
                     'SEC ', 56,'SED ',248,'SEI ',120,'TAX ',170,^
                     'TAY ',168,'TYA ',152,'TSX ',186,'TXA ',138,^
                     'TXS ',154 /
      DATA  NIMPLI / 75 /

C           RELATIVE ADDRESS INSTRUCTIONS (BRANCH)
      DATA  RELTIV / 'BCC ',144,'BCS ',176,'BEQ ',240,'BMI ', 48,^
                     'BNE ',208,'BPL ', 16,'BVC ', 80,'BVS ',112 /
      DATA  NRELTI / 24 /

C           GROUP 1 INSTRUCTIONS - ADDRESSING MODES COMPUTED
      DATA  GROUP1 / 'ADC ', 97,'AND ', 33,'CMP ',193,'EOR ', 65,^
                     'LDA ',161,'ORA ',  1,'SBC ',225,'STA ',129 /
      DATA  NGROUP / 24 /
      DATA  STAX   / 22 /

C           OTHER INSTRUCTIONS - OP CODES BY ADDRESSING MODE
C                   IMM  ZP   ZPX  ZPY  AB   ABX  ABY  IND  AREG
      DATA  OTHERS /^
            'ASL ',  -1,   6,  22,  -1,  14,  30,  -1,  -1,  10,^
            'BIT ',  -1,  36,  -1,  -1,  44,  -1,  -1,  -1,  -1,^
            'CPX ', 224, 228,  -1,  -1, 236,  -1,  -1,  -1,  -1,^
            'CPY ', 192, 196,  -1,  -1, 204,  -1,  -1,  -1,  -1,^
            'DEC ',  -1, 198, 214,  -1, 206, 222,  -1,  -1,  -1,^
            'INC ',  -1, 230, 246,  -1, 238, 254,  -1,  -1,  -1,^
            'JMP ',  -1,  -1,  -1,  -1,  76,  -1,  -1, 108,  -1,^
            'JSR ',  -1,  -1,  -1,  -1,  32,  -1,  -1,  -1,  -1,^
            'LDX ', 162, 166,  -1, 182, 174,  -1, 190,  -1,  -1,^
            'LDY ', 160, 164, 180,  -1, 172, 188,  -1,  -1,  -1,^
            'LSR ',  -1,  70,  86,  -1,  78,  94,  -1,  -1,  74,^
            'ROL ',  -1,  38,  54,  -1,  46,  62,  -1,  -1,  42,^
            'ROR ',  -1, 102, 118,  -1, 110, 126,  -1,  -1, 106,^
            'STX ',  -1, 134,  -1, 150, 142,  -1,  -1,  -1,  -1,^
            'STY ',  -1, 132, 148,  -1, 140,  -1,  -1,  -1,  -1 /
      DATA  NOTHER / 165 /

      END
      'OUTFILE' CRUTCHJHP.FR

C     ROOT DRIVER FOR CRUSYM OVERLAY

      SUBROUTINE  CRUSYM

      'INCLUDE'   CRUCOMJHP.IN,
      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   STKDEFA.IN,

      INTEGER     IERR

      EXTERNAL    OLCRU

C     CHECK INITIAL ERROR
      IF (NAMEX (OPX).NE.0) CALL FAULTP (50)
      CALL OVLOD (OLCRU)
      CALL OCRUSY
      'IF' ( CSWFA .GT. 0 )
         CALL BLDOP (CSOW, CSWFA, CSOFF, CSNLX, CSWFB)
         'ELSE'
         CALL FAULTP (-CSWFA)
         IF (CSWFA .NE. -22) ^
            CALL SCAN (SEMIC, 0, 0)
         'ENDIF'
      NEXTOP = COMMA
      RETURN
      END
      'OUTFILE' OCRUCHJHP.FR
N     OVERLAY OLCRU

C     NAME     CRUSYM

C     PURPOSE  COMPILE SINGLE MACHINE INSTRUCTIONS FOR THE MOS6502
C              INPUT DESCRIPTION:
C                 OP   = OP CODE (ALWAYS 3 LETTERS)
C                 N    = UNSCRIPTED NAME (OPTIONAL)
C                 +-C  = CONSTANT EXPRESSION (OPTIONAL)
C                 AREG = ACCUMULATOR RESERVED NAME
C                 INDX = XREG OR YREG FOR INDEXING

C              FORMATS            ADDRESSING MODES
C                 $OP;               IMPLIED
C                 $OP, AREG;         IMPLIED
C                 $OP, N+-C;         RELATIVE, ZP, OR ABS
C                 $OP, >N+-C;        IMMEDIATE, LEFT HALF
C                 $OP, <N+-C;        IMMEDIATE, RIGHT HALF
C                 $OP, =C;           IMMEDIATE, CONSTANT (<256)
C                 $OP, N+-C, INDX;   ZP OR ABS, INDEXED
C                 $OP, @N+-C;        INDIRECT (JMP ONLY)
C                 $OP, @N+-C, INDX;  INDIRECT, INDEXED BY XREG OR YREG

C     CALL     CALL CRUSYM

      SUBROUTINE OCRUSY

      'INCLUDE' CRUCOMJHP.IN,
      'INCLUDE' LOGOSAJH.IN,
      'INCLUDE' OPERSAJH.IN,
      'INCLUDE' REGSJHP.IN,
      'INCLUDE' NLISTCFTM.IN,
      'INCLUDE' NLARAYFTM.IN,
      'INCLUDE' WFLAGSJHP.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE' SRCDFSFTM.IN,
      'INCLUDE' PRTCOMFTM.IN,

      INTEGER  ABSFLG
      INTEGER  AFLG
X     INTEGER  CSDEB
      INTEGER  CSOP (2)
      INTEGER  CSOPX
      INTEGER  G1MODE (16)
      INTEGER  IMMFLG
      INTEGER  INDFLG
      INTEGER  OPTION
      INTEGER  OTHRMO (9)
      INTEGER  TS
      INTEGER  XFLG
      INTEGER  YFLG
      INTEGER  ZPFLG

C     EXTERNALS
X     INTEGER  CLOCN
      INTEGER  NLOPS
      INTEGER  OPSRCH
      LOGICAL  NLTEST, ZPTST


C     TABLES 'G1MODE' AND 'OTHRMO' CONTAIN THE VALID ADDRESSING MODE
C     COMBINATIONS FOR THEIR INSTRUCTIONS, FORMED BY ADDING UP VALUES
C     FOR THE VARIOUS OPTIONS:
C        INDIRECT    1
C        IMMEDIATE   2 (>) OR 128 (=) OR 256 (<)
C        XREG        4
C        YREG        8
C        ZERO PAGE  16
C        ABSOLUTE   32
C        AREG       64

C           MODE CALCULATION TABLE FOR 'GROUP1' INSTRUCTIONS
      DATA  G1MODE / 21,  0, 16,  0,  2,  0, 32,  0,^
                     25,  0, 20, 24, 40,  0, 36,  0 /

C           MODE CALCULATION TABLE FOR 'OTHER' INSTRUCTIONS
      DATA  OTHRMO /  2, 16, 20, 24, 32, 36, 40, 33, 64 /

      'EJECT'
C     GET OP CODE & INITIALIZE
      CALL FNZS
      CALL PCHAR (CSOP, 1, SYMBOL)
      CALL FNZS
      CALL PCHAR (CSOP, 2, SYMBOL)
      CALL FNZS
      CALL PCHAR (CSOP, 3, SYMBOL)
      CALL FNZS
      CALL PCHAR (CSOP, 4, BLANK)
      INDFLG = 0
      IMMFLG = 0
      XFLG = 0
      YFLG = 0
      ZPFLG = 0
      ABSFLG = 0
      AFLG = 0
      CSWFA = WF4
      CSWFB = 0
      CSOFF = 0
      CSNLX = 0
C     PARSE THE STATEMENT PLEASE
      IF ( PSYMB .EQ. SEMIC ) GO TO 1000
X     CSDEB = 1
      IF ( PSYMB .NE. COMMA ) GO TO 2000
      CALL PEEK
      'IF' ( PEEKS .EQ. ATSIGN )
         INDFLG = 1
         CALL FNZS
         'ELSE'
         'IF' ( PEEKS .EQ. GTR )
            IMMFLG = 2
            CALL FNZS
            'ELSE'
            'IF' ( PEEKS .EQ. EQUAL )
               IMMFLG = 128
               CALL FNZS
               'ELSE'
               'IF' ( PEEKS .EQ. LESS )
                  IMMFLG = 256
                  CALL FNZS
                  'ENDIF'
               'ENDIF'
            'ENDIF'
         'ENDIF'
C     LOOK FOR N+-C CONSTRUCTION
      CALL ADVAN
      CSNLX = NAMEX (OPX)
      'IF' ( CSNLX .EQ. 0 )
C        NO NAME OR NUMBER
         'IF' ( NEXTOP .EQ. SEMIC )
            GO TO 1000
            'ENDIF'
         GO TO 500
         'ENDIF'
C     HAVE SOMETHING
C     CHECK FOR AREG
      'IF' (NLTEST (CSNLX, REGBIT))
C        REGISTER NAME - ONLY AREG ALLOWED HERE
         'IF' (NLOPS (REGNUM, CSNLX) .EQ. AREG)
            AFLG = 64
            CSNLX = NULLX
            GO TO 600
            'ENDIF'
X        CSDEB = 3
         GO TO 3000
         'ENDIF'
C     CHECK CONSTANT
      'IF' (NLTEST (CSNLX, CBIT))
         CSOFF = NLOPS (CVALUE, CSNLX)
         CSNLX = NULLX
         'ELSE'
         IF ( IMMFLG .EQ. 128 ) GO TO 3000
         CSWFB = WF7
C        CHECK FOR ZERO PAGE NAME
         'IF' ( ZPTST (CSNLX, 0))
            ZPFLG = 16
            'ELSE'
            ABSFLG = 32
            'ENDIF'
         'ENDIF'
500   'IF' ( NEXTOP .GE. PLUS )
C        GET CONSTANT EXPRESSION
         J = J - 1
         NAMEX (OPX) = 0
         CALL NEXP
         TS = NAMEX (OPX)
         'IF' (TS .EQ. 0)
            CSWFA = -11
            RETURN
            'ENDIF'
         'IF' (.NOT. NLTEST (TS, CBIT))
            CSWFA = -11
            RETURN
            'ENDIF'
         CSOFF = CSOFF + NLOPS (CVALUE, TS)
         'ENDIF'
C     SEE IF JUST HAVE CONSTANT - SET AS ZP OR ABS IF SO
      'IF' ( ZPFLG + ABSFLG .EQ. 0 )
         'IF' ( CSOFF .GE. 0 .AND. CSOFF .LT. 256 )
            ZPFLG = 16
            'ELSE'
            ABSFLG = 32
            'ENDIF'
         'ENDIF'
'EJECT'
C     LOOK FOR INDEXING
600   IF ( NEXTOP .EQ. SEMIC ) GO TO 1000
X     CSDEB = 4
      IF ( NEXTOP .NE. COMMA ) GO TO 3000
      CALL ADVAN
      NLX = NAMEX (OPX)
X     CSDEB = 5
      IF ( NEXTOP .NE. SEMIC ) GO TO 3000
      IF ( NLX .EQ. 0 ) GO TO 1000
X     CSDEB = 6
      IF (.NOT. NLTEST (NLX, REGBIT)) GO TO 3000
C     HAVE REGISTER NAME
      TS = NLOPS (REGNUM, NLX)
      'IF' ( TS .EQ. XREG )
         XFLG = 4
         'ELSE'
         'IF' ( TS .EQ. YREG )
            YFLG = 8
            'ELSE'
X           CSDEB = 7
            GO TO 3000
            'ENDIF'
         'ENDIF'

C     HAVE BASICALLY PARSED THE CONSTRUCTION

1000  OPTION = INDFLG+IMMFLG+XFLG+YFLG+ZPFLG+ABSFLG+AFLG
C     SEARCH FOR OP CODE
      CSOPX = OPSRCH (CSOP, IMPLID, NIMPLI, 3)
X     CSDEB = 8
      IF ( CSOPX .GT. 0 ) GO TO 4000
      CSOPX = OPSRCH (CSOP, RELTIV, NRELTI, 3)
X     CSDEB = 9
      IF ( CSOPX .GT. 0 ) GO TO 5000
C     RESET TO HANDLE POSSIBLE IMMEDIATE
      IF ( IMMFLG .NE. 0 ) OPTION=INDFLG+2+XFLG+YFLG+AFLG
      CSOPX = OPSRCH (CSOP, GROUP1, NGROUP, 3)
X     CSDEB = 10
      IF ( CSOPX .GT. 0 ) GO TO 6000
      CSOPX = OPSRCH (CSOP, OTHERS, NOTHER, 11)
X     CSDEB = 11
      IF ( CSOPX .GT. 0 ) GO TO 7000
C     UNKNOWN OP CODE
      CSWFA = -27
X     CALL EST (CSOP, LBUF, 1, 4)
X     CALL SGLPRT
      RETURN

C     FAULT PROCESSING

C     MISSING SEMICOLON
2000  CSWFA = -22
X     CALL ESP (CSDEB, LBUF, 1, 6)
X     CALL ESP (PSYMB, LBUF, 9, 14)
X     CALL ESP (NEXTOP, LBUF, 17, 22)
X     CALL SGLPRT
      RETURN

C     ILLEGAL CRUTCH CONSTRUCTION OF SOME SORT
3000  CSWFA = -75
X     CALL ESP (CSDEB, LBUF, 1, 6)
X     CALL ESP (OPTION, LBUF, 9, 14)
X     CALL ESP (CSOPX, LBUF, 17, 22)
X     CALL ESP (NEXTOP, LBUF, 25, 30)
X     CALL SGLPRT
      RETURN
      'EJECT'
C     CONSTRUCT INSTRUCTIONS

C     IMPLIED ADDRESSING
4000  IF ( OPTION .NE. 0 ) GO TO 3000
      CSOW = IMPLID (CSOPX+2)
      GO TO 8000

C     RELATIVE ADDRESSING
5000  TS = INDFLG + IMMFLG + XFLG + YFLG + AFLG
      IF ( TS .NE. 0 ) GO TO 3000
      CSOW = RELTIV (CSOPX+2)
      CSWFA = WF5
      CSWFB = WF7
      GO TO 8000

C     GROUP 1 INSTRUCTIONS - CHECK LEGAL MODE
6000  DO 6010 TS=1,16
      IF ( OPTION .EQ. G1MODE (TS) ) GO TO 6020
6010  CONTINUE
C     INVALID OPTION
      GO TO 3000

C     LOOKS OK
6020  'IF' ( ABSFLG .NE. 0 )
C        2 BYTE ADDRESS
         CSWFA = WF8
         'ELSE'
C        1 BYTE ADDRESS
         CSWFA = WF5
         'ENDIF'
C     CHECK FOR ZP,Y - USE ABS,Y
      IF ( TS .EQ. 12 ) TS=13
      CSOW = GROUP1 (CSOPX+2) + ISHFT (TS-1, 1)
C     CHECK STA IMMEDIATE - SPECIAL NONO
      IF ( CSOPX .EQ. STAX .AND. IMMFLG .NE. 0 ) GO TO 3000
      GO TO 7500

C     OTHER INSTRUCTIONS - SLOG IT OUT
7000  DO 7010 TS=1,9
      IF ( OPTION .EQ. OTHRMO(TS) ) GO TO 7020
7010  CONTINUE
C     CHECK FOR INDIRECT ZP - MAKE INDIRECT ABS
      'IF' ( OPTION .EQ. 17 )
         TS = 8
         GO TO 7020
         'ENDIF'
C     INVALID OPTION
X     CSDEB = 12
      GO TO 3000

C     PICK OUT OP CODE
7020  CSOW = OTHERS (CSOPX+1+TS)
X     CSDEB = 13
      IF ( CSOW .LT. 0 ) GO TO 3000
C     SET UP WORD FLAGS
X     CSDEB = 14
      CSWFA = WF5
      IF ( AFLG .NE. 0 ) CSWFA = WF4
      IF ( INDFLG .NE. 0 .OR. ABSFLG .NE. 0 ) CSWFA = WF8
C     SET UP WF IF HAVE IMMEDIATE
7500  IF ( IMMFLG .EQ. 0 ) GOTO 8000
      CSWFA = WF5
      'IF' ( IMMFLG .EQ. 2 )
         CSWFB = 13
         'ELSE'
         CSWFB = 12
         'ENDIF'
      GO TO 8010

C     BUILD THE INSTRUCTION
8000  IF ( CSNLX .EQ. 0 ) CSNLX = NULLX
8010  IF ( CSWFB .EQ. 0 ) CSWFA = 4
      CRUCNT = CRUCNT + 1
      RETURN
      END
      'OUTFILE' OPSRCHJHP.FR

C     NAME     OPSRCH
C     MODULE#

C     PURPOSE  SEARCH A TABLE FOR AN OP CODE (2 WORDS)

C     CALL     VALUE = OPSRCH (NAME, TABLE, SIZE, STEP)
C                 VALUE = TABLE INDEX IF FOUND
C                       = 0 IF NOT FOUND

      INTEGER FUNCTION OPSRCH (NAME, TABLE, SIZE, STEP)

      INTEGER  NAME(2), SIZE, TABLE(SIZE), STEP, I

      OPSRCH = 0
      DO 10 I=1,SIZE,STEP
      IF (NAME(1) .EQ. TABLE(I) .AND. NAME(2) .EQ. TABLE(I+1))GOTO 20
10    CONTINUE
      RETURN
20    OPSRCH = I
      RETURN
      END



\\\\\


SUBFILE: IOFTM.FS @15:58 23-MAY-1979 <055> (1496)
'HEAD'  INPUT/OUTPUT PROCESSING
C     EDIT DATE   12DEC78  10:53
C     SOURCE FILE IOFTM.FS
C     AUTHOR      F. T. MICKEY
C     CLUSTER     6

      'OUTFILE' IOFTM.FR
N     OVERLAY OLIO

      SUBROUTINE IO

      'INCLUDE' LOGOSAJH.IN,
      'INCLUDE' IOCONFTM.IN,
      'INCLUDE' NLISTCFTM.IN,
      'INCLUDE'   NLNAMEFTM.IN,
      'INCLUDE' SRCXDFFTM.IN,
      'INCLUDE' BLDPOAJH.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   STKDEFC.IN,
      'INCLUDE'   STKDEFD.IN,
      'INCLUDE' OPERSAJH.IN,
      'INCLUDE' LEVELSAJH.IN,
      'INCLUDE' CPAREAJH.IN,
      'INCLUDE' RMCODES.IN,
      'INCLUDE' GENCOMFTM.IN,
      'INCLUDE' OPINXJHP.IN,
      'INCLUDE' WFLAGSJHP.IN,
      'INCLUDE' BRACEFTM.IN,
      'INCLUDE' REGSJHP.IN,

      INTEGER     IOTS, IOSTOP, RET, OPTS
      INTEGER     IOSUFX (11), TS, IPKT(3), OPKT (3)
      INTEGER     ENTNUM, NLOPS, SNMLST, GCHAR
      LOGICAL     NLTEST

N     DATA  IPKT     / 1353,'.BUF'/        // '<5>I.BUF'
N     DATA  OPKT     / 1349,'.BUF'/        // '<5>E.BUF'
P     DATA  IPKT     /18693,'.BUF'/        // '<5>I.BUF'
P     DATA  OPKT     /17669,'.BUF'/        // '<5>E.BUF'

      DATA  IOSUFX   /'SP', ^      // SP      1
                      'DP', ^      // DP      2
                      'ST', ^      // STRING  3
                      'HX', ^      // HEX     4
                      'UN', ^      // N:      5
                      'LN', ^      // ;   ^N  6
                      'EJ', ^      // ^       7
                      'MC', ^      // <=      8
                      'PC', ^      // ->N     9
                      'TA', ^      // =N     10
                      'BL'/        // :N     11
      'EJECT'
C     SET UP FOR INPUT OR OUTPUT
      'IF' (OP .EQ. GTR)
         IOSTOP = LESS
         IONX = 4
         PACKET = -1          // SIGNAL INPUT PACKET
         'ELSE'
         IOSTOP = GTR
         IONX = 1
         PACKET = -2          // SIGNAL OUTPUT PACKET
         'ENDIF'
      LEVELB = ILEVEL
      'IF' (NEXTOP .EQ. SEMIC)
         PACKET = NAMEX (OPX)
         CALL BLDPO
         'ENDIF'
      'IF' (NAMEX (OPX) .NE. 0)
         IOSTEP = 5
         ASSIGN 5 TO RET
         GO TO 100
5        CONTINUE
         'ENDIF'
      QVALUE = 0
      RELPAS = 0
C     PROCESS IO
      'DO'
         SCOUNT = 0
         CALL PEEK
         'IF' (PEEKS .EQ. ARROW .OR. PEEKS .EQ. LESSEQ)
            CALL FNZS
            IOSTEP = PEEKS - 14
            GOTO 10
            'ENDIF'
         'IF' (PEEKS .EQ. EQUAL)
            IOSTEP = 10
            GOTO 10
            'ENDIF'
         'IF' (PEEKS .EQ. COLON)
            IOSTEP = 11
10          CALL FNZS
            'ELSE'
            'IF' (PEEKS .EQ. UPARO ^
                  .OR. PEEKS .EQ. IOSTOP ^
                  .OR. PEEKS .EQ. SEMIC ^
                  .OR. PEEKS .EQ. COMMA)
               CALL ADVAN
               GOTO 20
               'ENDIF'
C           FARG
            IOTYPE = 0
            QVALUE = 0
            DEFMOD = 0
            SCOUNT = 0
            STOAC = 0
            CALL BLDPO
            NEXTX = OPX
            OSTACK (NEXTX) = IAND (OSTACK (NEXTX), -64) + COMMA
            IOTS = NAMEX (NEXTX)
            IF (NLTEST (IOTS, REGBIT)) ^
               CALL GENER (SAVCAL)   // REGISTER, DEFINE TEMP
            IF (LOCFLG (NEXTX) .NE. 0) CALL FAULTP (66)
            IF (NEXTOP .NE. COLON) CALL FAULTP (33)
            'IF' (IOTYPE .NE. 0)
               IOSTEP = IOTYPE + 3 - ST
               'ELSE'
               IF (NLOPS (DFINED, NLX) .EQ. 0) ^
                   CALL NLSET (NLX, IOBIT)
               'IF' (SMSEEN .EQ. 0 ^
                     .AND. (QVALUE .NE. 0 ^
                     .OR. NLTEST (NLX, STRBIT)))
                  QVALUE = 0
                  IOSTEP = 3
                  'ELSE'
                  IOSTEP = MODE (NEXTX) + 1
                  'ENDIF'
               'ENDIF'
            OPX = OPX + 1
            'ENDIF'
15       CALL BLDPO
         CALL DUMST ('IO  ')
         NEXTX = OPX - 1
         'IF' (IOSTEP .EQ. 3)
            'IF' (NAMEX (NEXTX) .EQ. 0)
               NUMBER = SCOUNT
               NAMEX (NEXTX) = ENTNUM (NLX)
               'ENDIF'
            'ELSE'
            IF (IOSTEP .EQ. 6 .AND. NAMEX (OPX) .EQ. 0) ^
               IOSTEP = 7
            'ENDIF'
         SCOUNT = 0
         ASSIGN 20 TO RET
         GO TO 100
20       'WHILE' (NEXTOP .NE. IOSTOP)
            'IF' (NEXTOP .EQ. SEMIC)
               IOSTEP = 6
               NUMBER = 1
               CALL CLRSTK (OPX)
               NAMEX (OPX) = ENTNUM (NLX)
               ASSIGN 25 TO RET
               GO TO 100
25             CONTINUE
               'ELSE'
               'IF' (NEXTOP .EQ. UPARO)
                  IOSTEP = 6
                  GOTO 15
                  'ENDIF'
               'ENDIF'
            'END'
      CALL REGMAN (CLRSTA, 0, 0)
      NEXTOP = COMMA
      LEVELB = LLEVEL
      OPX = 2
      RETURN
      'EJECT'
100   'IF' (IOSTEP .LT. 5)
         TS = 3       // 'SP' 'DP' 'ST' 'HEX'
         'ELSE'
         TS = 2
         OPX = OPX + 1
         'ENDIF'
      IF (IOSTEP .EQ. 7) GO TO 120   // ^
110   CALL CLRSTK (OPX)
      NAMEX (OPX) = FLS (TS)
      NEXTX = OPX - 1
      LOCFLG (NEXTX) = 1
      MODE (OPX) = DPMODE
      MODE (NEXTX) = DPMODE
      ACTHI = 0
      ACTLO = 0
      CALL REGMAN (CLRSTA, 0, 0)
      CALL SETUP (LDAINX, NEXTX)
      CALL SETUP (STAINX, OPX)
      OPTS = NEXTOP
      NEXTOP = COMMA
      CALL GEN (ARROW, NEXTX, OPX)
      NEXTOP = OPTS
      'IF' (TS .EQ. 3)
         TS = 2
         OPX = OPX - 1
         GO TO 110
         'ENDIF'
      'IF' (TS .EQ. 2)
120      TS = 1
         NEXTX = OPX - 1
         CALL CLRSTK (NEXTX)
         'IF' (PACKET .LT. 0)
            'IF' (PACKET .EQ. -1)       // INPUT DEFAULT PACKET
               CALL MOVE (IPKT, NAME, 3)
               'ELSE'
               CALL MOVE (OPKT, NAME, 3)
               'ENDIF'
            NAMEX (NEXTX) = SNMLST (NLX)
            'ELSE'
            NAMEX (NEXTX) = PACKET
            'ENDIF'
         GO TO 110
         'ENDIF'
      CALL MOVE (IONAME (IONX), NAME, 3)
      NAME (4) = IOSUFX (IOSTEP)
      TS = SNMLST (TS)
      CALL BLDOP (32, WF8, 0, TS, WF7)   // JSR
      OPX = OPX - 1
      GO TO RET
      END




\\\\\


SUBFILE: LABELF.FS @15:58 23-MAY-1979 <055> (1028)
'HEAD'  LABEL PROCESSING
C     EDIT DATE   09DEC78  15:43
C     SOURCE FILE LABELFTM.FS
C     AUTHOR      F. T. MICKEY
C     CLUSTER     7

      'OUTFILE'   LABELDATA.FR
      BLOCK DATA

      'INCLUDE'   LABCOMFTM.IN,P

      DATA         LTLI /0/
      END
      'OUTFILE'   LABELFTM.FR
N     OVERLAY     OLLAB

      SUBROUTINE  LABEL
C
C     PROCESSES LABEL DEFINITIONS, CHECKING FOR "LABEL::"
C     ENTRY POINT DEFINITIONS
C

      'INCLUDE' LOGOSAJH.IN,
      'INCLUDE' OPERSAJH.IN,
      'INCLUDE' NLISTCFTM.IN,
      'INCLUDE' BLDPOAJH.IN,
      'INCLUDE' BRACEFTM.IN,
      'INCLUDE' RMCODES.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE' LCFUNCAJH.IN,
      'INCLUDE' LCONSTAJH.IN,
      'INCLUDE' LABCOMFTM.IN,
      'INCLUDE'   CODE1FTM.IN,

      INTEGER APAREN
      'EJECT'
C     LOOK FOR LOCAL LABELS
      'IF' (SPARFL .EQ. 0)
C        NOT IN A LOCAL AREA
         CALL NDEFN
         'ELSE'
C        THIS IS A LOCAL AREA
C        REDIRECT ANY PRIOR REFERENCES
         'DOLOOP' LLX = LTLI, TLI
            'IF' (TL (LLX) .EQ. -NLX)
               TL (LLX) = LC
               CALL DEFTL (LLX)
               'ENDIF'
            'END'
C        PUT THE DEFINITION IN THE LIST
         CALL LIST (LLNAME, NLX, 0)
         LLX = 1
         'DO'
            'IF' (LOCNLX (LLX) .EQ. NLX)
               CALL FAULTP (18)  // IT'S BEEN DEFINED BEFORE
               'BREAK'
               'ENDIF'
            'IF' (LOCNLX (LLX) .EQ. 0)
               LOCNLX (LLX) = NLX
               LOCTLI (LLX) = TLI
               CALL DEFTL (TLI)
               TLI = TLI + 1
               'BREAK'
               'ENDIF'
            LLX = LLX + 1
            IF (LLX .GT. 10) CALL FAULTP (55)
            'WHILE' (LLX .LE. 10)
               'END'
         'ENDIF'
      LABNLX = NLX
      CALL REGMAN (CLRACV, 0, 0)
      CALL SET (0, FLSAVE, 6)
      DEFMOD = STDMD
C     LOOK FOR "LABEL::" ENTRY POINT
      CALL PEEK
      'IF' (PEEKS .EQ. COLON)
         CALL FNZS
         IF (SPARFL .EQ. 0) ^
            CALL NLSET (NLX, EPBIT)
         'ENDIF'
      'EJECT'
      'IF' (STOAC .NE. 0)
         STOAC = 0
         CALL FAULTP (8)
         CALL SCAN (RBRACE, NINE, FOR)
         RETURN
         'ENDIF'
      CALL PEEK
      'IF' (PEEKS .EQ. LBRACE)
C        SET SUBROUTINE ENTRY
         SUBENT (SELX) = 0
         CALL STSLX (1)       // STEP SELX
         CALL PLBR         // PROCESS LEFT BRACE (1)
C        END SET SUBROUTINE ENTRY
         RETURN
         'ENDIF'
      'IF' (PEEKS .EQ. LPAREN)
         CALL PEEKFO
         IF (PEEKS .GE. SP) CALL PEEKFO
         IF (PEEKS .EQ. COMMA) GO TO 1000
         'IF' (PEEKS .EQ. RPAREN)
            CALL PEEKA
            'IF' (PEEKS .EQ. LBRACE)
               GOTO 1000
               'ENDIF'
            'ENDIF'
         'ENDIF'
      RETURN
'EJECT'
C     SUBROUTINE F PARAM

1000  IF (SPARFL .NE. 0) CALL FAULTP (54)
      CALL STSLX (1)       // STEP SELX
      PARFLG = 1
      FUNCNT = FUNCNT + 1
      PARSAV = -1
      'DO'
         'WHILE' (PARFLG .NE. 0 .AND. NEXTOP .NE. RPAREN)
            DEFMOD = STDMD
            CALL ADVAN
            ARGSIZ = 2
            'IF' (NEXTOP .GE. SP)
               DEFMOD = NEXTOP - SP
               CALL ADVAN
               'ENDIF'
            NLX = NAMEX (OPX)
C           PROCESS PARAMETER
            CALL RBOTH (NOUNLC)
            CALL NDEFN
            CALL NLSET (NLX, PBIT)
            SUBENT (SELX) = NLX
            IF (PARSAV .EQ. -1) PARSAV = NLX
            MAXLCV = MAXLCV + ARGSIZ
            CALL LIST (LBSS, ARGSIZ, 0)
            CALL SETLCI
            CALL STSLX (2)    // BUMP SELX
            'END'
      PARFLG = 0
      CALL RBOTH (CODE)
      SUBENT (SELX) = PARCNT
      SELX = SELX + 1
      SPARFL = PARCNT
      CALL ADVAN
      CALL PLBR
C     SAVE THE CURRENT TRANSFER LIST INDEX FOR LOCAL LABEL PROCESSING
      LTLI = TLI
      CALL SET (0, LOCNLX, 10)
      RETURN
      END
      'OUTFILE' DEFTLFTM.FR
C     SUBROUTINE DEFTL
C
C     MAKE AN ENTRY IN THE TRANSFER LIST
C
      SUBROUTINE DEFTL (TLX)

      'INCLUDE' LOGOSAJH.IN,
      'INCLUDE' CODE1FTM.IN,
      'INCLUDE' LCONSTAJH.IN,

      INTEGER TLX

      TL (TLX) = LC
      CALL LIST (LTLNA, TLX, 0)
      RETURN
      END



\\\\\


SUBFILE: LCOMPA.FS @15:58 23-MAY-1979 <055> (1429)
'HEAD'  COMPARISON ROUTINES
C     EDIT DATE   09DEC78  15:43
C     SOURCE FILE LCOMPAJH.FS
C     AUTHOR      A.  J. HOWARD
C     CLUSTER     8

      'OUTFILE'   LCOMPAJH.FR
C     EDIT DATE   09DEC78  15:43
C     SOURCE FILE LCOMPAJH.FS
C     AUTHOR      A.  J. HOWARD

N     OVERLAY     OLLCO

      SUBROUTINE  LCOMP (FUNC)

      INTEGER     FUNC
C
C     1 PROCESS RELATIONAL OPERATOR  = # < <= >= >
C     2 FINISH CONDITIONAL STATEMENT NEXT OP :
C     3 CLOSE SIDE  NEXT OP . OR ;
C
      INTEGER     ILBRET, SCRET     // INTERNAL SUBROUTINE RETURNS
      INTEGER     OPTS1,  LDROP
      INTEGER     TS, BROKTS
      INTEGER     COMPOP (6)
      INTEGER     JMP

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   BLDPOAJH.IN,
      'INCLUDE'   BRACEFTM.IN,
      'INCLUDE'   CODE1FTM.IN,
      'INCLUDE'   CPAREAJH.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   OPINXJHP.IN,
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   GENCOMFTM.IN,
      'INCLUDE'   RMCODES.IN,

      DATA        JMP   /76/
      DATA        COMPOP / 18, 17, 22, 21, 20, 19/

      GO TO (100, 200, 300), FUNC
      'EJECT'
C     PROCESS A RELATIONAL OPERATOR

100   CALL GENER (SETX)
      'IF' (CNLSID (NESTX) .EQ. 0)
         CNLSID (NESTX) = 1
         CNLEND (NESTX) = 0
         PLEVEL = PLEVEL + 1
         STOPS (PLEVEL) = CLX
         'ENDIF'
      CMPFLG = CMPFLG + 1
      OPTS1 = NEXTOP
      CALL SSBUF
      LDROP = 0                   // LEVEL DROP
      ILB = 0
C
C     PEEK PAST ANY )S
      'DO'
         'WHILE' (OPTS1 .EQ. RPAREN)
            LDROP = LDROP + 1
            CALL PEEKFO       // PEEK FOR OPERATOR
            OPTS1 = PEEKS
            'END'
      'IF' (OPTS1 .EQ. OROP)
         TRUEF = 1
         OP = OP - EQUAL
         OP = COMPOP (OP + 1)
         'ELSE'
         TRUEF = -1
         'IF' (OPTS1 .EQ. ANDOP)
            PLEVEL = PLEVEL + 1
            STOPS (PLEVEL) = CLX
            'ELSE'
            'IF' (OPTS1 .EQ. COLON)
               PNESTX = NESTX + 1
               'ELSE'
               CALL FAULTP (34)
               'ENDIF'
            'ENDIF'
         'ENDIF'
      'IF' (OPTS1 .EQ. COLON)
C        CHECK SPECIAL CASES
         CALL PEEKFO
         'IF' (PEEKS .EQ. PERIOD ^
            .OR. PEEKS .EQ. SEMIC ^
            .OR. PEEKS .EQ. RBRACE)
C           : LABEL.  OR  : SUBROUTINE;  OR  : SUBROUTINE 'END'
            ILB = 1
            TRUEF = 1
            OP = OP - EQUAL
            OP = COMPOP (OP + 1)
            'ENDIF'
         'ENDIF'
'EJECT'
C     SET CODE SEQUENCE
      CALL MSTAK (NEXTX, NEXTX+2)
      CALL SETUP (LDAINX, NEXTX)
      CALL SETUP (LDAINX, TOPX)
      CALL GEN (-1, NEXTX, -2)
      CALL GEN (OP, NEXTX, TOPX)
      CALL GEN (-1, -2, -2)
      CALL GENER (OUT)

      'IF' (OPTS1 .EQ. COLON)
         CALL REGLEV (1)      // SET CURRENT CONTENTS
         'ENDIF'
      PLEVEL = PLEVEL - LDROP
      ASSIGN 110 TO ILBRET
      IF (OPTS1 .EQ. OROP) GO TO 500
      GO TO 550
110   PLEVEL = PLEVEL + LDROP
      IF (OPTS1 .EQ. ANDOP) PLEVEL = PLEVEL - 1
      CALL REGMAN (CLRSTA, 0, 0)
      RETURN
      'EJECT'
C     CONDITIONAL STATEMENT TERMINATION

200   'IF' (RELCNT + 1 .NE. CMPFLG)
         CALL REGLEV (1)
         CALL FAULTP (36)
         'ENDIF'
      CMPFLG = 0
      RELCNT = 0
      STOAC  = 0
      'IF' (NESTX .EQ. 9)
         CALL FAULTP (37)
         'ELSE'
         NESTX = NESTX + 1
         'IF' (LOOPF (LSX-1) .EQ. WHILE)
C
C           MOVE THE CONDITIONAL INDEXES TO THE BRACE INDEXES
C
            LSX = LSX - 1
            WHLOW (LSX - 1) = SELX
            TS = STOPS (PLEVEL) + 1
            'DOLOOP' TS = TS, CLX
               L = CPLOC (TS - 1)
               'IF' (L .LT. 0)
                  CPLOC (TS - 1) = 0
                  SUBENT (SELX) = -L
                  CALL STSLX (2)         // BUMP SELX
                  'ENDIF'
               'END'
            WHHIGH (LSX - 1) = SELX
            CNLSID (NESTX - 1) = 2
            CNLTLI (NESTX - 1) = 0
            CNLEND (NESTX - 1) = 0
            GO TO 300         // CLEAR OUT THE REST OF THE CONDITIONAL
            'ENDIF'
         'ENDIF'
      RETURN
      'EJECT'
C     CLOSE SIDE OF A CONDITIONAL

300   TNESTX = NESTX - 1
      'IF' (CNLSID (TNESTX) .LT. 2)

C        TRUE SIDE

         CNLSID (TNESTX) = 2
         CALL REGLEV (2)
         'IF' (NEXTOP .EQ. SEMIC)
            CALL PEEK
            'IF' (PEEKS .NE. SEMIC)
               TS = TLI
               CNLTLI (TNESTX) = TS
               TLI = TLI + 1
               CALL BLDOP (JMP, WF8, 0, TS, WF9)
               'ENDIF'
            'ENDIF'
C
C        CHECK FALSE START IN RANGE OF FIRST BRANCH
C
         IF (CNLEND (TNESTX) + 129 .GE. LC) BROK = BROK + 1
         BRCT = BRCT + 1
         CNLEND (TNESTX) = NEXTOP
         ASSIGN 310 TO ILBRET
         GO TO 500           // FILL IN TRANSFERS TO FALSE
310      CONTINUE

C        FALSE SIDE

         'ELSE'
         NESTX = TNESTX
         PNESTX = NESTX
         IF (PNESTX .EQ. 1) CLX = 2
         CNLSID (NESTX) = 0
         TS = CNLTLI (NESTX)
         'IF' (TS .NE. 0)
            CNLTLI (NESTX) = 0
            CALL DEFTL (TS)
            'ENDIF'
         'IF' (CNLEND (NESTX) .EQ. SEMIC)
            CALL REGLEV (3)
            CALL SET (0, FLSAVE, 6)
            'ENDIF'
         PLEVEL = PLEVEL - 1
         'ENDIF'
      RETURN
      'EJECT'
C     FILL IN FALSE JUMPS

500   ASSIGN 510 TO SCRET
      'FOR' (I = STOPS (PLEVEL); I .LT. CLX; I = I + 1)
         L = -CPLOC (I)
         IF (L .GT. 0) GO TO 575
510      'END'
      GO TO ILBRET


C     FILL IN TRUE JUMPS

550   ASSIGN 560 TO SCRET
      'FOR' (I = STOPS (PLEVEL); I .LT. CLX; I = I + 1)
         L = CPLOC (I)
         IF (L .GT. 0) GO TO 575
560      'END'
      GO TO ILBRET

C     SET COMPARE

575   CALL DEFTL (L)
      CALL REGLEV (5)
      CALL SET (0, FLSAVE, 6)
      CPLOC (I) = 0
      GO TO SCRET
      END




\\\\\


SUBFILE: PNLAJH.FS @15:58 23-MAY-1979 <055> (2282)
      'HEAD'  PRINT NAME LIST
C     EDIT DATE   14JAN79  08:57
C     SOURCE FILE PNLAJH.FS
C     AUTHOR      A. J.HOWARD
C     CLUSTER     9

      'OUTFILE'      PNLAJH.FR
N     OVERLAY OLPNA
      SUBROUTINE  PNAMEL
C     EDIT DATE   14JAN79  08:57
C     SOURCE FILE PNLAJH.FR
C     AUTHOR      A. J.HOWARD

      'INCLUDE'   PNACOMAJH.IN,
      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   CPAREAJH.IN,
      'INCLUDE'   CTRLAJH.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   NLNAMEFTM.IN,
      'INCLUDE'   LCFUNCAJH.IN,
      'INCLUDE'   PRTCOMFTM.IN,

      INTEGER     HEAD1 (17), HEAD2 (2), HEAD3 (6), HEAD4 (6)
      INTEGER     HEAD5 (12), HEAD6 (6), HEAD7 (16), HEAD8 (17)
      INTEGER     TS
      INTEGER     PNNAME, PNENT, PNEXT, PNLOOP, NLCOMP, CLOCN

      EXTERNAL    PNNAME, PNENT, PNEXT, PNLOOP, NLCOMP
N     EXTERNAL    OLPN2

      DATA        HEAD1 / ' .....NAME....... ..LOC.... .TYPE.' /
      DATA        HEAD2 / ' :  ' /
      DATA        HEAD3 / 'ENTRY POINTS' /
      DATA        HEAD4 / 'EXTERNALS   ' /
      DATA        HEAD5 / 'NAMES       /      TEXT ' /
      DATA        HEAD6 / 'CC**""DDTTNN' /
      DATA        HEAD7 / 'USE COUNTS: REGISTER    , CRUTCH' /
      DATA        HEAD8 / '            BRANCHES    , IN RANGE' /
      'EJECT'
      IF (PRINTF .EQ. 0) RETURN
N     CALL OVLOD (OLPN2)
      CALL SGLPRT
      'DOLOOP' I = 1, 81, 40
         CALL EST (HEAD1, LBUF, I, I + 33)
         'END'
      CALL SGLPRT
      CALL SGLPRT
      CT = 0
      CALL NLSCAN (PNLOOP, NLX)
      'DOLOOP' I = 1, CT
         LIST (I) = I
         'END'
      'DOLOOP' I = 1, 6
         BITS (I, 2) = HEAD6 (I)
         'END'
      BITS (1, 1) = CBIT
      BITS (2, 1) = EPBIT
      BITS (3, 1) = STRBIT
      BITS (4, 1) = DPBIT
      BITS (5, 1) = TPLBIT
      BITS (6, 1) = USEBIT
      IF (CT .NE. 0) CALL SORT (LIST, CT, NAMES, NLCOMP)
      CALL PSEL (PNNAME, 0)
      CALL PSEL (PNENT, HEAD3)
      CALL PSEL (PNEXT, HEAD4)
      CALL EST (HEAD5,  LBUF, 1, 24)
      CALL ESP (NLENO,  LBUF, 1, 12)
      CALL ESP (NLSIZE, LBUF, 1, 17)
      CALL ESP (NTSTRT, LBUF, 1, 29)
      CALL SGLPRT
      CALL EST (HEAD7,  LBUF, 1, 32)
      CALL ESP (REGCNT, LBUF, 1, 24)
      CALL ESP (CRUCNT, LBUF, 1, 38)
      CALL SGLPRT
      CALL EST (HEAD8,  LBUF, 1, 34)
      CALL ESP (BRCT,   LBUF, 1, 24)
      CALL ESP (BROK,   LBUF, 1, 38)
      CALL SGLPRT
      'DOLOOP' I = 1, 14
         TS = LCTAB (I)
         'IF' (TS .NE. 0)
            CALL EHX (I, LBUF, 2, 3)
            CALL EST (HEAD2, LBUF, 4, 6)
            CALL EHX (TS, LBUF, 7, 10)
            'IF' (I .GT. COMLOC .AND. I .LT. ZREL)
               TS = CLOCN (CBTAB (I))
               CALL EST (NAME, LBUF, 13, 28)
               'ENDIF'
            CALL SGLPRT
            'ENDIF'
         'END'
      RETURN
      END
      'OUTFILE'   PNLOOPAJH.FR
      SUBROUTINE  PNLOOP
C     EDIT DATE   14JAN79  08:57
C     SOURCE FILE PNLOOPAJH.FR
C     AUTHOR      A. J. HOWARD

      'INCLUDE'   PNACOMAJH.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   NLARAYFTM.IN,
      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   CTRLAJH.IN,

      INTEGER     XPERID, TS, CLOCN
      INTEGER     GETTX, GCHAR
      LOGICAL     NLTEST, PNEQU
      DATA        XPERID   /46/

      IF (NLX .EQ. NULLX) RETURN
      TX = GETTX (NLX)
      TS = GCHAR (NTEXT (TX), 1)
      IF (IAND (TS, LOCALB) .NE. 0) RETURN
      TS = GCHAR (NTEXT (TX), 2)
      'IF' ((TS .LT. XA .AND. TS .NE. XPERID)  ^
               .OR.        ^
            (SNLPRT .NE. 0 ^
               .AND.       ^
            .NOT. NLTEST (NLX, EPBIT + USEBIT) ))
         'IF' (PNEQU (DUMMY))
            CT = CT + 1
            NAMES (CT) = NLX
            'ENDIF'
         'ELSE'
         CT = CT + 1
         NAMES (CT) = NLX
         'ENDIF'
      RETURN
      END
      'OUTFILE'   PSELAJH.FR
      SUBROUTINE  PSEL (SELECT, HEADER)
C     EDIT DATE   14JAN79  08:57
C     SOURCE FILE PSELAJH.FR
C     AUTHOR      A. J. HOWARD

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   PNACOMAJH.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   PRTCOMFTM.IN,
      INTEGER     HEADER (6), HEAD1 (2)
      DATA        HEAD1 / 'NO  ' /

      'IF' (HEADER (1) .NE. 0)
C        THERE IS A HEADING
         CALL EST (HEADER, LBUF, 1, 12)
         CALL SGLPRT
         CALL EST (HEAD1, LBUF, 1, 3)
         CALL EST (HEADER, LBUF, 4, 15)
         'ENDIF'
      K = 0
      'IF' (CT .NE. 0)
         'DOLOOP' J = 1, CT
            I = LIST (J)
            NLX = NAMES (I)
            CALL SELECT
            'END'
         'ENDIF'
      'IF' (K .NE. 0)
         CALL SGLPRT
         'ENDIF'
      CALL SGLPRT
      RETURN
      END
      'OUTFILE'   PNENTAJH.FR
      SUBROUTINE  PNENT
C     EDIT DATE   14JAN79  08:57
C     SOURCE FILE PNENTAJH.FR
C     AUTHOR      A. J. HOWARD

C     ENTER ENTRY POINT DEFINITIONS
      'INCLUDE'   NLISTCFTM.IN,
      INTEGER     DUMMY
      LOGICAL     NLTEST, PNEQU

      IF (NLTEST (NLX, EPBIT) .OR. PNEQU (DUMMY)) ^
         CALL PNNAME
      RETURN
      END
      'OUTFILE'   PNEXTAJH.FR
      SUBROUTINE  PNEXT
C     EDIT DATE   14JAN79  08:57
C     SOURCE FILE PNEXTAJH.FR
C     AUTHOR      A. J. HOWARD

C     ENTER EXTERNAL NAMES
      'INCLUDE'   NLISTCFTM.IN,
      INTEGER     DUMMY, NLOPS
      LOGICAL     NLTEST, PNEQU

      IF (.NOT. NLTEST (NLX, CBIT) ^
               .AND.   ^
          NLOPS (DFINED, NLX) .EQ. 0   ^
               .AND.   ^
          .NOT. PNEQU (DUMMY)) ^
         CALL PNNAME
      RETURN
      END
      'OUTFILE'   PNNAMEAJH.FR
N     OVERLAY     OLPN2

      SUBROUTINE  PNNAME
C     EDIT DATE   14JAN79  08:57
C     SOURCE FILE PNNAMEAJH.FR
C     AUTHOR      A. J. HOWARD

      INTEGER     ENBUF (20), XBLNKS, TS, NLTEMP, LTS
      INTEGER     CLOCN, NLOPS
      LOGICAL     NLTEST

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   PNACOMAJH.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   NLNAMEFTM.IN,
      'INCLUDE'   PRTCOMFTM.IN,
      'INCLUDE'   NLARAYFTM.IN,
      'INCLUDE'   XNAMEAJH.IN,

      INTEGER     HEAD1 (5), HEAD2 (5), HEAD3, HEAD4
      DATA        HEAD1 / ' DISP EXT ' /
      DATA        HEAD2 / ' NORM EXT ' /
      DATA        HEAD3 / ',,' /
      DATA        HEAD4 / ' :' /
      DATA        XBLNKS   / '  ' /
      'EJECT'
      CALL SET (XBLNKS, ENBUF, 20)
      TS = CLOCN (NLX)
      CALL EST (NAME, ENBUF, 2, 17)
      LTS = L
      'IF' (.NOT. NLTEST (NLX, CBIT) ^
             .AND. NLOPS (DFINED, NLX) .EQ. 0)
         'IF' (XNX .GT. 0)
            'DOLOOP' L = 1, XNX, 2
               'IF' (XNAME (L) .EQ. NLX)
                  'IF' (XNAME (L+1) .EQ. NLX)
                     'BREAK'
                     'ENDIF'
                  GO TO 100
                  'ENDIF'
               'IF' (XNAME (L+1) .EQ. NLX)
                  NLX = XNAME (L)
                  'IF' (NLOPS (DFINED, NLX) .EQ. 0)
                     'BREAK'
                     'ENDIF'
                  GO TO 100
                  'ENDIF'
               'END'
            'ENDIF'
         'IF' (NLTEST (NLX, EXDBIT))
            CALL EST (HEAD1, ENBUF, 18, 27)
            'ELSE'
            CALL EST (HEAD2, ENBUF, 18, 27)
            'ENDIF'
         'ELSE'
         'IF' (NLTEST (NLX, CBIT))
            CALL EHX (NLOPS (CVALUE, NLOPS (NAMLOC, NLX)), ^
                      ENBUF, 19, 22)
            'ELSE'
            CALL EHX (NLOPS (NAMLOC, NLX), ENBUF, 19, 22)
            CALL EST (HEAD3, ENBUF, 23, 23)
            CALL EHX (NLOPS (NLXLCI, NLX), ENBUF, 24, 25)
            'ENDIF'
         'ENDIF'
      'EJECT'
      NLTEMP = IEOR (NLIST (NLX), USEBIT)
      I = 28
      'DOLOOP' L = 1, 6
         'IF' (IAND (NLTEMP, BITS (L,1)) .NE. 0)
            'IF' (I .NE. 28)
               CALL EST (HEAD3, ENBUF, I, I)
               'ENDIF'
            I = I + 1
            CALL EST (BITS (L,2), ENBUF, I, I)
            I = I + 1
            'ENDIF'
         'END'
50    K = K + 1
      CALL MOVE (ENBUF, LBUF (20*K-19), 20)
      'IF' (K .GE. 3)
         CALL SGLPRT
         K = 0
         'ENDIF'
      L = LTS
      RETURN

100   TS = CLOCN (NLX)
      CALL EST (HEAD4, ENBUF, 18, 19)
      CALL EST (NAME, ENBUF, 20, 35)
      GO TO 50
      END
      'OUTFILE'   PNEQUAJH.FR
      LOGICAL FUNCTION PNEQU (DUMMY)
C     EDIT DATE   14JAN79  08:57
C     SOURCE FILE PNEQUAJH.FR
C     AUTHOR      A. J. HOWARD

      INTEGER     DUMMY, L, I
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   XNAMEAJH.IN,
      LOGICAL     NLTEST

      'IF' (XNX .GT. 0)
         'DOLOOP' L = 1, XNX, 2
            'IF' (XNAME (L+1) .EQ. NLX)
               PNEQU = NLTEST (XNAME (L), EPBIT)
               RETURN
               'ENDIF'
            'END'
         'ENDIF'
      PNEQU = .FALSE.
      RETURN
      END
      'OUTFILE'   NLCOMPAJH.FR
      INTEGER FUNCTION  NLCOMP (NAME1X, NAME2X)
C     EDIT DATE   14JAN79  08:57
C     SOURCE FILE NLCOMPAJH.FR
C     AUTHOR      A. J. HOWARD
C     MODULE      80.18
      INTEGER     GETTX, GCHAR

      INTEGER     NAME1X, NAME2X
      INTEGER     SCX, TS, L1, L2
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   NLARAYFTM.IN,

      TS = GETTX (NAME1X)
      L1 = GCHAR (NTEXT (TS), 1) + 1
      TX = GETTX (NAME2X)
      L2 = GCHAR (NTEXT (TX), 1) + 1
      'DOLOOP' SCX = 2, L1
         'IF' (SCX .GT. L2)
            NLCOMP = -1
            'BREAK'
            'ENDIF'
         NLCOMP = GCHAR (NTEXT (TS), SCX) - GCHAR (NTEXT (TX), SCX)
         'IF' (NLCOMP .NE. 0)
            RETURN
            'ENDIF'
         'END'
      NLCOMP = -1
      RETURN
      END




\\\\\


SUBFILE: OBJECT.FS @15:58 23-MAY-1979 <055> (4968)
'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
      CALL CLOSF (PI, ERRFLG)

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 RDSEQ  (SS2, OBFILE, 30, ERRFLG)
P     CALL DEVICE (OBFILE)    // SUBSTITUTE DEFAULT DEVICE IF NEEDED
      CALL OPENN  (BO, OBFILE, ERRFLG)

N     CALL OVLOD  (OLOB2)
N     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 DATE (BCARD (18))
      CALL TIME (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, ERRFLG)
      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)
         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)               // 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



\\\\\


SUBFILE: BRACES.FS @15:58 23-MAY-1979 <055> (2581)
'HEAD'  BRACE PROCESSING SUBROUTINES
C     EDIT DATE   09DEC78  16:43
C     SOURCE FILE BRACESFTM.FS
C     AUTHOR      F. T. MICKEY
C     CLUSTER     11

      'OUTFILE'   SETLLFTM.FR
N     OVERLAY     OLSLL
C
C     SET LIMITS FOR LOOP AND WHILE CONSTRUCTIONS
C
      SUBROUTINE  SETLL

      'INCLUDE' LOGOSAJH.IN,
      'INCLUDE' BRACEFTM.IN,
      'INCLUDE' CODE1FTM.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE' GENCOMFTM.IN,
      'INCLUDE' WFLAGSJHP.IN,
      'INCLUDE' NLISTCFTM.IN,
      'INCLUDE' OPERSAJH.IN,
      'INCLUDE' RMCODES.IN,
      'INCLUDE' BLDPOAJH.IN,
      'INCLUDE' OPINXJHP.IN,
      'INCLUDE' CPAREAJH.IN,

      INTEGER     INCTL, IOP, CLXTS, LIOPX, TESTTL
      INTEGER     CTS, TLTS, BRANCH, LOOPOP
      INTEGER     NLOPS    // EXTERNAL FUNCTION
      'EJECT'
      CALL REGLEV (1)                         // SET REG LEVEL
      LOOPT (LSX) = TLI
      INCTL = TLI
      TESTTL = TLI + 1
      TLI = TLI + 2
      CALL BLDOP (76, WF8, 0, TESTTL, WF9)    // JMP TO TEST
      CALL DEFTL (INCTL)                      // START OF INCREMENT CODE
      CALL REGMAN (CLRSTA, 0, 0)
      CALL REGMAN (CLRACV, 0, 0)
      CALL SET (0, FLSAVE, 6)

C     RECOVER LOOP INDEX
C
      LIOPX = OPX - 1
      NAMEX (LIOPX) = NAMEX (OPX + 3)
      MODE  (LIOPX) = MODE  (OPX + 3)
      CALL DUMST ('SLL ')

C     CHECK TYPE OF LOOP
C
      CALL PEEK
      'IF' (PEEKS .EQ. MINUS)

C        DECREMENTING LOOP
C
         CALL FNZS                           // EAT THE MINUS
         IOP = MINUS
         BRANCH = 144   // BCC FOR SINGLE PRECISION
         LOOPOP = GEQ
         'ELSE'

C        INCREMENTING LOOP
C
         IOP = PLUS
         BRANCH = 176   // BCS FOR SINGLE PRECISION
         LOOPOP = LESSEQ
         'ENDIF'


C     COMPILE INCREMENT VALUE
C
      CALL BLDPO

C     SETUP FOR LOOP INDEX INCREMENT
C
      CALL CLRSTK (OPX)
      NAMEX (OPX) = NAMEX (LIOPX)
      MODE  (OPX) = MODE  (LIOPX)
      TOPX = OPX - 1
      NEXTX = OPX
      'EJECT'
C     LOOK FOR SPECIAL CASES OF INCREMENT
C     NEXTX: LOOP INDEX
C     TOPX:  INCREMENT
C
      CALL GENER (SETX)
      CALL DUMST ('SLLI')
      'IF' (CFLAG .NE. 0)
         'IF' (NLOPS (CVALUE, OPTOPX) .EQ. 1)
            'IF' (IOP .EQ. PLUS)
C              CASE IS 'FOR' A -> B, 1, X'LBR'  -- USE INCREMENT
C
               IOP = UPARO
               BRANCH = 240          // BEQ
               'ELSE'
C              CASE IS 'FOR' A -> B, -1, X'LBR' -- USE DECREMENT
C
               IOP = DNARO
               'IF' (MODE (LIOPX) .EQ. SPMODE)
C                 LOAD THE LOOP INDEX
C
                  CALL SETUP (LDAINX, NEXTX)
                  CALL GEN (COM + 1, NEXTX, LIOPX)
C                 RESERVE TWO TRANSFER LIST LABELS
                  TLTS = TLI
                  TLI = TLI + 2
C                 CHECK FOR CASE 'FOR' A -> B, -1, 0'LBR'
C
                  OPX = OPX + 1
                  CALL ADVAN
                  'IF' (NEXTOP .EQ. LBRACE .AND. CFLAG .NE. 0)
                     IF (NLOPS (CVALUE, NAMEX (OPX)) .NE. 0)GO TO 50

C                    FOUND THE SPECIAL CASE,
C
                     CALL BLDOP (208, WF5, 0, TLTS, WF9)    // BNE IN
                     CALL BLDOP (76, WF8, 0, TLTS + 1, WF9) // JMP LOOPE
                     LOOPE (LSX) = TLTS + 1
                     CALL DEFTL (TLTS)        // IN:
C                    NOW DO DECREMENT, SETUP ALREADY DONE
                     CALL GEN (DNARO, LIOPX, NEXTX)
                     CALL DEFTL (TESTTL)      // TEST:
                     GO TO 100                // CLEAN UP AND EXIT
                     'ENDIF'
50                CALL STUFF    // UNDO THE ADVANCE
                  OPX = OPX - 1
                  CALL BLDOP (240, WF5, 0, TLTS, WF9)  // BEQ OUT
                  CALL GEN   (-2, TLTS, 0)             // SET INTBR
                  BRANCH = 0                           // TEST DONE
                  'ENDIF'
               'ENDIF'
            'ENDIF'
         'ENDIF'
      'EJECT'
C     GENERATE LOOP INCREMENT CODE
C
      CALL SETUP (LDAINX, NEXTX)
      'IF' (IOP .LE. MINUS)
C        DO ADD OR SUBTRACT, NEED STORE
C
         CALL SETUP (LDAINX, TOPX)
         CALL GEN   (IOP, NEXTX, TOPX)
         CALL GENER (OUT)
         CALL CLRSTK (OPX)
         NAMEX (OPX) = NAMEX (LIOPX)
         MODE  (OPX) = MODE  (LIOPX)
         CALL SETUP (STAINX, NEXTX)
         CALL GEN (-1, -2, LIOPX-2)
         CALL GEN   (ARROW, TOPX, NEXTX)
         CALL GEN (-1, -2, -2)
         'ELSE'
C        DO INCREMENT OR DECREMENT
C
         CALL GEN (IOP, LIOPX, NEXTX)
         'ENDIF'
      OPX = OPX - 1
      'IF' (MODE (LIOPX) .EQ. SPMODE)
C        ADDITIONAL END CONDITION CODE FOR SP LOOPS
C
         TLTS = TLI
         TLI = TLI + 1
         CALL ADVAN
         'IF' (NEXTOP .EQ. LBRACE .AND. CFLAG .NE. 0)
            CTS = NLOPS (CVALUE, NAMEX (OPX))
            'IF' (CTS .EQ. 0 .AND. IOP .EQ. MINUS)
C              CASE  'FOR' A -> B, -C, 0'ELSE'
C
               BRANCH = 176           // BCS IN
               GO TO 900
               'ENDIF'
            'IF' (CTS .EQ. 255 .AND. IOP .NE. MINUS)
               'IF' (IOP .EQ. UPARO)
C                 SPECIAL CODE FOR 'FOR' A -> B, 1, 255'LBR'
C
                  BRANCH = 208        // BNE IN
                  'ELSE'
                  BRANCH = 144        // BCC IN
                  'ENDIF'
               GO TO 900
               'ENDIF'
            'ENDIF'
         CALL STUFF                   // UNDO ADVANCE
         'IF' (BRANCH .NE. 0)
            CALL BLDOP (BRANCH, WF5, 0, TLTS, WF9)  // BCS/BCC LOOPE
            CALL GEN (-2, TLTS, 0)    // SET INTBR TO TLTS
            'ENDIF'
         'ENDIF'
      'EJECT'
      CALL REGLEV (3)                // RECOVER REG LEVEL
      CALL REGMAN (CLRSTA, 0, 0)
      CALL DEFTL (TESTTL)            // DEFINE THE TEST POINT
      CALL SET (0, FLSAVE, 6)
      CALL BLDPO                     // COMPILE THE SECOND LIMIT

C     NEXTX: LOOP INDEX
C     TOPX:  SECOND LIMIT
C
      TOPX = OPX - 1
      NEXTX = LIOPX
      CALL DUMST ('SLLX')
      CALL SETUP (LDAINX, NEXTX)
      CALL SETUP (LDAINX, TOPX)
      CLXTS = CLX
      ILB = 0
      TRUEF = -1
      CALL GEN (LOOPOP, NEXTX, TOPX)      // STANDARD CONDITIONAL CODE
      'FOR' (I = CLXTS; I .LT. CLX; I = I + 1)
         L = CPLOC (I)
         IF (L .LT. 0) ^
            LOOPE (LSX) = -L              // SAVE TO JUMP TO FALSE INDEX
         IF (L .GT. 0)  CALL DEFTL (L)     // BRANCHES INTO LOOP
         CPLOC (I) = 0
         'END'
      CLX = CLXTS
100   STOAC = 0
      LOOPF (LSX) = 0                     // THIS IS A LOOP BRACE
      LSX = LSX + 1
      OPX = 2
      BSTACK (BRACEX) = 0
      IF (NEXTOP .NE. LBRACE)CALL FAULTP (58)
      'IF' (BRACEX .LT. 9)
         BRACEX = BRACEX + 1
         'ELSE'
         CALL FAULTP (59)
         'ENDIF'
      RETURN

C     ALL TEST CODE GENERATED WITHOUT CALL TO GEN FOR <=, >= CODE
C
900   CALL BLDOP (BRANCH, WF5, 0, TESTTL, WF9)   // BCS/BNE/BCC
      CALL BLDOP (76,     WF8, 0, TLTS,    WF9)  // JMP LOOPE
      CALL DEFTL (TESTTL)                        // IN: TEST:
      LOOPE (LSX) = TLTS
      GO TO 100
      END
      'OUTFILE' STSLXFTM.FR
      SUBROUTINE STSLX (FUNC)

C     FUNC = 1   --   STEP SELX
C     FUNC = 2   --   BUMP SELX
C

      INTEGER FUNC

      'INCLUDE' BRACEFTM.IN,
      'INCLUDE' NLISTCFTM.IN,

      IF (FUNC .EQ. 1) PARCNT = 0
      SELX = SELX + 1
      'IF' (SELX .GT. 9)
         SELX = 9
         CALL FAULTP (52)
         'ELSE'
         PARCNT = PARCNT + PARFLG
         'ENDIF'
      IF (FUNC .EQ. 1) CALL ADVAN
      RETURN
      END
      'OUTFILE' PLBRFTM.FR

      SUBROUTINE PLBR

      'INCLUDE' BRACEFTM.IN,
      'INCLUDE' LOGOSAJH.IN,
      'INCLUDE' OPERSAJH.IN,
      'INCLUDE' NLISTCFTM.IN,
      'INCLUDE' WFLAGSJHP.IN,
      'INCLUDE' CODE1FTM.IN,

      BSTACK (BRACEX) = 1
      'IF' (PARCNT .NE. 0)
         NUMBER = (PARCNT * 2) - 1
         CALL BLDOP (160, WF5, NUMBER, NULLX, WF7)    // LDY =PARCNT
         CALL DEFTL (TLI)
         CALL SET (1, FLSAVE, PARCNT)
         CALL BLDOP (185, WF8, 0, FLS (1), WF7)       // LDA FL0,Y
         CALL BLDOP (153, WF8, 0, PARSAV, WF7)        // STA TEMP,Y
         CALL BLDBLK (136, WF4)                       // DEY
         CALL BLDOP (16, WF5, 0, TLI, WF9)            // BPL XXXTL
         TLI = TLI + 1
         'ENDIF'
      IF (NEXTOP .NE. LBRACE) CALL FAULTP (58)
      'IF' (BRACEX .GT. 9)
         CALL FAULTP (59)
         'ELSE'
         BRACEX = BRACEX + 1
         'ENDIF'
      RETURN
      END
      'OUTFILE'   PRBRFTM.FR
N     OVERLAY     OLRBR
      SUBROUTINE  PRBR

      'INCLUDE' LOGOSAJH.IN,
      'INCLUDE' WFLAGSJHP.IN,
      'INCLUDE' NLARAYFTM.IN,
      'INCLUDE' NLISTCFTM.IN,
      'INCLUDE' BRACEFTM.IN,
      'INCLUDE' RMCODES.IN,

      INTEGER     PLCTS, PLCLIM
      INTEGER     GCHAR, MODTXT


      BRACEX = BRACEX - 1
      'IF' (BRACEX .LT. 1)
         CALL FAULTP (14)
         BRACEX = 1
         'ELSE'
         L = BSTACK (BRACEX)
         'IF' (L .EQ. 0)

C           POST LOOP CONTROL
C
            LSX = LSX - 1
            PLCTS = LOOPT (LSX)
            CALL BLDOP (76, WF8, 0, PLCTS, WF9)  // JMP TO LOOPI/'DO'
            'IF' (LOOPF (LSX) .EQ. 0)            // LOOP RIGHT BRACE
               CALL DEFTL (LOOPE (LSX))
               'ELSE'
               'IF' (WHLOW (LSX) .GE. 0)         // WHILE RIGHT BRACE
                  SELX = WHLOW (LSX)
                  PLCLIM = WHHIGH (LSX) - 1
                  'DOLOOP' PLCTS = SELX, PLCLIM
                     CALL DEFTL (SUBENT (PLCTS))
                     'END'
                  'ENDIF'
               'ENDIF'
            CALL REGMAN (CLRACV, 0, 0)
            CALL SET (0, FLSAVE, 6)
            LOOPT (LSX) = 0
            LOOPE (LSX) = 0
            LOOPF (LSX) = 0
            'ELSE'
      'EJECT'
            'IF' (L .GT. 0)

C              FUNCTION AND SUBROUTINE TERMINATION
C
               SELX = SELX - 1
               'IF' (SELX .LT. 1)
                  SELX  = 1
                  CALL FAULTP (53)
                  'ELSE'
                  PARCNT = SUBENT (SELX)
                  SELXB = SELX - PARCNT
                  'IF' (PARCNT .NE. 0)
                     SPARFL = 0
                     'FOR' (K = SELXB; K .LT. SELX; K = K + 1)
                        NLX = SUBENT (K)
                        TX = MODTXT (NLX)
                        CALL PCHAR (NTEXT (TX), 1, ^
                          GCHAR (NTEXT (TX), 1) + LOCALB)
                        'END'
                     'ENDIF'
                  SELX = SELXB
                  'IF' (SELX .LT. 1)
                     SELX = 1
                     CALL FAULTP (53)
                     'ENDIF'
                  'ENDIF'
               CALL BLDBLK (96, WF4)    // RTS
               'ENDIF'
            'ENDIF'
         'ENDIF'
      RETURN
      END




\\\\\


SUBFILE: BPOLSH.FS @15:58 23-MAY-1979 <055> (4606)
'HEAD'  BUILD POLISH
C     EDIT DATE   07FEB79  08:23
C     SOURCE FILE BPOLSHAJH.FS
C     AUTHOR      A. J. HOWARD
C     CLUSTER     12

      'OUTFILE'   BLDPOAJH.FR
C     EDIT DATE   07FEB79  08:23
C     SOURCE FILE BLDPOAJH.FR
C     AUTHOR      A.J. HOWARD
C     CLUSTER     11

      SUBROUTINE  BLDPO

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   CTRLAJH.IN,
      'INCLUDE'   SRCDFSFTM.IN,

      EXTERNAL    OLCTL

      'DO'
         CALL BP
         'WHILE' (NEXTOP .EQ. CONTRL)
            CALL OVLOD (OLCTL)
            CTLUSE = 1
            CTLERR = 0
            CALL PCONT
            CTLUSE = 0
            IF (CTLERR .NE. 0) CALL FAULTP (CTLERR)
            IF (CONEND) RETURN
            'END'
      RETURN
      END
      'OUTFILE'   BPAJH.FR
C     EDIT DATE   07FEB79  08:23
C     SOURCE FILE BPAJH.FR
C     AUTHOR      A. J. HOWARD
C     CLUSTER     11

      SUBROUTINE  BP

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   BLDPOAJH.IN,
      'INCLUDE'   CPAREAJH.IN,
      'INCLUDE'   GENCOMFTM.IN,
      'INCLUDE'   LEVELSAJH.IN,
      'INCLUDE'   LCFUNCAJH.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   REGSJHP.IN,
      'INCLUDE'   SRCDFSFTM.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   STKDEFC.IN,
      'INCLUDE'   STKDEFD.IN,
      'INCLUDE'   BRACEFTM.IN,
      'INCLUDE'   OPINXJHP.IN,
      'INCLUDE'   IOCONFTM.IN,
      'INCLUDE'   RMCODES.IN,

      INTEGER     TS, ISOPX, GACT
      INTEGER     DECODE, NLOPS, ENTNUM
      INTEGER     BPRET         // RETURN FOR INTERNAL SUBROUTINES
      INTEGER     COP (2)       // TRANSFORM FOR AND, OR
      INTEGER     FSX, FSTACK (5), FOPX

      LOGICAL     NLTEST
      EXTERNAL    OLLCO

      DATA        COP      / 31, 33/
      DATA        FSX      /  0/
      'EJECT'

C     BUILD POLISH SUBROUTINE TO EVALUATE AN EXPRESSION

1     MSEEN = .FALSE.

C     NEXT PAIR
      'DO'
         SMSEEN = .FALSE.
         SMODE = 0
         OSTACK (OPX) = 0
C        RE ADVANCE
2        'DO'
            CALL ADVAN
25          IF (NEXTOP .EQ. CONTRL) RETURN
            'IF' (NEXTOP .EQ. TEMPL)
               CALL PEEK
               IF (LOGICF .NE. 0 .OR. PEEKS .NE. LBK) CALL FAULTP (49)
               TPFLAG = TPLBIT
               'NEXT'
               'ENDIF'
            'IF' (NEXTOP .EQ. ZRL)
               CALL PEEK
               IF (LOGICF .NE. 0 .OR. PEEKS .NE. LBRACE) ^
                  CALL FAULTP (68)
               ZFLAG = .TRUE.
               'NEXT'
               'ENDIF'
            'IF' (NEXTOP .GE. ST)
               IOTYPE = NEXTOP
               'NEXT'
               'ENDIF'
            'WHILE' (NEXTOP .GE. SP)
               SMODE = NEXTOP
               DEFMOD = SMODE - SP
               SMSEEN = .TRUE.
               MSEEN  = .TRUE.
               'IF' (NAMEX (OPX) .NE. 0)
                  CALL FAULTP (16)
                  'ENDIF'
               'END'
      'EJECT'
C        LOOK FOR UNARY + OR -
         'IF' (NAMEX (OPX) .EQ. 0 ^
               .AND. ISHFT (OSTACK (OPX-1), -10) .LE. 10)
            IF (NEXTOP .EQ. PLUS) GOTO 2
            IF (NEXTOP .EQ. MINUS) NEXTOP = NEG
            'ENDIF'
         'IF' (SMODE .NE. 0)
            SMODE = 0
            TS = DEFMOD
            'ELSE'
            NLX = NAMEX (OPX)
            'IF' (NLX .EQ. 0)
               TS = STDMD
               'ELSE'
               'IF' (NLTEST (NLX, CBIT) ^
                     .AND. .NOT. NLTEST (NLX, DPBIT) ^
                     .AND. DEFMOD .NE. DPMODE)
                  TS = DEFMOD
                  'ELSE'
                  TS = NLOPS (NLMODE, NLX)
                  'ENDIF'
               'ENDIF'
            'ENDIF'
         MODE (OPX) = TS
         'IF' (LOCFLG (OPX) .NE. 0)
            MODE (OPX) = DPMODE
            'ENDIF'
         CALL DUMST ('BP2 ')
         OPX = OPX + 1
      'EJECT'
C
C        TEST LEVEL
C
100      LEVEL = DECODE (1, NEXTOP)
         'IF' (LEVEL .NE. 2)
C           NOT OPEN LEVEL
            ASSIGN 101 TO BPRET
            GO TO 700              // CALL CHECK CONSTANT LOC
101         GO TO 800              // CALL CHECK SPECIAL LEVELS
102         GO TO 900              // CALL POP STACK
103         'IF' (LEVEL .EQ. 4)
C              CLOSE LEVEL, GET ACTION
               TS = DECODE (2, NEXTOP)
               GO TO (  3,   9,   9, 200, 300), TS
               'ENDIF'
C           NEXT OP IS OPEN LEVEL
            'ELSE'
            'IF' (NEXTOP .EQ. LBK)
               CALL PEEK
               IF (PEEKS .EQ. RBK) CALL FAULTP (41)
               'ENDIF'
            'IF' (NEXTOP .EQ. LPAREN)
               PLEVEL = PLEVEL + 1
               STOPS (PLEVEL) = CLX
C              IS THIS A FUNCTION CALL?
               'IF' (NAMEX (OPX-1) .NE. 0)
                  IF (LEVELB .EQ. LLEVEL .OR. LEVELB .EQ. ILEVEL) ^
                     GO TO 400
                  CALL FAULTP (4)    // ILLEGAL FUNCTION CALL
                  NAMEX (OPX-1) = 0
                  CALL SCAN (RPAREN, 0, 0)
                  PLEVEL = PLEVEL - 1
                  GO TO 100
                  'ENDIF'
               'ELSE'
               'IF' (NEXTOP .EQ. LOC)
                  OPX = OPX - 1
                  CALL ADVAN
                  MODE (OPX) = DPMODE
                  LOCFLG (OPX) = 1
                  GO TO 25
                  'ENDIF'
               'ENDIF'
            'ENDIF'
C
C        STACK OPERATOR/OPERAND
         IF (NEXTOP .EQ. ARROW) LEVEL = 22
         OSTACK (OPX-1) = ^
               ISHFT (LEVEL, 10) + ISHFT (CFLAG, -3) + NEXTOP
         'END'
C
C     BP EXIT
C
3     'IF' (IAND (OSTACK (OPX-2), 63) .EQ. LBK)
         CALL FAULTP (60)
         OPX = OPX - 1
         'ENDIF'
      IF (FSX .NE. 0) GO TO 410
      RETURN

9     CALL  FATAL (6)
      RETURN
      'EJECT'
C     PROCESS RIGHT PAREN

200   'IF' (IAND (OSTACK (OPX-2), 63) .NE. LPAREN)
         CALL FAULTP (62)
         'ELSE'
         PLEVEL = PLEVEL - 1
         IF (IAND (OSTACK (OPX-2), FUNBIT) .NE. 0) GO TO 3
         OPX = OPX - 1
         ISOPX = OPX + 20
         CALL MSTAK (OPX, OPX - 1)
         NAMEX (OPX) = 0
         OSTACK (OPX-1) = OSTACK (OPX)
         'DOLOOP' I = 1, NRREGS
            'IF' (STATUS (I) .GE. OPX .AND. STATUS (I) .LE. STKSIZ ^
                  .OR. STATUS (I) .GE. ISOPX)
               STATUS (I) = STATUS (I) - 1
               'ENDIF'
            'END'
         'ENDIF'

C     FUNCTION RETURN
250   LEVEL = CFLAG
      CALL ADVAN
      CALL DUMST ('BPFR')
      CFLAG = LEVEL
      IF (NAMEX (OPX) .NE. 0 .OR. DECODE (1, NEXTOP) .EQ. 2) ^
         CALL FAULTP (3)
      GO TO 100
      'EJECT'
C     PROCESS RIGHT BRACKET

300   'IF' (IAND (OSTACK (OPX-2), 63) .NE. LBK)
         CALL FAULTP (61)
         'ELSE'
         OPX = OPX - 1
         NEXTX = OPX
         'IF' (SUBX (OPX) .NE. 0 .OR. BIAS (OPX) .NE. 0 ^
               .OR. LOCFLG (OPX) .NE. 0)
            CALL GENER (SETX)
            'IF' (LOGICF .EQ. 0)
               CALL FAULTP (11)
               'ELSE'
               CALL SETUP (LDAINX, OPX)
               CALL GEN (COM+1, OPX, OPX)
               CALL REGMAN (CLRACX, AREG, 0)
               TS = MODE (OPX)           // PRESERVE THE MODE
               CALL CLRSTK (OPX)
               NAMEX (OPX) = REGS (AREG)
               MODE (OPX) = TS
               STATUS (AREG) = OPX
               'ENDIF'
            'ENDIF'
         BIAS (OPX-1) = SBIAS
         SBIAS = 0
         OPTOPX = NAMEX (OPX)
         'IF' (OPTOPX .NE. 0)
            'IF' (NLTEST (OPTOPX, CBIT))
               BIAS (OPX-1) = BIAS (OPX-1) + NLOPS (CVALUE, OPTOPX)
               'ELSE'
               'IF' (NLTEST (OPTOPX, REGBIT))
                  TS = NLOPS (REGNUM, OPTOPX)   // SUBSCRIPT IS REG
                  'IF' (STATUS (TS) .NE. 0)
                     STATUS (TS) = STATUS (TS) + 19
                     'ENDIF'
                  'ENDIF'
               SUBX (OPX-1) = OPTOPX
               SUBXM (OPX-1) = MODE (OPX)
               NAMEX (OPX) = 0
               'ENDIF'
            'ENDIF'
         'ENDIF'
C     GET THE LBK OUT OF THE STACK
      OSTACK (OPX-1) = 0
      IF (NAMEX (OPX-1) .EQ. 0) NAMEX (OPX-1) = NULLX
      NLX = NAMEX (OPX-1)
      IF (NLTEST (NLX, CBIT + REGBIT)) CALL FAULTP (65)
      CALL ADVAN
      CALL DUMST ('BP ]')
      STOAC = 0
      ASSIGN 310 TO BPRET
      GO TO 700                  // CALL CHECK CONSTANT LOC
310   IF (NAMEX (OPX) .NE. 0) CALL FAULTP (32)
      CUROP = IAND (OSTACK (OPX-2), 63)
      GO TO 100
      'EJECT'
C     FUNCTION PROCESSING

400   FSX = FSX + 1
      FSTACK (FSX) = OPX
      IF (CUROP .EQ. ARROW) CALL FAULTP (8)
      CALL PEEK
      'IF' (PEEKS .NE. RPAREN)
         'DO'
C           STACK A FUNCTION ( AND GET AN ARGUMENT
            OSTACK (OPX-1) = 1024 + LPAREN + FUNBIT
            DEFMOD = STDMD
            STOAC = 0
            GO TO 1
410         NLX = NAMEX (OPX-1)
            'IF' (NLTEST (NLX, REGBIT))
               TS = NLOPS (REGNUM, NLX)
               IF (STATUS (TS) .EQ. 0) STATUS (TS) = OPX - 1
               CALL GENER (SAVCAL)
               'ENDIF'
            'WHILE' (NEXTOP .EQ. COMMA)
               'END'
         IF (NEXTOP .NE. RPAREN) CALL FAULTP (60)
         'ELSE'
         PLEVEL = PLEVEL - 1
         CALL FNZS
         'ENDIF'
      FOPX = OPX - 1
      OPX = FSTACK (FSX)
      FSX = FSX - 1
      'IF' (OPX .LE. FOPX)
         CALL GENER (SAVCAL)
         TS = FOPX - OPX + 1
         'FOR' (K = FOPX; K .GE. OPX; K = K - 1)
            TOPX = K + 1
            NEXTX = K
            CALL CLRSTK (TOPX)
            NAMEX (TOPX) = FLS (TS)
            MODE (TOPX) = DPMODE
            MODE (NEXTX) = DPMODE
            LOCFLG (NEXTX) = 1
            NEXTOP = COMMA
            CALL REGMAN (CLRSTA, 0, 0)
            CALL SETUP (LDAINX, NEXTX)
            CALL SETUP (STAINX, TOPX)
            CALL GEN (ARROW, NEXTX, TOPX)
            CALL REGMAN (CLRSTA, 0, 0)
            TS = TS - 1
            'END'
         NAMEX (OPX) = 0
         'ENDIF'
      CALL DUMST ('FUNC')
      'EJECT'
      OPX = OPX - 1
      CALL GENT (1)   // GENERATE JSR
      ACTLO = AREG
      'IF' (MODE (OPX) .EQ. DPMODE)
         ACTHI = AREG
         ACTLO = XREG
         'ENDIF'
      OPX = OPX + 1
      CALL GENER (OUT)
      CALL REGSRC (6, REGS, SPMODE, 0, 0, 0, NZREG)
      STOAC = 1
      GO TO 250
      'EJECT'
C     SUBROUTINE CHECK CONSTANT LOC

C     IF THE OPERAND IS THE LOCATION OF AN ABSOLUTE NAME +/-
C     A CONSTANT, CONSIDER IT A COMPILE TIME CONSTANT
C     = 'LOC' NAME +/- CONSTANT

700   'IF' (LOCFLG (OPX-1) .NE. 0 .AND. SUBX (OPX-1) .EQ. 0)
         'IF' (NLOPS (NLXLCI, NAMEX (OPX-1)) .EQ. ABSLC)
            NLX = NAMEX (OPX-1)
            NUMBER = NLOPS (NAMLOC, NLX) + BIAS (OPX-1)
            NAMEX (OPX-1) = ENTNUM (DUMMY)
            BIAS (OPX-1) = 0
            LOCFLG (OPX-1) = 0
            'ENDIF'
         'ENDIF'
      GO TO BPRET
      'EJECT'
C     SUBROUTINE  CHECK SPECIAL LEVELS

C     DECIDE IF 'AND' OR 'OR' IS RELATIONAL OR ARITHMETIC

800   'IF' (LEVEL .EQ. 10 .AND. NEXTOP .NE. ARROW)
         RELLEV = PLEVEL
         RELPAS = .TRUE.
         'ELSE'
         'IF' (LEVEL .EQ. 6)
C           BOOLEAN LEVEL
            'IF' (RELPAS .AND. PLEVEL .LE. RELLEV)
C              RELATIONAL 'AND' OR 'OR'
               RELCNT = RELCNT + 1
               RELPAS = .FALSE.
               'ELSE'
C              ARITHMETIC 'AND' OR 'OR'
               NEXTOP = COP (NEXTOP - 28)
               LEVEL = DECODE (1, NEXTOP)
               'ENDIF'
            'ENDIF'
         'ENDIF'
      GO TO 102
      'EJECT'
C     SUBROUTINE  POP STACK

900   'DO'
         TS = ISHFT (OSTACK (OPX-2), -10)
         'WHILE' (TS .GE. LEVEL)
            OPX = OPX - 1
            TOPX = OPX
            NEXTX = TOPX - 1
            OP = IAND (OSTACK (NEXTX), 63)
            CALL DUMST ('POP ')
            CALL GENER (SETX)
            STOAC = 0
            TS = DECODE (2, OP)
            GO TO (  3, 999, 999, 999, 999, ^
                   960, 970, 970, 970, 980, ^
                   970, 970, 970, 970, 970, 990), TS

C           COMPARISON OR I/O
960         'IF' ( (OP .EQ. LESS .OR. OP .EQ. GTR) ^
                   .AND. OPNXTX .EQ. 0)
C              EXIT TO CALLER TO PROCESS I/O STATEMENT
               IOFLAG = 1
               GO TO 3
               'ENDIF'
            CALL OVLOD (OLLCO)
            CALL LCOMP (1)
            NAMEX (OPX) = 0
            'NEXT'

C           ARITHMETIC
970         CONTINUE
            CALL CODE2 (TS)
            CALL DUMST ('POP1')
            'NEXT'

C           RELATIONAL AND/OR
980         NAMEX (OPX) = 0
            'NEXT'

C           CONDITIONAL COMPILATION COMPARE
990         TS = OP
            OP = MINUS
            CALL CODE2 (8)     // SUBTRACT
            OP = TS
            NAMEX (OPX) = 0
            'END'
      GO TO 103

999   CALL FATAL (6)
      RETURN
      END
      'OUTFILE' NEXPFTM.FR
C     SUBROUTINE NEXP
C
C     PROCESS A NOUN EXPRESSION
C
      SUBROUTINE NEXP

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   NLISTCFTM.IN,

      INTEGER  OPXTS

      LCTS = LC
      FNLX = 0
      OPXTS = OPX
      CALL BLDPO
      IF (CONEND) RETURN
      OPX = OPX - 1
      IF (OPX .NE. OPXTS) ^
         CALL FAULTP (60)
      IF (LCTS .LT. LC .AND. QVALUE .EQ. 0) ^
         CALL FAULTP (11)
      IF (SUBX (OPX) .NE. 0) ^
         CALL FAULTP (5)
      RETURN
      END
      'OUTFILE'   DECODEAJH.FR
C     EDIT DATE   07FEB79  08:24
C     SOURCE FILE DECODEAJH.FR
C     AUTHOR      A. J. HOWARD

      INTEGER  FUNCTION DECODE (ITYPE, INDEX)

      INTEGER     ITYPE, INDEX
      INTEGER     TABLE (2, 44), EXCEPT (2, 6, 4)
      'INCLUDE'   LEVELSAJH.IN,

C     TABLE (1, INDEX) = OPERATOR LEVEL
C     TABLE (2, INDEX) = CODE GENERATOR NUMBER

C     IF THE TABLE ENTRY IS -K:
C        GET THE ENTRY FROM EXCEPT (1/2, -K, LEVELB)

C     LEVEL DEFINITIONS
      DATA  TABLE (1,  1) / 0/         // NUMBER
      DATA  TABLE (1,  2) / 4/         // ,
      DATA  TABLE (1,  3) / 4/         // ;
      DATA  TABLE (1,  4) / 4/         // .
      DATA  TABLE (1,  5) / 4/         // :
      DATA  TABLE (1,  6) /-6/         // 'FOR'
      DATA  TABLE (1,  7) / 4/         // 'DO'
      DATA  TABLE (1,  8) / 4/         // 'WHILE'
      DATA  TABLE (1,  9) / 4/         // 'RBR'
      DATA  TABLE (1, 10) / 4/         // 'LBR'
      DATA  TABLE (1, 11) / 4/         // 'RETURN'
      DATA  TABLE (1, 12) / 4/         // $
      DATA  TABLE (1, 13) / 2/         // (
      DATA  TABLE (1, 14) / 4/         // )
      DATA  TABLE (1, 15) / 2/         // [
      DATA  TABLE (1, 16) / 4/         // ]
      DATA  TABLE (1, 17) /-1/         // =
      DATA  TABLE (1, 18) /-1/         // #
      DATA  TABLE (1, 19) /-1/         // >
      DATA  TABLE (1, 20) /-1/         // >=
      DATA  TABLE (1, 21) /-1/         // <
      DATA  TABLE (1, 22) /-1/         // <=
      DATA  TABLE (1, 23) /-2/         // ->
      DATA  TABLE (1, 24) /12/         // +
      DATA  TABLE (1, 25) /12/         // -
      DATA  TABLE (1, 26) /14/         // *
      DATA  TABLE (1, 27) /14/         // /
      DATA  TABLE (1, 28) /14/         // 'MOD'
      DATA  TABLE (1, 29) /-3/         // 'OR'
      DATA  TABLE (1, 30) /-4/         // 'AND'
      DATA  TABLE (1, 31) /16/         // 'OR'
      DATA  TABLE (1, 32) /16/         // 'XOR'
      DATA  TABLE (1, 33) /18/         // 'AND'
      DATA  TABLE (1, 34) /20/         // 'LS'
      DATA  TABLE (1, 35) /20/         // 'RS'
      DATA  TABLE (1, 36) /20/         // 'LC'
      DATA  TABLE (1, 37) /20/         // 'RC'
      DATA  TABLE (1, 38) /20/         // 'ALS'
      DATA  TABLE (1, 39) /20/         // 'ARS'
      DATA  TABLE (1, 40) /14/         // NEG
      DATA  TABLE (1, 41) /-5/         // UPARO
      DATA  TABLE (1, 42) /22/         // 'DEC'
      DATA  TABLE (1, 43) /20/         // 'COM'
      DATA  TABLE (1, 44) / 2/         // 'LOC'
C     EXCEPTIONAL LEVELS
      DATA  EXCEPT (1, 1, 1) / 4/
      DATA  EXCEPT (1, 1, 2) /10/
      DATA  EXCEPT (1, 1, 3) / 4/
      DATA  EXCEPT (1, 1, 4) /10/
      DATA  EXCEPT (1, 2, 1) / 4/
      DATA  EXCEPT (1, 2, 2) /10/
      DATA  EXCEPT (1, 2, 3) /10/
      DATA  EXCEPT (1, 2, 4) / 4/
      DATA  EXCEPT (1, 3, 1) / 6/
      DATA  EXCEPT (1, 3, 2) / 6/
      DATA  EXCEPT (1, 3, 3) / 6/
      DATA  EXCEPT (1, 3, 4) /16/
      DATA  EXCEPT (1, 4, 1) / 6/
      DATA  EXCEPT (1, 4, 2) / 6/
      DATA  EXCEPT (1, 4, 3) / 6/
      DATA  EXCEPT (1, 4, 4) /18/
      DATA  EXCEPT (1, 5, 1) / 4/
      DATA  EXCEPT (1, 5, 2) /22/
      DATA  EXCEPT (1, 5, 3) / 4/
      DATA  EXCEPT (1, 5, 4) /22/
      DATA  EXCEPT (1, 6, 1) / 4/
      DATA  EXCEPT (1, 6, 2) / 2/
      DATA  EXCEPT (1, 6, 3) / 2/
      DATA  EXCEPT (1, 6, 4) / 2/
      'EJECT'
C     CODE GENERATOR NUMBERS
      DATA  TABLE (2,  1)  / 2/        // NUMBER
      DATA  TABLE (2,  2)  / 1/        // ,
      DATA  TABLE (2,  3)  / 1/        // ;
      DATA  TABLE (2,  4)  / 1/        // .
      DATA  TABLE (2,  5)  / 1/        // :
      DATA  TABLE (2,  6)  / 1/        // 'FOR'
      DATA  TABLE (2,  7)  / 1/        // 'DO'
      DATA  TABLE (2,  8)  / 1/        // 'WHILE'
      DATA  TABLE (2,  9)  / 1/        // 'RBR'
      DATA  TABLE (2, 10)  / 1/        // 'LBR'
      DATA  TABLE (2, 11)  / 1/        // 'RETURN'
      DATA  TABLE (2, 12)  / 1/        // $
      DATA  TABLE (2, 13)  / 3/        // (
      DATA  TABLE (2, 14)  / 4/        // )
      DATA  TABLE (2, 15)  / 3/        // [
      DATA  TABLE (2, 16)  / 5/        // ]
      DATA  TABLE (2, 17)  /-1/        // =
      DATA  TABLE (2, 18)  /-1/        // #
      DATA  TABLE (2, 19)  /-1/        // >
      DATA  TABLE (2, 20)  /-1/        // >=
      DATA  TABLE (2, 21)  /-1/        // <
      DATA  TABLE (2, 22)  /-1/        // <=
      DATA  TABLE (2, 23)  /-2/        // ->
      DATA  TABLE (2, 24)  / 8/        // +
      DATA  TABLE (2, 25)  / 8/        // -
      DATA  TABLE (2, 26)  / 9/        // *
      DATA  TABLE (2, 27)  / 9/        // /
      DATA  TABLE (2, 28)  / 9/        // 'MOD'
      DATA  TABLE (2, 29)  /10/        // 'OR'
      DATA  TABLE (2, 30)  /10/        // 'AND'
      DATA  TABLE (2, 31)  / 8/        // 'OR'
      DATA  TABLE (2, 32)  / 8/        // 'XOR'
      DATA  TABLE (2, 33)  / 8/        // 'AND'
      DATA  TABLE (2, 34)  /11/        // 'LS'
      DATA  TABLE (2, 35)  /11/        // 'RS'
      DATA  TABLE (2, 36)  /11/        // 'LC'
      DATA  TABLE (2, 37)  /11/        // 'RC'
      DATA  TABLE (2, 38)  /11/        // 'ALS'
      DATA  TABLE (2, 39)  /11/        // 'ARS'
      DATA  TABLE (2, 40)  /12/        // NEG
      DATA  TABLE (2, 41)  /-3/        // UPARO
      DATA  TABLE (2, 42)  /14/        // 'DEC'
      DATA  TABLE (2, 43)  /15/        // 'COM'
      DATA  TABLE (2, 44)  / 3/        // 'LOC'
C     EXCEPTIONAL OPERATORS
      DATA  EXCEPT (2, 1, 1) / 1/
      DATA  EXCEPT (2, 1, 2) / 6/
      DATA  EXCEPT (2, 1, 3) / 1/
      DATA  EXCEPT (2, 1, 4) /16/
      DATA  EXCEPT (2, 2, 1) / 1/
      DATA  EXCEPT (2, 2, 2) / 7/
      DATA  EXCEPT (2, 2, 3) / 7/
      DATA  EXCEPT (2, 2, 4) / 1/
      DATA  EXCEPT (2, 3, 1) / 1/
      DATA  EXCEPT (2, 3, 2) /13/
      DATA  EXCEPT (2, 3, 3) / 1/
      DATA  EXCEPT (2, 3, 4) /13/


      DECODE = TABLE (ITYPE, INDEX)
      'IF' (DECODE .LT. 0)
         DECODE = -DECODE
         DECODE = EXCEPT (ITYPE, DECODE, LEVELB)
         'ENDIF'
      RETURN
      END




\\\\\


SUBFILE: CONTFT.FS @15:59 23-MAY-1979 <055> (2231)
'HEAD'  CONTROL CARD PROCESSING
C     EDIT DATE   14DEC78  13:29
C     SOURCE FILE CONTFTM.FS
C     AUTHOR      F. T. MICKEY
C     CLUSTER     13

      'OUTFILE'   PCONTFTM.FR

N     OVERLAY     OLCTL
      SUBROUTINE  PCONT

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   BLDPOAJH.IN,
      'INCLUDE'   LCFUNCAJH.IN,
      'INCLUDE'   SRCDFSFTM.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   NLNAMEFTM.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   CTRLAJH.IN,
      'INCLUDE'   SRCXDFFTM.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   PRTCOMFTM.IN,
      'INCLUDE'   WFLAGSJHP.IN,

      INTEGER     TS, HPTR, CHAR, LCITS, LFTS, NEWLCV
      INTEGER     FNLXTS, CONLST (17), CTS, XSEMI, CNAME (16)
      LOGICAL     CZERO (18)

      INTEGER     GCHAR, SNMLST, NLOPS  // EXTERNAL FUNCTIONS

      DATA  CZERO /.FALSE., .TRUE., .TRUE.,  .FALSE., .TRUE., .FALSE., ^
                   .TRUE., .FALSE., .TRUE.,  .TRUE.,  .FALSE., .FALSE.,^
                   .TRUE., .FALSE., .FALSE., .FALSE., .TRUE.,  .TRUE./
C           TABLE REPRESENTS:  COMP ZERO (6), COMP NEG (6), COMP POS (6)

      DATA  XSEMI    /59/
      DATA  CONLST   /'RUPRLIUSEJORIFEVHEENLOTISYDADSSHCO'/
      DATA  CNAME    /16*0/
      'EJECT'
      FNLXTS = FNLX
      LFTS = LISTF
      LISTF = 0   // TURN OFF LIST FLAG
      CALL SET (XSEMI, SOURCE (SRCEND), 3)
      SRCEND = SRCEND + 3
      J = J + 2
      CALL FNZS
      'IF' (PSYMB .NE. MINUS)
         NEGFLG = -1
         'ELSE'
         NEGFLG = 0
         CALL FNZS
         'ENDIF'
      CALL CTNAME
      'IF' (PSYMB .NE. COLON)
         IF (SKIP .LT. 0) GO TO 99
         'DOLOOP' TS = 1, 17
            'IF' (NAME (1) .EQ. CONLST (TS))
               GO TO ^
                  (10, ^      // ''RU NAT
                   15, ^      // ''PR INT
                   20, ^      // ''LI ST
                   25, ^      // ''US E
                   30, ^      // ''EJ ECT
                   35, ^      // ''OR G
                   40, ^      // ''IF
                   45, ^      // ''EV EN
                   50, ^      // ''HE AD
                   55, ^      // ''EN D
                   60, ^      // ''LO C
                   65, ^      // ''TI TLE
                   70, ^      // ''SY MBOLS
                   75, ^      // ''DA TE
                   80, ^      // ''DS TACK
                   85, ^      // ''SH ORT
                   90),^      // ''CO MPILE
                   TS

               'ENDIF'
            'END'
         CTLERR = 71
         'ELSE'
         'IF' (SKIP .LT. 0)
            NK = NK + 1
            'DOLOOP' NI = 1, NK
               IF (NAME (NI) .NE. SKNAME (NI)) GO TO 99
               'END'
            SKIP = 0         // NAME FOUND, RESUME COMPILATION
            'ENDIF'
         'ENDIF'
      'EJECT'
99    FNLX = FNLXTS
      LISTF = LFTS
      IF (PRINTF .NE. 0) PRINTF = 1
      LCTS = LC
      J = SRCEND
      RETURN
'EJECT'
C     RUNAT
10    'IF' (LCI .NE. CODE)
C        CALL FINAL LIT POOL
         LCTAB (CODE) = LC - LDLCVO
         LDLCVO = 0
         CALL RLCI (CODE)
C        BSTACK = PAKLCI (TS)
         'ENDIF'
      IF (NEGFLG .EQ. 0) GO TO 99
      ORGFLG = 1
      CALL CTNUM
      ORGFLG = 0
      TS = NAMEX (OPX + 1)
      'IF' (TS .NE. 0)
         'IF' (NLOPS (NLXLCI, TS) .EQ. ABSLC)
            LCTAB (ABSLC) = NLOPS (NAMLOC, TS) + BIAS (OPX + 1)
            LDLCVO = LCTAB (ABSLC) - LC
            CALL RLCI (ABSLC)
C           BSTACK = PAKLCI (TS)
            GO TO 99                  // CONTROL EXIT
            'ENDIF'
         'ENDIF'
      CTLERR = 11
      GO TO 99


C     PRINT
15    PRINTF = NEGFLG
      GO TO 99


C     LIST
20    LFTS = NEGFLG
      GO TO 99
'EJECT'
C     USE
25    USFLGS = ISHFT (USFLGS, 1) + PRINTF
      'DOLOOP' NI = 1, 30
         CALL FNZS
         'IF' (PSYMB .NE. SEMIC)
            'IF' (PSYMB .NE. EOCC)
               CALL PCHAR (CNAME, NI, SYMBOL)
               'END'
            'ELSE'
            GO TO 26
            'ENDIF'
         'ENDIF'
      IF (PI .EQ. 7) GO TO 26
P     CALL DEVICE (CNAME)     // DEFAULT DEVICE SPECIFICATION
      CALL OPENF (PI+1, CNAME, TS)
      IF (TS .NE. 1) GO TO 26
      PI = PI + 1
      FLINCT (PI) = 0
      PSYMB = 0
      CALL CTNUM
      PRINTF = IAND (NUMBER, PRINTF)
      GO TO 99

26    CTLERR = 74
      GO TO 99
'EJECT'
C     EJECT
30    IF (LCOUNT .GE. 2) CALL NPAGE
      GO TO 99


C     ORG
35    ORGFLG = 1
      CALL CTNUM
      ORGFLG = 0
      TS = NAMEX (OPX+1)
      'IF' (TS .NE. 0)
         'IF' (NLOPS (DFINED, TS) .NE. 0)
            CTS = NLOPS (NLXLCI, TS)
            NEWLCV = NLOPS (NAMLOC, TS) + BIAS (OPX+1)
            'IF' (CTS .EQ. LCI)
               MAXLCV = NEWLCV
               CALL SETLCI
               GO TO 99
               'ENDIF'
            'IF' (LOGICF .NE. 0)
C              VERB LIST ORG
               'IF' (CTS .EQ. ABSLC .OR. CTS .EQ. 1) // 1 IS CODE LCI
                  CODE = CTS
                  LCTAB (CODE) = NEWLCV
                  CALL RBOTH (CODE)
                  GO TO 99
                  'ENDIF'
               'ENDIF'
            'ENDIF'
         'ENDIF'
      CTLERR = 73
      GO TO 99
'EJECT'
C     IF
40    OP = -1
      CALL CTNUM
      TS = NUMBER
      IF (OP .LT. EQUAL .OR. OP .GT. LESSEQ) OP = NEQUAL
      CTS = OP - EQUAL + 1
C     READY FOR ZERO CASE, CHECK FOR POS OR NEG
      IF (TS .LT. 0) CTS = CTS + 6       // NEG
      IF (TS .GT. 0) CTS = CTS + 12      // POS
      SKIP = 0
      'IF' (NEXTOP .NE. SEMIC)
C        FORM   ''IF, R: L.
         IF (CZERO (CTS))  GO TO 99   // NO SKIP
         SKIP = -32767
         CALL FNZS
         CALL CTNAME
         CALL MOVE (NAME, SKNAME, 8)
         GO TO 99
         'ENDIF'
C     FORM   ''IF, R
      IF (CZERO (CTS)) SKIP = -2
      GO TO 99


C     EVEN
45    CONTINUE
C**** IF (LODLCI .NE. LCI) CALL DFTEMP
      CALL CTNUM
      TS = NUMBER - 1 + LC
      MAXLCV = (TS/NUMBER)*NUMBER
      CALL SETLCI
      GO TO 99


C     HEAD
50    CALL SET (XBBL, UHEAD, 15)
      'DOLOOP' HPTR = 1, 30
         CHAR = GCHAR (RECORD, HPTR + 7)
         'IF' (CHAR .NE. EOCC)
            CALL PCHAR (UHEAD, HPTR, CHAR)
            'END'
         'ENDIF'
      IF (TTL (1) .NE. XBBL) GO TO 99
C     TITLE
65    CALL FNZS
      CALL CTNAME
      CALL MOVE (NAME, TTL, 8)
      GO TO 99
      'EJECT'
C     END
55    CONEND = .TRUE.
      CALL FNZS
      'IF' (PSYMB .LT. COMMA)
         CALL RDNAME (-1)
         NLX = SNMLST (TS)
         IF (NLOPS (DFINED, NLX) .NE. 0) TNAME = NLX
         'ENDIF'
      IF (ENDOK) GO TO 99
      CALL FATAL (80)


C     LOC
60    CONTINUE
      CALL CTNUM
      LBIAS = NUMBER
      LOCPRT = NEGFLG
      GO TO 99


C     SYMBOLS
70    SYMFLG = NEGFLG
      GO TO 99


C     DATE
75    CALL FNZS
      CALL RDNAME (-1)
      LCITS = LCI
      CALL RLCI (DATALC)
      FNLX = SNMLST (NAME)
      CALL NDEFN
      CALL NLSET (NLX, STRBIT)
      CALL DATE (CNAME)
      'DOLOOP' TS = 1, 9
         CALL BLDBLK (GCHAR (CNAME, TS), WF1)
         'END'
      CALL RLCI (LCITS)
      GO TO 99

C     DSTACK
80    DUMFLG = NEGFLG
      GO TO 99

C     SHORT
85    SNLPRT = NEGFLG
      GO TO 99
      'EJECT'
C     COMPILE
90    COMPFL (1) = 0
      COMPFL (2) = 0
      'DO'
         CALL FNZS
         TS = SYMBOL - XA
         'WHILE' (TS .GE. 0)
            'IF' (TS .GE. 16)
               COMPFL (2) = IOR (COMPFL (2), ISHFT (1, TS-16))
               'ELSE'
               COMPFL (1) = IOR (COMPFL (1), ISHFT (1, TS))
               'ENDIF'
            'END'
      GO TO 99
      END
      'OUTFILE'   CTNAMEFTM.FR

      SUBROUTINE  CTNAME

      'INCLUDE'   CTRLAJH.IN,

      INTEGER     SKIPTS

      SKIPTS = SKIP
      SKIP = -1
      CALL CTNUM
      SKIP = SKIPTS
      RETURN
      END
      'OUTFILE'   CTNUMFTM.FR

      SUBROUTINE  CTNUM

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   CTRLAJH.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   NLNAMEFTM.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   LEVELSAJH.IN,

      INTEGER     TS
      INTEGER     NLOPS, GCHAR   // EXTERNAL FUNCTIONS
      LOGICAL     NLTEST

      NUMBER = 0
      'IF' (PSYMB .NE. SEMIC)
         CALL PUSH (LEVELB, NLX, OPX)
         OPX = OPX + 1
         LEVELB = CLEVEL
         'IF' (SKIP .LT. 0)
            CALL SET (XBBL, NAME, 9)
            CALL RDNAME (-1)
            'DOLOOP' TS = 1, 17
               CALL PCHAR (NAME, TS, GCHAR (NAME, TS+1))
               'END'
            NAMEX (OPX) = 0
            'ELSE'
            CALL BP   // SIDE DOOR FOR ''CONTROL PROCESSING
            'ENDIF'
         CALL POP (LEVELB, NLX, OPX)
         'IF' (ORGFLG .EQ. 0)
            TS = NAMEX (OPX + 1)
            'IF' (TS .NE. 0)
               'IF' (NLTEST (TS, CBIT) .OR. SKIP .LT. 0)
                  NUMBER = NLOPS (CVALUE, TS)
                  'ELSE'
                  CTLERR = 11
                  'ENDIF'
               'ENDIF'
            NAMEX (OPX + 1) = 0
            SUBX (OPX + 1) = 0
            BIAS (OPX + 1) = 0
            'ENDIF'
         'ENDIF'
      RETURN
      END



\\\\\


SUBFILE: LEXFTM.FS @15:59 23-MAY-1979 <055> (2168)
'HEAD'  LEXICAL PROCESSING
C     EDIT DATE   14JAN79  09:26
C     SOURCE FILE LEXFTM.FS
C     AUTHOR      A. J. HOWARD
C     CLUSTER     14

      'OUTFILE'   ADVANFTM.FR
C
C     GET NEXT OPERAND-OPERATOR PAIR FROM INPUT STREAM
C
      SUBROUTINE  ADVAN

      EXTERNAL    OLQOT

      INTEGER     ENTNUM, SOPLST, SNMLST   // EXTERNAL FUNCTIONS
      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   SRCDFSFTM.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STUFFAJH.IN,
      'INCLUDE'   NLNAMEFTM.IN,

      CALL CLRSTK (OPX)
      'IF' (STUFFO .NE. 0)
         NEXTOP = STUFFO
         STUFFO = 0
         NAMEX (OPX) = STUFFN
         RETURN
         'ENDIF'
      CUROP = NEXTOP
      CFLAG = 0
      CALL FNZS
      'IF' (PSYMB  .EQ. 0)
         CALL RDNAME (-1)  // NAME, LOOK IT UP IN THE NAME LIST
         NAMEX (OPX) = SNMLST (DUMMY)
         'ELSE'
         'IF' (PSYMB .EQ. NINE)
            CALL RDNUM     // NUMBER, CONVERT AND LOOK IT UP
            NAMEX (OPX) = ENTNUM (DUMMY)
            'ELSE'
            'IF' (PSYMB .EQ. QUOTE)
               CALL OVLOD (OLQOT)
               CALL PQUOTE // PROCESS STRING TEXT
               'ELSE'
               'IF' (PSYMB .EQ. CONTRL)
                  NEXTOP = CONTRL
                  RETURN
                  'ENDIF'
               'ENDIF'
            'ENDIF'
         'ENDIF'
      NEXTOP = PSYMB
      'IF' (NEXTOP .EQ. GIZZY)
         CALL FNZS
         NAME (1) = 0
         IF (PSYMB .NE. GIZZY) CALL RDNAME (-1)
         NEXTOP = SOPLST (DUMMY)
         'ELSE'
         CALL CHEKCO (NEXTOP, J)
         'ENDIF'
      RETURN
      END
      'OUTFILE'   CHEKCOFTM.FR
C     CHECK FOR ->, <=, >= OPERATORS AND REDEFINE FOR COMPILER
      SUBROUTINE  CHEKCO (SYM, INDEX)

      'INCLUDE'   SRCDFSFTM.IN,
      'INCLUDE'   LOGOSAJH.IN,

      INTEGER     SYM, INDEX, FIRST (3), SECOND (3), COMPOS (3)

      DATA  FIRST  /25, 21, 19/  //  -    <    >   INTERNAL
      DATA  SECOND /62, 61, 61/  //  >    =    =   ASCII
      DATA  COMPOS /23, 22, 20/  // ->   <=   >=   INTERNAL

      'DOLOOP' K = 1, 3
         'IF' (SYM .EQ. FIRST (K) ^
               .AND. SOURCE (INDEX) .EQ. SECOND (K) )
            SYM = COMPOS (K)
            INDEX = INDEX + 1
            'BREAK'
            'ENDIF'
         'END'
      RETURN
      END
      'OUTFILE'   FNZSFTM.FR
C     FINDS A NON-BLANK CHARACTER AND RETURNS COMPILER ID

      SUBROUTINE  FNZS

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   SRCDFSFTM.IN,
      'INCLUDE'   SRCXDFFTM.IN,
      'INCLUDE'   SYMBOLFTM.IN,

      'DO'
         'IF' (J .GE. SRCEND)
C           END OF CURRENT LINE, PREPARE A NEW LINE
C
            J = 1
            CALL PSRENT
            'IF' (CONTF .EQ. CONTRL)
               PSYMB = CONTRL
               'BREAK'
               'ENDIF'
            'ENDIF'
         SYMBOL = SOURCE (J)
         J = J + 1
         'IF' (SYMBOL .EQ. 32 .AND. NOTINQ)
            'NEXT'
            'ENDIF'
         'IF' (SYMBOL .LT. 32 .OR. SYMBOL .GE. 97)
            'IF' (SYMBOL .EQ. CONTRL)
               PSYMB = CONTRL         // LEFT BY PEEK
               J = J - 1
               'BREAK'
               'ENDIF'
C           CHARACTER OUT OF TABLE LIMITS
C
            CALL FAULTP (88)
            'NEXT'
            'ENDIF'
C        GET COMPILER ID FROM SYMBOL TABLE
C
         PSYMB = SYMTBL (SYMBOL - 31)
C        CHECK FOR VALID DEFINITION IF NOT PROCESSING STRING DATA
C
         'WHILE' (PSYMB .LT. 0 .AND. NOTINQ)
C           PRINT "ILLEGAL SOURCE CHARACTER" MESSAGE
C
            CALL FAULTP (88)
            'END'
C     EXIT WITH VALID COMPILER ID IN PSYMB
C
      RETURN
      END
      'OUTFILE'   RDNUMFTM.FR
C     SUBROUTINE  RDNUM
C
C     READS A NUMBER FROM THE INPUT STREAM;  IF THERE IS
C     A LEADING ZERO, BASE IS HEX INSTEAD OF DECIMAL.
C
      SUBROUTINE  RDNUM

      INTEGER     TS

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   OPERSAJH.IN,

      NUMBER = 0
      'IF' (SYMBOL .NE. XZERO)
         'DO'  // DECIMAL CONVERT
         'WHILE' (PSYMB .EQ. NINE)
            TS = SYMBOL - XZERO
            'IF' ((NUMBER .EQ. 3276 .AND. TS .GE. 8) ^
                  .OR. NUMBER .GT. 3276)
               CALL FAULTP (86)
               'ELSE'
               NUMBER = NUMBER*10 + TS
               'ENDIF'
            CALL FNZS
            'END'
         'ELSE'
         'DO'  // HEXADECIMAL CONVERT
            'IF' (PSYMB .NE. NINE)
               'IF' (SYMBOL .LT. XA .OR. SYMBOL .GT. XF)
                  'BREAK'
                  'ENDIF'
               TS = SYMBOL - XA + 10
               'ELSE'
               TS = SYMBOL - XZERO
               'ENDIF'
            IF (IAND (NUMBER, -4096) .NE. 0) CALL FAULTP (86)
            NUMBER = IOR (ISHFT (NUMBER, 4), TS)
            CALL FNZS
            'END'
         'ENDIF'
      'IF' (PSYMB .EQ. 0 .OR. PSYMB .GE. QUOTE)
         CALL FAULTP (26)
         CALL SCAN (COMMA, NINE, QUOTE)
         'ENDIF'
      RETURN
      END
      'OUTFILE'   RDNAMEFTM.FR
C
C     READS UP TO 16 ALPHANUMERIC CHARACTERS FROM THE INPUT
C     STREAM AND PLACES THEM IN ARRAY NAME, STARTING IN
C     BYTE 2. THE LENGTH OF THE NAME IS PLACED IN BYTE 1
C     UPON NAME TERMINATION.
C
      SUBROUTINE  RDNAME (ACHAR)

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   SRCDFSFTM.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   NLNAMEFTM.IN,
      'INCLUDE'   OPERSAJH.IN,

      INTEGER     ACHAR

      NK = 1
      NI = 0
      PSYMB = 0

      'DO'
C        NAME TERMINATED BY NON-ALPHANUMERIC CHARACTER
         'WHILE' (PSYMB .LT. COMMA .OR. PSYMB .EQ. ACHAR)
            'IF' (NI .LT. NSIZE)
C              STILL WITHIN NAME LIMIT, STORE CHARACTER
               NI = NI + 1
               NK = NK + 1
               CALL PCHAR (NAME, NK, SYMBOL)
               'ENDIF'
            CALL FNZS
            'END'
C     PUT NAME LENGTH IN CHARACTER POSITION 1
      CALL PCHAR (NAME, 1, NI)
      NK = NK + 1
C     PUT IN AN EXTRA BLANK FOR LAST WORD PADDING
      CALL PCHAR (NAME, NK, BLANK)
C     LEAVE (LENGTH IN WORDS) - 1 IN NK
      NK = (NI - 1)/2
      'IF' (PSYMB .GE. QUOTE)
C        NOT A VALID TERMINATOR, "MISSING OPERATOR AFTER NAME"
         CALL FAULTP (20)
         CALL SCAN (RBRACE, NINE, RBRACE)
         'ENDIF'
      RETURN
      END
      'OUTFILE'   PQUOTEFTM.FR
N     OVERLAY     OLQOT
C
C     BUILDS A QUOTE, THEN EITHER DEFINES IT IN THE NAME
C     LIST WITH A TEMPORARY NAME, OR, IF THE QUOTE IS
C     ONLY ONE CHARACTER LONG, DEFINES IT AS A NUMBER.
C     THIS ROUTINE INCLUDES BUILD QUOTE, GET QUOTE CHAR,
C     AND DEF QNAME.
C
      SUBROUTINE  PQUOTE

      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   NLNAMEFTM.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   SRCXDFFTM.IN,
      'INCLUDE'   LCFUNCAJH.IN,

      INTEGER     TS, QSYM, QLCI
      INTEGER     SNMLST, INDNAM, NLOPS, ENTNUM
      LOGICAL     NLTEST

      QVALUE = 1
      QSYM = 0
      SCOUNT = 0
      NOTINQ = .FALSE.
      'DO'
         CALL FNZS
         'WHILE' (PSYMB .NE. QUOTE)
            'IF' (PSYMB .EQ. LESS)
C              IMBEDDED CONSTANT
               NOTINQ = .TRUE.
               CALL FNZS
               'IF' (PSYMB .EQ. 0)
                  CALL RDNAME (-1)
                  NLX = SNMLST (NAME)
                  IF (.NOT. NLTEST (NLX, CBIT)) CALL FAULTP (11)
                  SYMBOL = NLOPS (CVALUE, NLX)
                  'ELSE'
                  CALL RDNUM
                  SYMBOL = NUMBER
                  'ENDIF'
               'IF' (PSYMB .NE. GTR)
C                 CAN'T HAVE EXPRESSIONS
                  CALL FAULTP (43)
                  CALL SCAN (GTR, QUOTE - 1, QUOTE + 1)
                  'ENDIF'
               'ENDIF'
            QSYM = IAND (SYMBOL, 255)
C           BUILD QUOTE
            'IF' (QVALUE .GE. 0)
C              LONG QUOTE
               IF (PSYMB .EQ. QUOTE) GOTO 10
               CALL PEEK
               IF (PEEKS .EQ. QUOTE) GOTO 10
               QVALUE = -1
               'IF' (LOGICF .NE. 0)
                  QLCI = LCI
                  CALL PCHAR (NAME, 1, 3)
                  CALL PCHAR (NAME, 2, 34)  // "
                  NLX = INDNAM (QINDEX, DATALC, 0)
                  CALL NLSET (NLX, STRBIT)
                  'ENDIF'
               'ENDIF'
            CALL BLDBLK (QSYM, WF1)
10          NOTINQ = .FALSE.
            SCOUNT = SCOUNT + 1
            'IF' (SCOUNT .GE. 216)
               CALL FAULTP (28)
               QMODE = 0
               CALL SCAN (RBRACE, NINE, RBRACE)
               'BREAK'
               'ENDIF'
            'END'
      'IF' (QVALUE .LT. 0)
         'IF' (LOGICF .NE. 0)
            CALL RBOTH (QLCI)
            'ENDIF'
         'ELSE'
         NUMBER = QSYM
         NLX = ENTNUM (DUMMY)
         'ENDIF'
      NOTINQ = .TRUE.
      NAMEX (OPX) = NLX
      CALL FNZS
      'IF' (PSYMB .LT. COMMA .OR. PSYMB .GE. QUOTE)
         CALL FAULTP (24)
         CALL SCAN (RBRACE, NINE, RBRACE)
         'ENDIF'
      RETURN
      END




\\\\\


SUBFILE: PEEKFT.FS @15:59 23-MAY-1979 <055> (625)
'HEAD'  PEEK PROCESSING
C     EDIT DATE   14JAN79  09:06
C     SOURCE FILE PEEKFTM.FS
C     AUTHOR      A. J. HOWARD
C     CLUSTER     15

      'OUTFILE' PEEKFTM.FR
C     SUBROUTINE PEEK
C
C     COMPACTS THE SOURCE BUFFER, THEN PEEKS AHEAD IN
C     THE INPUT STREAM AT THE NEXT CHARACTER
C
      SUBROUTINE PEEK

      CALL SSBUF
      CALL PEEKA
      RETURN
      END
      'OUTFILE' SSBUFFTM.FR
      SUBROUTINE SSBUF

      'INCLUDE' LOGOSAJH.IN,
      'INCLUDE' SRCDFSFTM.IN,

      SRCEND = SRCEND - J + 2
      CALL MOVE (SOURCE (J-1), SOURCE, SRCEND + 1)
      J = 2
      I = 2
      RETURN
      END
      'OUTFILE'   PEEKAFTM.FR

      SUBROUTINE  PEEKA

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   SRCDFSFTM.IN,
      'INCLUDE'   SRCXDFFTM.IN,
      'INCLUDE'   SYMBOLFTM.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   NLNAMEFTM.IN,

      INTEGER     TS, XGIZZY
      INTEGER     SOPLST
      DATA        XGIZZY /39/

      'DO'
         'IF' (I .GE. SRCEND)
            CALL PUSH (LOCSUP, I, J)
            LOCSUP = LOCSUP + 1
            J = I
C           PUT NEXT LINE INTO SOURCE
            CALL PSRENT
            CALL POP (LOCSUP, I, J)
            'IF' (CONTF .EQ. CONTRL)
               PEEKS = CONTRL
               SOURCE (I) = CONTRL
               'BREAK'
               'ENDIF'
            'ENDIF'
         TS = SOURCE (I)
         I = I + 1
         'IF' (TS .EQ. BLANK .AND. NOTINQ)
            'NEXT'
            'ENDIF'
         'IF' (TS .EQ. CONTRL)
            PEEKS = CONTRL
            'ELSE'
            TS = TS - BLANK + 1
            PEEKS = SYMTBL (TS)
            'ENDIF'
         'IF' (PEEKS .EQ. GIZZY .AND. NOTINQ .NE. 0)
            CALL PUSH (PSYMB, J, J)
            J = I + 1
            SYMBOL = SOURCE (I)
            NAME (1) = 0
            IF (SYMBOL .NE. XGIZZY) CALL RDNAME (-1)
            PEEKS = SOPLST (DUMMY)
            I = J
            CALL POP (PSYMB, J, J)
            'WHILE' (PEEKS .EQ. 0)
               'END'
            'ELSE'
            CALL CHEKCO (PEEKS, I)
            'ENDIF'
      RETURN
      END
      'OUTFILE'   PEEKFOFTM.FR
      SUBROUTINE  PEEKFO

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   OPERSAJH.IN,

      'DO'
         CALL PEEKA
         'WHILE' (PEEKS .LT. COMMA)
            'END'
      RETURN
      END
      'OUTFILE'   STUFFAJH.FR
      SUBROUTINE  STUFF

      'INCLUDE'   STUFFAJH.IN,
      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   STKDEFA.IN,

      STUFFO = NEXTOP
      STUFFN = NAMEX (OPX)
      RETURN
      END



\\\\\


SUBFILE: LCCONT.FS @15:59 23-MAY-1979 <055> (355)
'HEAD'  LOCATION COUNTER CONTROL
C     EDIT DATE   10DEC78  19:03
C     SOURCE FILE LCCONTFTM.FS
C     AUTHOR      A. J. HOWARD
C     CLUSTER     16

      'OUTFILE' RLCIFTM.FR
C     SUBROUTINE RLCI
C
C     RESETS THE LOCATION COUNTER INDEX TO THE NEW VALUE IF
C     THE NEW VALUE AND OLD VALUE ARE NOT THE SAME.
C
      SUBROUTINE RLCI (NEWLCI)

      'INCLUDE' LOGOSAJH.IN,
      'INCLUDE' WFLAGSJHP.IN,
      'INCLUDE' LCFUNCAJH.IN,
      'INCLUDE' LCONSTAJH.IN,
      'INCLUDE' LISTCMAJH.IN,

      INTEGER NEWLCI

      'IF' (NEWLCI .NE. LCI)
         IF (LENTER) ^
            CALL LIST (LMOVEP, 0, 0)
         LCTAB (LCI) = LC
         LCI = NEWLCI
         CALL BLDBLK (LCI, WF10)
         MAXLCV = LCTAB (LCI)
         CALL SETLCI
         'ENDIF'
      RETURN
      END
      'OUTFILE' RBOTHFTM.FR
C     SUBROUTINE RBOTH
C
C     RESET LCI AND LOAD LCI
C
      SUBROUTINE RBOTH (NEWLCI)

      'INCLUDE' LOGOSAJH.IN,
      'INCLUDE' WFLAGSJHP.IN,

      INTEGER NEWLCI

      LODLCI = NEWLCI
      CALL BLDBLK (LODLCI, WF14)
      CALL RLCI (LODLCI)
      RETURN
      END
      'OUTFILE' SETLCIFTM.FR
C     SUBROUTINE SETLCI
C
C     GENERATES LOADER BLOCKS FOR LOCATION COUNTER SWITCH
C
      SUBROUTINE SETLCI

      'INCLUDE' LOGOSAJH.IN,
      'INCLUDE' WFLAGSJHP.IN,

      CALL BLDBLK (MAXLCV, WF2)
      LC = MAXLCV
      LODLCV = LC - LDLCVO
      CALL BLDBLK (LODLCV, WF15)
      RETURN
      END



\\\\\


SUBFILE: SOURCE.FS @15:59 23-MAY-1979 <055> (1706)
'HEAD'  SOURCE PROCESSING
C     EDIT DATE   14JAN79  09:09
C     SOURCE FILE SOURCEFTM.FS
C     AUTHOR      F. T. MICKEY
C     CLUSTER     17

      'OUTFILE' LDSRCEFTM.FR
C     SUBROUTINE LDSRCE
C
C     GETS A NEW LINE FROM INPUT, PREPARES IT FOR SCANNING,
C     AND PRINTS THE SOURCE LINE IF NOT INHIBITED
C
N     OVERLAY OLLDS
      SUBROUTINE LDSRCE

      INTEGER GCHAR

      'INCLUDE' SRCDFSFTM.IN,
      'INCLUDE' SRCXDFFTM.IN,
      'INCLUDE' LOGOSAJH.IN,
      'INCLUDE' CTRLAJH.IN,
      'INCLUDE' PRTCOMFTM.IN,
      'INCLUDE' CPAREAJH.IN,

      INTEGER  ESMSG (4), NCMSG (4), TS, TS1, IERR

      DATA  ESMSG    / '***ES***' /
      DATA  NCMSG    / '***NC***' /

C     CLEAR THE INPUT RECORD AND READ FROM INPUT
1     CALL SET (XBBL, RECORD, 66)
      CALL RDLIN (PI, RECORD, SLEN, IERR)
      'IF' (IERR .EQ. 9)
C        END-OF-FILE ROUTINE
         'IF' (PI .GT. 4)
C           USE FILE, NOT UNEXPECTED EOF
            CALL CLOSF (PI, IERR)
            PI = PI - 1
            PRINTF = IAND (USFLGS, 1)
            USFLGS = ISHFT (USFLGS, -1)
            GO TO 1
            'ENDIF'
C        "UNEXPECTED EOF"
         CALL FAULTP (82)
         SKIP = 6
         CALL SET (XBBL, RECORD, 66)
         CALL MOVE (ENDCRD, RECORD, 3)
         'ENDIF'
C     IGNORE FORM FEED LINES
      IF (GCHAR (RECORD, 1) .EQ. 12) GO TO 1
      RECPTR = 1
C     FLAG NEW CARD READ AND UPDATE FILE LINE COUNT
      CARDC = CARDC + 1
      FLINCT (PI) = FLINCT (PI) + 1
      'EJECT'
C     CHECK FOR '' INDICATING CONTROL CARD
      CALL SETCF
      'IF' (CONTF .EQ. CONTRL)
C        CHECK FOR ''HEAD OR ''END
         TS = RECORD (2)
         'IF' (TS .EQ. HEAD .OR. TS .EQ. EJECT)
            'IF' (CARDC .LT. 2)
C              FIRST CARD, START PAGE
               LCOUNT = 3
               'ENDIF'
            SKIP = SKIP + 1
C           RETURN CONTROL CARD
            RETURN
            'ENDIF'
         'ENDIF'
      'IF' (FCHRTS .NE. 0)
C        SIGNAL FLOWCHART BEGUN
         FCHRTS = 0
         IF (LCOUNT .NE. 1) CALL NPAGE
         'ENDIF'
      'IF' (PRINTF .NE. 0)
C        PRINTING NOT INHIBITED BY GLOBAL SWITCH
         CALL SET (XBBL, LBUF, 66)
C        PRINT LINE NUMBER WITHIN FILE
         CALL ESP (FLINCT (PI), LBUF, 1, 4)
C        SET UP LOCATION COUNTER VALUE FOR PRINT
         CALL LCVSET
         'IF' (PNESTX .NE. 1)
C           CONDITIONALS PRESENT, PRINT T/F FLAGS
            N = 6
            'DOLOOP' TS = 2, PNESTX
               TS1 = CNLSID (TS - 1) + 1
               CALL EST (TF (TS1), LBUF, N, N)
               N = N + 1
               'END'
            'ENDIF'
C        PRINT THE SOURCE LINE
         CALL EST (RECORD, LBUF, 19, 98)
         IF (SCFLAG .NE. 0) ^ // ERROR SCAN, INCLUDE ESMSG
            CALL EST (ESMSG, LBUF, 6, 13)
         'ENDIF'
      'EJECT'
      TS = GCHAR (RECORD, RECPTR) - XA
C     CHECK FOR ALPHABETIC COMPILE CHARACTER
      'IF' (TS .GE. 0)
C        FOUND ONE - SEE IF COMPILE FLAG SET FOR THIS ONE
         'IF' (QMODE .EQ. 0)
            'IF' (TS .GE. 16)
C              SECOND WORD OF COMPILE FLAGS
               TS = ISHFT (COMPFL (2), 16 - TS)
               'ELSE'
               TS = ISHFT (COMPFL (1), -TS)
               'ENDIF'
            'IF' (IAND (TS, 1) .EQ. 0)
C              COMPILE NOT REQUESTED, SKIP FOR THIS LINE
               SKIP = SKIP + 1
               CALL EST (NCMSG, LBUF, 6, 13)
               CALL SGLPRT
               GO TO 1
               'ENDIF'
C           COMPILE REQUESTED, BLANK COMPILE LETTER
            CALL PCHAR (RECORD, RECPTR, BLANK)
            RECPTR = RECPTR + 1
            CALL SETCF
            RECPTR = RECPTR - 1
            'ENDIF'
         'ENDIF'
      SKIP = SKIP + 1
      IF (SKIP .LT. 0) ^
         CALL EST (NCMSG, LBUF, 6, 13)
C     PRINT, SINGLE SPACED
      CALL SGLPRT
      RETURN
      END
      'OUTFILE' LCVSETFTM.FR
C     SUBROUTINE LCVSET
C
C     SET UP LOCATION COUNTER VALUE IN LBUF
C
      SUBROUTINE LCVSET

      'INCLUDE' SRCXDFFTM.IN,
      'INCLUDE' LOGOSAJH.IN,
      'INCLUDE' CTRLAJH.IN,
      'INCLUDE' LCFUNCAJH.IN,
      'INCLUDE' PRTCOMFTM.IN,

      INTEGER  TS

      'IF' (LOCPRT .NE. 0 .AND. LOCSUP .LE. 0)
C        LOCATION COUNTER NOT SUPPRESSED
         TS = LC
         IF (LCI .EQ. CODE) TS = TS + LBIAS
         CALL EHX (TS, LBUF, 14, 17)
         'ENDIF'
      RETURN
      END
      'OUTFILE' SETCFFTM.FR
C     SUBROUTINE SETCF
C
C     SET CONTROL FLAG IF FIRST TWO CHARACTERS ARE "''"
      SUBROUTINE SETCF

      INTEGER GCHAR

      'INCLUDE' SRCDFSFTM.IN,

      CONTF = ISHFT (GCHAR (RECORD, RECPTR), 8) ^
                   + GCHAR (RECORD, RECPTR + 1)
      RETURN
      END
      'OUTFILE' PRNEWSFTM.FR
C     SUBROUTINE PRNEWS
C
C     PROCESS INCOMING SOURCE LINE, SQUASH BLANKS AND OMIT COMMENTS
C
      SUBROUTINE PRNEWS

      'INCLUDE' SRCDFSFTM.IN,
      'INCLUDE' LOGOSAJH.IN,
      'INCLUDE' SRCXDFFTM.IN,

      K = 1
      'DO'
C        GET CHARACTER FROM SOURCE LINE
         CALL GETC (I,K)
1        SOURCE (J) = I
C        CHECK FOR COMMENT
         'IF' (I .EQ. SLASH .AND. QMODE .EQ. 0)
C           SUPPRESS CHECK IF IN QUOTE MODE
            CALL GETC (I, K)
            'IF' (I .NE. SLASH)
C              NOT A COMMENT, PROCEED
               J = J + 1
               GO TO 1
               'ENDIF'
C           COMMENT, END OF CURRENT LINE
            'BREAK'
            'ENDIF'
         'IF' (I .EQ. BLANK .AND. QMODE .EQ. 0)
C           NOT A STRING, DROP THE BLANK
            'NEXT'
            'ENDIF'
C        FLIP QUOTE FLAG IF QUOTE IS ENCOUNTERED
         'IF' (I .EQ. 34)
            QMODE = IEOR (QMODE, 1)
            'ENDIF'
C        SUPPRESS NULL, TAB AND FORM FEED CHARACTERS
         'IF' (I .EQ. 0 .OR. I .EQ. 9 .OR. I .EQ. 12)
            'NEXT'
            'ENDIF'
         'WHILE' (I .NE. EOCC)
C           NOT END OF CARD, PROCEED
            J = J + 1
            'END'
      SOURCE (J) = 0
      RETURN
      END
      'OUTFILE' GETCFTM.FR
C     SUBROUTINE GETC (I, K)
C
C     UNPACK A CHARACTER FOR PRNEWS
C
      SUBROUTINE GETC (I, K)

      'INCLUDE' SRCDFSFTM.IN,

      INTEGER GCHAR, I, K

      K = K + 1
      'IF' (K .GT. SLEN)
C        RETURN END OF CARD CODE
         I = EOCC
         'ELSE'
         I = GCHAR (RECORD, RECPTR)
         RECPTR = RECPTR + 1
         'ENDIF'
      RETURN
      END
      'OUTFILE' PSRENTFTM.FR
C     SUBROUTINE PSRENT
C
C     LOADS NEXT SOURCE LINE UNTIL INFORMATION IS PRESENT
C
      SUBROUTINE PSRENT
      EXTERNAL OLLDS

      'INCLUDE' SRCDFSFTM.IN,
      'INCLUDE' LOGOSAJH.IN,
      'INCLUDE' CTRLAJH.IN,

      INPUTJ = J
      CALL OVLOD (OLLDS)
      'DO'
         CALL LDSRCE
C        RESET SOURCE LINE POINTER
         K = 0
         'IF' (SKIP .LT. 0 .AND. CONTF .NE. CONTRL)
C           IGNORE THIS LINE
            'NEXT'
            'ENDIF'
C        COMPRESS SOURCE AND CHECK FOR CONTROL CARD
         CALL PRNEWS
         SRCEND = J
C        IF THE INPUT POINTER HASN'T CHANGED, GET ANOTHER LINE
         'WHILE' (J .EQ. INPUTJ)
            'END'
      J = INPUTJ
      RETURN
      END




\\\\\


SUBFILE: SETUPJ.FS @15:59 23-MAY-1979 <055> (4437)
'HEAD'  SETUP
C     EDIT DATE   26JAN79  11:13
C     SOURCE FILE SETUPJHP.FS
C     AUTHOR      J.H.PERINE
C     CLUSTER     18

      'OUTFILE'   SETUPJHP.FR

C     NAME     SETUP
C     MODULE#

C     PURPOSE  GENERATE SETUP CODE AND PROPER INSTRUCTION TO
C              PERFORM THE REQUESTED OPERATION.

C     CALL     SETUP (FUNC, INDX)
C                 FUNC = OPERATION DESCRIPTOR (FROM OPINXJHP.IN)
C                 INDX = STACK INDEX

C     OUTPUT   1. SETUP CODE AS REQUIRED THROUGH 'GEN' & 'BLDBLK'
C              2. STACK ENTRIES MAY BE MODIFIED


C                 ALSO 'SUBOP' AND 'WFSOP'

      SUBROUTINE  SETUP (FUNC, INDX)

      INTEGER     FUNC, INDX

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   STKDEFC.IN,
      'INCLUDE'   STKDEFE.IN, // KEEP IT
      'INCLUDE'   STKDEFF.IN,
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   OPINXJHP.IN,
      'INCLUDE'   RMCODES.IN,
      'INCLUDE'   REGSJHP.IN,
      'INCLUDE'   BRACEFTM.IN,
      'INCLUDE'   SETCOMJHP.IN,
      'INCLUDE'   SETEQUAJH.IN,

      INTEGER     CTN, CTS, CTB

C     EXTERNALS
      INTEGER     NLOPS
      LOGICAL     ZPTST, NLTEST
      EXTERNAL    OLPLO, OLPSB, OLPLC
      'EJECT'
      SOPC = LDAZP
      SWF = WF5
      SWFOPN = WF7
      SSUBOP = LDYZP
      SWFSUB = WF5
      SETSTX = INDX
      SETNLX = NAMEX (SETSTX)
C     CHECK FOR NO OPERAND
      'IF' (SETNLX .EQ. 0)
         CALL FAULTP (10)
         SETNLX = NULLX
         'ENDIF'
      STMODE = MODE (SETSTX)
      SSUBX = SUBX (SETSTX)
      SSUBXM = SUBXM (SETSTX)
      STBIAS = BIAS (SETSTX)
      SSUBXB = 0
      STLOC = LOCFLG (SETSTX) .NE. 0

C     SHORT CIRCUIT IF REGISTER, SET FOR RECOVERY FROM CT
10    'IF' (NLTEST (SETNLX, REGBIT))
C        SET ACTIVE REGISTER IF NOT SET
         TS1 = NLOPS (REGNUM, SETNLX)
         'IF' (STATUS (TS1) .EQ. 0 .AND. FUNC .NE. STAINX)
            STATUS (TS1) = SETSTX
            ACTLO = TS1
            'IF' (STMODE .EQ. DPMODE)
               ACTLO = XREG
               ACTHI = AREG
               'ENDIF'
            'ENDIF'
         GO TO 1
         'ENDIF'
      ZPFLAG = ZPTST (SETNLX, STBIAS)
C     SUBSCRIPTED?
      IF ( SSUBX .NE. 0 ) GO TO 6000

C     PROCESS PARAM [N] AND 'LOC' PARAM [N]
      IF (NLTEST (SETNLX, PBIT)) GO TO 5000

C     PROCESS UNSUBSCRIPTED GROUP1
C     'LOC' REQUESTED?
      'IF' (STLOC)
         SOPC = LDAIMM
         SWFOPN = WF12
         GO TO 1
         'ENDIF'

C     CHECK FOR UNSUBSCRIPTED 'TP' USAGE
C
      IF (NLTEST (SETNLX, TPLBIT)) CALL FAULTP (49)
      'EJECT'
C     NOT A LOC - CONSTANT?
      'IF' (NLTEST (SETNLX, CBIT))

C        HAVE A CONSTANT
         SOPC = LDAIMM
         IF ( STMODE .EQ. DPMODE ) SWFOPN = WF12
         STBIAS = NLOPS (CVALUE, SETNLX)
         SETNLX = NULLX
         'ELSE'

C        NOT A CONSTANT - SIMPLE LOAD
         'IF' (.NOT. ZPFLAG)
            SOPC = LDAABS
            SWF = WF8
            'ENDIF'
         'ENDIF'

C     GENERAL EXIT, RESET THE STACK
1     CALL STSET (SETSTX, SETNLX, STMODE, STBIAS, ^
                  SOPC,   SWF,    SWFOPN)

      SUBX  (SETSTX) = SSUBX
      SUBXB (SETSTX) = SSUBXB
      SUBXM (SETSTX) = SSUBXM
      SUBOP (SETSTX) = SSUBOP
      WFSOP (SETSTX) = SWFSUB

      CALL DUMST ('SETX')
      RETURN
      'EJECT'
C     UNSUBSCRIPTED PARAMETER AND 'LOC' PARAMETER

5000  CALL OVLOD (OLPLO)
      'IF' (.NOT. STLOC)
C        NOT A LOC, CHECK FOR BIAS < 255
         'IF' (STBIAS .LT. 255 .AND. STBIAS .GE. 0)
            CALL PLOAD (SETNLX, STMODE, 1, TS1)     // 'LOC' P -> FL
            SETNLX = FLS (TS1)
            SSUBX = NULLX
            GO TO 6680
            'ENDIF'
C        BIAS IS 'DP'
         CALL PLOAD (SETNLX, STMODE, 2, TS1)        // 'LOC' P -> AREG
         SETNLX = NULLX
         SSUBX = REGS (AREG)
         GO TO 6210
         'ENDIF'
C     'LOC' PARAM
      CALL PLOAD (SETNLX, STMODE, 0, TS1)           // TS1 = P NUMBER
      'IF' (FLSAVE (TS1) .EQ. 0)
         SOPC = LDAABS
         SWF = WF8
         'ELSE'
         SETNLX = FLS (TS1)
         'ENDIF'
      GO TO 1
'EJECT'
C     PROCESS GROUP1 SUBSCRIPT

C     IDENTIFY CHARACTERISTICS OF SUBX
C     A/X/Y=1, 'DP'A=2, S=3, D=4, P=5, 'DP' P=6
6000  TS1 = 3
      IF (NLTEST (SSUBX, REGBIT)) TS1 = 1
      IF (NLTEST (SSUBX, PBIT)) TS1 = 5
      IF ( SSUBXM .EQ. DPMODE ) TS1 = TS1 + 1
      IF (NLTEST (SSUBX, TPLBIT)) CALL FAULTP (49)
C     BASIC DIVISION: NAMEX IS S/D, P, OR LOC
      IF (STLOC) GO TO 8000
      IF (NLTEST (SETNLX, PBIT)) GO TO 7000
C     NOT A PARAMETER OR LOC - PROCESS S/D
      GO TO (6100, 6200, 6300, 6400, 6500, 6500),TS1

C     S [REGISTER + N],  D [REGISTER + N]
6100  SOPC = LDAABY
      SWF = WF8
      SWFOPN = WF7
      GO TO 1

C     S ['DP' AREG + N],  D ['DP' AREG + N]

C     LOOK FOR SPECIAL CASE OF 'LOC' S + N IN ZP
6200  'IF' (STAREG .EQ. 0)
         STAREG = SETSTX + STKSIZ
         ACTLO = XREG
         ACTHI = AREG
         'ENDIF'
      'IF' ( ZPTST (SETNLX, STBIAS) )
C        CAN SHORTCUT; GOES TO  (CT), 'LOC' S + N
         SSUBX = SETNLX
         SSUBXB = STBIAS
         CALL STSET (SLEFT, REGS (AREG), DPMODE, 0, 0, 0, 0)
         'ELSE'
C        DO IT THE HARD WAY
C        'LOC' S + N + 'DP' AREG ->  'DP' AREG
6210     CALL STSET (SRIGHT, SETNLX, DPMODE, STBIAS, ^
                     LDAIMM, WF5, WF12)
         CALL STSET (SLEFT, SSUBX, DPMODE, 0, ^
                     LDAZP, WF5, WF7)
         STAREG = SLEFT
         CALL GEN (PLUS, SLEFT, SRIGHT)
         SSUBX = NULLX
         'ENDIF'
      CTN = 0       // DON'T KNOW WHAT WAS IN THE REGISTER
      GO TO 6600
      'EJECT'
C     S [S' + N],  D [S' + N]

6300  'IF' (.NOT. ZPTST (SSUBX, 0) )
         SSUBOP = LDYABS
         SWFSUB = WF8
         'ENDIF'
      GO TO 6100

C     S [D' + N], D [D' + N]
C     SPECIAL CASE IF D IS IN ZP AND 'LOC' S + N IS ZP
6400  'IF' ( ZPTST (SSUBX, 0) .AND. ZPFLAG)
C        SHORTCUT - DONT NEED CT; USE (D), 'LOC' S + N
         TS1 = SSUBX
         SSUBX = SETNLX
         SETNLX = TS1
         GO TO 6680
         'ENDIF'
      'EJECT'
C     ADDRESS SETUP REQUIRES USE OF CT AND LDA, @YREG

      CTN = NULLX
      CTS = SSUBX
      CTB = 0
      CALL STSET (SLEFT, CTS, DPMODE, 0, LDAABS, WF8, WF7)
      'IF' (ZPTST (SSUBX, 0))   // INDEX IN ZP?
         LOPC = LDAZP
         LWFOP = WF5
         'ENDIF'
      'IF' (ZPFLAG)               // 'LOC' S + N IN ZP
         SSUBX = SETNLX
         SSUBXB = STBIAS
         CALL REGSRC (3, CTN, ADRFLG, CTS, DPMODE, CTB, SCTN)
         IF (SCTN .NE. 0) GO TO 6650
         CALL GEN (COM + 1, SLEFT, SLEFT)
         GO TO 6600
         'ENDIF'
      'IF' (ZPTST (SETNLX, 0))    // 'LOC' S IN ZP
         SSUBX = SETNLX
         SSUBXB = 0
         CTB = STBIAS
         GO TO 6420
         'ENDIF'
      CTN = SETNLX
      'IF' (STBIAS .GE. 0 .AND. STBIAS .LT. 255)
         SSUBX = NULLX
         SSUBXB = STBIAS
         GO TO 6420
         'ENDIF'
      SSUBX = NULLX
      SSUBXB = 0
      CTB = STBIAS
6420  CALL REGSRC (3, CTN, ADRFLG, CTS, DPMODE, CTB, SCTN)
      IF (SCTN .NE. 0) GO TO 6650
      CALL STSET (SRIGHT, CTN, DPMODE, CTB, LDAIMM, WF5, WF12)
      CALL GEN (PLUS, SLEFT, SRIGHT)
      GO TO 6600
      'EJECT'
C     PARAMETER SUBSCRIPT -- BECOMES AREG

6500  CALL OVLOD (OLPLO)
      CALL PLOAD (SSUBX, SSUBXM, 3, TS1)   // P -> AREG
      SSUBX = REGS (AREG)
      STAREG = SETSTX + STKSIZ
      CALL DUMST ('PLOD')
      GO TO 6000

C     'DP' AREG -> CT
6600  STAREG = SLEFT
      CALL REGMAN (SAVREG, AREG, SCTN)
C     SETUP FOR @CT
6650  SETNLX = REGS (SCTN)
      CALL REGSRC (6, CTN, ADRFLG, CTS, DPMODE, CTB, SCTN)
      SSUBOP = LDYIMM
      STATUS (SCTN) = SETSTX
      GO TO 6700

6680  SSUBXB = STBIAS
      SSUBOP = LDYIMM

C     [ZP + Y]

6700  SOPC = LDAINY
      SWF = WF5
      SWFOPN = WF7
      STBIAS = 0
      GO TO 1

C     PARAMETER [SOMETHING]

7000  CALL OVLOD (OLPSB)
      CALL PARSUB
      GO TO 6700

C     'LOC' SOMETHING [SOMETHING ELSE]
8000  'IF' (NLOPS (NAMAT0, SETNLX) .EQ. 0 .AND. STBIAS .EQ. 0)
C        'LOC' [X] SAME AS X
         SETNLX = SSUBX
         STMODE = SSUBXM
         SSUBX  = 0
         STLOC  = .FALSE.
         GO TO 10
         'ENDIF'
      CALL OVLOD (OLPLC)
      CALL PARLOC
      GO TO 1
      END
      'OUTFILE'   PLOADFTM.FR
N     OVERLAY     OLPLO

      SUBROUTINE  PLOAD (INDEX, INMODE, LOAD, PARNO)

C     LOAD = 0    RETURN PARAMETER NUMBER
C            1    MOVE ADDRESS OF PARAM TO FL
C            2    MOVE ADDRESS TO 'DP' AREG
C            3    MOVE VALUE TO AREG ('SP'/'DP')
C

      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   NLARAYFTM.IN,
      'INCLUDE'   REGSJHP.IN,
      'INCLUDE'   RMCODES.IN,
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   BRACEFTM.IN,

      INTEGER     INDEX, INMODE, LOAD, PARNO, STEMP, TS1, TS2
P     INTEGER     PAD (575)   // FOR PDP-11 OVERLAY SIZING

      PARNO = (NLOC (INDEX) - NLOC (PARSAV))/2 + 1
      IF (LOAD .EQ. 0) RETURN
      'IF' (FLSAVE (PARNO) .NE. 0)
         IF (LOAD .EQ. 1) RETURN    // LOAD INTO FL NOT NEEDED
         CALL REGMAN (SAVREG, AREG, STEMP)   // NEED AREG, SAVE IT
         IF (LOAD .EQ. 3) GOTO 100      //LOAD DIRECTLY THROUTH FL
         CALL BLDOP (165, WF5, 0, FLS (PARNO), WF7)  //LDA ZP
         CALL BLDOP (166, WF5, 1, FLS (PARNO), WF7)  //LDX ZP HI
         'ELSE'
         CALL REGMAN (SAVREG, AREG, STEMP)
         CALL BLDOP (173, WF8, 0, INDEX, WF7)    //LDA ABS
         CALL BLDOP (174, WF8, 1, INDEX, WF7)    //LDX ABS HI
         'ENDIF'
      ACTHI = XREG
      ACTLO = AREG
      IF (LOAD .EQ. 2) RETURN
      CALL BLDOP (133, WF5, 0, FLS (PARNO), WF7)   //STA ZP
      CALL BLDOP (134, WF5, 1, FLS (PARNO), WF7)   //STX ZP HI
      FLSAVE (PARNO) = 1
      ACTHI = 0
      ACTLO = 0
      IF (LOAD .EQ. 1) RETURN
      'EJECT'
100   IF (STYREG .NE. 0) ^
         CALL REGMAN (SAVREG, YREG, STEMP)
      'IF' (INMODE .EQ. DPMODE)
C        DO HI BYTE FIRST, TRANSFER TO XREG
         STEMP = 160
         TS1 = WF5
         TS2 = 1
         CALL REGSRC (7, STEMP, TS1, NULLX, 0, TS2, 0)
         IF (STEMP .GE. 0) ^
            CALL BLDOP (STEMP, TS1, TS2, NULLX, WF12)   //LDY IMM 1
         CALL BLDOP (177, WF5, 0, FLS (PARNO), WF7)  //LDA @FL,Y
         CALL BLDBLK (170, WF4)  //TAX
         STEMP = 160
         TS1 = WF5
         TS2 = 0
         CALL REGSRC (7, STEMP, TS1, NULLX, 0, TS2, 0)
         IF (STEMP .GE. 0) ^
            CALL BLDOP (STEMP, TS1, TS2, NULLX, WF7)  //DEY
         ACTHI = XREG
         'ELSE'
         STEMP = 160
         TS1 = WF5
         TS2 = 0
         CALL REGSRC (7, STEMP, TS1, NULLX, 0, TS2, 0)
         IF (STEMP .GE. 0) ^
            CALL BLDOP (STEMP, TS1, TS2, NULLX, WF12)  //LDY IMM 0
         'ENDIF'
      CALL BLDOP (177, WF5, 0, FLS (PARNO), WF7)   //LDA @FL, Y
      ACTLO = AREG
      RETURN
      END
      'OUTFILE'   PARSUBFTM.FR
N     OVERLAY     OLPSB

      SUBROUTINE  PARSUB

      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   REGSJHP.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,   // KEEP IT
      'INCLUDE'   STKDEFE.IN,   // KEEP IT
      'INCLUDE'   STKDEFF.IN,   // KEEP IT
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   BRACEFTM.IN,
      'INCLUDE'   RMCODES.IN,
      'INCLUDE'   SETCOMJHP.IN,
      'INCLUDE'   SETEQUAJH.IN,

      INTEGER     TS
      LOGICAL     ZPTST,  NLTEST
      INTEGER     NLOPS
      EXTERNAL    OLPLO
      'EJECT'
C     PROCESS SUBSCRIPTED PARAMETER (NOT 'LOC')
C
      'IF' (NLTEST (SSUBX, PBIT))
         CALL OVLOD (OLPLO)
         CALL PLOAD (SSUBX, SSUBXM, 3, TS1)   // P -> AREG
         SSUBX = REGS (AREG)
         'ENDIF'
      'IF' (SSUBXM .EQ. SPMODE)
         'IF' (NLTEST (SSUBX, REGBIT))
            TS = NLOPS (REGNUM, SSUBX)
            STATUS (TS) = SETSTX + STKSIZ
            ACTLO = TS
            IF (TS .EQ. XREG)  CALL REGMAN (SAVREG, XREG, TS)
            'ELSE'
            'IF' (.NOT.ZPTST (SSUBX, 0))
               SSUBOP = LDYABS
               SWFSUB = WF8
               'ENDIF'
            'ENDIF'
         'IF' (STBIAS .NE. 0)
C           ADD BIAS TO 'LOC' P  -- USE FL IF POSSIBLE
            CALL STSET (SLEFT, SETNLX, DPMODE, 0, ^
                        LDAABS, WF8, WF7)
            CALL OVLOD (OLPLO)
            CALL PLOAD (SETNLX, STMODE, 0, TS1)   // TS1 = P NUMBER
            'IF' (FLSAVE (TS1) .NE. 0)
C              USE FL
               LNAMEX = FLS (TS1)
               LOPC = LDAZP
               LWFOP = WF5
               'ENDIF'
            CALL STSET (SRIGHT, NULLX, DPMODE, STBIAS, ^
                        LDAIMM, WF5, WF12)
            CALL GEN (PLUS, SLEFT, SRIGHT)
            STBIAS = 0
            STAREG = SLEFT
            CALL REGMAN (SAVREG, AREG, TS)
            SETNLX = REGS (TS)
            STATUS (TS) = SETSTX
            'ELSE'
            CALL OVLOD (OLPLO)
            CALL PLOAD (SETNLX, STMODE, 1, TS)          // 'LOC' P -> FL
            SETNLX = FLS (TS)
            'ENDIF'
         RETURN
         'ENDIF'
      'EJECT'
C     P ['DP' ANYTHING]
      CALL STSET (SLEFT, SSUBX, DPMODE, 0, ^
                  LDAZP, WF5, WF7)
      IF (SSUBX .EQ. REGS (AREG))  STAREG = SLEFT
      'IF' (NLTEST (SSUBX, REGBIT) ^
            .AND. .NOT. ZPTST (SSUBX, 0))
C        P [D], P [D+K]
         LOPC = LDAABS
         LWFOP = WF8
         'ENDIF'
      CALL STSET (SRIGHT, SETNLX, DPMODE, 0, ^
                  LDAABS, WF8, WF7)
      CALL OVLOD (OLPLO)
      CALL PLOAD (SETNLX, STMODE, 0, TS1)   // TS1 = P NUMBER
      'IF' (FLSAVE (TS1) .NE. 0)
C        USE ADDRESS OF P FROM FL
         LNAMEX = FLS (TS1)
         LOPC = LDAZP
         LWFOP = WF5
         'ENDIF'
      CALL GEN (PLUS, SLEFT, SRIGHT)
      STAREG = SLEFT
      'IF' (STBIAS .LT. 255 .AND. STBIAS .GE. 0)
         SSUBXB = STBIAS
         'ELSE'
         CALL STSET (SLEFT, REGS (AREG), DPMODE, 0, ^
                     LDAZP, WF5, WF7)
         CALL STSET (SRIGHT, NULLX, DPMODE, STBIAS, ^
                     LDAIMM, WF5, WF12)
         CALL GEN (PLUS, SLEFT, SRIGHT)

         'ENDIF'
      CALL REGMAN (SAVREG, AREG, TS)
      SETNLX = REGS (TS)
      STATUS (TS) = SETSTX
      SSUBX = NULLX
      SSUBOP = LDYIMM
      RETURN
      END
      'OUTFILE'   PARLOCFTM.FR
N     OVERLAY     OLPLC

      SUBROUTINE  PARLOC

      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   REGSJHP.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,   // KEEP IT
      'INCLUDE'   STKDEFC.IN,
      'INCLUDE'   STKDEFE.IN,   // KEEP IT
      'INCLUDE'   STKDEFF.IN,   // KEEP IT
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   BRACEFTM.IN,
      'INCLUDE'   RMCODES.IN,
      'INCLUDE'   SETCOMJHP.IN,
      'INCLUDE'   SETEQUAJH.IN,

      LOGICAL     ZPTST,  NLTEST
      INTEGER     NLOPS
      EXTERNAL    OLPLO


      CALL CLRSTK (SLEFT)
C     SUBSCRIPTED LOC - CHECK FOR [PARAM]
      'IF' (NLTEST (SSUBX, PBIT))
         CALL OVLOD (OLPLO)
         CALL PLOAD (SSUBX, SSUBXM, 3, TS1)    // P -> AREG
         SSUBX = REGS (AREG)
         'ENDIF'
      LOPC = LDAZP
      LWFOP = WF5
      'IF' (NLTEST (SSUBX, REGBIT))
         'IF' (SSUBX .NE. REGS (AREG))
            CALL REGMAN (SAVREG, AREG, TS2)
C           MOVE REG TO 'DP' AREG   ******
            'ENDIF'
         STAREG = SLEFT
         'IF' (ACTLO .EQ. 0)
            'IF' (SSUBXM .EQ. SPMODE)
               ACTLO = AREG
               'ELSE'
               ACTHI = AREG
               ACTLO = XREG
               'ENDIF'
            'ENDIF'
         'ELSE'
         'IF' (.NOT. ZPTST (SSUBX, 0))
            LOPC = LDAABS
            LWFOP = WF8
            'ENDIF'
         'ENDIF'
      'EJECT'
      LNAMEX = SSUBX
      LMODE = SSUBXM
      LWFOPN = WF7
      'IF' (NLTEST (SETNLX, PBIT))
         'IF' (STBIAS .NE. 0)
            CALL STSET (SRIGHT, NULLX, DPMODE, STBIAS, ^
                        LDAIMM, WF5, WF12)
            CALL GEN (PLUS, SLEFT, SRIGHT)
            STAREG = SLEFT
            STBIAS = 0
            CALL CLRSTK (SRIGHT)
            LNAMEX = REGS (AREG)
            LMODE = DPMODE
            LOPC = LDAZP
            LWFOP = WF5
            'ENDIF'
         CALL OVLOD (OLPLO)
         CALL PLOAD (SETNLX, STMODE, 0, TS1)   // TS1 = P NUMBER
         'IF' (FLSAVE (TS1) .NE. 0)
            RNAMEX = FLS (TS1)
            ROPC = LDAZP
            RWFOP = WF5
            'ELSE'
            ROPC = LDAABS
            RWFOP = WF8
            RNAMEX = SETNLX
            'ENDIF'
         RMODE = STMODE
         RWFOPN = WF7
         'ELSE'
         CALL STSET (SRIGHT, SETNLX, DPMODE, STBIAS, ^
                     LDAIMM, WF5, WF12)
         'ENDIF'
      CALL GEN (PLUS, SLEFT, SRIGHT)
      STAREG = SETSTX
      STXREG = 0
      SETNLX = REGS (AREG)
      STMODE = DPMODE
      SSUBX = 0
      LOCFLG (SETSTX) = 0
      SOPC = LDAZP
      SWF = WF5
      SWFOPN = WF7
      RETURN
      END
      'OUTFILE' STSETFTM.FR

      SUBROUTINE STSET (ROW, SNAMEX, SMODE, SBIAST, SOPCOD, ^
                        SWFOP, SWFOPN)

      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   STKDEFE.IN,
      'INCLUDE'   STKDEFF.IN,

      INTEGER ROW, SNAMEX, SMODE, SBIAST, SOPCOD
      INTEGER SWFOP, SWFOPN

      CALL CLRSTK (ROW)
      NAMEX (ROW) = SNAMEX
      MODE  (ROW) = SMODE
      BIAS  (ROW) = SBIAST
      OPCODE(ROW) = SOPCOD
      WFOP  (ROW) = SWFOP
      WFOPND(ROW) = SWFOPN
      RETURN
      END
      'OUTFILE'   ZPTSTJHP.FR

C     NAME     ZPTST
C     MODULE#

C     PURPOSE  SEE IF A NAME LIST ENTRY IS ZERO PAGE ADDRESSABLE

C     CALL     ZPTST (ZNLX, ZBIAS)
C                 ZNLX  = NAME LIST INDEX
C                 ZBIAS = CONSTANT BIAS

C     OUTPUT   FUNCTION VALUE .TRUE. IF ZP IS OK

      LOGICAL FUNCTION ZPTST (ZNLX, ZBIAS)

      'INCLUDE'   LCFUNCAJH.IN,
      'INCLUDE'   NLISTCFTM.IN,

      INTEGER     ZNLX, ZBIAS, TS1, TS2
      INTEGER     NLOPS
      LOGICAL     NLTEST

      ZPTST = .FALSE.
C     IS NAME DEFINED?
      'IF' ( NLOPS (DFINED, ZNLX) .NE. 0 )
C        YES - CHECK LOCATION
         TS1 = NLOPS (NLXLCI, ZNLX)
         TS2 = NLOPS (NAMLOC, ZNLX) + ZBIAS
C        CHECK LOW CORE ADDRESS
         IF ( ( TS1 .EQ. ZREL .OR. TS1 .EQ. ABSLC ) ^
                .AND. TS2 .GE. 0 .AND. TS2 .LT. 255 ) ZPTST = .TRUE.
C        NOT DEFINED - CHECK EXTD
         'ELSE'
         IF (NLTEST (ZNLX, EXDBIT) .AND. ZBIAS .LT. 256) ^
            ZPTST = .TRUE.
         'ENDIF'
      RETURN
      END



\\\\\


SUBFILE: GENAJH.FS @15:59 23-MAY-1979 <055> (4235)
'HEAD'  INTERFACE TO CODE GENERATION
C     EDIT DATE   05FEB79  16:57
C     SOURCE FILE GENAJH.FS
C     AUTHOR      A. J. HOWARD
C     CLUSTER     19

      'OUTFILE'   GENDATA.FR
      BLOCK DATA

      'INCLUDE'   GENCOMAJH.IN,P

      DATA  BCC   / 144/   // 090
      DATA  BNE   / 208/   // 0D0
      DATA  CLC   /  24/   // 018
      DATA  JMP   /  76/   // 04C
      DATA  LDAABS/ 173/   // 0AD
      DATA  LDAI  / 169/   // 0A9
      DATA  LDAZP / 165/   // 0A5
      DATA  SBCI  / 233/   // 0E9
      DATA  SEC   /  56/   // 038
      DATA  STAZP / 133/   // 085
      DATA  TAX   / 170/   // 0AA
      DATA  TXA   / 138/   // 08A

      DATA  LOW   / 1/
      DATA  HI    / 2/
      DATA  INTBR / 0/
      DATA  LSTKX / 0/
      DATA  RSTKX / 0/
      END
      'OUTFILE'   IGENAJH.FR
      SUBROUTINE  GEN (OPIN, LEFTIN, RIN)

      INTEGER     OPIN, LEFTIN, RIN

      'INCLUDE'   GENCOMAJH.IN,
      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   REGSJHP.IN,
      'INCLUDE'   STKDEFA.IN,

      EXTERNAL    OLAGN, OLCGN, OLSGN, OLMGN, OLUGN, OLARA, OLARB

      'IF' (LOGICF .EQ. 0)
         CALL FAULTP (4)      // CAN'T GENERATE CODE IN THE NOUNLIST
         RETURN
         'ENDIF'
      OP = OPIN
      LEFT = LEFTIN
      RIGHT = RIN
      'IF' (OP .EQ. -2)
C        PRESET OF INTBR FOR LOOP CODE
C
         INTBR = LEFT
         RETURN
         'ENDIF'
      'IF' (OP .EQ. -1)
C        PRE/POST GEN CALL FOR USER ARROW
C
         LSTKX = LEFT + 2
         RSTKX = RIGHT + 2
         RETURN
         'ENDIF'
1     THIS = LOW              // ASSUME LOW/HI SEQUENCE
      OTHER = HI
      SIDE = LEFT
      EZSTA = .FALSE.
      MORE  = .FALSE.
      CALL DUMST ('GEN0')
      BASE = OP - EQUAL + 1
      GO TO (  100, 100, 100, 100, 100, 100, ^ // = # > >= < <=
               600, ^                          // ->
               200, 200, ^                     // + -
               500, 500, 500, ^                // * / 'MOD'
                 6,   6, ^                     // 'OR' & RELATIONAL
               200, 200, 200, ^                // 'OR' 'XOR' &
               300, 300, 300, 300, 300, 300, ^ // 'LS' 'RS' 'LC' 'RC'
                    ^                          // 'ALS' 'ARS'
               400, 400, 400, 400, ^           // NEG ^ 'DEC' 'COM'
               200  ^   // LOAD
         ), BASE
      'EJECT'
6     CALL FATAL (6)

C     CONDITIONAL OPERATOR
100   CALL OVLOD (OLCGN)
      CALL CGEN
      GO TO 1000

200   CALL OVLOD (OLAGN)
      CALL AGEN
      GO TO 1000

C     SHIFT OPERATOR
300   CALL OVLOD (OLSGN)
      CALL SGEN
      GO TO 1000

C     UNARY OPERATOR
400   CALL OVLOD (OLUGN)
      CALL UGEN
      GO TO 1000

C     MULTIPLY, DIVIDE, MOD
500   CALL OVLOD (OLMGN)
      CALL MGEN
      GO TO 1000

C     STORE
600   CALL OVLOD (OLARA)
      CALL ARAGEN
      'IF' (MORE)
         CALL OVLOD (OLARB)
         CALL ARBGEN
         IF (MORE) GO TO 600
         'ENDIF'

1000  IF (MORE) GO TO 1

C     RELEASE ANY CT REGISTERS USED FOR THIS OPERATION
C
      'DOLOOP' I = 4, NRREGS
         TS = STATUS (I)
         IF (TS .EQ. LEFTIN .OR. TS .EQ. LEFTIN + STKSIZ ^
             .OR. TS .EQ. RIN .OR. TS .EQ. RIN + STKSIZ) ^
            STATUS (I) = 0
         'END'
      RETURN
      END
      'HEAD' ARITHMETIC CODE GENERATION
      'OUTFILE'   AGENAJH.FR

N     OVERLAY     OLAGN

      SUBROUTINE  AGEN

C     OP          LOGOS OPERATOR
C     LEFT        STACK POINTER TO LEFT  OPERAND
C     RIGHT       STACK POINTER TO RIGHT OPERAND

      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   REGSJHP.IN,
      'INCLUDE'   RMCODES.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   GENCOMAJH.IN,


      'IF' (OP .EQ. COM + 1)  // LOAD

C        LOAD THE AREG WITH LEFT [THIS], IF IT'S NOT THERE
         'IF' (STAREG .NE. LEFT)
            'IF' (MODE (LEFT) .EQ. DPMODE)
               CALL GLXY (XREG)
               THIS = HI
               'ENDIF'
            CALL GENLA
            'ENDIF'
         RETURN
         'ENDIF'
      'EJECT'
C     OP IS  +, -, 'OR', 'XOR', &

      'IF' (MODE (LEFT) .EQ. DPMODE)
         'IF' (OP .EQ. PLUS .OR. OP .EQ. MINUS)
C           OPERATION MUST BE DONE LOW/HI
            'IF' (STAREG .EQ. LEFT .AND. ACTHI .EQ. AREG)
C              SAVE THE HI BYTE, LOAD THE LOW BYTE
               THIS = HI
               OTHER = LOW
               CALL GENMOV
               'ENDIF'
            'ELSE'
C           OP IS 'OR' 'XOR' &. THE OPERATION CAN BE DONE
C           IN EITHER ORDER (LOW/HI OR HI/LOW)
            'IF' (STAREG .EQ. LEFT .AND. ACTHI .EQ. AREG)
C              THE AREG ALREADY HAS THE HI BYTE.
C              DO THE OPERATION HI/LOW
               THIS = HI
               OTHER = LOW
               'ENDIF'
            'ENDIF'
         'ENDIF'

C     LOAD THE AREG WITH LEFT [THIS], IF IT'S NOT THERE
      'IF' (STAREG .NE. LEFT)
         CALL GENLA
         'ENDIF'

C     IF OP IS +, GENERATE $CLC
      'IF' (OP .EQ. PLUS)
         CALL BLDBLK (CLC, WF4)
         'ELSE'
C        IF OP IS -, GENERATE $SEC
         'IF' (OP .EQ. MINUS)
            CALL BLDBLK (SEC, WF4)
            'ENDIF'
         'ENDIF'

C     DO THE OPERATION WITH RIGHT [THIS]
      SIDE = RIGHT
      CALL GENDO
      'EJECT'
      'IF' (MODE (LEFT) .EQ. SPMODE .AND. MODE (RIGHT) .EQ. SPMODE)
         MODE (LEFT) = SPMODE
         ACTHI = 0
         'ELSE'

C        DOUBLE PRECISION OPERATIONS

C        SETUP FOR THE SECOND HALF OF THE OPERATION
         SIDE = LEFT
         CALL GENMOV

C        DO THE OPERATION WITH THE OTHER HALF (NOW THIS HALF)

         SIDE = RIGHT
         CALL GENDO
         MODE (LEFT) = DPMODE
         MODE (RIGHT) = DPMODE
         'ENDIF'
      CALL REGMAN (CLRACX, AREG, 0)
      RETURN
      END
      'HEAD' MULT / DIVIDE / MOD
      'OUTFILE'   MGENAJH.FR
N     OVERLAY     OLMGN

      SUBROUTINE  MGEN

      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   NLNAMEFTM.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   RMCODES.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   GENCOMAJH.IN,

      INTEGER     MNAME (6), DNAME (5)
      INTEGER     SNMLST

      DATA        MNAME / 'CXXMULTIPLY ' /
      DATA        DNAME / 'CXXDIVIDE '   /
      'EJECT'
      'IF' (OP .EQ. MULT)
         CALL MOVE (MNAME, NAME, 6)      // *
         CALL PCHAR (NAME, 1, 11)
         'ELSE'
         CALL MOVE (DNAME, NAME, 5)      // / 'MOD'
         CALL PCHAR (NAME, 1, 9)
         'ENDIF'
      'IF' (MODE (LEFT) .EQ. SPMODE)
         CALL PCHAR (NAME, 2, 'SS')
         'ELSE'
         CALL PCHAR (NAME, 2, 'DD')
         'ENDIF'
      'IF' (MODE (RIGHT) .EQ. SPMODE)
         CALL PCHAR (NAME, 3, 'SS')
         'ELSE'
         CALL PCHAR (NAME, 3, 'DD')
         'ENDIF'
      NLX = SNMLST (NAME)
      CALL BLDOP (32, WF8, 0, NLX, WF7)  // JSR
      TS = MODE (LEFT)
      CALL CLRSTK (LEFT)
      NAMEX (LEFT) = REMNLX
      IF (OP .NE. MODOP) BIAS (LEFT) = 4
      'IF' (TS .EQ. DPMODE)
         MODE (LEFT) = DPMODE
         'ELSE'
         'IF' (OP .EQ. MULT .AND. MODE (RIGHT) .EQ. DPMODE)
            MODE (LEFT) = DPMODE
            'ELSE'
            MODE (LEFT) = SPMODE
            'ENDIF'
         'ENDIF'
      CALL REGMAN (CLRACV, 0, 0)
      RETURN
      END
      'HEAD' SHIFT CODE GENERATION
      'OUTFILE'   SGENAJH.FR
N     OVERLAY     OLSGN

      SUBROUTINE  SGEN


      'INCLUDE'   CODE1FTM.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   REGSJHP.IN,
      'INCLUDE'   RMCODES.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   STKDEFC.IN,
      'INCLUDE'   STKDEFE.IN,
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   GENCOMAJH.IN,

      INTEGER     SEQS, SEQCT, DEXTLI, BMITLI
      INTEGER     SHOP, OPTS, CTNX, SHFTLI
      LOGICAL     VARSHF

      'EJECT'
      MODE (RIGHT) = SPMODE

C     IS SHIFT COUNT A CONSTANT
      'IF' (NAMEX (RIGHT) .EQ. NULLX .AND. OPCODE (RIGHT) .EQ. LDAI)
         VARSHF = .FALSE.        // YES
         SEQS = BIAS (RIGHT)
         'ELSE'
         VARSHF = .TRUE.         // NO
         SEQS = 1
C        GET THE SHIFT COUNT INTO XREG
         SIDE = RIGHT
         CALL GLXY (XREG)
         'ENDIF'

C     LOAD THE VALUE TO BE SHIFTED INTO THE AREG
      'IF' (STAREG .NE. LEFT)
         SIDE = LEFT
         IF (.NOT. VARSHF .AND. SEQS .EQ. 1 ^
             .AND. MODE (LEFT) .EQ. DPMODE  ^
             .AND. (OP .EQ. LSHIFT .OR. OP .EQ. RSHIFT)) GO TO 2000
         CALL GENLA
         IF (MODE (LEFT) .EQ. DPMODE) CALL GENMOV
         STAREG = LEFT
         'ENDIF'

C     CLEAR THE LOC BIT OF LEFT
      LOCFLG (LEFT) = 0

C     CHECK FOR CONSTANT SHIFT OF 0
      IF (SEQS .EQ. 0) RETURN

C     GENERATE THE SEQUENCES FOR SPECIFIC SHIFTS
      SHOP = OP - LSHIFT + 1
      'IF' (MODE (LEFT) .EQ. DPMODE)
         SHOP = SHOP + 6
         CALL REGMAN (SAVREG, AREG, CTNX)
         CTNX = REGS (CTNX)
         'ELSE'
         'IF' (OP .EQ. RCYCLE)
            CALL REGMAN (CTFREE, CTNX, 1)
            CTNX = REGS (CTNX)
            CALL BLDOP (STAZP, WF5, 0, CTNX, WF7)
            'ENDIF'
         'ENDIF'

C     BUILD THE LOOP CODE IF NEEDED
      'IF' (VARSHF)
         CALL DEFTL (TLI)
         DEXTLI = TLI
         TLI = TLI + 1
         CALL BLDBLK (202, WF4)                  // DEX (0CA)
         BMITLI = TLI
         TLI = TLI + 1
         CALL BLDOP (48, WF5, 0, BMITLI, WF9)    // BMI (030)
         'ENDIF'
      'EJECT'
      'DOLOOP' SEQCT = 1, SEQS
         GO TO (100, 200, 300, 400, 100,  200, ^
                500, 600, 700, 800, 900, 1000), SHOP

C        'LS'  'ALS'
100      CALL BLDBLK (10, WF4)                   // ASL AREG
         'NEXT'

C        'RS'  'ARS'
200      CALL BLDBLK (74, WF4)                   // LSR AREG
         'NEXT'

C        'LC'
300      CALL BLDBLK (CLC, WF4)
         CALL BLDBLK (42,  WF4)                  // ROL AREG
         CALL BLDOP  (105, WF5, 0, NULLX, WF7)   // ADC #0
         'NEXT'

C        'RC'
400      CALL BLDOP  (102, WF5, 0, CTNX, WF7)    // ROR CTN FOR CARRY
         CALL BLDBLK (106, WF4)                  // ROR AREG
         'NEXT'

C        'DP' 'LS'
500      CALL BLDOP (  6, WF5, 0, CTNX, WF7)     // ASLZP CTN
         CALL BLDOP ( 38, WF5, 1, CTNX, WF7)     // ROLZP CTN+1
         'NEXT'

C        'DP' 'RS'
600      CALL BLDOP ( 70, WF5, 1, CTNX, WF7)     // LSRZP CTN+1
         CALL BLDOP (102, WF5, 0, CTNX, WF7)     // RORZP CTN
         'NEXT'

C        'DP' 'LC'
700      CALL BLDOP  (LDAZP, WF5, 0, CTNX, WF7)
         CALL BLDBLK (42, WF4)                   // ROL AREG
         CALL BLDOP  (38, WF5, 1, CTNX, WF7)     // ROLZP
         CALL BLDOP  (38, WF5, 0, CTNX, WF7)     // ROLZP
         'NEXT'

C        'DP' 'RC'
800      CALL BLDOP  (LDAZP, WF5, 0, CTNX, WF7)
         CALL BLDBLK (106, WF4)                  // ROR AREG
         CALL BLDOP  (102, WF5, 1, CTNX, WF7)    // RORZP
         CALL BLDOP  (102, WF5, 0, CTNX, WF7)    // RORZP
         'NEXT'

C        'DP' 'ALS'
900      CONTINUE

C        'DP' 'ARS'
1000     CALL FAULTP (15)
         'END'
      'EJECT'
C     BRANCH TO TEST CODE IF VARIABLE SHIFT COUNT
C
      'IF' (VARSHF)
         CALL BLDOP (76, WF8, 0, DEXTLI, WF9)    // JMP
         CALL DEFTL (BMITLI)
         CALL REGMAN (CLRACX, NZREG, 0)
         'ENDIF'
      CALL REGMAN (CLRACX, AREG, 0)
      RETURN

C     'DP' 'LS' 1 OR 'DP' 'RS' 1
2000  'IF' (OP .EQ. LSHIFT)
         CALL GENLA
         CALL BLDBLK (10, WF4)    // ASL A
         CALL GENMOV
         CALL BLDBLK (42, WF4)    // ROR A
         'ELSE'
         THIS = HI
         OTHER = LOW
         CALL GENLA
         CALL BLDBLK (74, WF4)    // LSR A
         CALL GENMOV
         CALL BLDBLK (106, WF4)   // ROL A
         'ENDIF'
      RETURN
      END
      'HEAD' UNARY CODE GENERATION
      'OUTFILE'   UGENAJH.FR
N     OVERLAY     OLUGN

      SUBROUTINE  UGEN

C     GENERATE CODE FOR UNARY OPERATORS -- NEG, INC, DEC, COM

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   CODE1FTM.IN,
      'INCLUDE'   GENCOMAJH.IN,
      'INCLUDE'   GENCOMFTM.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   REGSJHP.IN,
      'INCLUDE'   RMCODES.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   STKDEFE.IN,
      'INCLUDE'   WFLAGSJHP.IN,

      INTEGER     OPTS, INCTLI, UMODE, OPTYPE, TSTK, LEFTTS
      INTEGER     OP1, OP2
      INTEGER     NLOPS
      LOGICAL     NLTEST

      DATA        TSTK  / 20/

      OPTS = OP - NEG + 1
      LEFTTS = LEFT
      SIDE = RIGHT
      UMODE = MODE (SIDE)
      OPTYPE = 4
      NLX = NAMEX (SIDE)
      'IF' (NLTEST (NLX, REGBIT))
         OPTYPE = NLOPS (REGNUM, NLX)
         'IF' (STATUS (OPTYPE) .EQ. 0)
            STATUS (OPTYPE) = SIDE
            ACTHI = AREG
            ACTLO = OPTYPE
            'ENDIF'
         'IF' (UMODE .EQ. SPMODE)
            ACTHI = 0
            'ELSE'
            OPTYPE = 5
            'ENDIF'
         'ENDIF'
      GO TO (100, 200, 300, 400), OPTS
1     RETURN
      'EJECT'
C     OP IS NEG

C     GET THE AREG
100   CALL REGMAN (SAVREG, AREG, DUMMY)
      IF (ACTLO .EQ. XREG) CALL REGMAN (SAVREG, XREG, DUMMY)
      IF (ACTLO .EQ. YREG) CALL REGMAN (SAVREG, YREG, DUMMY)

      CALL BLDOP (169, WF5, 0, NULLX, WF7)      // LDA =0
      CALL BLDBLK (SEC, WF4)                    // SET CARRY
      CALL GENDO                                // SUBTRACT
      'IF' (UMODE .EQ. DPMODE)
         CALL REGMAN (SAVREG, XREG, DUMMY)
         CALL BLDBLK (TAX, WF4)
         ACTLO = XREG
         CALL BLDOP (169, WF5, 0, NULLX, WF7)   // LDA =0
         THIS = HI
         CALL GENDO                             // SUBTRACT
         'ENDIF'
      CALL REGMAN (CLRACX, AREG, 0)
      GOTO 1
      'EJECT'
C     OP IS INC
200   IF (LEFT .NE. 0) ^
         CALL REGSRC (5, NAMEX (LEFT), 0, 0, 0, 0, 0)
      GO TO (210, 220, 230, 240, 250), OPTYPE

C     INC AREG
210   CALL BLDBLK (CLC, WF4)
      CALL BLDOP  (105, WF5, 1, NULLX, WF7)  // ADC =1
      CALL REGMAN (CLRACX, AREG, 0)
      GO TO 1

C     INC XREG
220   CALL BLDBLK (232, WF4)                 // INX
      GO TO 1

C     INC YREG
230   CALL BLDBLK (200, WF4)                 // INY
      CALL REGMAN (CLRACX, YREG, 0)
      GO TO 1

C     INC CORE
240   'IF' (IAND (OPCODE (SIDE), 7) .EQ. 5)
         CALL GENDO        // INC RIGHT [0]
         'IF' (UMODE .EQ. DPMODE)
C           DOUBLE PRECISION
            INCTLI = TLI
            TLI = TLI + 1
            CALL BLDOP (BNE, WF5, 0, INCTLI, WF9)
            THIS = HI         // HI BYTE
            CALL GENDO        // INC RIGHT [1]

C           DEFINE THE ADDRESS OF THE BNE
            CALL DEFTL (INCTLI)
            CALL REGMAN (CLRACX, NZREG, 0)
            GO TO 1
            'ENDIF'
         'ELSE'
C        MUST ADD 1, BUT IT IS LEFT IN THE AREG
         OP1 = CLC
         OP2 = 105        // ADC
         GO TO 500
         'ENDIF'
      GO TO 345

C     INC  'DP' AREG: CHANGE TO 'DP' AREG + 1
250   OP = PLUS
251   MORE = .TRUE.
      LEFT = RIGHT
      RIGHT = TSTK
      CALL STSET (RIGHT, NULLX, SPMODE, 1, LDAI, WF5, WF7)
      GO TO 1
      'EJECT'
C     OP IS 'DEC'
300   IF (LEFT .NE. 0) ^
         CALL REGSRC (5, NAMEX (LEFT), 0, 0, 0, 0, 0)
      GO TO (310, 320, 330, 340, 350), OPTYPE

C     'DEC' AREG
310   CALL BLDBLK (SEC, WF4)
      CALL BLDOP  (233, WF5, 1, NULLX, WF7)  // SBC =1
      GO TO 1

C     'DEC' XREG
320   CALL BLDBLK (202, WF4)                 // DEX
      GO TO 1

C     'DEC' YREG
330   CALL BLDBLK (136, WF4)                 // DEY
      CALL REGMAN (CLRACX, YREG, 0)
      GO TO 1

C     'DEC' CORE
340   'IF' (UMODE .EQ. SPMODE .AND. IAND (OPCODE (SIDE), 7) .EQ. 5)
C        CAN DO IT DIRECTLY
         CALL GENDO
         'ELSE'
C        MUST SUBTRACT 1, BUT IT IS LEFT IN THE AREG
         OP1 = SEC
         OP2 = 233        // SBC
         GO TO 500
         'ENDIF'
345   CALL REGMAN (SETREG, NZREG, LEFTTS)
      GO TO 1

C     'DEC' 'DP' AREG: CHANGE TO 'DP' AREG - 1
350   OP = MINUS
      GO TO 251
      'EJECT'
C     OP IS 'COM'
400   GO TO (440, 420, 430, 440, 440), OPTYPE

C     'COM' XREG
420   CALL GENTRA (XREG, AREG)
      GO TO 440

C     'COM' YREG
430   CALL GENTRA (YREG, AREG)

440   'IF' (STAREG .NE. SIDE)
         CALL REGMAN (SAVREG, AREG, DUMMY)
         CALL GENDO
         'ENDIF'
      CALL BLDOP (73, WF5, 255, NULLX, WF7)     // EOR =0FF
      CALL REGMAN (CLRACX, AREG, 0)
      IF (UMODE .EQ. SPMODE) GO TO 1
      LEFT = SIDE
      CALL GENMOV
      CALL BLDOP (73, WF5, 255, NULLX, WF7)     // EOR =0FF
      GO TO 1
      'EJECT'
C     COMMON CODE FOR TOUGH INCREMENT AND DECREMENT

500   CALL REGMAN (SAVREG, AREG, DUMMY)
      'DOLOOP' THIS = LOW, HI
         LEFT = SIDE
         RIGHT = 0
         'IF' (THIS .EQ. LOW)
            CALL GENDO
            CALL BLDBLK (OP1, WF4)               // CLC/SEC
            'ELSE'
            'IF' (NEXTOP .GT. RBRACE)
               CALL REGMAN (SAVREG, XREG, DUMMY)
               CALL BLDBLK (TAX, WF4)
               'ENDIF'
            CALL GENDO
            'ENDIF'
         CALL BLDOP  (OP2, WF5, 2-THIS, NULLX, WF7)   // ADC/SBC =1/=0
         RIGHT = SIDE
         LEFT = 0
         BASE = ARROW - EQUAL + 1
         CALL GENDO
         'IF' (UMODE .EQ. SPMODE)
            'BREAK'
            'ENDIF'
         IF (NEXTOP .GT. RBRACE) ACTLO = XREG
         'END'
      CALL REGMAN (SETREG, AREG, LEFTTS)
      CALL GENER (OUT)
      GO TO 345
      END




\\\\\


SUBFILE: GENDOA.FS @15:59 23-MAY-1979 <055> (2033)
'HEAD'  BASE LEVEL CODE GENERATION
C     EDIT DATE   05FEB79  14:13
C     SOURCE FILE GENDOAJH.FS
C     AUTHOR      A. J. HOWARD
C     CLUSTER     19

      'OUTFILE'   GENDOAJH.FR
      SUBROUTINE  GENDO

      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   REGSJHP.IN,
      'INCLUDE'   RMCODES.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   STKDEFE.IN,
      'INCLUDE'   STKDEFF.IN,
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   GENCOMAJH.IN,

      INTEGER     OPTS,   WFTS,   BIASTS, TSUBX
      INTEGER     DUMMY,  TSUBXB, TSUBOP, TWFSOP
      INTEGER     NAMXTS
      INTEGER     MAGIC (28)

      INTEGER     NLOPS
      LOGICAL     NLTEST

      DATA  MAGIC / ^      // CONVERT FROM LDA TO REAL OP CODE
           32,      ^      // =
           32,      ^      // #
           64,      ^      // >
           64,      ^      // >=
           64,      ^      // <
           64,      ^      // <=
          -32,      ^      // ->
          -64,      ^      // +
           64,      ^      // -
            0, 0, 0,^      // * / 'MOD' NOT USED
            0, 0,   ^      // 'OR' & RELATIONAL NOT USED
         -160,      ^      // 'OR'
          -96,      ^      // 'XOR'
         -128,      ^      // &
            0, 0, 0,^      // SHIFTS USE LOAD
            0, 0, 0,^      // SHIFTS USE LOAD
           64,      ^      // NEG SAME AS -
           65,      ^      // ^
           33,      ^      // 'DEC'
            0,      ^      // 'COM' USES LOAD
            0/             // LOAD
      'EJECT'
C     IF THE SIDE IS RIGHT TURN THE LOAD OP CODE INTO
C     THE PROPER OP CODE FOR THE OPERATION

C     GENERATE THE INSTRUCTION

C     SET ACTREG (THIS) = AREG

      'IF' (MODE (SIDE) .EQ. SPMODE .AND. THIS .EQ. HI)
C        THE HI BYTE OF AN SP VALUE IS 0
         OPTS = LDAI
         IF (SIDE .EQ. RIGHT) OPTS = OPTS + MAGIC (BASE)
         CALL BLDOP (OPTS, WF5, 0, NULLX, WF7)
         'ELSE'
         OPTS = OPCODE (SIDE)
C        ADJUST THE BIAS AND WORD FLAG AS NEEDED
         BIASTS = BIAS (SIDE)
         WFTS = WFOPND (SIDE)
         TSUBX = SUBX (SIDE)
         NAMXTS = NAMEX (SIDE)
         'IF' (SIDE .EQ. RIGHT)
C           CONVERT OPCODE FROM LOAD
            OPTS = OPTS + MAGIC (BASE)
            'ELSE'
            'IF' (NLTEST (NAMXTS, REGBIT))
               CALL GENTRA (NLOPS (REGNUM, NAMXTS), AREG)
               RETURN
               'ENDIF'
            'ENDIF'
         IF (TSUBX .NE. 0) ^         // SUBSCRIPTED ?
            GO TO 200
C        NO SUBSCRIPT
         'IF' (THIS .EQ. HI)
            'IF' (WFTS .LE. WF8)
               BIASTS = BIASTS + 1
               'ELSE'
               WFTS = WFTS + 1
               'ENDIF'
            'ENDIF'
100      CALL BLDOP (OPTS, WFOP (SIDE), BIASTS, NAMXTS, WFTS)
         'ENDIF'
      IF (.NOT. EZSTA) ACTREG (THIS) = AREG
      RETURN
'HEAD' SUBSCRIPT CODE GENERATION
      'EJECT'
200   'IF' (NLTEST (TSUBX, REGBIT))
C        REGISTER AS SUBSCRIPT
         TS = NLOPS (REGNUM, TSUBX)
         'IF' (TS .EQ. AREG)
            CALL REGMAN (SAVREG, YREG, DUMMY)
            CALL BLDBLK (168, WF4)           // TAY
            SUBX (SIDE) = REGS (YREG)
            'ELSE'
            IF (TS .EQ. XREG) ^
               OPTS = OPTS + 4               // USE XREG FORM
            'ENDIF'
         'IF' (THIS .EQ. HI)
            'IF' (OPCODE (SIDE) .EQ. 177)    // LDA @Y
               CALL BLDBLK (200, WF4)        // INY
               CALL REGMAN (CLRACX, YREG, 0)
               'ELSE'
               BIASTS = BIASTS + 1
               'ENDIF'
            'ENDIF'
         'ELSE'
C        SUBSCRIPT IS NOT A REGISTER
         TSUBXB = SUBXB (SIDE)
         'IF' (THIS .EQ. HI)
            'IF' (OPCODE (SIDE) .EQ. 177)    // LDA @ Y
               TSUBXB = TSUBXB + 1           // ADJUST YREG VALUE
               'ELSE'
               BIASTS = BIASTS + 1           // ADJUST ADDRESS BIAS
               'ENDIF'
            'ENDIF'
         TSUBOP = SUBOP (SIDE)
         TWFSOP = WFSOP (SIDE)
         CALL REGSRC (7, TSUBOP, TWFSOP, TSUBX, 0, TSUBXB, 0)
         IF (TSUBOP .GE. 0) ^
            CALL BLDOP (TSUBOP, TWFSOP, TSUBXB, TSUBX, WF7)
         'ENDIF'
      GO TO 100
      END
'HEAD' LOAD A REGISTER
      'OUTFILE'   GENLAAJH.FR
      SUBROUTINE  GENLA

      'INCLUDE'   GENCOMAJH.IN,
      'INCLUDE'   REGSJHP.IN,
      'INCLUDE'   RMCODES.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,

      INTEGER     X, TRACK

      'IF' (SIDE .EQ. LEFT)
         TRACK = LSTKX
         'ELSE'
         TRACK = RSTKX
         'ENDIF'
      X = 0
      IF (TRACK .NE. 0) ^
         CALL REGSRC (2, NAMEX (LSTKX), MODE (LSTKX), ^
                         SUBX  (LSTKX), SUBXM (LSTKX), ^
                         BIAS  (LSTKX), X)
      'IF' (X .NE. AREG)
         IF (STAREG .NE. SIDE + STKSIZ) ^
            CALL REGMAN (SAVREG, AREG, X)
         CALL GENDO
         'ENDIF'
      'IF' (TRACK .NE. 0)
         CALL REGMAN (SETREG, AREG, TRACK)
         'ELSE'
         CALL REGMAN (CLRACX, AREG, 0)
         'ENDIF'
      RETURN
      END
'HEAD' TRANSFER REGISTER/REGISTER
      'OUTFILE'   GENTRAAJH.FR
      SUBROUTINE  GENTRA (INREG, OUTREG)

      INTEGER     INREG, OUTREG

      'INCLUDE'   REGSJHP.IN,
      'INCLUDE'   RMCODES.IN,
      'INCLUDE'   WFLAGSJHP.IN,

      INTEGER     REGREG (3, 3), X, DUMMY

      DATA        REGREG / ^
                       0,  ^ // ERROR
                     138,  ^ // TXA
                     152,  ^ // TYA
                     170,  ^ // TAX
                       0,  ^ // ERROR
                       0,  ^ // ERROR
                     168,  ^ // TAY
                       0,  ^ // ERROR
                       0/    // ERROR

      CALL REGMAN (SAVREG, OUTREG, DUMMY)
      X = REGREG (INREG, OUTREG)
      IF (X .EQ. 0) CALL FAULTP (6)
      CALL BLDBLK (X, WF4)
      STATUS (OUTREG) = STATUS (INREG)
      STATUS (INREG)  = 0
      ACTLO = OUTREG
      CALL REGMAN (TRAREG, INREG, OUTREG)
      RETURN
      END
'HEAD' LOAD X/Y REGISTER
      'OUTFILE'   GENLXYAJH.FR
      SUBROUTINE  GENLXY (OREG)
      'INCLUDE'   GENLXYAJH.IN,P
      'OUTFILE'   GLXYAJH.FR
      SUBROUTINE  GLXY (OREG)
      'INCLUDE'   GENLXYAJH.IN,P
'HEAD' STORE X/Y REGISTER
      'OUTFILE'   GENSXYAJH.FR
      SUBROUTINE  GENSXY (IREG, TRANS)
      INTEGER     IREG, TRANS

      'INCLUDE'   REGSJHP.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFE.IN,
      'INCLUDE'   GENCOMAJH.IN,


      TS = OPCODE (RIGHT)
      'IF' (TS .EQ. LDAZP .OR. TS .EQ. LDAABS)
         OPCODE (RIGHT) = TS + TRANS
         EZSTA = .TRUE.
         'ELSE'

C        GO THROUGH AREG
C
         CALL GENTRA (IREG, AREG)
         'ENDIF'
      RETURN
      END
'HEAD' MOVE DP REGISTER
      'OUTFILE'   GENMOVAJH.FR
      SUBROUTINE  GENMOV

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   REGSJHP.IN,
      'INCLUDE'   RMCODES.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFE.IN,
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   GENCOMAJH.IN,
      'EJECT'
C     MOVE THE DP REG ONE WAY OR THE OTHER
      'IF' (OP .GE. ARROW .AND. .NOT. EZSTA)
         'IF' (NEXTOP .GT. RBRACE .OR. ^
            (OP .NE. ARROW .AND. OP .NE. UPARO .AND. OP .NE. DNARO))
            'IF' (ACTREG (OTHER) .EQ. XREG)
C              XREG IS BUSY, USE CORE
               CALL REGMAN (CTFREE, TS, 1)
               CALL BLDOP (STAZP, WF5, THIS-1, REGS (TS), WF7)
               STATUS (TS) = SIDE
               ACTREG (THIS) = TS

               'ELSE'
C              MOVE IT TO XREG
               CALL REGMAN (SAVREG, XREG, DUMMY)
               CALL BLDBLK (TAX, WF4)
               STXREG = SIDE
               ACTREG (THIS) = XREG
               'ENDIF'
            'ENDIF'
         'ENDIF'
C     LOAD THE OTHER HALF
C     EXCHANGE SIDES
      TS = THIS
      THIS = OTHER
      OTHER = TS
      'IF' (ACTREG (THIS) .EQ. XREG)
         'IF' (EZSTA)
C           STORE DIRECTLY FROM XREG
            OPCODE (RIGHT) = OPCODE (RIGHT) + 1
            'ELSE'
            CALL BLDBLK (TXA, WF4)
            STXREG = 0
            ACTREG (THIS) = AREG
            'ENDIF'
         'ELSE'
C        IF IT IS IN A CT, LOAD IT
         TS = ACTREG (THIS)
         'IF' (TS .GT. YREG)
            CALL BLDOP (LDAZP, WF5, THIS-1, REGS (TS), WF7)
            ACTREG (THIS) = AREG
            STATUS (TS) = 0
            'ELSE'
C           IT IS STILL IN CORE, GET IT
            SIDE = LEFT
            CALL GENDO
            'ENDIF'
         'ENDIF'
      RETURN
      END




\\\\\


SUBFILE: ARGENA.FS @15:59 23-MAY-1979 <055> (3289)
'HEAD'  STORE CODE GENERATION
C     EDIT DATE   05FEB79  16:11
C     SOURCE FILE ARGENAJH.FS
C     AUTHOR      A. J. HOWARD
C     CLUSTER     19

      'OUTFILE'   ARAGENAJH.FR

N     OVERLAY     OLARA

      SUBROUTINE  ARAGEN

C     OP          LOGOS OPERATOR
C     LEFT        STACK POINTER TO LEFT  OPERAND
C     RIGHT       STACK POINTER TO RIGHT OPERAND

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   REGSJHP.IN,
      'INCLUDE'   RMCODES.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   STKDEFE.IN,
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   GENCOMAJH.IN,

      INTEGER     RET, RET1, RET2
      INTEGER     TRANS
      INTEGER     BCODE (3, 3)

      INTEGER     NLOPS
      LOGICAL     NLTEST

      DATA        BCODE / 169, 173, 165, ^ // LDAI LDAABS LDAZP
                          162, 174, 166, ^ // LDXI LDXABS LDXZP
                          160, 172, 164/   // LDYI LDYABS LDYZP
      'EJECT'
      IF (MORE) GO TO 54
      IF (RSTKX .NE. 0) ^
         CALL REGSRC (5, NAMEX (RSTKX), 0, 0, 0, 0, 0)
1000  TS = LEFT
      'DO'
         COL = 4           // ASSUME NOT REGISTER
         NLX = NAMEX (TS)
         'IF' (NLTEST (NLX, REGBIT))
            'IF' (MODE (TS) .EQ. SPMODE)
               COL = NLOPS (REGNUM, NLX)
               'ELSE'
               COL = 5            // 'DP' AREG
               'ENDIF'
            'ELSE'
C           CHECK FOR STACK/STACK POINTER REF
            'IF' (NLX .EQ. STPTRX)
               COL = 6
               'ELSE'
               'IF' (SUBX (TS) .EQ. STPTRX)
                  COL = 7
                  IF (MODE (TS) .EQ. DPMODE) COL = 8
                  'ENDIF'
               'ENDIF'
            'ENDIF'
         'WHILE' (TS .EQ. LEFT)
            ROW = COL
            TS = RIGHT
            'END'
      ASSIGN 1 TO RET
      GO TO ( 2, 2, 2, 40, 50, 2, 2, 2), ROW

1     RETURN

2     MORE = .TRUE.
      RETURN
      'EJECT'
40    GO TO (41, ^ // CORE -> AREG
             42, ^ // CORE -> XREG
             43, ^ // CORE -> YREG
             44, ^ // CORE -> CORE
             45, ^ // CORE -> 'DP' AREG
             46, ^ // CORE -> STK PTR
             47, ^ // CORE -> [STK PTR]
             48  ^ // CORE -> 'DP' [STK PTR]
         ), COL

C     CORE -> AREG
41    CALL GENLA
      GO TO 1

C     CORE -> XREG
42    CALL GENLXY (XREG)
      GO TO 1

C     CORE -> YREG
43    CALL GENLXY (YREG)
      GO TO 1

C     CORE -> CORE
44    'IF' (MODE (RIGHT) .EQ. DPMODE ^
         .AND. NAMEX (LEFT) .EQ. NAMEX (RIGHT))
         CALL GENLXY (XREG)
         THIS = HI
         CALL GENDO
         THIS = LOW
         GO TO 54
         'ENDIF'
      CALL GENLA
440   SIDE = RIGHT
      CALL GENDO         // STORE
      CALL REGMAN (SETREG, AREG, RSTKX)
      'IF' (MODE (RIGHT) .EQ. SPMODE)
         MODE (LEFT) = SPMODE
         GO TO 1
         'ENDIF'
      SIDE = LEFT
      CALL GENMOV        // LOAD
      SIDE = RIGHT
      CALL GENDO         // STORE
      MODE (LEFT) = DPMODE
      GO TO 1

C     CORE -> 'DP' AREG
C     DO IT LOW/HI: LOW -> X, HI -> A
45    CALL GENLXY (XREG)
      THIS = HI
      CALL GENDO
      MODE (LEFT) = DPMODE
      GO TO 1
      'EJECT'
C     CORE -> STK PTR  =>  CORE -> X -> S
46    CALL GENLXY (XREG)
      CALL BLDBLK (154, WF4)   // TXS
      ACTLO = XREG
      GO TO 1

C     CORE -> [STK PTR]  =>  CORE -> A -> [S]
47    CALL GENLA
      CALL BLDBLK (72, WF4)   // PHA
      ACTLO = AREG
      GO TO 1

C     CORE -> 'DP' [STK PTR]
C     DO IT HI/LOW
48    THIS = HI
      CALL GENLA
      CALL BLDBLK (72, WF4)   // PHA
      ACTHI = 0
      THIS = LOW
      CALL GENDO
      CALL BLDBLK (72, WF4)   // PHA
      ACTLO = 0
      GO TO 1
      'EJECT'
50    'IF' (STAREG .EQ. 0)
         STAREG = LEFT
         ACTHI = AREG
         ACTLO = XREG
         'ENDIF'
      GO TO (51, ^ // 'DP' AREG -> AREG
             52, ^ // 'DP' AREG -> XREG
             53, ^ // 'DP' AREG -> YREG
             54, ^ // 'DP' AREG -> CORE
             55, ^ // 'DP' AREG -> 'DP' AREG
             56, ^ // 'DP' AREG -> STK PTR
             57, ^ // 'DP' AREG -> [STK PTR]
             58  ^ // 'DP' AREG -> 'DP' [STK PTR]
         ), COL

C     'DP' AREG -> AREG
51    CONTINUE

C     'DP' AREG -> XREG
52    CONTINUE

C     'DP' AREG -> YREG
53    STATUS (ACTHI) = 0
      ACTHI = 0
      NAMEX (LEFT) = REGS (ACTLO)
      MODE (LEFT) = SPMODE
      GO TO 1000

C     'DP' AREG -> CORE
54    MORE = .FALSE.
      IF (MODE (RIGHT) .EQ. SPMODE) GO TO 53
C     'DP' AREG -> 'DP' CORE
      'IF' (ACTHI .EQ. AREG)
C        DO IT HI/LOW
         THIS = HI
         OTHER = LOW
         'ENDIF'
      IF (OPCODE (RIGHT) .EQ. LDAZP .OR. OPCODE (RIGHT) .EQ. LDAABS) ^
         EZSTA = .TRUE.
      GO TO 440
      'EJECT'
C     'DP' AREG -> 'DP' AREG
55    'IF' (ACTHI .EQ. AREG)
         'IF' (ACTLO .GT. YREG)
            CALL BLDOP (166, WF5, 0, REGS (ACTLO), WF7)  // LDXZP
            CALL BLDOP (  9, WF5, 0, NULLX, WF7)         // ORA =0
            'ENDIF'
         'ELSE'
         'IF' (ACTHI .EQ. XREG)
            'IF' (ACTLO .EQ. AREG)
               CALL REGMAN (CTFREE, ACTLO, 1)
               CALL BLDOP  (STAZP, WF5, 0, REGS (ACTLO), WF7)
               'ENDIF'
            CALL BLDOP (134, WF5, 1, REGS (ACTLO), WF7)  // STXZP
            CALL BLDOP (166, WF5, 0, REGS (ACTLO), WF7)  // LDXZP
            CALL BLDOP (LDAZP, WF5, 1, REGS (ACTLO), WF7)
            'ELSE'
C           ACTHI = CT, ACTLO = AREG
            CALL REGMAN (SAVREG, XREG, DUMMY)
            CALL BLDBLK (TAX, WF4)
            CALL BLDOP  (LDAZP, WF5, 1, REGS (ACTHI), WF7)
            'ENDIF'
         'ENDIF'
      STATUS (ACTLO) = 0
      STATUS (ACTHI) = 0
      ACTLO = XREG
      ACTHI = AREG
      GO TO 1

C     'DP' AREG -> STK PTR
56    CONTINUE

C     'DP' AREG -> [STK PTR]
57    GO TO 51
      'EJECT'
C     'DP' AREG -> 'DP' [STK PTR]
C     MUST BE DONE HI/LO TO GET ONTO STACK
58    'IF' (ACTHI .GT. YREG)
C        SAVE LOW THEN DO CORE -> 'DP' [STKPTR]
         CALL BLDOP (STAZP, WF5, 0, REGS (ACTHI), WF7)
         NAMEX (LEFT) = REGS (ACTHI)
         STAREG = 0
         ACTHI = 0
         ACTLO = 0
         GO TO 48
         'ENDIF'
      'IF' (ACTHI .EQ. AREG)
         CALL BLDBLK (72, WF4)   // PHA
         'IF' (ACTLO .EQ. XREG)
            CALL BLDBLK (TXA, WF4)
            'ELSE'
            CALL BLDOP (LDAZP, WF5, 0, REGS (ACTLO), WF7)
            'ENDIF'
         'ELSE'
C        ACTHI IS XREG
         'IF' (ACTLO .EQ. AREG)
            CALL REGMAN (CTFREE, ACTLO, 1)
            CALL BLDOP  (STAZP, WF5, 0, REGS (ACTLO), WF7)
            'ENDIF'
C        ACTLO IS CT
         CALL BLDBLK (TXA, WF4)
         CALL BLDBLK ( 72, WF4)  // PHA
         CALL BLDOP  (LDAZP, WF5, 0, REGS (ACTLO), WF7)
         'ENDIF'
      CALL BLDBLK (72, WF4)      // PHA
      STATUS (ACTHI) = 0
      ACTHI = 0
      STATUS (ACTLO) = 0
      ACTLO = 0
      GO TO 1
      END
      'OUTFILE'   ARBGENAJH.FR

N     OVERLAY     OLARB

      SUBROUTINE  ARBGEN

C     OP          LOGOS OPERATOR
C     LEFT        STACK POINTER TO LEFT  OPERAND
C     RIGHT       STACK POINTER TO RIGHT OPERAND

      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   REGSJHP.IN,
      'INCLUDE'   RMCODES.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   STKDEFE.IN,
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   GENCOMAJH.IN,

      INTEGER     RET, RET1, RET2
      INTEGER     TRANS


      ASSIGN 1 TO RET
      MORE = .FALSE.
      GO TO ( 10, 20, 30, 6, 6, 60, 70, 80), ROW

1070  CALL FAULTP (70)    // ILLEGAL STKPTR USEAGE
1     RETURN

6     CALL FATAL (6)

54    MORE = .TRUE.
      RETURN
      'EJECT'
10    GO TO ( 1, ^ // AREG -> AREG
             12, ^ // AREG -> XREG
             13, ^ // AREG -> YREG
             14, ^ // AREG -> CORE
             15, ^ // AREG -> 'DP' AREG
             16, ^ // AREG -> STK PTR
             17, ^ // AREG -> [STK PTR]
           1070  ^ // AREG -> 'DP' [STK PTR]
         ), COL

C     AREG -> AREG  => NO CODE

C     AREG -> XREG
12    CALL GENTRA (AREG, XREG)
      GO TO 1

C     AREG -> YREG
13    CALL GENTRA (AREG, YREG)
      GO TO 1

C     AREG -> CORE
14    INREG = AREG
      TRANS = 0
140   SIDE = RIGHT
      CALL GENDO
      STATUS (INREG) = 0
      CALL REGMAN (SETREG, INREG, RSTKX)
      IF (MODE (RIGHT) .EQ. SPMODE) GO TO 1
      SIDE = LEFT
      CALL GENMOV
      SIDE = RIGHT
      OPCODE (RIGHT) = OPCODE (RIGHT) - TRANS
      CALL GENDO
      MODE (LEFT) = DPMODE
      GO TO 1

C     AREG -> 'DP' AREG  =>  A -> X -> 'DP' A
15    CALL GENTRA (AREG, XREG)
      GO TO 25

C     AREG -> STK PTR  =>  A -> X -> S
16    CALL GENTRA (AREG, XREG)
      GO TO 26

C     AREG -> [STK PTR]
17    CALL BLDBLK (72, WF4)   // PHA
      ACTLO = AREG
      GO TO 1

C     AREG -> 'DP' [STK PTR] => ERROR
      'EJECT'
20    GO TO (21, ^ // XREG -> AREG
              1, ^ // XREG -> XREG
             23, ^ // XREG -> YREG
             24, ^ // XREG -> CORE
             25, ^ // XREG -> 'DP' AREG
             26, ^ // XREG -> STK PTR
             27, ^ // XREG -> [STK PTR]
           1070  ^ // XREG -> 'DP' [STK PTR]
         ), COL

C     XREG -> AREG
21    CALL GENTRA (XREG, AREG)
      GO TO 1

C     XREG -> XREG  =>  NO CODE

C     XREG -> YREG  =>  X -> A -> Y
23    CALL GENTRA (XREG, AREG)
      GO TO 13

C     XREG -> CORE
C     CHECK DIRECT STORE OR GO THROUGH A
24    TRANS = 1
      CALL GENSXY (XREG, TRANS)
      INREG = XREG
      GO TO 140

C     XREG -> 'DP' AREG
25    ACTLO = XREG
      ACTHI = AREG
      CALL BLDOP (169, WF5, 0, NULLX, WF7)   // LDA =0
      GO TO 1

C     XREG -> STK PTR
26    CALL BLDBLK (154, WF4)   //TXS
      ACTLO = XREG
      GO TO 1

C     XREG -> [STK PTR]  =>  X -> A -> [S]
27    CALL GENTRA (XREG, AREG)
      GO TO 17

C     XREG -> 'DP' [STK PTR]  => ERROR
      'EJECT'
30    GO TO (31, ^ // YREG -> AREG
             32, ^ // YREG -> XREG
              1, ^ // YREG -> YREG
             34, ^ // YREG -> CORE
             35, ^ // YREG -> 'DP' AREG
             36, ^ // YREG -> STK PTR
             37, ^ // YREG -> [STK PTR]
           1070  ^ // YREG -> 'DP' [STK PTR]
         ), COL

C     YREG -> AREG
31    CALL GENTRA (YREG, AREG)
      GO TO 1

C     YREG -> XREG  =>  Y -> A -> X
32    CALL GENTRA (YREG, AREG)
      GO TO 12

C     YREG -> YREG  =>  NO CODE

C     YREG -> CORE
C     CHECK DIRECT STORE OR GO THROUGH A
34    TRANS = -1
      CALL GENSXY (YREG, TRANS)
      INREG = YREG
      GO TO 140

C     YREG -> 'DP' AREG  =>  Y -> A -> 'DP' A
35    CALL GENTRA (YREG, AREG)
      GO TO 15

C     Y -> STK PTR  =>  Y -> A -> X -> S
36    CALL GENTRA (YREG, AREG)
      GO TO 16

C     Y -> [STK PTR]  =>  Y -> A -> [S]
37    CALL GENTRA (YREG, AREG)
      GO TO 17

C     YREG -> 'DP' [STK PTR]  =>  ERROR
      'EJECT'
C     GET STK PTR INTO XREG
60    CALL REGMAN (SAVREG, XREG, DUMMY)
      CALL BLDBLK (186, WF4)              // TSX
      ACTLO = XREG
      GO TO (21, ^ // STK PTR -> AREG
              1, ^ // STK PTR -> XREG
             23, ^ // STK PTR -> YREG
             24, ^ // STK PTR -> CORE
             25, ^ // STK PTR -> 'DP' AREG
              1, ^ // STK PTR -> STK PTR
             27, ^ // STK PTR -> [STK PTR]
           1070  ^ // STK PTR -> 'DP' [STK PTR]
         ), COL

C     STK PTR -> AREG  =>  S -> X -> A

C     STK PTR -> XREG

C     STK PTR -> YREG  =>  STK PTR -> X -> Y

C     STK PTR -> CORE  =>  S -> X -> CORE

C     STK PTR -> 'DP' AREG  =>  S -> X -> 'DP' A

C     STK PTR -> STK PTR  =>  NO CODE

C     STK PTR -> [STK PTR]  =>  S -> X -> A -> [S]

C     STK PTR -> 'DP' [STK PTR]  =>  ERROR
      'EJECT'
C     [STK PTR] -> AREG
70    CALL REGMAN (SAVREG, AREG, DUMMY)
      CALL BLDBLK (104, WF4)    // PLA
      ACTLO = AREG
      GO TO ( 1, ^ // [STK PTR] -> AREG
             12, ^ // [STK PTR] -> XREG
             13, ^ // [STK PTR] -> YREG
             14, ^ // [STK PTR] -> CORE
             15, ^ // [STK PTR] -> 'DP' AREG
             16, ^ // [STK PTR] -> STK PTR
              1, ^ // [STK PTR] -> [STK PTR]
           1070  ^ // [STK PTR] -> 'DP' [STK PTR]
         ), COL

C     [STK PTR] -> AREG

C     [STK PTR] -> XREG  =>  [S] -> A -> X

C     [STK PTR] -> YREG  =>  [S] -> A -> Y

C     [STK PTR] -> CORE  =>  [S] -> A -> CORE

C     [STK PTR] -> 'DP' AREG  =>  [S] -> A -> 'DP' A

C     [STK PTR] -> STK PTR  =>  [S] -> A -> X -> S

C     [STK PTR] -> [STK PTR]  =>  NO CODE

C     [STK PTR] -> 'DP' [STK PTR]  =>  ERROR
      'EJECT'
C     GET 'DP' [STK PTR] INTO 'DP' AREG
C
80    CALL REGMAN (SAVREG, AREG, DUMMY)
      CALL BLDBLK (104, WF4)             // PLA
      CALL GENTRA (AREG, XREG)
      CALL BLDBLK (104, WF4)             // PLA
      ACTHI = AREG
      GO TO (1070, ^ // 'DP' [STK PTR] -> AREG
             1070, ^ // 'DP' [STK PTR] -> XREG
             1070, ^ // 'DP' [STK PTR] -> YREG
               54, ^ // 'DP' [STK PTR] -> CORE
                1, ^ // 'DP' [STK PTR] -> 'DP' AREG
             1070, ^ // 'DP' [STK PTR] -> STK PTR
             1070, ^ // 'DP' [STK PTR] -> [STK PTR]
                1  ^ // 'DP' [STK PTR] -> 'DP' [STK PTR]
         ), COL

C     'DP' [STK PTR] -> AREG  => ERROR

C     'DP' [STK PTR] -> XREG  => ERROR

C     'DP' [STK PTR] -> YREG  => ERROR

C     'DP' [STK PTR] -> CORE  =>  'DP' [S] -> 'DP' A -> CORE

C     'DP' [STK PTR] -> 'DP' AREG  =>  [S] -> A -> X, [S] -> A

C     'DP' [STK PTR] -> STK PTR  =>  ERROR

C     'DP' [STK PTR] -> [STK PTR]  =>  ERROR

C     'DP' [STK PTR] -> 'DP' [STK PTR]  =>  ERROR
      END




\\\\\


SUBFILE: CGENAJ.FS @15:59 23-MAY-1979 <055> (1864)
'HEAD'  COMPARISON CODE GENERATION
C     EDIT DATE   26JAN79  10:16
C     SOURCE FILE CGENAJH.FS
C     AUTHOR      A. J. HOWARD
C     CLUSTER     19

      'OUTFILE'   CGENAJH.FR
N     OVERLAY     OLCGN

      SUBROUTINE  CGEN

C     GENERATE CODE FOR COMPARISONS

      'INCLUDE'   ATESTAJH.IN,
      'INCLUDE'   CPAREAJH.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   REGSJHP.IN,
      'INCLUDE'   RMCODES.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   STKDEFE.IN,
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   GENCOMAJH.IN,

      INTEGER     NLOPS
      INTEGER     STEP4 (6), STEP5 (48), STEP10 (12)
      INTEGER     S4SAVE
      'EJECT'
      DATA  STEP4    / 1, 1, 0, 1, 1, -1/

      DATA  STEP5    / ^
         240, -1, ^  // SP =  SP  BEQ T
         208, -1, ^  // SP #  SP  BNE T
         208, -1, ^  // SP >  SP  BNE T
         176, -1, ^  // SP >= SP  BCS T
         144, -1, ^  // SP <  SP  BCC T
         240, -1, ^  // SP <= SP  BEQ T
         208,  0, ^  // DP =  DP  BNE F1
         208, -1, ^  // DP #  DP  BNE T
           0,  0, ^  // DP >  DP  NO CODE
           0,  0, ^  // DP >= DP  NO CODE
           0,  0, ^  // DP <  DP  NO CODE
           0,  0, ^  // DP <= DP  NO CODE
         240, -1, ^  // SP =  0   BEQ T
         208, -1, ^  // SP #  0   BNE T
         208, -1, ^  // SP >  0   BNE T
          -1,  0, ^  // SP >= 0   FAULT 39
          -1,  0, ^  // SP <  0   FAULT 39
         240, -1, ^  // SP <= 0   BEQ T
           0,  0, ^  // DP =  0   NO CODE
           0,  0, ^  // DP #  0   NO CODE
          48,  0, ^  // DP >  0   BMI F1
          16, -1, ^  // DP >= 0   BPL T
          48, -1, ^  // DP <  0   BMI T
          48, -1/    // DP <= 0   BMI T

      DATA  STEP10   / ^
         240, 208, ^ // DP =  DP BEQ   DP #  DP BNE
         208,  16, ^ // DP >  DP BNE   DP >= DP BPL
          48, 240, ^ // DP <  DP BMI   DP <= DP BEQ
         240, 208, ^ // DP =  0  BEQ   DP #  0  BNE
         208,   0, ^ // DP >  0  BNE   DP >= 0  ---
           0, 240/   // DP <  0  ---   DP <= 0  BEQ
      'EJECT'
C     OP IS =, #, >, >=, <, <=

      BASE = OP - EQUAL + 1

C     CHECK FOR COMPARE AGAINST 0
      COMZER = .FALSE.
      IF (NAMEX (RIGHT) .EQ. NULLX ^
         .AND. BIAS (RIGHT) .EQ. 0 ^
         .AND. OPCODE (RIGHT) .EQ. LDAI) ^
            COMZER = .TRUE.

C     SETUP ORDER OF COMPARE FOR DP COMPARE
      'IF' (MODE (LEFT) .EQ. DPMODE)
         'IF' (OP .LE. NEQUAL)
C           =, # CAN BE DONE IN EITHER ORDER
            'IF' (STAREG .EQ. LEFT .AND. ACTHI .EQ. AREG)
C              THE AREG HAS THE HI BYTE
               THIS = HI
               OTHER = LOW
               'ENDIF'
            'ELSE'
C           >, >=, <, <=
            'IF' (COMZER)
C              MUST BE DONE HI/LOW FOR A OP 0:
               IF (STAREG .EQ. LEFT .AND. ACTLO .EQ. AREG) ^
                  CALL GENMOV     // SAVE LOW BYTE, LOAD HI BYTE
               THIS = HI
               OTHER = LOW
               'ELSE'
C              MUST BE DONE LOW/HI FOR A OP B:
               'IF' (STAREG .EQ. LEFT .AND. ACTHI .EQ. AREG)
                  THIS = HI
                  OTHER = LOW
                  CALL GENMOV
                  'ENDIF'
               'ENDIF'
            'ENDIF'
         'ENDIF'
      'EJECT'
C     STEP 1, LOAD A WITH LEFT [THIS]
      'IF' (STAREG .NE. LEFT)
         CALL REGSRC (4, NAMEX (LEFT), MODE (LEFT), ^
                         SUBX  (LEFT), SUBXM (LEFT), ^
                         BIAS  (LEFT), TS)
         IF (.NOT. COMZER .OR. TS .EQ. 0) ^
            CALL GENLA
         'ENDIF'
C     STEP 2, $SEC IF REQUIRED
      IF (OP .GE. GTR .AND. .NOT. COMZER) ^
         CALL BLDBLK (SEC, WF4)
C     STEP 3, SET CONDITION CODE
      'IF' (.NOT. COMZER)
         SIDE = RIGHT
         CALL GENDO
         IF (OP .GE. GTR) CALL REGMAN (CLRACV, AREG, 0)
         'ENDIF'
C     STEP 4, TEST CONDITION CODE OR SAVE REGISTER
      S4SAVE = 0
      'IF' (.NOT. COMZER .AND. STEP4 (BASE) .LE. 0)
         'IF' (MODE (LEFT) .EQ. SPMODE)
            CALL GENJMP (STEP4 (BASE), BCC, WF5)
            'ELSE'
            CALL REGMAN (CTFREE, S4SAVE, 1)
            S4SAVE = REGS (S4SAVE)
            CALL BLDOP (133, WF5, 0, S4SAVE, WF7)   // STAZP
            'ENDIF'
         'ENDIF'
C     STEP 5, TEST CONDITION CODE
      TS = 2*BASE - 1
      IF (MODE (LEFT) .EQ. DPMODE) TS = TS + 12
      IF (COMZER) TS = TS + 24
      'IF' (STEP5 (TS) .NE. 0)
         'IF' (STEP5 (TS) .LT. 0)
            'IF' (ATEST)
               ATEST = .FALSE.
               'ELSE'
               IF (OP .EQ. GEQ) ILB = 1     // SUPPRESS JMP FALSE
               CALL FAULTP (39)
               'ENDIF'
            TS = TS + 12
            'ENDIF'
         CALL GENJMP (STEP5 (TS+1), STEP5 (TS), WF5)
         'ENDIF'
      'EJECT'
C     STEPS 6 - 10 ARE FOR DP ONLY
      'IF' (MODE (LEFT) .EQ. DPMODE)
C        STEP 6, SETUP FOR NEXT LOAD/ORA
         SIDE = LEFT
         'IF' (.NOT. COMZER .OR. (OP .NE. GEQ .AND. OP .NE. LESS))
            'IF' (COMZER)
C              ORA MUST BE FROM MEMORY
               TS = ACTREG (OTHER)
               'IF' (TS .EQ. XREG)     // GET XREG INTO MEMORY
                  CALL REGMAN (CTFREE, TS, 1)
                  CALL BLDOP  (134, WF5, OTHER-1, REGS (TS), WF7) // STX
                  'ENDIF'
               'IF' (TS .GT. YREG)
                  CALL BLDOP  (  5, WF5, OTHER-1, REGS (TS), WF7) // ORA
                  'ELSE'
                  RIGHT = LEFT
                  BASE = AOROP - EQUAL + 1
                  CALL GENMOV
                  'ENDIF'
               'ELSE'
               CALL GENMOV
               'ENDIF'
            'ENDIF'
C        STEPS 7 - 9 ONLY IF NOT TESTING 0
         'IF' (.NOT. COMZER)
C           STEP 7, ADJUST CARRY NO LONGER REQUIRED
C           STEP 8, DO $CMP OR $SBC
            SIDE = RIGHT
            BASE = OP - EQUAL + 1
            CALL GENDO
C           STEP 9, TEST CONDITION CODE
            IF (STEP4 (BASE) .LE. 0) ^
               CALL GENJMP (STEP4 (BASE), 48, WF5)  // BMI
            IF (S4SAVE .NE. 0) ^
               CALL BLDOP (5, WF5, 0, S4SAVE, WF7)   // ORAZP
            'ENDIF'
C        STEP 10, TEST CONDITION CODE
         TS = OP - EQUAL + 1
         IF (COMZER) TS = TS + 6
         IF (STEP10 (TS) .NE. 0) ^
            CALL GENJMP (-1, STEP10 (TS), WF5)
         'ENDIF'
C     HAS THERE BEEN AN INTERMEDIATE BRANCH
      IF (INTBR .NE. 0) CALL DEFTL (INTBR)
      INTBR = 0
C     BUILD A JUMP TO FALSE
      IF (ILB .EQ. 0) CALL GENJMP (1, JMP, WF8)
      RETURN
      END
      'OUTFILE'   GENJMPAJH.FR
      SUBROUTINE  GENJMP (CSIDE, OPTS, WFTS)

      INTEGER     CSIDE, OPTS, WFTS, TFSIDE
      'INCLUDE'   CODE1FTM.IN,
      'INCLUDE'   CPAREAJH.IN,
      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   GENCOMAJH.IN,
C     'INCLUDE'   PRTCOMFTM.IN,   //DEBUG ONLY

C     GENERATE A BRANCH/JUMP TO SIDE OF A CONDITIONAL

C     CSIDE = -1 TRUE
C           =  0 BRANCH TO JUMP
C           =  1 FALSE

      CALL BLDOP (OPTS, WFTS, 0, TLI, WF9)
      TFSIDE = CSIDE
      'IF' (ILB .NE. 0 .AND. TFSIDE .EQ. 0)
C        CHANGE BRANCH TO JMP FALSE TO BRANCH FALSE
         TFSIDE = 1
         'ENDIF'
C     START DEBUG CODE
C     CALL EST ('GENJMP', LBUF,  1,  6)
C     CALL ESP (TFSIDE  , LBUF,  6, 12)
C     CALL ESP (TRUEF   , LBUF, 12, 18)
C     CALL ESP (ILB     , LBUF, 18, 24)
C     CALL SGLPRT
C     END DEBUG CODE
      'IF' (CSIDE .EQ. 0)
C        INTERMEDIATE BRANCH
         INTBR = TLI
         'ELSE'
         'IF' (CLX .GE. 30)
            CALL FAULTP (7)
            'ELSE'
C           SAVE LOCATION OF FIRST BRANCH
            IF (CNLEND (NESTX) .EQ. 0 .AND. WFTS .EQ. WF5) ^
                CNLEND (NESTX) = LC
            CPLOC (CLX) = TLI*TRUEF*TFSIDE
            CALL REGLEV (4)
            CLX = CLX + 1
            'ENDIF'
         'ENDIF'
      TLI = TLI + 1
      RETURN
      END



\\\\\


SUBFILE: REGMAN.FS @15:59 23-MAY-1979 <055> (1113)
'HEAD'  REGISTER MANAGEMENT
C     EDIT DATE   14JAN79  09:14
C     SOURCE FILE REGMANJHP.FS
C     AUTHOR      J.H.PERINE
C     CLUSTER     20

      'OUTFILE'   REGMANJHP.FR

      SUBROUTINE  REGMAN (FUNC, REG, AUX)

      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   REGSJHP.IN,
      'INCLUDE'   STKDEFA.IN,
      'INCLUDE'   STKDEFB.IN,
      'INCLUDE'   RMCOMJHP.IN,P

      INTEGER     FUNC,   REG,    AUX
      INTEGER     SRREG,  SRX,    CREG,   CTREG,  FREECT, MAXCT
      INTEGER     RET,    SRRET,  ACX,    PASS
      INTEGER     STINS (3),      AC (11, 5)

      EQUIVALENCE (ACADDR, AC)

      DATA        STINS / 133, ^     // STA ZP
                          134, ^     // STX ZP
                          132 /      // STY ZP

C     SWITCH ON FUNCTION CODE
      ASSIGN 1 TO RET
      FREECT = AUX                   // FREE REGISTER COUNT FOR CTFREE
      GO TO ( 100, ^  // ERASE ALL REGISTER CONTENTS
              200, ^  // ERASE SPECIFIC REGISTER CONTENTS
              300, ^  // ERASE STATUS OF ALL REGISTERS
              400, ^  // TRANSFER REGISTER TO REGISTER
              500, ^  // TEMP STORE
              600, ^  // FIND FREE CT
              700  ^  // SET CONTENTS FROM STACK
         ), FUNC

C     COMMON EXIT

1     RETURN
      'EJECT'
C     ERASE ALL REGISTER CONTENTS

100   CALL SET (0, ACADDR, 11)
      GO TO 1

C     ERASE SPECIFIC REGISTER CONTENTS

200   ACADDR (REG) = 0
      GO TO 1

C     ERASE ACTIVE STATUS OF ALL REGISTERS

300   CALL SET (0, STATUS, NRREGS)
      ACTHI = 0
      ACTLO = 0
      GO TO 1

C     REGISTER/REGISTER TRANSFER
C
C     CALL REGMAN (TRAREG, REGIN, REGOUT)


400   'IF' (AUX .EQ. YREG .AND. BIAS (REG) .NE. 0)
         ACADDR (YREG) = 0
         'ELSE'
         'DOLOOP' ACX = 1, 5
            AC (AUX, ACX) = AC (REG, ACX)
            'END'
         'ENDIF'
C     SET NZREG TO OUTREG
      ACADDR (NZREG) = REGS (AUX)
      'DOLOOP' ACX = 2, 5
         AC (NZREG, ACX) = 0
         'END'
      CALL DUMST ('REG4')
      GO TO RET
      'EJECT'
C     DO TEMP STORE IF REGISTER IS ACTIVE

500   SRREG = REG

C     CHECK FOR ACTIVE
      SRX = STATUS (SRREG)
      'IF' ( SRX .NE. 0 )
C        REGISTER IS ACTIVE
         CALL DUMST ('REG5')
         FREECT = 1            // ALWAYS NEED 1 CT
         'IF' (MODE (SRX) .EQ. SPMODE)
C           GET A COMPILER TEMP
            ASSIGN 520 TO RET
            GO TO 600
520         CALL BLDOP (STINS (SRREG), WF5, 0, REGS (CREG), WF7)
            'ELSE'
C           DOUBLE AREG SAVE
            'IF' (ACTHI .GT. YREG)
C              HI IS IN CT; STAZP CTN (LOW)
               CREG = ACTHI
               CTREG = REGS (CREG)
               CALL BLDOP (STINS (ACTLO), WF5, 0, CTREG, WF7)
               'ELSE'
               'IF' (ACTLO .GT. YREG)
C                 LOW IS IN CT; STAZP CTN+1 (HI)
                  CREG = ACTLO
                  CTREG= REGS (CREG)
                  CALL BLDOP (STINS (ACTHI), WF5, 1, CTREG, WF7)
                  'ELSE'
C                 IN AREG/XREG GET NEW CT
                  ASSIGN 530 TO RET
                  GO TO 600
530               CALL BLDOP (STINS (ACTLO), WF5, 0, CTREG, WF7)
                  CALL BLDOP (STINS (ACTHI), WF5, 1, CTREG, WF7)
                  STATUS (XREG) = 0
                  'ENDIF'
               'ENDIF'
            ACTHI = 0
            ACTLO = 0
            'ENDIF'
         STATUS (SRREG) = 0
         STATUS (CREG) = SRX
         NAMEX (SRX) = CTREG
         AUX = CREG
         ASSIGN 540 TO RET
         GO TO 400           // SET THE CONTENTS OF THE CT REGISTER
         'ENDIF'
540   ACADDR (SRREG) = 0
      GO TO 1
      'EJECT'
C     FIND EMPTY SPACE IN CT

C     MAKE TWO PASSES
C        1. STATUS = 0 AND CONTENTS = 0
C        2. STATUS = 0
C
600   MAXCT = NRREGS + 1 - FREECT
      'DOLOOP' PASS = 1, 2
         'DOLOOP' CREG = 4, MAXCT
            'IF' (STATUS (CREG) .EQ. 0 ^
               .AND. (PASS .EQ. 2 .OR. ACADDR (CREG) .EQ. 0))

               'IF' (FREECT .EQ. 2 .AND. STATUS (CREG+1) .NE. 0)
C                 NOT A FREE PAIR, KEEP LOOKING
                  'NEXT'
                  'ENDIF'
               IF (FUNC .EQ. 6) REG = CREG   // RETURN IT TO CALLER
               CTREG = REGS (CREG)
               GO TO RET
               'ENDIF'
            'END'
         'END'
      CALL FATAL (69)
      GO TO RET


C     SET REGISTER CONTENTS FROM STACK
C
C     CALL REGMAN (SETREG, REG, STACKX)


700   IF (AUX .NE. 0) ^
         CALL REGSRC (6, NAMEX (AUX), MODE (AUX), ^
                         SUBX  (AUX), SUBXM (AUX),^
                         BIAS (AUX),  REG)
      GO TO 1
      END




\\\\\


SUBFILE: REGAPB.FS @15:59 23-MAY-1979 <055> (1023)
      'HEAD' REGISTER MANAGEMENT
C     EDIT DATE   10DEC78  20:16
C     SOURCE FILE REGAPB.FS
C     AUTHOR      A.P. BUCHALTER
C     CLUSTER     20

      'OUTFILE'   OREGAPB.FR
C     EDIT DATE   10DEC78  20:16
C     SOURCE FILE REGAPB.FS
C     AUTHOR      A.P. BUCHALTER

N     OVERLAY     OLREG

C     ROUTINES TO KEEP TRACK OF REGISTER CONTENTS
      SUBROUTINE OREGS(FUNC, OPND, OTYPE, SUBSC, STYPE, BIAS, REG)

      INTEGER     FUNC, OPND, OTYPE, SUBSC, STYPE, BIAS, REG

      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   RMCOMJHP.IN,
      'INCLUDE'   WFLAGSJHP.IN,
      'INCLUDE'   REGSJHP.IN,

      INTEGER     MODE, SBIAS, DBIAS
      INTEGER     REGLO,  REGHI

      LOGICAL     NLTEST

C     FUNCTIONS
C       SEARCH ALL = 1
C       SEARCH AXY = 2
C       SEARCH CTS = 3
C       SEARCH NZ  = 4
C       CLEAR MATCH = 5
C       SET = 6
C       LOADY = 7


      CALL REGDMP (FUNC)
      GO TO (100, 200, 300, 400, 500, 600, 700), FUNC

C     SEARCH ALL
100   REGLO = AREG
      REGHI = NZREG-1
      GO TO 8000

C     SEARCH A, X, Y
200   REGLO = AREG
      REGHI = YREG
      GO TO 8000

C     SEARCH CTS
300   REGLO = 4
      REGHI = NRREGS
      GO TO 8000

C     SEARCH NZ
400   REGLO = NZREG
      REGHI = NZREG
      GO TO 8000
      'EJECT'

C     CLEAR REGISTERS WHICH MATCH OPND OR SUBSCRIPT
500   'DOLOOP' REGLO = AREG, NZREG
        IF ((OPND .EQ. ACADDR(REGLO)  .AND. ^
            ACTYPE(REGLO) .NE. ADRFLG)   .OR. ^
           (ACSUBS(REGLO) .EQ. OPND .AND. ^
             ACSBTY(REGLO) .NE. ADRFLG)) ^
         ACADDR(REGLO) = 0
         'END'
      GO TO 9000


C     SET REGISTER
600   ACADDR (REG) = 0
      IF (OTYPE .EQ. DPMODE .AND. REG .LE. YREG) ^
         GO TO 9000
      IF (OPND .EQ. 0) ^
         GO TO 9000
      IF (NLTEST (OPND, REGBIT)) ^
         GO TO 9000
      'IF' (SUBSC .NE. 0)
         IF (NLTEST (SUBSC, REGBIT)) GO TO 9000
         'ENDIF'
      ACADDR(REG) = OPND
      ACTYPE(REG) = OTYPE
      ACSUBS(REG) = SUBSC
      ACSBTY(REG) = STYPE
      ACBIAS(REG) = BIAS
      GO TO 9000
      'EJECT'

C     LOAD Y - CAN WE USE WHAT IS IN YREG
C     CALLED AS REGSRC(7, SUBOP, WFSOP, SUBX, SUBXM, SUBXB, -)
C     WHERE DESIRE YREG TO BE:
C       'LOC'SUBX[0+SUBXB] OR 'SP'SUBX[0+0]+SUBXB
C      NOTE: THE YREG IS A VERY SPECIAL CASE. THE ACADDR, ETC. ARRAYS
C      HAVE A DIFFERENT INTERPRETATION.
C      IF MODE = 'LOC' THEN NORMAL INTERPRETATION
C      IF MODE = 'SP' THEN: YREG = ACADDR[ACSUBS+0]+ACBIAS

700   'IF' (OPND .EQ. 160)    // LDYIMM
         MODE = ADRFLG
         'ELSE'
         MODE = SPMODE
         'ENDIF'
      SBIAS = BIAS
C     IF 'MODE'SUBX[0+--] = YREG
      'IF' ((ACADDR(YREG) .EQ. SUBSC) .AND. ^
               ACTYPE(YREG) .EQ. MODE  .AND. ^
               ACSUBS(YREG) .EQ. 0)
         DBIAS = BIAS-ACBIAS(YREG)
C        CHECK +-1 FROM CURRENT BIAS
         'IF' (DBIAS .EQ. 1)
            OTYPE = WF4
            BIAS = 0
            OPND = 200   // INY
            'ELSE'
            'IF' (DBIAS .EQ. -1)
               OTYPE = WF4
               BIAS = 0
               OPND = 136   // DEY
               'ELSE'
               IF (DBIAS .EQ. 0) OPND = -1
               'ENDIF'
            'ENDIF'
         'ENDIF'
      ACADDR(YREG) = SUBSC
      ACTYPE(YREG) = MODE
      ACSUBS(YREG) = 0
      ACSBTY(YREG) = SPMODE
      ACBIAS(YREG) = SBIAS
      GO TO 9000
      'EJECT'
C     GENERAL REGISTER SEARCH
8000  'DOLOOP' REG = REGLO, REGHI
         IF (ACADDR(REG) .EQ. OPND .AND. ^
             ACTYPE(REG) .EQ. OTYPE .AND. ^
             ACSUBS(REG) .EQ. SUBSC .AND. ^
             ACSBTY(REG) .EQ. STYPE .AND. ^
           ACBIAS(REG) .EQ. BIAS) ^
         GO TO 9000
         'END'
C     NO MATCH
      REG = 0

9000  CALL REGDMP (REG)
      RETURN
      END
      'OUTFILE' REGAPB.FR
C     EDIT DATE   10DEC78  20:16
C     SOURCE FILE REGAPB.FS
C     AUTHOR      A.P. BUCHALTER
C     CLUSTER     ?

      SUBROUTINE REGSRC(FUNC, OPND, OTYPE, SUBSC, STYPE, BIAS, REG)
      EXTERNAL  OLREG
      INTEGER FUNC, OPND, OTYPE, SUBSC, STYPE, BIAS, REG

C     ROOT FOR OREGS SUBROUTINE


      CALL OVLOD(OLREG)
      CALL OREGS(FUNC, OPND, OTYPE, SUBSC, STYPE, BIAS, REG)
      RETURN
      END



\\\\\