 TITLE 'TELEFILE ASSEMBLY PROGRAM - APPART'
         PCC      0
         SPACE    6
*   %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
*   %%%%%     MODULE NAME:     APPART                  %%%%%
*   %%%%%     LAST UPDATED:    MAR 07, 1984            %%%%%
*   %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
         SPACE    2
         SPACE    12
*        T E L E F I L E    P R O P R I E T A R Y    P R O D U C T
         SPACE    2
*        THIS DOCUMENT INCLUDES DATA AND INFORMATION WHICH IS CONSIDERED
*        PROPRIETARY TO TELEFILE COMPUTER PRODUCTS, INC. REPRODUCTION,
*        DUPLICATION, DISCLOSURE OR DISSEMINATION, IN WHOLE OR IN PART,
*        TO OTHERS THAN REPRESENTATIVES OF THE UNITED STATES GOVERNMENT
*        SHALL NOT BE MADE WITHOUT PRIOR WRITTEN AUTHORIZATION OF TELEFILE
*        COMPUTER PRODUCTS, INC. NOTWITHSTANDING THE FOREGOING, USE OF
*        THE DATA OR INFORMATION IN WHOLE OR IN PART FOR DESIGN,
*        PROCUREMENT OR MANUFACTURE IS STRICTLY FORBIDDEN.
         PAGE
         SPACE    12
*        T E L E F I L E    P R O P R I E T A R Y    P R O D U C T
         SPACE    2
*        THIS DOCUMENT INCLUDES DATA AND INFORMATION WHICH IS CONSIDERED
*        PROPRIETARY TO TELEFILE COMPUTER PRODUCTS, INC. REPRODUCTION,
*        DUPLICATION, DISCLOSURE OR DISSEMINATION, IN WHOLE OR IN PART,
*        TO OTHERS THAN REPRESENTATIVES OF THE UNITED STATES GOVERNMENT
*        SHALL NOT BE MADE WITHOUT PRIOR WRITTEN AUTHORIZATION OF TELEFILE
*        COMPUTER PRODUCTS, INC. NOTWITHSTANDING THE FOREGOING, USE OF
*        THE DATA OR INFORMATION IN WHOLE OR IN PART FOR DESIGN,
*        PROCUREMENT OR MANUFACTURE IS STRICTLY FORBIDDEN.
         PAGE
DGPART   CSECT    1                 PROCEDURE
         DEF      DGPART
         DEF      PARTIC
*
         DEF      ADJKLINE
         DEF      ADV%ITM
*
         REF      ABORT
*
         REF      DELETEXP
         REF      GETPLOC1
         REF      LINE%FLDS
         REF      LOADXM
         REF      LOADXW
         REF      SCAN
         REF      SUBVAL
*
         SYSTEM   AP%IL
         SYSTEM   AP%DG
         PAGE
         USECT    DGPART
*
*   A D J K L I N E
*        THIS SUBROUTINE ADJUSTS KLINE WITHIN AVAILABLE DYNAMIC
*          STORAGE IF FINDSPCXIT (BYTE 0) IS NON-ZERO.  KLINE AND
*          ALL EXISTING ECT, EVT, AND PROCEDURE LEVEL TABLES WILL
*          BE MOVED TO THE MID-POINT OF AVAILABLE STORAGE.
*
*        INPUT:   BYTE ZERO OF FINDSPCXIT IS 0 IF NO ADJUSTMENT IS
*                   NEEDED; NON-ZERO IF ADJUSTMENT IS REQUIRED.
*
*        OUTPUT:  BYTE ZERO OF FINDSPCXIT IS ZERO
*                 KLINE AND LVL HAVE BEEN ADJUSTED
*
*        USES REGISTERS
*                 ER, RL, XT, XT1, XT2, LVL
*
ADJKLINE RES      0
*
         MTB,0    FINDSPCXIT
         EXIT,EQ  RL                EXIT IF NO KLINE ADJUSTMENT NEEDED
*
         STW,RL   FINDSPCXIT        SAVE EXIT & RESET ADJUST INDICATOR
         LCW,RL   ECT,LVL
         AW,RL    EVT,LVL
         LW,XT1   ECT,LVL
         LI,ER    1
         LW,XT    NXTLOCAL
         AW,XT    NXTSYMT
         SLS,XT   -1                COMPUTE ADDRESS OF MID-POINT
         AW,XT    ECT,LVL           EXIT IF MOVE WOULD RESULT IN
         CW,XT    NXTSYMT             ECT OVERLAPPING NXTSYMT
         BL       *FINDSPCXIT
*
         AW,XT    RL
         CW,XT    NXTLOCAL          EXIT IF MOVE WOULD RESULT IN
         BG       *FINDSPCXIT         EVT OVERLAPPING NXTLOCAL
*
         SW,XT    EVT,LVL
         AI,RL    -1                NUMBER OF WORDS TO MOVE
         CW,XT    KLINE             IF MID-POINT IS LESS THAN KLINE,
         BL       ADJKLN1             KLINE MUST BE MOVED DOWN
*
         LW,XT1   EVT,LVL
         LI,ER    -1
ADJKLN1  RES      0
         AW,XT1   ER                MOVE KLINE, AND ALL TABLES THAT
         LW,XT2   *KLINE,XT1          INDEX OFF OF KLINE, SUCH THAT
         STW,XT2  *XT,XT1             KLINE OCCUPIES THE MID-POINT
         BDR,RL   ADJKLN1             OF AVAILABLE DYNAMIC STORAGE
*
         SW,LVL   KLINE
         STW,XT   KLINE             STORE NEW ADDRESS FOR KLINE
         AW,LVL   XT                  AND NEW ADDRESS FOR LVL
         B        *FINDSPCXIT
         PAGE
*
*   I N T S S Y M
*        TEST THE ENCODED ITEM FOR BEING INTRINSIC SUBSCRIPTED
*          SYMBOL LF, CF, AF, OR NAME
*
*   I N T S Y M
*        TEST THE ENCODED ITEM FOR BEING INTRINSIC SYMBOL
*          LF, CF, AF, OR NAME
*
*        INPUT:   REGISTER XT CONTAINS THE ENCODED ITEM
*
*        OUTPUT:  RETURN IS TO CALLING LINE+1 IF ENCODED ITEM
*                   IS LF, CF, AF, OR NAME
*                 RETURN IS TO CALLING LINE+2 IF ENCODED ITEM
*                   IS NOT LF, CF, AF, OR NAME
*
*        CALL:    BAL,RL  INTSSYM   INTRINSIC SUBSCRIPTED SYMBOL
*                 BAL,RL  INTSYM    INTRINSIC SYMBOL
*
INTSSYM  RES      0
         CI,XT    AFSSYM
         EXIT,EQ  RL                RETURN IF SUBSCRIPTED SYMBOL IS AF
         CI,XT    CFSSYM
         BL       INTSYM2           NOT CF, LF, OR NAME
         CI,XT    NAMESSYM
         B        INTSYM1
*
INTSYM   RES      0
         CI,XT    AFSYM
         EXIT,EQ  RL                RETURN IF SYMBOL IS AF
         CI,XT    CFSYM
         BL       INTSYM2           NOT LF, CF, OR NAME
         CI,XT    NAMESYM
INTSYM1  RES      0
         EXIT,L   RL                RETURN IF ITEM IS CF OR LF
         BNE      INTSYM2           BRANCH IF ITEM IS NOT NAME
         MTB,0    PARTICRTN         IS THIS A REFERENCE TO A COM
         EXIT,NE  RL                NO,  ITEM IS NAME
INTSYM2  RES      0
         B        1,RL              SYMBOL WAS NOT LF, CF, AF, OR NAME
         PAGE
*
*    P A R T I C
*
         OPEN     TX1,TX2,XT2
         OPEN     TMP1,TMP2,TMP3
TX1      EQU      10
TX2      EQU      11
XT2      EQU      12
TMP1     EQU      XT2
TMP2     EQU      14
TMP3     EQU      13
PARTIC   RES      0
         STW,RL   PARTICRTN
         STB,XT   PARTICRTN         STORE 'NAME' FLAG
         BAL,RL   DELETEXP          DELETE PREVIOUS PARTIC BUFFER
         BAL,RL   ADJKLINE          ADJUST KLINE IF NEEDED
         BAL,RL   LINE%FLDS         SAVE LBL & CMND LOCATIONS
         LW,XT2   NXTLOCAL
         SW,XT2   KLINE             AMT OF ROOM IN PARTIC AREA
         SLS,XT2  1                 CONVERT TO HALF WORDS
         STW,XT2  VALCNT            SAVE IN TEMP FOR TEST IN GETPRTC
         LW,XW    LBL,LVL           SET XW BACK TO LABEL
         LI,XT2   0
         STW,XT2  FLDCNT
         STW,XT2  PPLVL
         STW,LVL  SAVELVL           SAVE CURRENT PROC LEVEL TBL PTR
         LW,XR    EVT,LVL           FORM INDEX TO START OF
         SLS,XR   1                   PARTIC BUFFER
         LW,XT    ECT,LVL           SET UP POINTER TO CONTROL STACK
         AW,XT    KLINE
         STW,XT   CNTRLSTK
         CW,XT    NXTSYMT           IS THERE SPACE
         BLE      HILIMIT4          NO, ABORT
         STW,XR   *CNTRLSTK         PUSH INIT BUFFER INDEX ONTO STACK
         BAL,RL   GETPLOC1          GET ADDRESS OF PREVIOUS PROC LVL TBL
         STW,XW   SAVEXW            SAVE SAMPLE LINE INDEX
         BAL,RL   NXT%ITM           GET FIRST ITEM
         CV,XT    BEGINLIST         IS IT A BEGIN LIST
         BNE      %8                NO
         STW,XW   XM
         BAL,RL   NXT%ITM           YES, GET NEXT ITEM
         CV,XT    AFSSYM            IS IT = AFA,AF,CF,LF
         BL       %8                NO
         CV,XT    NAMESSYM
         BG       %8                NO
         BAL,RL   ADV%ITM           ADVANCE ITEM
         XW,XW    XM
         BAL,RL   NXT%ITM
         CV,XT    ENDLIST           IS NEXT ITEM AN END LIST
         BNE      %8                NO
         AI,XW    -2                YES
         BAL,RL   NXT%ITM           IS PREVIOUS ITEM AN END SUB SYM
         CV,XT    ENDSBSYM
         BNE      %8                NO
         LV,XT    IGNRLST           YES
         STH,XT   *SYMT,XW          REPLACE ENDLIST WITH IGNORELIST
         LW,XW    SAVEXW
         STH,XT   *SYMT,XW          REPLACE BEGINLIST WITH IGNORELIST
PT1%BASE RES      0
%8       LW,XW    SAVEXW            RESTORE XW
         LW,XR    *CNTRLSTK         RESTORE XR
%10      BAL,RL   NXT%ITM           MOVE NEXT ITEM TO LINE BUFFER
         STW,XT   XT1               GET TYPE OF ITEM
         SHIFT,XT1  TLOB,31         RT ADJUST ITEM TYPE
         LB,XT1   PT1%JUMP,XT1      BRANCH TO APPROPRIATE
         B        PT1%BASE,XT1        PROCESSING ROUTINE
%20      MTW,0    PPLVL             IS NESTING LEVEL 0
         BNEZ     %10               NO
%22      RES      0
         MTW,1    FLDCNT            YES, BUMP FIELD COUNT TO NEXT FIELD
         LW,XT2   FLDCNT
         CI,XT2   1                 ARE WE PROCESSING CF(1)
         BNE      %10               NO
         BAL,RL   NXT%ITM           YES, GET NEXT ITEM
         CV,XT    BEGINLIST         IS 1ST ITEM A BEGINLIST
         BNE      %22               NO, MOVE TO NEXT FIELD
         BAL,RL   NXT%ITM           GET NEXT ITEM
         B        %130              BUMP NESTING LEVEL
%30      RES      0
         LV,XT1   IFFLD             MASK FOR IF FIELD
         BAL,RL   INTSSYM           CHECK FOR SUBSCRIPTED INTRINSIC
         STS,XT1  *CNTRLSTK           SYMBOL LF, CF, AF, OR NAME
         B        %42               NONE OF ABOVE
%40      LW,XT1   PROCREF           MAKE LOCAL SPECIFIC TO THIS
         SLS,XT1  31-PLVLLOB          LEVEL BY ADDING PROC LEVEL
         OR,XT    XT1                 TO SYMBOL NUMBER
         AI,XR    -1
         BAL,RL   GETPRTC           STORE AND BUMP PARTIC INDEX
%42      BAL,RL   GETCNTRL          GET A WORD FOR CONTROL STACK
         STW,XR   *CNTRLSTK         SAVE POINTER TO START OF SUBSCRIPT
         MTW,-1   *CNTRLSTK
         B        %130
%50      RES      0
         BAL,RL   INTSYM            CHECK FOR INTRINSIC SYMBOL LF, CF,
         B        %52                 AF, OR NAME          FOUND
         CV,XT    AFASYM            NO, IS SYMBOL = AFA
         BNE      %20               NO
         LW,XM    OPRND,LVL         YES, GET POINTER TO PRL AF
         BAL,RL   LOADXM            SET XM BASE
         AI,XR    -1                DELETE PREVIOUS SYMBOL ENTRY
%32      RES      0
         LV,XT    ENC0
         LH,RL    *XMBASE,XM        GET FIRST ITEM
         BEZ      %65
         BAL,RL   ADV%ITM
         AI,XM    -1
         LH,XT2   *XMBASE,XM        GET 1ST ITEM
         AI,XM    1
         CV,XT2   ASTFLG            IS IT = '*'
         BNE      %+2               NO, SUBSTITUTE A 0
         LV,XT    ENC1              YES, SUBSTITUTE A ONE
%65      RES      0
         BAL,RL   GETPRTC           STORE AND BUMP PARTIC INDEX
         B        %20
%52      RES      0                 SET INTRINSIC FLAG AT THIS LEVEL
         LV,RL    IFFLD
         STS,RL   *CNTRLSTK
         AI,XR    -1
         LW,XM    LBL,LVL           GET POINTER TO LABEL FIELD
         CV,XT    LFSYM             IS ITEM = LF
         BE       %56               YES
         CV,XT    CFSYM             IS ITEM = CF
         BNE      %62               NO
         LW,XM    CMND,LVL          YES, GET POINTER TO COMMAND FIELD
%56      RES      0
         BAL,RL   LOADXM            SET XM BASE
         LH,XT2   *XMBASE,XM
         CV,XT2   BEGINLIST         IS 1ST ITEM A BEGIN LIST
         BE       %58               YES
%57      BAL,RL   MOVE%ITM          NO, MOVE ITEM
         B        %20
%58      LW,XT2   FLDCNT            ARE WE PROCESSING LABEL FIELD
         OR,XT2   PPLVL               AND DOES NESTING LEVEL = 0
         BEZ      %57               YES
%51      RES      0
         AI,XM    1
%59      RES      0
         BAL,RL   MOVE%ITM          MOVE UNTIL END-LIST, END-LINE,
*                                     OR END-SUBSCRIPTED-SYMBOL
         CV,XT2   ENDSBSYM
         BG       %59
         B        %20
%62      LW,XM    OPRND,LVL         GET POINTER TO AF FIELD
         CV,XT    NAMESYM           IS ITEM = NAME
         BNE      PRTC%2            NO
         LW,XM    NAMELOC,LVL       GET POINTER TO 'NAME' FIELD
PRTC%2   RES      0
         BAL,RL   LOADXM            SET XM BASE
         LV,XT    BLANKEXP          MOVE A BLANK IF 1ST ITEM IN AF
         LH,TX1   *XMBASE,XM          IS END-LINE
         BEZ      %65
         LW,XT2   FLDCNT            ARE WE IN LABEL FIELD AND DOES
         OR,XT2   PPLVL               NESTING LEVEL = 0
         BNEZ     %59               NO
         LV,TX2   TFLD
         CS,TX1   =ENCSYM           IS ITEM A SYMBOL
         BE       %64               YES
         CS,TX1   =ENCLSYM          NO, IS IT A LOCAL SYMBOL
         BE       %64               YES
         CV,TX1   BLANKEXP          NO, IS IT A BLANK EXP
         BNE      %66               NO
%64      RES      0
         LW,XT    XM
         AI,XT    1
         LH,XT2   *XMBASE,XT        LOOK AHEAD FOR END OF LINE
         BEZ      %59               NEXT ITEM IS END OF LINE
%66      RES      0
         LV,XT    BEGINLIST
         BAL,RL   GETPRTC           STORE AND BUMP PARTIC INDEX
%72      BAL,RL   MOVE%ITM          MOVE ITEM UNTIL END OF LINE
         BNEZ     %72               BRANCH IF NOT END OF LINE
PRTC%4   RES      0
         LV,XT    ENDLIST
         B        %65
*    HERE FOR LOCAL SYMBOL
%60      RES      0
         LW,XT1   PROCREF           MAKE LOCAL SPECIFIC TO THIS LEVEL
         SLS,XT1  31-PLVLLOB          BY ADDING PROC LEVEL
         OR,XT    XT1
         BDR,XR   %65               SUBT. 1 FROM XR AND BRANCH
*    HERE FOR CONTROL
%80      RES      0
         CI,XT    BEGINEXP
         BG       %10
         LB,XT1   PT2%JUMP,XT       BRANCH TO APPROPRIATE
         B        PT1%BASE,XT1        CONTROL ROUTINE
*    HERE FOR END LINE
%90      LW,LVL   SAVELVL           RESTORE CURRENT PROC LVL TBL PTR
         STW,XW   SAMP,LVL
         LW,XW    *CNTRLSTK         SET ENCODED INPUT POINTER
         OR,XW    L(PARTICBASE)       TO PARTIC BUFFER
         BAL,RL   LOADXW
         AI,XR    1                 CALCULATE NEW VALUE OF EVT
         SLS,XR   -1
         STW,XR   EVT,LVL
         B        *PARTICRTN        RETURN
*    HERE FOR INTEGER
%70      AND,XT   L(LFLD)           GET LENGTH OF CONSTANT
         LW,XT1   XT                ANY MORE
%74      RES      0
         NXTENC                     YES
         BAL,RL   GETPRTC           STORE NEXT HALFWORD OF INTEGER
         BDR,XT1  %74
         B        %20
*    HERE FOR BEGIN EXPRESSION
%120     BAL,RL   GETCNTRL          GET A WORD FOR CONTROL STACK
         LI,XT2   0
         STW,XT2  *CNTRLSTK
*    HERE FOR BEGIN LIST
%130     MTW,1    PPLVL
         B        %10
*    HERE FOR END SUBSCRIPTED SYMBOL
%140     RES      0
         LW,XT1   *CNTRLSTK         GET POINTER TO START OF SUBSCRIPT
         LH,XT    *KLINE,XT1        GET SUBSCRIPTED SYMBOL
         AND,XT   L(ENCITEM)        CLEAN IT
         CV,XT    NUMSSYM           IS SYMBOL = NUM
         BNE      %146              NO
         MTW,0    *CNTRLSTK         YES, IS INTRINSIC FLAG SET
         BGEZ     %100              NO
         LW,XM    *CNTRLSTK         YES, SET UP POINTER TO
         BAL,RL   LOADXM            SET XM BASE
         AI,XM    1                   ARGUMENT OF NUM
         LI,XT    ENCSMINT
         LH,XT2   *XMBASE,XM
         CV,XT2   BLANKEXP          IS IT A BLANK EXPRESSION
         BNE      %142              NO
         AI,XT1   2                 YES
         LH,XT2   *XMBASE,XT1
         CV,XT2   ASTFLG            IS IT AN ASTERISK FLAG
         BNE      %141              NO
*
         AI,XT1   1                 YES
         LH,XT2   *XMBASE,XT1
%141     RES      0
         CV,XT2   ENDSBSYM          IS NEXT ITEM END SUB-SYMBOL
         BE       %144              YES
%142     BAL,RL   ADV%ITM           NO, SKIP NEXT ITEM
         AI,XT    1
         CI,TMP2  0                 BRANCH IF END-SUB-SYMBOL
         BE       %142                NOT YET FOUND
         AI,XT    -1
%144     LW,XR    *CNTRLSTK
         AND,XR   L(BUFFFLD)
%161     RES      0
         BAL,RL   GETPRTC           STORE AND BUMP PARTIC INDEX
         B        %100
%148     RES      0
         BAL,RL   INTSSYM           CHECK FOR SUBSCRIPTED INTRINSIC
         B        %149                SYMBOL LF, CF, AF, OR NAME
*   HERE FOR END EXPRESSION
%100     RES      0
         MTW,1    CNTRLSTK
*   HERE FOR END LIST
%110     RES      0
         MTW,-1   PPLVL
         B        %20
%146     RES      0
         LI,XT2   0
         CV,XT    AFASSYM           IS SYMBOL = AFA
         BNE      %148              NO
         LI,XT2   1                 YES
%149     STW,XT2  AFA%FLG           0=NO, 1=YES
         LW,LVL   SAVELVL           RESTORE CURRENT PROC LVL TBL PTR
         LW,XT2   ECT,LVL           SAVE ECT VALUE
         STW,XT2  ECTSAVE
         LW,XT2   XR                CALCULATE NEW VALUE OF EVT
         SLS,XT2  -1
         AI,XT2   1
         STW,XT2  EVT,LVL
         LW,XT2   CNTRLSTK          CALCULATE NEW VALUE OF ECT
         SW,XT2   KLINE
         AI,XT2   -1
         STW,XT2  ECT,LVL
         LI,XT    ENDLINE           STORE IN CASE SUBSCRIPTS HAVE
         BAL,RL   GETPRTC             NON-ARGUMENT FNAME REFERENCE
         LW,XR    *CNTRLSTK         GET POINTER TO SUBSCRIPTED SYMBOL
         AND,XR   L(BUFFFLD)
         STW,XW   SAVEXW            SAVE INPUT POINTER
         STW,XR   SAVEXR            SAVE PARTIC BUF POINTER
         LW,XW    XR                SET INPUT POINTER TO BEGINNING
         AI,XW    1                   OF SUBSCRIPT
         OR,XW    L(PARTICBASE)
         BAL,RL   LOADXW
         BAL,RL   SCAN              EVALUATE SUBSCRIPT
         STW,XS   SUBLOC            SET POINTER TO START OF ECT
         LW,XW    SAVEXW            RESTORE INPUT BUFFER
         BAL,RL   LOADXW
         LW,XR    SAVEXR            RESTORE PARTIC BUF POINTER
         LW,XT2   ECTSAVE           RESTORE ECT VALUE
         STW,XT2  ECT,LVL
         STW,LVL  SAVELVL           SAVE ADDRESS OF CURRENT PROC LVL TBL
         BAL,RL   GETPLOC1          GET ADDRESS OF PREVIOUS PROC LVL TBL
         LH,XT    *KLINE,XR         GET SYMBOL
         AND,XT   L(ENCITEM)        CLEAN IT
         LW,XM    LBL,LVL           GET POINTER TO LABEL FIELD
         CV,XT    LFSSYM            IS IT LF
         BE       PRTC%5            ITEM IS LF
         CV,XT    CFSSYM            IS ITEM = CF
         BNE      %1494             NO
         LW,XM    CMND,LVL          YES, GET POINTER TO COMMAND FIELD
PRTC%5   RES      0
         BAL,RL   LOADXM            SET XM BASE
         B        %151
%1494    LW,XM    OPRND,LVL
         CV,XT    NAMESSYM          IS ITEM = NAME
         BNE      PRTC%3            NO
         LW,XM    NAMELOC,LVL       GET POINTER TO 'NAME' FIELD
PRTC%3   RES      0
         BAL,RL   LOADXM            SET XM BASE
         LH,TX2   *XMBASE,XM        IS THERE AN 'AF' FIELD
         BEZ      %160              BRIF NO
*
%180     RES      0
         LI,TX2   1                 PRESET ELEMENT NUMBER TO 1
         BAL,RL   SUBVAL            GET SUBSCRIPT VALUE
%150     RES      0
         CW,TX2   SUB#              IS THIS REQUIRED ELEMENT
         BL       %184
         MTW,-1   LSTCT
         BEZ      %170
%151     LH,XT2   *XMBASE,XM
         CV,XT2   BEGINLIST         IS ITEM A BEGIN LIST
         BNE      %152              NO
         AI,XM    1                 YES
         B        %180
%152     RES      0
         BAL,RL   SUBVAL            GET NEXT SUBSCRIPT
         CI,XT    1                 CONTINUE IF IT'S = 1
         BE       %164              SUBSCRIPT = 1
%160     LV,XT    BLANKEXP
         MTW,0    AFA%FLG
         BEZ      %161
         LV,XT    ENC0
         B        %161
%164     MTW,-1   LSTCT
         BGZ      %152
%170     RES      0
         MTW,+1   CNTRLSTK          DELETE CONTROL ENTRY
         MTW,-1   PPLVL             DECREASE PARTIC LEVEL
         MTW,0    AFA%FLG
         BNEZ     %32               BRANCH IF AFA
         LH,XT2   *XMBASE,XM        LOOK AHEAD FOR BEGIN-LIST
         LW,RL    PPLVL             IS NESTING LEVEL 0, AND ARE WE
         OR,RL    FLDCNT              SUBSTITUTING INTO LABEL
         BNEZ     TEST%STRIP        GO LOOK FOR REDUNDANT BEGIN-LIST
         CV,XT2   BEGINLIST
         BE       MOVE              YES. SEE WHETHER IT'S REQUIRED
         CV,XT2   BLANKEXP
         BE       %57
         AND,XT2  L(TFLD)
         CV,XT2   ENCSYM
         BE       %57
         CV,XT2   ENCLSYM
         BE       %57               BRANCH FOR LOCAL SYMBOL
         LV,XT    BEGINLIST         MOVE A BEGINLIST TO PARTIC BUFFER
         BAL,RL   GETPRTC           BUMP PARTIC INDEX
         BAL,RL   MOVE%ITM          MOVE SUBSCRIPTED ITEM
         B        PRTC%4            GO STORE ENDLIST
MOVE     RES      0
         LW,XT    XM
         AI,XT    1
         LH,XT2   *XMBASE,XT        LOOK FOR A BLANK OR SYMBOL
         CV,XT2   BLANKEXP            FOLLOWED BY END-LIST
         BE       MOVE5
         AND,XT2  =TFLD
         CV,XT2   ENCSYM
         BE       MOVE5
         CV,XT2   ENCLSYM           LOCAL SYMBOL
         BNE      %57
MOVE5    RES      0
         AI,XT    1
         LH,XT2   *XMBASE,XT
         CV,XT2   ENDLIST
MOVE1    RES      0
         BNE      %57
         B        %51
TEST%STRIP  RES   0
         CV,XT2   BEGINLIST         DISCARD BEGIN-LIST IF PRESENT
         B        MOVE1
%184     RES      0
         BAL,RL   ADV%ITM
*                                   TEST FOR END-LINE, END-LIST,
         CV,XT2   ENDSBSYM            OR END-SUBSCRIPTED SYMBOL
         BLE      %160              YES, THE ITEM ISN'T THERE
         AI,TX2   1                 BUMP ELEMENT NUMBER
         B        %150
PT1%JUMP RES      0
         BYTE,PT1%BASE  %80         CONTROL
         BYTE     %10               DIRECTIVE
         BYTE     %50               GLOBAL SYMBOL
         BYTE     %60               LOCAL SYMBOL
         BYTE     %30               GLOBAL SUBSCRIPTED SYMBOL
         BYTE     %40               LOCAL  SUBSCRIPTED SYMBOL
         BYTE     %10               SMALL INTEGER
         BYTE     %70               LARGE INTEGER
         BOUND    4
PT2%JUMP RES      0
         BYTE,PT1%BASE  %90         END LINE
         BYTE     %10
         BYTE     %110              END LIST
         BYTE     %140              END SUBSCRIPTED SYMBOL
         BYTE     %100              END EXPRESSION
         BYTE     %20               BLANK EXPRESSION
         BYTE     %130              BEGIN LIST
         BYTE     %120              BEGIN EXPRESSION
         BOUND    4
         OPEN     %10,%20,%30,%40,%50,%60,%70,%22,%62
         OPEN     XT1
XT1      EQU      10
*
*    G E T C N T R L
*
GETCNTRL RES      0
         MTW,-1   CNTRLSTK          GET A WORD FOR THE CONTROL STACK
         LW,ER    CNTRLSTK
         CW,ER    NXTSYMT           IS THE WORD AVAILABLE
         EXIT,G   RL                YES, RETURN
HILIMIT4 RES      0
         ABORT    1                 SPACE OVERFLOW
*
*    N X T % I T M
*
NXT%ITM  RES      0
         NXTENC                     GET NEXT ENCODED ITEM
         AND,XT   L(ENCITEM)        CLEAN IT
         CV,XT    IGNRLST           IS THIS ITEM AN IGNORE LIST
         BE       NXT%ITM           YES
*
*    GETPRTC
*
GETPRTC  RES      0
         STH,XT   *KLINE,XR         STORE ITEM IN PARTIC BUFFER
         AI,XR    1                 GET NEXT HALF-WD FOR PARTIC BUFFER
         CW,XR    VALCNT            TEST MAX HALFWORDS AVAILABLE
         EXIT,L   RL                EXIT IF OKAY
*
         B        HILIMIT4
*
*    A D V % I T M
*    M O V E % I T M
*
ADV%ITM  RES      0
         LI,TMP1  0                 INDICATE NO MOVE
         B        %5
MOVE%ITM RES      0
         LI,TMP1  1
%5       RES      0
         STW,RL   ADV%RTN
         STW,XT   SAVEXT
         BAL,RL   LOADXM
         LI,TMP2  0
         LI,TMP3  -1
%10      RES      0                 GET NEXT ITEM FROM THE SOURCE LINE
         LH,XT1   *XMBASE,XM
         LV,RL    TFLD
         AND,RL   XT1
         BEZ      %20               TYPE = CONTROL
         SHIFT,RL TLOB,31
         CI,TMP3  1                 IS MAIN ITEM PROCESSED
         BE       %26               YES, GO RETURN
         B        %15,RL
%15      EQU      %-1
         B        %30               DIRECTIVE
         B        %30               GLOBAL SYMBOL
         B        %30               LOCAL SYMBOL
         B        %40               GLOBAL SUBSCRIPTED SYMBOL
         B        %40               LOCAL SUBSCRIPTED SYMBOL
         B        %30               SMALL INTEGER
         B        %50               INTEGER
%40      LI,TMP3  0                 INDICATE SUBSCRIPTED SYMBOL
         AI,TMP2  1                 BUMP NESTING LEVEL
%30      CI,TMP3  -1
         BNE      %70
%24      RES      0
         LI,TMP3  1                 INDICATE MAIN ITEM PROCESSED
%70      RES      0
         AI,XM    1                 BUMP INPUT POINTER
         CI,TMP1  0                 WANT TO MOVE ITEM
         BE       %10               NO
         LW,XT    XT1
         BAL,RL   GETPRTC           STORE AND BUMP PARTIC INDEX
         B        %10
%50      RES      0                 HERE FOR MULTI-ITEM INTEGER
         AND,XT1  =LFLD
%60      CI,TMP1  0                 IS ITEM TO BE MOVED
         BE       %62               NO
         LH,XT    *XMBASE,XM        GET NEXT ITEM OF INTEGER
         BAL,RL   GETPRTC           STORE IT & BUMP PARTIC INDEX
%62      AI,XM    1                 BUMP INDEX TO SOURCE
         BDR,XT1  %60
         LH,XT1   *XMBASE,XM        GET LAST WORD OF CONSTANT
         B        %30
%20      CI,TMP3  1                 IS MAIN ITEM PROCESSED
         BNE      %21               NO
         CV,XT1   ASTFLG            YES, IS ITEM A PREFIX CONTROL
         BL       %26               NO
         B        %70               YES, CONTINUE
%21      RES      0
         CV,XT1   IGNRLST
         BL       %26               YES, RETURN
         BE       %70
         CV,XT1   SYNERR            NO, ITEM = SYNTAX ERROR
         BE       %30               YES
         CV,XT1   BEGINLIST         NO, ITEM = BEGIN LIST
         BE       %40               YES
         CV,XT1   BEGINEXP          NO, ITEM = BEGIN EXP
         BE       %40               YES
         CV,XT1   BLANKEXP          NO, ITEM = BLANK OR END-SOMETHING
         BE       %30               YES, BLANK
         BG       %70               NOT END-LIST,-EXPR,-SUBSYMBOL
%22      AI,TMP2  -1                DECR NESTING LEVEL
         BEZ      %24
         BGZ      %70
%26      RES      0                 HERE TO RETURN
         LW,XT    SAVEXT            RESTORE XT
         LH,XT2   *XMBASE,XM        LOAD HALFWORD AFTER SKIPPED ITEM
         AND,XT2  =ENCITEM            AND TRIM IT TO 16 BITS
         B        *ADV%RTN          RETURN
*
         CLOSE    XT1
         CLOSE    T
