*DECK     LABEL - LABELS AND *DO* STATEMENT.
          IDENT  LABEL
 LABEL    SECT   (LABELS AND *DO* STATEMENT.) 
 LABEL    SPACE  4
*         IN ALLOC
          EXT    ADW,ALC
  
*         IN CONRED 
          EXT    LCT
  
*         IN FEC
          EXT    ARGCOMA,ARGMODE,ASK,ASL,BBC,CSB,CSLTAG,CT1,DTI,ERT 
          EXT    ESTACK,ESY,FEC.RTN,FLOW,HANGER,INN,IFLEVEL,LDEAD 
          EXT    NOPATH,OIL,REFLIN,REFNUM,SSY 
  
*         IN FERRS
          EXT    E.DO01,E.DO03,E.DO05,E.DO06,E.DO07,E.DO08,E.DO12,E.DO13
          EXT    E.DO14,E.DO18,E.DO19,E.IF16,E.NP1,E.SL00,E.SL01,E.SL02 
          EXT    E.SL03,E.SL04,E.SL05,E.SL06,E.SL07,E.SL08,E.SL09,E.SL10
          EXT    E.SL11,E.SL12,E.SL13,E.SL14,E.SL15,E.SL16,E.SL17,E.SL18
          EXT    E.SL19,FILL.,FILL.2,FILL.3,E.DO20,E.SL20 
  
*         IN FLINK
          EXT    MDD,DER,LPE
  
*         IN FSNAP
          EXT    DMT= 
  
*         IN FTN
          EXT    CO.SNAP
  
*         IN IO 
          EXT    IODOLEN
  
*         IN KEY
          EXT    IFFLAG,INIF,KW=ENDI
  
*         IN LEX
          EXT    TB=TYPE,KW=FORM
  
*         IN PAR
          EXT    ACT,CURST,DOARM,DO.BEG,DTC,EMT,OPBSS,OPDUM,PAR 
  
*         IN PEM
          EXT    ANSI=,PDM
  
*         IN PUC
          EXT    CONONE,E=TOTAL,N.DOB,N.GL,T=ARG,T=BLST,T=PAR,T=SCR 
          EXT    T.BLST,T.PAR,T.SCR,T.SYM,WO.DOLG,WO.DOOT,WO.LOR
          EXT    T=DATL 
  
*         IN QSKEL/FSKEL
          EXT    V=GOTO,V=NOOP,V=DOC.S,V=DOC.O
  
*         IN UTILITY
          EXT    MVE= 
 CELLS    SPACE  4,10 
**        DATA STORAGE. 
  
  
 DOMODE   BSSENT 1           MODE OF CURRENT LOOP CONTROL-INDEX 
          TITLE  STATEMENT LABELS.
 CUL      SPACE  4,8
**        CUL -  COMPILE (UPCOMING) STATEMENT LABEL 
*         ENTRY  X1 = DPC STATEMENT LABEL TO BE ASSEMBLED 
*                     (0L FORMAT, MUST HAVE AT LEAST 12 ZERO BITS TERM- 
*                     INATING FIELD)
* 
*         EXIT   (B2) = SHIFT COUNT NECESSARY TO LEFT-JUSTIFY (X6). 
*                IF VALID LABEL --
*                  (X6) = DPC STATEMENT LABEL IN 0R FORM
*                IF ERROR --
*                  (X6) = -1
* 
*         POSTS ERRORS FOR ILL-FORMED STATEMENT LABELS. 
*         AND EXIT WITH STATEMENT LABEL = TO *ERR.* 
*         USES   X - 0,1,2,3,4,6,7  A - 2,3,6  B - 2,3,7. 
  
  
 CUL      SUBR   =           ...ENTRY/EXIT... 
          SA2    ZRBLMSK     (X2) = ZERO AND BLANK MASK 
          SA3    ="NUM09"    (X3) = 0...9 MASK
          BX6    X1 
          MX0    -CHAR
          SA6    FILL.
          SB2    10*CHAR
          BX6    0
          SB3    B2 
  
 CUL10    ZR     X1,CUL30    IF NO MORE CHARS 
          LX1    CHAR 
          BX7    -X0*X1 
          SB7    X7 
          BX1    X1-X7       ERASE CHARACTER FROM INPUT 
          LX4    X2,B7
          MI     X4,CUL10    IF BLANK OR LEAD 0 
          LX4    X3,B7
          SX2    1BS14       CLEAR LEAD 0 BIT 
          LX6    CHAR 
          BX6    X6+X7       PACK CHAR
          SB2    B2-CHAR
          MI     X4,CUL10    IF DIGIT 
          SB7    E.SL15 
  
 CUL20    FATAL  B7 
          MX6    -1 
          EQ     EXIT.
  
 CUL30    SB7    E.SL19      ** INVALID LABEL 
          EQ     B2,B3,CUL20 IF ZERO/NULL LABEL 
          SB3    4*CHAR 
          SB7    E.SL14      ** LABEL TOO LONG
          LE     B2,B3,CUL20 IF LABEL TOO LONG
          EQ     EXIT.
  
 ZRBLMSK  CON    1BS32+1BS14
 GSL      SPACE  4,10 
**        GSL -  GET STATEMENT LABEL
* 
*         ENTERED FROM *FEC.* - STMT TRANSITION TABLE EXECUTIVE 
*         THIS ROUTINE HANDLES ALL LABEL DEFINITIONS
* 
*         ENTRY  (X6) = STATEMENT LABEL FIELD 
*                (FILL.) = STATEMENT LABEL, LEFT-JUSTIFIED
*                (REFLIN) = LINE NUMBER IN (XR.LINE) FIELD, REST ZERO.
* 
*         EXIT   (STN) = STMT LABEL FIELD OF SOURCE CARD IN OR
*                     FORMAT. 
*                (CSLTAG) = TAG OF THE STATEMENT LABEL.  42/ 0,  18/TAG 
*                (DTI) = COPY OF (CSLTAG) IF THIS IS A DO-TERMINAL
* 
*         USES   A1,A2,A3,A5,A6  X0,X1,X2,X3,X5,X6,X7  B2,B3,B7 
* 
*         CALLS  ALU, ERT, ESY, SSY 
  
  
 GSL      SUBR   =           ...ENTRY/EXIT... 
          MI     X6,EXIT.    IF ERROR, EXIT TO CONTROLLER...
          LX6    WA.STLP
          CALL   SSY         SEARCH SYMBOL TABLE
          SA5    TB=TYPE
          SB2    E.SL01 
          BX7    X5 
          LX7    -KW.JMPP 
          MX3    -KW.JMPL 
          BX3    -X3*X7      ISOLATE STMT PROCESSOR ADDRESS 
          SX7    KW=FORM
          IX3    X3-X7
          SB3    X3 
          CLAS=  X7,WB,(LAB,SDEF) 
          MI     B7,GSL5     IF LABEL NOT PREVIOUSLY IN SYMTAB
          CLAS=  X3,WB,(SDEF,FDEF,NDEF) 
          BX1    X3*X2
          ZR     X1,GSL10    IF LABEL NOT DEFINED 
  
**        HERE IF *STATEMENT LABEL* IS IN TABLE AND *DEFINED* 
*         ERROR - DUPLICATE STATEMENT LABEL DEFINITION. 
  
          SB2    E.SL00 
          NZ     B3,GSL20    IF NOT A FORMAT STATEMENT
          SB2    E.SL16 
          EQ     GSL20
  
**        HERE IF *STATEMENT LABEL* IS NOT IN TABLE.
  
 GSL5     SA2    REFLIN 
          LX2    -XR.LINEP+WC.LINEP 
          NZ     B3,GSL5A    IF NOT A FORMAT STMT 
          CLAS=  X1,WB,(LAB,FDEF) 
          BX7    X1 
          EQ     GSL7 
  
 GSL5A    SBIT   X5,KW.LBLP 
          MI     X5,GSL6     IF EXECUTABLE STMT 
          CLAS=  X1,WB,(LAB,NDEF) 
          BX7    X1 
          EQ     GSL7 
  
 GSL6     CLAS=  X7,WB,(LAB,SDEF) 
  
 GSL7     ADSYM  T.SYM
          =B2    0
          EQ     GSL20       CONTINUE 
  
**        HERE IF *STATEMENT LABEL* IS IN TABLE.
*                AND IS NOT-DEFINED.
  
 GSL10    SA3    REFLIN 
          BX1    X7          PRESERVE X7
          LX3    -XR.LINEP+WC.LINEP 
          BX7    X3 
          SA7    A2-WB.W+WC.W 
          BX7    X1          RESTORE X7 
          NZ     B3,GSL10A   IF NOT A FORMAT STMT 
          CLAS=  X1,WB,(FREF,SREF,DOT)
          =B2    0
          CLAS=  X3,WB,(FDEF) 
          BX1    X1*X2
          ZR     X1,GSL10B   IF NO REF BITS SET 
          HX6    WB.FREF
          MI     X6,GSL10B   IF PREVIOUSLY REFED AS FORMAT
          SB2    E.SL10 
          LX6    WB.FREFP-WB.DOTP 
          MI     X6,GSL10B   IF A *DO* TERMINAL 
          SB2    E.SL12 
          EQ     GSL10B 
  
 GSL10A   SBIT   X5,KW.LBLP 
          MI     X5,GSL11    IF EXECUTABLE STMT 
  
 GSL10B   BX6    X2+X3
          SA6    A2          RESET *WB* INDICATING DEFINED
          BX2    X6 
          EQ     GSL20
  
 GSL11    =B2    0
          HX2    WB.FREF
          PL     X2,GSL15    IF PRIOR REF WAS NOT AS FORMAT 
          SB2    E.SL13      PREVIOUSLY USED AS FORMAT
  
 GSL15    BX6    X6+X7
          LX2    X6          REMEMBER (X2) = NEW (WB.)
          SA6    A2          RESET *WB* INDICATING DEFINED
  
*         SETUP LABEL CELLS AND LINKAGES. 
*                (X0) = SYMORD OF LABEL.
*                (X2) = SYMTAB (WB) OF LABEL. 
*                (B2) = ERROR MESSAGE, .ZR. IF OKAY.
  
 GSL20    BX6    X0 
          SA6    CSLTAG 
          ZR     B2,GSL30    IF NO ERROR
          FATAL  B2 
          EQ     GSL50
  
 GSL30    BX1    X2 
          HX1    WB.DOT 
          PL     X1,GSL40    IF NOT A DO-TERMINATOR 
          SA6    DTI         INDICATE DO TERMINATION
  
 GSL40    SA3    T=BLST 
          ZR     X3,GSL50    IF NOT IN BLOCK STRUCTURE
          SBIT   X2,WB.FDEFP
          MI     X2,GSL50    IF FORMAT LABEL
          SA1    TB=TYPE
          SX2    KW=ENDI
          HX1    KW.JMP 
          AX1    -KW.JMPL    EXTRACT STATEMENT TYPE 
          IX2    X1-X2
          ZR     X2,GSL50    IF ENDIF, DEFER ANALYSIS 
          SA1    FILL.
          BX7    X1 
          =A7    A1+1        DPC OF LABEL TO FILL.2 
          SB2    1           INDICATE LABEL BEING DEFINED 
          RJ     ALU         ANALYZE THE LABEL USAGE
  
 GSL50    SA2    CSLTAG 
          SX1    CR.LAB 
          LX2    XR.TAGP
          ADDREF X2,X1
          EQ     EXIT.
 ISL      SPACE  4,10 
**        ISL -  IDENTIFY STATEMENT LABEL 
* 
*         ENTRY  (X6) = STATEMENT LABEL (IN STRING BUFFER FORMAT).
* 
*                (X2) = USAGE DEFINITION FOR STATEMENT LABEL. 
*                --  SELECT ONE OF FOLLOWING  --
*                WB.SREF = CONTROL LABEL.  ==  GO TO  1 
*                WB.FREF = FORMAT LABEL.   ==  PRINT  1 
*                WB.DOT  = DO DEFINITION.  ==  DO     1 
*                *NULL*  = ASSIGN LABEL.   ==  ASSIGN 1 TO I
* 
*                (REFNUM)= TYPE OF REFERENCE FOR *CROSS REFERENCE*
*                          PROCESSOR. 
* 
*         EXIT   (X6) = PASS 2 TAG FOR STATEMENT LABEL
* 
*         NOTE   (X6) = -1 IF SYNTAX ERROR IN STATEMENT LABEL 
* 
*         USES   A1,A2,A3,A4,A6,A7  X0,X1,X2,X3,X4,X6,X7  B2,B3,B7
*                FILL.2 = CURRENT STATEMENT LABEL IN 0L FORM. 
* 
*         CALLS  ALU, CT1, CUL, ESY, RBE, SSY 
  
  
 ISL      SUBR   =           ...ENTRY/EXIT... 
  
*         FORM STATEMENT LABEL
  
          SX0    X6-O.CONS
          ZR     X0,ISL2     IF DIGIT STRING
          SX0    X6 
          NZ     X0,E.SL18   IF TYPED OTHER THAN DIGIT STRING 
 ISL2     MX0    TB.TOCL
          LX6    59-TB.TOCL-TB.TOCP+1 
          BX6    X0*X6
          BX7    X2 
          SA6    FILL.2 
          SA1    IFFLAG 
          CLAS=  X2,WB,(SREF) 
          BX3    X2*X7
          BX3    X2-X3       X3 = 0 ONLY IF WB.SREF IS SET
          BX3    X1+X3       X3 = 0 IF IFFLAG AND PREVIOUS X3 ARE BOTH 0
          MX2    0
          NZ     X3,ISL4     IF WB.ACT NOT TO BE SET
          CLAS=  X2,WB,(ACT)
  
 ISL4     BX7    X7+X2
          LX1    X6 
          SA7    STLUSE      SET USAGE DEFINITION 
          RJ     CUL
          SA6    STL0R       SAVE 0R LABEL
          MI     X6,ISL75    IF ERROR - EXIT
          LX6    WA.STLP
          CALL   SSY
          MI     B7,ISL40    IF STATEMENT LABEL NOT IN TABLE
          SA3    T=BLST 
          ZR     X3,ISL4A    IF NOT IN A DO OR BLOCK IF STRUCTURE 
          SA1    T.BLST 
          SB3    X3-1 
          SA3    X1+B3
          LX3    -LC.DOP
          SB3    X3 
          ZR     B3,ISL4A    IF NOT IN A *DO* 
          CLAS=  X3,WB,(ALRN,GOTO)
          BX7    X3 
          SA3    STLUSE 
          BX6    -X7*X3 
          SA6    A3          WB.ALRN OR WB.GOTO CLEARED 
 ISL4A    LX3    X2          X3 = WB OF LABEL 
          SBIT   X3,WB.DEFP 
          PL     X3,ISL5     IF NOT YET DEFINED 
          CLAS=  X3,WB,(ALRN,GOTO)
          LX6    X3 
          SA3    STLUSE 
          ZR     X3,ISL5     IF AMBIGUOUS USAGE 
          BX3    X3+X2
          BX7    X6*X3
          BX6    -X6*X3 
          BX6    X6+X7
          HX2    WB.SREF
          MI     X2,ISL4B    IF NOT FIRST REFERENCE 
          SA3    A2 
          HX3    WB.FR
          AX3    -WB.FRL
          NZ     X3,ISL4B    IF NOT FIRST REFERENCE 
          SA3    REFLIN 
          LX3    -XR.LINEP+WB.FRP 
          BX6    X6+X3
  
 ISL4B    SA6    A2          UPDATE WB,(GOTO OR ALRN) AND REF LINE
  
**        STATEMENT LABEL ALREADY IN TABLE
*         CHECK VALIDITY OF CURRENT USE 
  
 ISL5     CALL   CT1
          SA6    STLTAG 
          LX6    X2 
          BX0    X2 
          SB2    E.SL11 
          SBIT   X2,WB.NDEFP
          MI     X2,ISL50    IF LABEL DEFINED ON NON-EXECUTABLE 
          SA3    STLUSE 
          CLAS=  X1,WB,(SDEF,FDEF)
          BX1    X1*X0
          ZR     X1,ISL20    IF LABEL NOT DEFINED 
          NZ     X3,ISL9     IF UNAMBIGUOUS USAGE 
          SA3    IFFLAG 
          CLAS=  X2,WB,(ACT)
          ZR     X3,ISL6     IF WB.ACT TO BE SET
          MX2    0
  
 ISL6     SBIT   X1,WB.SDEFP
          MI     X1,ISL8     IF DEFINED AS EXECUATABLE LABEL
          CLAS=  X2,WB,(FREF) 
 ISL8     BX6    X6+X2
          SA6    A2          RESET *WB* INDICATING THIS REFERENCE 
          EQ     ISL72       NO PROCESSING FOR AMBIGUOUS CASE 
  
**        STATEMENT LABEL IS DEFINED.  TEST EXISTING DEFINITION BITS VS.
*         USAGE BITS PASSED TO THIS ROUTINE.  ACTION IS TAKEN AS PER THE
*         DECISION MATRIX BELOW:  
* 
*                            IN SYMBOL TABLE
* 
*                          DOT      FMT      LAB
*                      +---------+--------+--------+
*                DOT   +  E.SL02 + E.SL04 + E.SL17 +
*                      +---------+--------+--------+
*    USAGE       FMT   +  E.SL03 + ISL60  + E.SL06 +
*                      +---------+--------+--------+
*                LAB   +  ISL60  + E.SL05 + ISL60  +
*                      +---------+--------+--------+
* 
*                (X0) = SYMBOL TABLE *WB* ENTRY 
*                (X3) = USAGE BITS
  
 ISL9     SBIT   X3,WB.DOTP 
          PL     X3,ISL12    IF NOT USED AS DO TERMINATOR 
  
*         WHEN LABEL ALREADY DEFINED, USE AS DO TERMINATOR IS ILLEGAL.
*         SORT OUT WHAT HAPPENED AND ISSUE PROPER DIAGNOSTIC. 
  
          SBIT   X0,WB.DOTP 
          PL     X0,ISL10    IF NOT DEFINED AS DO TERMINATOR
          SB2    E.SL02      DO LABEL ALREADY DEFINED, BAD NESTING
          EQ     ISL50
  
 ISL10    SB2    E.SL17      DO LABEL DEFINITION PRECEEDS DO STATEMENT
          SBIT   X0,WB.FDEFP/WB.DOTP
          PL     X0,ISL50    IF NOT DEFINED AS FORMAT 
          SB2    E.SL04      ILLEGAL TRANSFER TO FORMAT 
          EQ     ISL50
  
 ISL12    SBIT   X3,WB.FREFP/WB.DOTP
          PL     X3,ISL16    IF NOT USED AS FORMAT
  
*         LABEL USED AS FORMAT.  IF DEFINED AS NON FORMAT, ISSUE THE
*         PROPER DIAGNOSTIC.
  
          SBIT   X0,WB.DOTP 
          PL     X0,ISL14    IF NOT DEFINED AS DO TERMINATOR
          SB2    E.SL03      ILLEGAL USE OF DO TERMINATOR AS FORMAT 
          EQ     ISL50
  
 ISL14    SBIT   X0,WB.FDEFP/WB.DOTP
          MI     X0,ISL60    IF DEFINED AS FORMAT 
          SB2    E.SL06      REFERENCE TO EXECUATABLE LABEL AS FORMAT 
          EQ     ISL50
  
*         THE LABEL HAS BEEN USED AS AN EXECUTABLE LABEL. 
  
 ISL16    SB2    E.SL05      ILLEGAL TRANSFER TO FORMAT 
          LX3    X0 
          SBIT   X0,WB.FDEFP
          MI     X0,ISL50    IF DEFINED AS FORMAT 
          SBIT   X0,WB.INAP/WB.FDEFP
          PL     X0,ISL18    IF NO ATTEMPT TO TRANSFER INTO CLOSED BLOCK
          SBIT   X3,WB.ALRNP
          PL     X3,ISL17    IF NO ALTERNATE RETURN INTO CLOSED BLOCK 
          SB2    B7 
          WARN   E.SL20      ALTERNATE RETURN INTO CLOSED BLOCK 
          SB7    B2 
  
 ISL17    SBIT   X3,WB.GOTOP/WB.ALRNP 
          SB2    E.SL09      ILLEGAL TRANSFER INTO CLOSED BLOCK 
          MI     X3,ISL50    IF UNCONDITIONAL *GOTO* INTO CLOSED BLOCK
  
 ISL18    SBIT   X0,WB.INDOP/WB.INAP
          PL     X0,ISL19    IF NOT IN A DO 
          SB2    B7 
          ANSI   E.DO19 
          SB7    B2 
  
 ISL19    CALL   DER         DETECT EXTENDED RANGE (DO LOOPS) 
          EQ     ISL60
  
  
**        STATEMENT LABEL IS NOT DEFINED.  TEST EXISTING REFERENCE BITS 
*         VS. USAGE BITS PASSED TO THIS ROUTINE.  ACTION TAKEN AS PER 
*         THE DECISION MATRIX BELOW:  
* 
*                            IN SYMBOL TABLE
* 
*                          DOT      FMT      LAB
*                      +---------+--------+--------+
*                DOT   +  ISL30  + E.SL07 + ISL30  +
*                      +---------+--------+--------+
*    USAGE       FMT   +  E.SL06 + ISL60  + E.SL06 +
*                      +---------+--------+--------+
*                LAB   +  ISL60  + E.SL08 + ISL60  +
*                      +---------+--------+--------+
* 
*                (X0) = SYMBOL TABLE *WB* ENTRY 
*                (X3) = USAGE BITS
  
 ISL20    ZR     X3,ISL72    IF USAGE AMBIGUOUS (ASSIGN)
          CLAS=  X1,WB,(SREF,FREF,DOT)
          BX1    X0*X1
          ZR     X1,ISL60    IF NO REFERENCE BITS SET 
  
          SBIT   X3,WB.DOTP 
          PL     X3,ISL22    IF NOT USED AS DO TERMINATOR 
  
*         THIS USAGE IS AS DO TERMINATOR. 
  
          SBIT   X0,WB.FREFP
          PL     X0,ISL30    IF NOT REFERENCED AS FORMAT
          SB2    E.SL07      ILLEGAL REFERENCE TO DO TERMINAL AS FORMAT 
          EQ     ISL50
  
 ISL22    SBIT   X3,WB.FREFP/WB.DOTP
          PL     X3,ISL26    IF NOT USED AS FORMAT
  
*         USAGE AS FORMAT 
  
          SBIT   X0,WB.DOTP 
          PL     X0,ISL24    IF NOT REFERENCED AS DO TERMINATOR 
          SB2    E.SL06      EXECUTABLE LABEL USED AS FORMAT
          EQ     ISL50
  
 ISL24    SBIT   X0,WB.FREFP/WB.DOTP
          MI     X0,ISL60    IF REFERENCED AS FORMAT
          SB2    E.SL08 
          EQ     ISL50
  
 ISL26    SBIT   X0,WB.FREFP
          PL     X0,ISL60    IF NOT REFERENCED AS FORMAT
          SB2    E.SL08 
          EQ     ISL50
  
  
**        STATEMENT LABEL REFERENCE IS AS A DO LOOP TERMINATOR.  THE
*         LABEL CANNOT BE ENTERED INTO T.BLST VIA ALU BECAUSE THIS
*         STATEMENT BEGINS A NEW BLOCK STRUCTURE.  THUS THE FOLLOWING 
*         ANALYSIS. 
  
  
 ISL30    SBIT   X0,WB.DOTP/WB.FREFP
          PL     X0,ISL60    IF NOT ALREADY DO TERMINATOR 
  
*         THIS LABEL TERMINATES MULTIPLE DO STATEMENTS (AT LEAST ONE
*         OTHER).  THE BLOCK STRUCTURES MUST BE CONTIGUOUS FOR ALL DO 
*         LOOPS ENDING AT THIS TERMINATOR.  (E.G., NO OTHER DO LOOP OR
*         IF BLOCK MAY BE INTERSPERCED.)
  
          SA1    T.BLST 
          SA3    T=BLST 
          SB3    X3-1 
          SA3    X1+B3       FETCH COUNT WORD 
          LX3    -LC.DOP
          SB3    X3          EXTRACT DO INDEX 
          ERRNZ  18-LC.DOL
          NZ     B3,ISL31    IF NOT BLOCK IF
          SA1    T.SYM
          CLAS=  X0,WB,(DOT)
          BX6    -X0*X6      CLEAR DO TERMINAL BIT
          SA6    X1+B7
          SA1    STLTAG 
          LX6    X1 
          RJ     RBE         REMOVE DO ENTRY
          SB2    E.DO06      ILLEGAL NESTING OF IF BLOCK AND DO 
          EQ     ISL50
  
 ISL31    LX3    LC.DOP-LC.CNTP 
          SB3    X3-1 
          ERRNZ  18-LC.CNTL 
          SA3    A3-B3       BASE OF SEGMENT
          =A3    A3+DO.W
          SA1    STLTAG 
          LX3    -DO.TAGP 
          SX3    X3          ISOLATE (X3) = SYMORD OF INNERMOST DO TERM 
          ERRNZ  18-DO.TAGL 
          HX1    TP.ORD 
          AX1    -TP.ORDL    ISOLATE (X1) = SYMORD OF THIS LABEL
          IX1    X1-X3
          ZR     X1,ISL72    IF LEGAL NESTING 
          SA1    T.SYM
          CLAS=  X0,WB,(DOT)
          BX6    -X0*X6      CLEAR DO TERMINAL BIT
          SA6    X1+B7
          SA1    STLTAG 
          LX6    X1 
          RJ     RBE         REMOVE DO ENTRY
          SB2    E.DO12      ILLEGAL DO NEST
          EQ     ISL50
  
**        STATEMENT LABELS FIRST USE
*         A.  SET USAGE BITS AND (WB.LAB) FOR SYMTAB. 
*         B.  ADD LABEL TO STATEMENT LABEL TABLE
*         C.  CONTINUE, CHECKING CROSS REFERENCE, AND LINK
  
 ISL40    SA3    STLUSE 
          CLAS=  X7,WB,(LAB)
          BX7    X3+X7
          MX2    0
          ADSYM  A1          ADD LABEL TO TABLE 
          CALL   CT1         FORM (TP.) OPERAND FOR LABEL 
          SA6    STLTAG 
          SA2    STLUSE      RELOAD USAGE 
          MX1    0           MARK FIRST USE 
          EQ     ISL70       CONTINUE 
  
**        OUTPUT ERROR  (B2) _ ERROR
  
 ISL50    FATAL  B2 
          MX6    59          (X6) = -1 IMPLIES ERROR IN DO
          EQ     EXIT.       EXIT...
  
**        SET TAG IN TABLE ADDING DEFINED BITS FOR USAGE
*                (X2) = CLASSIFICATION BITS.
*                (X6) = SYMTAB WORD (WB.) FOR LABEL.
*                (B7) = SYMTAB (WB.) INDEX. 
  
 ISL60    BSS    0
          SA1    T.SYM
          SA2    STLUSE 
          BX3    X6 
          BX6    X6+X2
          SA6    X1+B7       REPLACE TAG REFLECTING USE.
          BX1    X3          SAVE OLD WB. WORD
  
**        DO LABEL ANALYSIS IF IN BLOCK STRUCTURE AND ADD LABEL TO
*         CROSS REFERENCE TABLE.
*                (X2) = USAGE.
  
 ISL70    ZR     X2,ISL72    IF AMBIGUOUS REFERENCE (ASSIGN)
          CLAS=  X0,WB,(FREF) 
          BX7    X0*X2
          NZ     X7,ISL72    IF PROCESSING FORMAT 
          CLAS=  X0,WB,(DOT)
          BX7    X0*X2
          NZ     X7,ISL72    IF DEFINES NESTING 
          HX1    WB.SREF
          MI     X1,ISL71    IF NOT FIRST REF 
          SA1    T.SYM
          SA1    X1+B7       FETCH *WB* 
          LX0    X1 
          HX0    WB.FR
          AX0    -WB.FRL     EXTRACT FIRST REFERENCE
          NZ     X0,ISL71    IF NOT FIRST REFERENCE 
          BX7    X1 
          SA2    REFLIN 
          LX2    -XR.LINEP+WB.FRP 
          BX7    X2+X7
          SA7    A1          UPDATE WITH FIRST REFERENCE LINE 
  
 ISL71    SA3    T=BLST 
          ZR     X3,ISL72    IF NOT IN A BLOCK STRUCTURE
          SA1    STLTAG 
          HX1    TP.ORD 
          AX1    -TP.ORDL    EXTRACT SYMBOL TABLE ORDINAL 
          BX6    X1 
          SB2    0           INDICATE LABEL BEING REFERENCED
          RJ     ALU         ANALYZE THE LABEL USAGE
  
**        ADD LABEL TO CROSS REFERENCE TABLE -- IF SELECTED.
  
 ISL72    SA3    STLTAG 
          SA2    WO.LOR 
          BX6    X3 
          PL     X2,EXIT.    IF NO REFERENCE MAP
          HX3    TP.ORD      LEFT JUSTIFY 
          AX3    -TP.ORDL    ISOLATE ORDINAL
          SA1    REFNUM 
          LX3    XR.TAGP
          ADDREF X3,X1
          SA1    STLTAG 
          BX6    X1          RESTORE TAG
          SB7    X2          RESTORE INDEX
 ISL75    MX7    0
          SA7    STLUSE 
          EQ     EXIT.
  
 STLUSE   DATA   0           TYPE OF REFERENCE ON ENTRY TO *ISL*
 STL0R    CONENT 0           STATEMENT LABEL IN 0R FORMAT 
 STLTAG   DATA   0           PASS TWO TAG OF LABEL
 PSL      SPACE  4,20 
**        PSL -  PROCESS STATEMENT LABEL. 
* 
*         ENTRY  (STN) = STATEMENT LABEL ON CURRENT CARD PROCESSING.
*                (DTI) = TAG OF STATEMENT LABEL IF THIS IS A DO-TERMINAL
*                (INIF) = P2.TAG TO BE COMPILED IN FRONT OF NEXT STMNT
*                            FOR JUMP AROUND ANY ONE-BRANCH *IF*. 
* 
*         EXIT   IF STATEMENT LABEL PRESENT --
*                1. IF *DO* LABEL PROCESS *DO* CONCLUSION CODE
* 
*                EXIT TO FRONT END CONTROLLER *FEC*.
* 
*         USES   ALL REGISTERS. 
* 
*         CALLS  CSB, PDT 
  
  
 PSL      BSSENT 0           ENTRY... 
          SHRINK T=ARG       IN CASE OF ERRORS
          SA1    CDIFLG 
          ZR     X1,PSL1     IF NO ERRORS DURING *CDI*
          MX6    0
          SA6    A1          RESET THE FLAG 
          SA1    T.BLST 
          SA2    T=BLST 
          =B2    X2-1 
          SA1    X1+B2       X1 = LC. WORD
          LX1    -LC.CNTP 
          SB2    X1-1-DO.W
          ERRNZ  LC.CNTL-18 
          SA1    A1-B2       X1 = DO.W
          LX1    -DO.IODP 
          SB2    X1          IMPLIED DO INDICATOR 
          ERRNZ  18-DO.IODL 
          MX6    1
          NZ     B2,PSL0     IF IMPLIED DO
          LX1    DO.IODP-DO.TAGP
          SX6    X1 
          ERRNZ  DO.TAGL-18 
          LX6    TP.ORDP
 PSL0     RJ     RBE         REMOVE BLOCK ENTRY 
  
 PSL1     SA1    HANGER 
          SA2    INIF 
          NZ     X1,PSL4     IF HANGING STATEMENT 
          ZR     X2,PSL2     IF NO ACTIVE *IF*
          BX6    0
          SA6    NOPATH 
 PSL2     CALL   CSB         CHECK FOR SEQUENCE BREAK 
  
**        COMPILE DO-TERMINATION CODE, IF NECESSARY.
  
          SA2    DTI
          ZR     X2,FEC.RTN  IF NO DO TERMINATION 
          LX2    DO.TAGP
          RJ     PDT         PROCESS *DO* TERMINATION 
          EQ     FEC.RTN     EXIT TO FRONT END CONTROLLER...
  
 PSL4     NZ     X2,"BLOWUP" IF PENDING IF-LABEL
          EQ     FEC.RTN     EXIT TO FRONT END CONTROLLER...
 DO       TITLE  *DO* STATEMENT.
 SDO      SPACE  4,10 
**        SDO -  SET-UP *DO* FOR PROCESSING 
* 
*         *SDO* ENTERED FROM CONTROLLER. (*FEC*)
* 
*         ENTRY  (B4) _ *TB* WHERE *DO* STARTS. 
* 
*         EXIT   TO PSL.
* 
*         USES   ALL REGISTERS. 
  
  
          CON    0           DUMMY FOR DUMB *ASK* 
  
          HEREIF DO 
          SA5    SDOA 
          CALL   ASK         ADJUST STATEMENT KEYWORD 
          SA1    B4 
          SB7    X1-O.CONS
          NZ     B7,E.DO05   IF NO LABEL
          CALL   ASL         ADJUST STATEMENT LABEL 
          BX6    X1 
          SA4    B4          FETCH SUPPOSED VARIABLE
          SB2    X4-O.COMMA 
          NZ     B2,SDO1     IF NOT A COMMA 
          =B4    B4+1        SKIP IT
          SA4    B4 
  
 SDO1     SB2    X4-O.VAR 
          NZ     B2,E.DO14   IF NO CONTROL INDEX
          SB4    A4+1        POINT TO *=* 
          LX7    X4          SAVE CONTROL INDEX FOR  ERROR RECOVERY 
          SA4    B4 
          SB7    X4-O.= 
          ZR     B7,SDO3     IF *=* 
          FATAL  E.DO10 
  
 SDO2     =A4    B4+1 
          =B4    B4+1 
          ZR     X4,PSL      IF *EOS* 
          ERRNZ  O.EOS
          SB7    X4-O.= 
          NZ     B7,SDO2     IF NOT *=*, CONTINUE SEARCH
          SA7    B4-1        MOVE CONTROL INDEX TO LEFT OF *=*
  
 SDO3     RJ     CDI         PROCESS *DO* DEFINITION
          SA3    FLOW 
          ZR     X3,PSL      IF DO IS ACCESSABLE (NOT NOPATH) 
  
*         NOTE - FOR DO LOOPS, ONLY THE DO STATEMENT WILL GET THE NOPATH
*                WARNING MESSAGE.  FLOW, NOPATH AND LDEAD ARE CLEARED,
*                AND THE DO LOOP CODE WILL BE GENERATED. CHECKING ALL 
*                CASES FOR NOPATH CONDITIONS DIDNT SEEM WORTH THE CODE
*                SAVINGS. 
  
          BX7    0
          SA7    A3 
          SA7    NOPATH 
          SA7    LDEAD
          EQ     E.NP1
  
 SDOA     VFD    24/2LDO,9/0,9/2*CHAR-1,18/=1L0+1 
 CDI      EJECT 
**        CDI -  COMPILE *DO* INITIAL TURPLES.
* 
*         ENTRY  (B4) _ *=* OF *DO* STATEMENT.
*                (X6) = 
*                1. IF LOW ORDER 18 BITS ARE ZERO 
*                   PROCESSING A PROGRAMMER *DO*
*                2. OTHERWISE ASSUMED TO BE A I/O LIST PROCESSOR CALL.
* 
*         EXIT   ENTRYS MADE INTO - 
*                (X6) = 0 
*                1. T.SYM OF STATEMENT LABEL.(IF NOT I/O LIST PROCESS)
*                2. T.BLST OF *DO* PARAMETERS. (SEE T.BLST WRITE-UP)
* 
*                (X6) = 1S59
*                *DO* DEFINITION CONTAINED AN ERROR -- NO TABLE ENTRIES 
*                MADE IN T.BLST.
* 
*         CALLS  ACT,ALC,CT1,DTC,EMT,FLP,ISL,INN,LCT,MXP,PAR
* 
*         USES   ALL REGISTERS. 
  
  
 CDI      SUBR   =           ENTRY/EXIT...
          SA2    E=TOTAL
          SX7    X2+1 
          SA7    CDIFLG      PRESERVE ORIGINAL STMT ERROR COUNT 
          SB7    X6 
          SX7    B7 
          SA7    CDIE        INDICATE USER VS I/O DO
          NZ     B7,CDI10    IF I/O DO
  
**        IDENTIFY STATEMENT LABEL AS DO TERMINATOR.
  
          CLAS=  X2,WB,(DOT)
          =X7    CR.DO       MARK DO IN CROSS REF.
          SA7    REFNUM 
          RJ     ISL         IDENTIFY STATEMENT LABEL 
          PL     X6,CDI5     IF NO ERROR IN DO STATEMENT LABEL
          MX7    0
          SA7    CDIFLG 
          EQ     EXIT.
  
 CDI5     HX6    TP.ORD 
          AX6    -TP.ORDL 
          LX6    DO.TAGP     INDICATE PROGRAMMER DO 
  
*         INVENT DO-BEGIN LABEL, CREATE (T.BLST) ENTRY. 
*                (X6) = DO.[TAG OR IOD] SET UP. 
  
 CDI10    SA1    N.DOB
          SA6    CDIA        SAVE TAG FOR TERMINAL LABEL
          SX7    3RDO.
          CALL   INN         INVENT NEW NAME FOR DO-BEGIN LABEL 
          SA5    REFLIN 
          SA4    CDIA 
          MX1    -WB.TLL
          LX4    -DO.TAGP 
          BX7    -X1*X4 
          =A3    A2-WB.W+WC.W 
          LX5    -XR.LINEP+WC.LINEP 
          LX7    WB.TLP 
          CLAS=  X1,WB,(DOGL,SDEF,LAB,ACT)
          BX2    X2+X7       SET SYMORD OF TERMINAL LABEL 
          BX7    X3+X5       SET DEFLINE IN SYMTAB(DOGL)
          BX6    X1+X2
          SA7    A3 
          SB5    X0          REMEMBER (B5) = SYMORD OF DOBEGIN
          SA6    A2          SET ATTRIBUTES FOR DOBEGIN LABEL 
          BX6    X0 
          SA6    CDIB        SAVE SYMORD
          ALLOC  T.BLST,Z=BLST+1
          SX2    Z=BLST+1 
          LX5    -WC.LINEP+LC.LINEP 
          LX2    LC.CNTP
          BX6    X5+X2       ORGIN/COUNT WORD 
          BX7    X4 
          SX4    B5 
          LX4    1
          SX4    X4+B5
          =X4    X4+WB.W     CONVERT TO *WB* INDEX
          LX4    LC.DOP 
          BX6    X6+X4       MERGE IN DO.N INDEX
          LX7    DO.TAGP
          SA6    B7-B1
          SX0    B5 
          =A7    B7-Z=BLST-1+DO.W 
          CALL   CT1         CONSTRUCT (TP) FOR DOB LAB 
          =A6    A7-DO.W+DORT.W 
          =X7    0
          =A7    A6-DORT.W+DP.W  CLEAR
          SA1    CONONE      INITIALIZE INDUCTION PARAMETERS
          BX7    X1 
          LX6    X1 
          =A6    A7-DP.W+DOII.W 
          =A7    A6-DOII.W+DOLI.W 
          =A6    A7-DOLI.W+DOSI.W 
  
*         PARSE DO INDICIES.
*                INSTALL SPECIAL LEFT PAREN IF I/O LOOP.
  
          SA2    CDIA 
          SB3    X2 
          SB4    B4-B1       POINT TO TOKEN FOR CONTROL INDEX 
          ZR     B3,CDI20    IF NOT IN I/O LIST PROCESSING
          =X6    O.SLP
          SA6    B4-B1       INDICATE TERMINATION OF MATCHING *)* 
          SB4    B4-B1
  
 CDI20    =X7    0
          SA3    DOARM
          BX6    X3 
          SA7    ARGCOMA
          SA6    ARGMODE
          CALL   PAR         PARSE DO INDICIES
  
*         DETERMINE TRIP COUNT, PUT IT IN THIS T.BLST ENTRY.
  
          CALL   DTC         DETERMINE TRIP COUNT 
          SA1    T.BLST 
          SA2    T=BLST 
          IX1    X1+X2
          SB5    X1-Z=BLST-1
          LX6    X5 
          SA6    CDID        SAVE TC FOR POSSIBLE OPTIMIZATION
          SA6    B5+DOTC.W
  
*         OUTPUT THE STORE OF START INDEX INTO DO CONTROL.
  
          =A4    A6-DOTC.W+DOSI.W 
          =A5    A4-DOSI.W+DOCI.W 
          SB6    ESTACK+1 
          SX1    O.=
          CALL   ACT         OUTPUT STORE TURPLE
          SA1    T.BLST 
          SA2    T=BLST 
          IX1    X1+X2
          SB5    X1-Z=BLST-1
          SA2    E=TOTAL
          SA4    CDIFLG 
          =X4    X4-1 
          IX2    X2-X4
          MX6    0
          SA6    A4          RESET THE FLAG 
          ZR     X2,CDI30    IF NO ERRORS INSIDE DO 
          BX7    0
          SA2    B5+DO.W
          SA7    B5+DORT.W   INDICATE ERROR IN DO 
          SB7    X2 
          MX6    1           INDICATE ERROR 
          ZR     B7,EXIT.    IF PROGRAM DEFINED *DO* (NOT I/O)
          MX6    1
          RJ     RBE         REMOVE BLOCK ENTRY FOR IMPLIED DO
          MX6    1           INDICATE ERROR 
          EQ     EXIT.
  
*         TEST INCREMENT FOR CONSTANT.  IF NOT CONSTANT, INVENT CELL
*         TO STORE THE INCREMENT.  REPLACE INCREMENT WITH CELL NAME 
*         (TP. FORMAT) IN DOII.W. 
*                (B5) _ DOSI.W OF THE CURRENT DO
  
 CDI30    SA4    B5+DOII.W
          BX1    X4 
          LX5    X4          SAVE INCREMENT 
          CALL   LCT         TEST FOR CONSTANT
          NZ     B2,CDI40    IF CONSTANT
          SA2    N.DOB
          SA1    CDIA        USE AS DUMMY FOR INN 
          SX1    X2-1        USE LAST DO.N NUMBER 
          SX7    3RDI.
          CALL   INN         INVENT NEW NAME FOR INCREMENT VARIABLE 
          LX4    X5          RESTORE INCREMENT VARIABLE 
          CLAS=  X7,WB,(VAR)
          MX1    -WB.MODEL
          ERRNZ  TP.MODEL-WB.MODEL
          BX1    -X1*X4      EXTRACT MODE 
          ERRNZ  TP.MODEP-WB.MODEP+TP.MODEL-WB.MODEL
          BX7    X7+X2
          BX7    X7+X1
          SA7    A2          UPDATE *WB*
          CALL   CT1         GET TP. FORMAT 
          SX1    O.=
          SB6    ESTACK+1 
          LX5    X6 
          CALL   ACT         OUTPUT STORE TURPLE FOR INCREMENT CELL 
          MX6    -1          MARK POSSIBLE NEGATIVE INCREMENT 
  
**        SELECT PROPER DO BEGIN SKELETON AND MODIFY AS NECESSARY THE 
*         DO CONCLUSION SKELETON FOR MEGATURPLE OUTPUT. 
*                (X5) = OPERAND FOR (DOII.W). 
  
 CDI40    PL     X6,CDI405   IF NOT POSSIBLE NEGATIVE INCREMENT 
          SA2    CDIB        SYMORD OF LOOP TOP LABEL 
          SA1    T.SYM
          LX6    B1,X2
          IX2    X6+X2
          IX1    X2+X1
          SA2    X1+WB.W
          MX1    1
          LX1    1+WB.NINP
          BX6    X1+X2       NIN[WB(LOOPTOP)] = 1 
          SA6    A2 
  
 CDI405   SA1    T.BLST 
          SA2    T=BLST 
          IX1    X1+X2
          SB5    X1-Z=BLST-1
          BX6    X5          POSSIBLY RESET INCREMENT OPERAND 
          SA6    B5+DOII.W
          SA5    B5+DOLI.W   X5 = DO LIMIT
          CALL   BBC         CONVERT TO BASE/BIAS FORM
          BX6    X5 
          SA6    B5+DOLI.W   REPLACE TABLE ENTRY WITH CONVERSION
          SA5    B5+DOCI.W   X5 = OPERAND FOR CONTROL INDEX 
          SA1    T=BLST 
          BX6    X1 
          CALL   MDD         MARK DO PARAMETER DEFINED
          SA1    B5+DOTC.W
          CALL   LCT         TEST FOR CONSTANT TRIP COUNT 
          SA1    WO.DOOT     MINIMUM TRIP COUNT 
          SB3    X1 
          ZR     B2,CDI70    IF TRIP COUNT NOT CONSTANT 
          =X0    1
          IX0    X6-X0
          PL     X0,CDI50    IF TRIP COUNT .GE. 1 
          SB7    E.DO01 
          ZR     B3,CDI41    IF IN ZERO TRIP MODE 
          SB7    E.DO18      FATAL - TRIP COUNT LESS THAN 1 
  
 CDI41    WARN   B7 
          SA1    N.GL 
          SA2    B5+DP.W
          CLAS=  X4,TP,(GL) 
          BX7    X1 
          =X6    X1+1 
          SA6    A1          INCREMENT N.GL 
          LX1    TP.ORDP
          BX4    X1+X4       (1OP) = GL FOR EXIT
          LX7    DP.DOXLP 
          BX7    X7+X2
          MX0    -DP.TURCL
          LX0    DP.TURCP 
          BX7    X0*X7       CLEAR CONCLUSION SKELETON
          SA7    A2          UPDATE DP.W
          MX5    0           (2OP) = NULL 
          EMIT   V=GOTO 
          MX6    0
          EQ     EXIT.
  
*         CONSTANT TRIP COUNT.  DO LOOP MUST MATERIALIZE. 
*                (B5) _ DOSI.W OF THE CURRENT DO
*                (X6) = TRIP COUNT (BINARY) 
  
 CDI50    SA1    WO.DOLG     DO LOOP LENGTH INDICATOR 
          SB3    1           LOOP EXECUTES, MODIFY TRIP COUNT INDICATOR 
          NZ     X1,CDI70    IF LONG LOOP SELECTED
          SA1    =10HTRIP COUNT 
          SX2    MAX.SDL
          BX7    X1 
          =X0    1
          IX0    X2+X0
          IX0    X6-X2
          PL     X0,CDI60    IF TRIP COUNT TOO LARGE FOR SHORT LOOP 
          SA1    B5+
          RJ     KDI         CONVERT INITIAL
          LX3    X6          *M1* BINARY
          =A1    B5-DOSI.W+DOLI.W 
          RJ     KDI         CONVERT LIMIT
          LX4    X6          *M2* BINARY
          =A1    B5-DOSI.W+DOII.W 
          RJ     KDI         CONVERT INCREMENT
          SX2    MAX.SDL
          =X0    1
          IX2    X0+X2
          IX3    X3+X6       *M1+M3*
          PL     X3,CDI51    IF POSITIVE
          BX3    -X3         ABSOLUTE VALUE 
  
 CDI51    SA1    =5HM1+M3 
          LX7    X1 
          IX3    X3-X2
          PL     X3,CDI60    IF M1+M3 TOO LARGE FOR SHORT LOOP
          IX4    X4+X6       *M2+M3*
          PL     X4,CDI52    IF POSITIVE
          BX4    -X4         ABSOLUTE VALUE 
  
 CDI52    SA1    =5HM2+M3 
          BX7    X1 
          IX4    X4-X2
          MI     X4,CDI70    IF M2+M3 IS SMALL ENOUGH FOR SHORT LOOP
  
 CDI60    SA7    FILL.3 
          FATAL  E.DO03      ** TOO LARGE FOR SHORT LOOP
  
**        SELECT THE PROPER TURPLE
*                (B3) = MINIMUM TRIP COUNT INDICATOR
*                (B5) _ DOSI.W OF THE CURRENT DO
  
 CDI70    NZ     B3,CDI80    IF ONE TRIP DO LOOPS SELECTED
          SA1    N.GL 
          SA2    B5+DP.W
          =X6    X1+1 
          SA6    A1          INCREMENT N.GL 
          LX1    DP.DOXLP 
          BX6    X1+X2       ADD IN DOXL
          SA6    A2 
  
 CDI80    SA1    WO.DOLG     DO LOOP LENGTH 
          SA2    B5+DOCI.W
          MX0    -TP.MODEL
          LX2    -TP.MODEP
          BX0    -X0*X2 
          SB2    X0-M.REAL
          MI     B2,CDI81    IF CONTROL VARIABLE INTEGER OR BOOLEAN 
          =X1    1           SIMULATE LONG LOOP 
  
 CDI81    LX1    1
          SB3    B3+X1       SELECT PROPER TURPLE HEADER
          SA2    B3+DO.BEG   FETCH PROPER TURPLE HEADER 
          LX6    X2 
          SA6    CDIC        SAVE FOR TURPLE OUTPUT 
  
*         INVENT TRIP COUNT VARIABLE
  
          SA1    CDID        TRIP COUNT 
          CALL   LCT         CHECK FOR CONSTANT 
          ZR     B2,CDI82    IF TRIP COUNT NOT CONSTANT 
          SX1    B1 
          IX6    X6-X1
          NZ     X6,CDI82    IF TRIP COUNT " 1
          SA1    T.BLST 
          SA2    T=BLST 
          SA3    =XCO.OPT 
          SB2    X3 
          SB5    X2-Z=BLST-1+DP.W 
          SA3    X1+B5
          SB7    V=DOC.S
          BX3    -X3
          SX3    X3+B7
          NZ     X3,CDI81A   IF SKEL NOT V=DOC.S
          SX6    V=DOC.O
          EQ     B2,CDI81B   IF OPT .EQ. 0
          SX6    =YV=DOC.1
  
 CDI81B   SA6    A3 
          SA4    T=DATL 
          ZR     X4,CDI82    IF NOT IN DATA STATEMENT 
  
 CDI81A   SB5    X2-Z=BLST-1 INDEX OF THIS DO ENTRY 
          MX6    -0          INDICATE ONE TRIP DO 
          SB5    X1+B5
          SA6    B5+DORT.W   REFLECT ONE TRIP 
          SX6    0           INDICATE NO ERROR
          EQ     EXIT.
  
 CDI82    SA2    N.DOB
          SA1    CDIA        USE AS DUMMY FOR INN 
          SX1    X2-1        USE LAST DO.N NUMBER 
          SX7    3RDC.
          CALL   INN         INVENT NEW NAME FOR TRIP COUNT VARIABLE
          CLAS=  X7,WB,(VAR),INT
          BX7    X7+X2
          SA7    A2          UPDATE *WB*
          SA3    T.BLST 
          SA4    T=BLST 
          SB5    X4-Z=BLST-1 (B5) = (T.BLST) INDEX OF THIS DO 
          SB7    X3+B5
          SA1    B7+DP.W
          LX6    X0 
          LX6    DP.DOTIP 
          BX6    X1+X6       MERGE IN TRIP COUNT ORDINAL
          SA6    A1 
  
**        FINALLY, EMIT DO-INITIAL MEGATURPLE TO THE IL.
* 
*         A DO-INITIAL MEGA-TURPLE CONSISTS OF THREE TURPLES, 
*         ORGANIZED AS FOLLOWS -- 
* 
*         1.  OPR = DOBEGIN SKELETON. 
*                P1 = CONTROL INDEX.               (DOCI.W) 
*                P2 = TRIP COUNT.                  (DOTC.W) 
* 
*         2.  OPR = NOOP. 
*                P3 = TRIP COUNT VARIABLE (DC.N).  (DP.DOTI)
*                P4 = UPPER VALUE        (DOLI.W) 
* 
*         3.  OPR = NOOP. 
*                P5 = GL FOR DO-BEGIN.             (DORT.W) 
*                P6 = GL FOR DO-END.               (DP.DOXL)
* 
*         NOTE THAT (P6) IS OMITTED (ZERO) FOR A ONE-TRIP LOOP. 
* 
*         ALSO RECORD POINTER TO THIS MEGATURPLE IN THE (T.BLST) ENTRY. 
  
  
          SA1    T=PAR
          =A2    B7+DO.W
          LX1    DO.FLGP
          BX6    X1+X2       RECORD INDEX OF DOB MEGATURPLE 
          =A4    B7+DOCI.W
          =A5    A4-DOCI.W+DOTC.W 
          SA6    A2 
          EMIT   CDIC,* 
  
          SA3    T.BLST 
          SB7    X3+B5
          =A4    B7+DP.W
          =A5    B7+DOLI.W
          HX4    DP.DOTI
          AX4    -DP.DOTIL   EXTRACT TRIP COUNT VARIABLE ORDINAL
          LX0    X4 
          CALL   CT1         GET INTO TP. FORMAT
          BX4    X6 
          EMIT   V=NOOP,BOTH
  
          SA3    T.BLST 
          SB7    X3+B5
          =A4    B7+DORT.W
          =A5    A4-DORT.W+DP.W 
          HX5    DP.DOXL
          AX5    -DP.DOXLL   EXTRACT DO END GL ORDINAL
          ZR     X5,CDI90    IF NO GENERATED LABEL
          CLAS=  X1,TP,(GL) 
          LX5    TP.ORDP
          BX5    X5+X1
  
 CDI90    EMIT   V=NOOP 
          SA1    CDIE        TYPE OF DO 
          NZ     X1,CDI95    IF I/O DO
          CALL   OIL         FLUSH I.L. 
  
 CDI95    SX6    0           INDICATE NO ERRORS 
  
 SNAP=N   IFEQ   TEST,ON
          SA1    CO.SNAP
          LX1    1RN
          PL     X1,CDIXX    IF (SNAP=N) NOT SELECTED 
 CDI      DUMPT  (BLST) 
 CDIXX    BSS 
 SNAP=N   ENDIF 
  
          EQ     EXIT.
  
 CDIA     BSS    1           GENERAL SAVE CELL
 CDIB     BSS    1           DO BEGIN LABEL (TP. FORMAT)
 CDIC     BSS    1           DO BEGIN TURPLE HEADER 
 CDID     BSS    1           DO TRIP COUNT (TP.)
 CDIE     BSS    1           DO TYPE INDICATOR
 CDIFLG   BSZENT 1           ERRORS IN STMT + 1 (ON ENTRY)
 KDI      SPACE  4,10 
**        KDI - CONVERT DO INDEX (TO BINARY)
* 
*         ENTRY  (X1) = TP. FORM OF INDEX 
* 
*         EXIT   (X6) = BINARY OF CONSTANT
* 
*         CALLS  LCT
* 
*         USES   X0,X6
  
  
 KDI      SUBR               ...ENTRY/EXIT... 
          CALL   LCT         LOAD BINARY OF CONSTANT
          ZR     B2,EXIT.    IF NOT CONSTANT
          SX0    X0-M.REAL
          MI     X0,EXIT.    IF NOT FLOATING
          UX6    X6,B2
          LX6    B2,X6       INTEGERIZE 
          EQ     EXIT.
 PDT      EJECT 
**        PDT -  PROCESS *DO* TABLES. 
* 
*         *PDT* WILL EMIT A *D0* CONCLUSION MEGATURPLE TO T.PAR.
* 
*         ENTRY  IF I/O LIST PROCESSING 
*                (X2) = TABLE FORMAT FOR AN I/O DO. 
*         TABLE FORMAT= 
*                       24/ 0,  18/ 0       18/ TP.ORDL 
* 
*                IF PROGRAMMER DEFINED *DO* 
*                (X2) = TABLE FORMAT FOR PROGRAMMER DO. 
*         TABLE FORMAT= 
*                       24/ 0,  18/ TP.ORDL, 18/ 0
* 
*         EXIT   DO CONCLUSION SKELETONS ADDED TO PARSED FILE.
* 
*         USES   ALL REGISTERS EXCEPT *B4*
* 
*         CALLS  EMT, FBS, PDT
  
  
 PDT      SUBR   =           ENTRY/EXIT...
  
 SNAP=N   IFEQ   TEST,ON
          SA1    CO.SNAP
          LX1    1RN         DO SNAP FLAG 
          PL     X1,PDT1A 
 N-PDT    DUMPT  (BLST) 
 PDT1A    BSS    0
 SNAP=N   ENDIF 
  
          BX6    X2 
          SA6    PDTA        SAVE STATEMENT TAG (LOW ORDER) 
  
 PDT1     SA4    T=BLST 
          ZR     X4,EXIT.    IF ALL BLOCKS REMOVED (FOR ERRORS) 
          SA1    T.BLST 
          =B3    X4-1 
          SA3    X1+B3       FETCH COUNT WORD 
          LX3    -LC.DOP
          SX0    X3          EXTRACT DO LOOP INDEX
          ERRNZ  18-LC.DOL
          NZ     X0,PDT2     IF NOT IF BLOCK
          FATAL  E.IF16      UNTERMINATED IF BLOCK
          SX6    0           INDICATE IF BLOCK
          RJ     RBE         REMOVE THE BLOCK ENTRY 
          EQ     PDT1        CONTINUE PROCESSING
  
 PDT2     SA2    PDTA        FETCH DO CONCLUSION
          LX3    LC.DOP-LC.CNTP 
          SX0    X3          EXTRACT SEGMENT SIZE 
          ERRNZ  18-LC.CNTL 
          IX0    X4-X0
          SB5    X0-DOSI.W+DO.W 
          MX0    DO.FLGL
          SA3    X1+B5
          BX5    X3-X2       COMPARE TABLE ENTRY TO LABEL 
          HX5    DO.FLG 
          =B5    A3-DO.W     (B5) = ADDRESS OF THIS DO-TABLE ENTRY
          BX2    -X0*X5      REMOVE (DO.FLG) FROM COMPARISON
          ZR     X2,PDT5     IF NOT ILLEGALLY NESTED DO 
          FATAL  E.DO12 
          SA1    PDTA 
          HX1    DO.TAG 
          AX1    -DO.TAGL    EXTRACT LABEL SYMTAB ORDINAL 
          BX6    X1 
          LX6    TP.ORDP
          RJ     RBE         REMOVE THE T.BLST ENTRY
          EQ     EXIT.
  
**        CHECK IF *DO* DEFINITION HAD ERRORS.
*         (B5) = FWA FROM *DO* TABLE FOR CURRENT *DO*.
*         (X3) = CURRENT *DO* ENTRY TAG.
*         (X4) = CURRENT LENGTH OF DO TABLE 
  
 PDT5     SA2    B5+DORT.W
          NZ     X2,PDT7     IF NO ERROR IN DO DEFINITION 
          MI     X2,PDT6     IF NO CODE BECAUSE ONE TRIP LOOP 
          TRIV   E.DO13      DEFINITION ERROR 
  
 PDT6     SB7    X3 
          NZ     B7,PDT40    IF CURRENT IS AN I/O IMPLIED DO
          RJ     FBS         FINISH THE DO STRUCTURE
          EQ     PDT40
  
 PDT7     SB7    X3 
          NZ     B7,PDT10    IF CURRENT IS AN I/O IMPLIED DO
          RJ     FBS         FINISH THE DO STRUCTURE
          =B7    0           INDICATE PROGRAMMER *DO* 
  
 PDT10    BSS    0
  
**        EMIT DO-CONCLUSION MEGA-TURPLE TO PARSED FILE.
* 
*         THE T.BLST SEGMENT BEING PROCESSED HAS LABELS REMOVED.
* 
*         A DO-CONCLUSION MEGA-TURPLE CONSISTS OF TWO TURPLES,
*         OPTIONALLY FOLLOWED BY A DO-EXIT LABEL DEFINITION TURPLE, 
*         ORGANIZED AS FOLLOWS -- 
*         1.  OPR = DOEND SKELETON. 
*                P1 = CONTROL INDEX.               (DOCI.W) 
*                P2 = INCREMENT VALUE OR (DI.N)    (DOII.W) 
*         2.  OPR = NOOP. 
*                P3 = INVENTED DO-BEGIN LABEL.     (DORT.W) 
*                P4 = TRIP COUNT VARIABLE (DC.N)   (DP.DOTI)
* 
*         3.   OPR = OPBSS (IF NECESSARY) 
*                P5 = GL FOR DO-CONCLUSION.        (DP.DOXL)
*                P6 = NULL. 
  
          SA1    T.BLST 
          SA2    T=BLST 
          SB5    X2-Z=BLST-1 RELATIVIZE (B5) = INDEX OF CURRENT DO
          SB7    X1+B5
          SA2    B7+DP.W
          HX2    DP.TURC
          AX2    -DP.TURCL   EXTRACT DO CONCLUSION SKELETON 
          ZR     X2,PDT25    IF CONCLUSION NOT TO BE OUTPUT 
          LX2    SP.SKELP 
          SA3    OPDUM+DUC=BOTH 
          BX6    X2+X3
          SA6    PDTB        SAVE FOR TURPLE OUTPUT 
          =A4    B7+DOCI.W
          =A5    A4-DOCI.W+DOII.W 
          EMIT   PDTB,* 
  
          SA3    T.BLST 
          SB7    X3+B5
          =A4    B7+DORT.W
          =A5    A4-DORT.W+DP.W 
          HX5    DP.DOTI
          AX5    -DP.DOTIL   EXTRACT TRIP COUNT VARIABLE ORDINAL
          BX0    X5 
          CALL   CT1         GET TP. FORM OF TRIP COUNT VARIABLE
          LX5    X6 
          EMIT   V=NOOP,2ND 
  
 PDT25    SA1    T.BLST 
          SB7    X1+B5
          SA4    B7+DP.W
          HX4    DP.DOXL
          AX4    -DP.DOXLL   EXTRACT DO CONCLUSION GL 
          ZR     X4,PDT30    IF NO GENERATED LABEL
          CLAS=  X1,TP,(GL) 
          LX4    TP.ORDP
          BX4    X4+X1
          MX5    0
          EMIT   OPBSS,*
  
**        CLEAR *DO* CELLS.  CHECK IF MORE THAN ONE *DO* TERMINATES 
*         ON CURRENT LABEL.  PROPAGATE (DLNI) ATTRIBUTE OUTWARD.
  
 PDT30    SA1    T=PAR
          BX7    X1 
          SA7    CURST       DONT SQUEEZE PAST DO 
  
 PDT40    SA4    T=BLST 
          SX6    X4-Z=BLST-1
          SHRINK A4,X6       REMOVE CONCLUDED LOOP FROM DO-STACK
          ZR     X6,EXIT.    IF DO-STACK EMPTY
          SA2    T=BLST 
          CLAS=  X0,WB,(DLNI) 
          RJ     PDA         PROPOGATE DO LOOP ATTRIBUTES 
  
*         CHECK FOR BLOCK IF ENTRY
  
          SA1    T.BLST 
          SA2    T=BLST 
          SB2    X2-1 
          SA3    X1+B2       FETCH COUNT WORD 
          LX3    -LC.DOP
          SX0    X3          EXTRACT DO INDEX 
          ERRNZ  18-LC.DOL
          ZR     X0,EXIT.    IF BLOCK IF
  
**        CHECK IF MORE THAN ONE LOOP TERMINATES ON THIS *DO* LABEL.
*                (X6) = CURRENT LENGTH OF DO TABLE
  
          LX3    LC.DOP-LC.CNTP 
          SX0    X3          EXTRACT COUNT
          ERRNZ  18-LC.CNTL 
          IX0    X2-X0       INDEX TO NEXT LOOP SEGMENT 
          SA2    PDTA        FETCH (X2) = TAG OF CURRENT DO LABEL 
          =B2    X0+DO.W
          MX0    -DO.TAGL 
          SA3    X1+B2
          LX0    DO.TAGP
          BX3    -X0*X3 
          BX7    X3-X2
          NZ     X7,EXIT.    IF NOT CURRENT *DO* LABEL. 
  
**        NESTING OF *DO* WITH SINGLE TERMINATOR. MARK LABEL AS 
*         TERMINATING MORE THAN ONE DO, IF PROGRAMMER DO.  (IS THIS 
*         REALLY NECESSARY?)
  
          SB7    X3 
          ERRNZ  18-DO.IODL 
          BX4    X6 
          =B5    A3-DO.W
          NZ     B7,PDT5     IF IN *I/O* DO 
          BX6    X3 
          SA1    T.SYM
          AX6    DO.TAGP
          SB2    X6          EXTRACT (B2) = SYMORD OF DO-LABEL
          ERRNZ  18-DO.TAGL 
          SX6    B2+B2
          SB2    X6+B2       CONVERT ORDINAL TO INDEX 
          ERRNZ  3-Z=SYM
          =B2    B2+WB.W
          SA2    X1+B2       LOAD *WB*
          CLAS=  X0,WB,(DLNI) 
          BX6    X2+X0
          SA6    A2          INDICATE LABEL TERMINATES MORE THAN 1 LOOP 
          EQ     PDT5        CONTINUE 
  
 PDTA     CON    0           CURRENT DO LABEL 
 PDTB     BSS    1           TURPLE HEADER FOR DO CONCLUSION
          TITLE  DO NEST AND IF BLOCK LABEL LINKAGE.
 ALU      SPACE  4,10 
**        ALU -  ANALYZE LABEL USAGE
* 
*         CALLED WHEN A LABEL DEFINITION OR REFERENCE OCCURS WITHIN A DO
*         LOOP OR BLOCK IF STRUCTURE. 
* 
*         ENTRY  (B2) = DEFINITION/REFERENCE INDICATOR
*                (B7) = SYMBOL TABLE *WB* INDEX 
*                (X6) = CURRENT LABEL SYMBOL TABLE ORDINAL
* 
*         EXIT
* 
*         USES   A1,A2,A3,A6,A7  X0,X1,X2,X3,X6,X7  B2,B3,B7
* 
*         CALLS  ADW
  
  
 ALU      SUBR   =           ...ENTRY/EXIT... 
          SA1    T.BLST 
          SA2    T=BLST 
          =B3    X2-1 
          SA3    X1+B3       FETCH DO/ORIGIN/COUNT WORD 
          LX3    -LC.CNTP 
          SX0    X3          EXTRACT SEGMENT SIZE 
          ERRNZ  18-LC.CNTL 
          SB3    X0-Z=BLST-1 COUNT OF LABELS IN THIS STRUCTURE
          LX3    LC.CNTP-LC.LINEP 
          SX0    X3          EXTRACT BLOCK ORIGIN 
          ERRNZ  18-LC.LINEL
          SA1    T.SYM
          LX3    LC.LINEP-LC.DOP
          SX3    X3          EXTRACT DO INDEX 
          ERRNZ  18-LC.DOL
          NZ     X3,ALU5     IF DO LOOP 
  
*         HERE WHEN CURRENT STRUCTURE IS IF BLOCK 
*                (X0) = BLOCK ORIGIN LINE NUMBER
*                (X1) = (T.SYM) 
*                (B2) = REF/DEF INDICATOR 
  
          NZ     B2,ALU1     IF LABEL BEING DEFINED 
          CLAS=  X3,LA,(REF)
          EQ     ALU20
  
 ALU1     SA2    X1+B7       FETCH *WB* 
          BX3    X2 
          HX2    WB.FR
          AX2    -WB.FRL     EXTRACT FIRST REFERENCE
          SBIT   X3,WB.SREFP
          PL     X3,ALU2     IF NOT PREVIOUSLY REFERENCED 
          IX0    X2-X0
          PL     X0,ALU2     IF FIRST REFERENCE WITHIN CURRENT ARM
          FATAL  E.SL09 
  
 ALU2     CLAS=  X3,LA,(DEF)
          EQ     ALU20
  
*         HERE WHEN DATA STRUCTURE IS DO LOOP 
*                (X0) = BLOCK ORIGIN LINE NUMBER
*                (X1) = (T.SYM) 
*                (X3) = DO LOOP HEADER LABEL INDEX
*                (B2) = REF/DEF INDICATOR 
  
 ALU5     NZ     B2,ALU10    IF LABEL IS BEING DEFINED
          SB2    X3          PRESERVE DO HEADER INDEX 
          SA2    X1+B7       FETCH *WB* 
          SBIT   X2,WB.SDEFP
          CLAS=  X3,LA,(REF)
          PL     X2,ALU20    IF LABEL NOT YET DEFINED 
          =A2    A2-WB.W+WC.W 
          HX2    WC.LINE
          AX2    -WC.LINEP   EXTRACT DEFINITION LINE NUMBER 
          IX0    X2-X0
          SA2    X1+B2       FETCH DO LOOP HEADER *WB*
          CLAS=  X7,WB,(DLBB) 
          PL     X0,ALU7     IF DEFINITION IS WITHIN CURRENT DO LOOP
          CLAS=  X3,LA,(REF,EXT)
          CLAS=  X7,WB,(DLEX) 
  
 ALU7     BX7    X2+X7
          SA7    A2          UPDATE DO HEADER *WB*
          EQ     ALU20
  
*         HERE WHEN LABEL IS DEFINED WITHIN LOOP
  
 ALU10    SA2    X1+B7
          SB2    X3          PRESERVE DO HEADER INDEX 
          CLAS=  X3,LA,(DEF)
          SBIT   X2,WB.SREFP
          PL     X2,ALU20    IF NOT PREVIOUSLY REFERENCED 
          LX2    WB.SREFP+WB.SREFL-WB.FRP-WB.FRL
          AX2    -WB.FRL     EXTRACT FIRST REFERENCE LINE 
          ZR     X2,ALU20    IF FIRST REFERENCE IS ASSIGN 
          IX0    X2-X0
          PL     X0,ALU20    IF REFERENCE WAS INSIDE THIS LOOP
          SA2    X1+B2       FETCH DO HEADER *WB* 
          CLAS=  X7,WB,(DLEN) 
          BX7    X2+X7
          SA7    A2          RESET DO HEADER *WB* INDICATING ENTRY
          SA1    T.SYM
          LX2    B1,X6       X6 -> CURRENT LABEL SYMBOL TABLE ORDINAL 
          IX2    X2+X6
          IX1    X2+X1
          SA1    X1+WB.W
          MX2    0
          LX0    X2 
          SBIT   X1,WB.ALRNP
          PL     X1,ALU12    IF NO ALTERNATE RETURN TO THIS LABEL 
          CLAS=  X2,LA,(ALRN) 
          LX0    X2 
  
 ALU12    SBIT   X1,WB.GOTOP/WB.ALRNP 
          PL     X1,ALU14    IF NO *GOTO* TO THIS LABEL 
          CLAS=  X2,LA,(GOTO) 
  
 ALU14    CLAS=  X3,LA,(DEF,ENT)
          BX3    X3+X2
          BX3    X3+X0
  
*         FINISH UP THIS ENTRY
*                (B3) = COUNT OF LABELS IN STRUCTURE
*                (X3) = BITS TO SET IN LABEL WORD 
*                (X6) = LABEL SYMBOL TABLE ORDINAL
  
 ALU20    SA1    T.BLST 
          SA2    T=BLST 
          SB2    X2-1 
          SB2    B2-B3
          SA1    X1+B2       PREFETCH LABEL WORD
  
 ALU21    ZR     B3,ALU25    IF NO MORE LABELS
          =B3    B3-1 
          BX7    X1-X6
          SX7    X7 
          BX2    X1          SAVE CURRENT LABEL 
          =A1    A1+1        (A1,X1) = A+C NEXT LABEL 
          NZ     X7,ALU21    IF NOT A MATCH 
  
*         CURRENT LABEL ALREADY REFERENCED OR DEFINED IN CURRENT BLOCK
*         MERGE IN CURRENT USAGE BITS.
  
          BX6    X3+X2
          SA6    A1-1        UPDATE TABLE ENTRY 
          EQ     EXIT.
  
*         THE CURRENT LABEL IS NEW TO THE CURRENT BLOCK.  ADD TO T.BLST 
*         AND UPDATE THE COUNT WORD 
  
 ALU25    BX6    X3+X6
          SA6    A1          ADD THE LABEL ENTRY
          =X6    1
          IX6    X6+X1       INCREMENT THE DO/ORIGIN/COUNT WORD 
          ADDWD  T.BLST 
          EQ     EXIT.
 DDR      SPACE  4,10 
**        DDR -  DIAGNOSE DO (INDEX) REDEFINITION 
* 
*         ENTRY  (X5) = POSSIBLE DO INDEX 
*                (B3) = .MI. DO CONTROL INDEX 
*                       .PL. NOT DO CONTROL INDEX 
* 
*         EXIT   (X5) = BASE/BIAS FORM OF POSSIBLE DO INDEX 
*                DO INDEX REDEFINITION DIAGNOSED (AS APPLICABLE)
* 
*         CALLS  BBC, RBE 
* 
*         USES   A1,A2,A3,A7  X1,X2,X3,X7  B2,B7
  
  
 DDR      SUBR   =           ...ENTRY/EXIT... 
          BX7    X5 
          SBIT   X7,TP.INTRP
          MI     X7,EXIT.    IF ARRAY LOAD, CANT TELL 
          MX7    -TP.MODEL
          LX5    -TP.MODEP
          BX7    -X7*X5 
          LX5    TP.MODEP 
          SX7    X7-M.CHAR
          ZR     X7,EXIT.    IF CHARACTER OPERAND 
          CALL   BBC         CONVERT TO BASE/BIAS 
          SA1    T.BLST 
          SA2    T=BLST 
          SB2    X2-1 
          MX7    TP.ORBIL 
          LX7    TP.ORBIL+TP.ORBIP
          ZR     X2,EXIT.    IF NO ACTIVE BLOCKS
  
 DDR1     SA3    X1+B2       FETCH LC. WORD FOR BLOCK 
          LX3    -LC.CNTP 
          SB7    X3          NUMBER OF WORDS IN THIS T.BLST ENTRY 
          ERRNZ  18-LC.CNTL 
          HX3    LC.DO
          AX3    -LC.DOL     EXTRACT DO LOOP HEADER LABEL INDEX 
          SB2    B2-B7
          ZR     X3,DDR5     IF NOT DO LOOP 
          SB7    B2+DOCI.W+1
          SA3    X1+B7
          IX3    X5-X3
          BX3    X7*X3       EXTRACT TAG/BIAS 
          NZ     X3,DDR5     IF NO DO INDEX REDEFINITION
          SB2    X2-1        RESTORE INVALID ENTRY LC. POINTER
          SA3    X1+B2       LC. WORD 
          LX3    -LC.CNTP 
          SB7    X3          NUMBER OF WORDS IN T.BLST ENTRY
          ERRNZ  18-LC.CNTL 
          SB2    B2-B7
          SB2    X1+B2       TOP OF T.BLST ENTRY
          SA3    B2+DO.W+1
          MX6    1           NEGATIVE IF IMPLIED DO (FOR RBE) 
          HX3    DO.IOD 
          AX3    -DO.IODL    EXTRACT IMPLIED DO FLAG
          NZ     X3,DDR2     IF IMPLIED I/O DO
          SA1    STLTAG      CURRENT DO TERMINAL
          BX6    X1          FOR RBE CALL 
          HX1    TP.ORD 
          AX1    -TP.ORDL    EXTRACT ORDINAL
          SB2    X1 
          LX1    1
          SB2    B2+X1       CONVERT ORDINAL TO INDEX 
          ERRNZ  3-Z=SYM
          =B2    B2+WB.W
          SA1    T.SYM
          SA1    X1+B2       FETCH DO TERMINAL *WB* 
          CLAS=  X7,WB,(DOT)
          BX7    -X7*X1      CLEAR DO TERMINAL BIT
          SA7    A1          UPDATE 
  
 DDR2     RJ     RBE         REMOVE THE DO ENTRY
          MX6    0
          SA6    CDIFLG      CLEAR TO AVOID SECOND SCRATCH
          EQ     E.DO08      ** DO INDEX REDEFINITION 
  
 DDR5     PL     B2,DDR1     IF MORE BLOCKS 
          EQ     EXIT.
 FBS      SPACE  4,10 
**        FBS -  FINISH BLOCK STRUCTURE 
* 
*         CALLED WHEN A DO LOOP OR BLOCK IF ARM IS COMPLETED. 
*         ALL LABEL WORDS ARE MERGED INTO THE NEXT OUTER BLOCK
*         (AS NECESSARY) AND THE CURRENT BLOCK IS RETURNED TO T.BLST
*         WITH AN UPDATED LC. WORD. 
* 
*         USES   A1,A2,A3,A5,A6,A7  X0,X1,X2,X3,X5,X6,X7  B2,B3,B7
* 
*         CALLS  ADW, ALC, ALU, MVE=
  
  
 FBS      SUBR   =           ...ENTRY/EXIT... 
  
*         COPY THE BLOCK STRUCTURE SEGMENT TO T.SCR FOR PROCESSING EASE.
  
          SA1    T.BLST 
          SA2    T=BLST 
          =B3    X2-1 
          SA1    X1+B3       FETCH COUNT WORD 
          BX6    X1 
          SA6    FBSA        SAVE 
          LX1    -LC.CNTP 
          SB3    X1 
          ERRNZ  18-LC.CNTL 
          LX1    LC.CNTP-LC.DOP 
          SB2    X1 
          ERRNZ  18-LC.DOL
          ALLOC  T.SCR,B3 
          LX3    X1          DESTINATION
          SA5    T=BLST 
          SA2    T.BLST 
          SX1    B3          LENGTH 
          IX5    X5-X1       NEW LENGTH OF T.BLST 
          SHRINK T=BLST,X5
          IX2    X2+X5       SOURCE 
          MOVE   X1,X2,X3 
          SB7    B2 
          SA1    T.SCR
          SB2    X1          BASE OF THE CURRENT SEGMENT
          SB3    B3-Z=BLST-1 NUMBER OF LABELS TO PROCESS
          NZ     B7,FBS10    IF BLOCK IS DO LOOP
  
*         BLOCK IS IF BLOCK 
  
          ZR     B3,FBS3     IF NO LABELS IN THIS ARM 
          SB2    B2+Z=BLST   ADVANCE TO FIRST LABEL 
  
 FBS1     SA1    B2          FETCH LABEL
          SX2    X1          EXTRACT ORDINAL
          ERRNZ  0-LA.ORDP+18-LA.ORDL 
          SBIT   X1,LA.DEFP 
          PL     X1,FBS2     IF LABEL NOT DEFINED IN CURRENT BLOCK
          SA1    T.SYM
          SB7    X2 
          LX2    1
          SB7    B7+X2       CONVERT ORDINAL TO INDEX 
          ERRNZ  3-Z=SYM
          =B7    B7-WA.W+WB.W 
          SA2    X1+B7
          CLAS=  X3,WB,(INA)
          BX6    X2+X3
          SA6    A2          MARK DEFINED LABEL AS INACTIVE 
  
 FBS2     =B2    B2+1 
          =B3    B3-1 
          NZ     B3,FBS1     IF NOT FINISHED
  
 FBS3     SA1    T=BLST 
          ZR     X1,FBS5     IF THIS IS ONLY BLOCK
  
*         MERGE LABELS INTO OUTER BLOCK 
  
          SA2    T=SCR
          SX2    X2-1 
          SHRINK A2,X2       REMOVE COUNT WORD (LC.)
  
 FBS4     SA1    T.SCR
          SB5    X2-Z=BLST
          ZR     B5,FBS5     IF NO MORE LABELS
          SB5    X2-1 
          SA3    X1+B5       FETCH LABEL
          CLAS=  X0,LA,(DEF)
          BX0    X0*X3
          HX0    LA.DEF 
          LX0    LA.DEFL
          SB2    X0          REF/DEF INDICATOR
          LX3    -LA.ORDP 
          SX6    X3          EXTRACT ORDINAL
          ERRNZ  18-LA.ORDL 
          IX3    X6+X6
          IX3    X3+X6       CONVERT ORDINAL TO INDEX 
          =B7    X3-WA.W+WB.W 
          RJ     ALU         ANALYZE LABEL USAGE (FOR OUTER STRUCTURE)
          SA2    T=SCR
          SX2    X2-1 
          SHRINK A2,X2       REMOVE THE LABEL JUST PROCESSED
          EQ     FBS4 
  
*         MOVE BLOCK BACK TO T.BLST 
  
 FBS5     ALLOC  T.BLST,Z=BLST
          SX1    Z=BLST      LENGTH 
          SA2    T.SCR       SOURCE 
          SX3    B7-Z=BLST   DESTINATION
          MOVE   X1,X2,X3 
          SX6    Z=BLST+1 
          SA1    REFLIN 
          LX1    -XR.LINEP+LC.LINEP 
          BX6    X1+X6
          SA1    FBSA        OLD COUNT WORD 
          CLAS=  X2,LC,(GLM)
          BX1    X1*X2
          BX6    X1+X6       MERGE IN LC.GLM (IF PRESENT) 
          ADDWD  T.BLST      NEW LC. WORD 
          EQ     FBS25
  
*         BLOCK IS DO LOOP
*                (B2) = BASE OF SEGMENT 
*                (B3) = NUMBER OF LABELS TO PROCESS 
*                (B7) = DO LOOP HEADER LABEL INDEX
*                (X1) = (T.SCR) 
  
 FBS10    ZR     B3,FBS3     IF NO LABELS IN THIS ARM 
          SA1    T.SYM
          SA3    X1+B7       DO HEADER LABEL *WB* 
          SB2    B2+Z=BLST   ADVANCE TO FIRST LABEL 
          MX6    0
          SA6    ALRNF
          SA6    GOTOF
  
 FBS11    SA1    B2          FETCH LABEL WORD 
          SX2    X1          EXTRACT ORDINAL
          BX7    X1          LABEL WORD USED AT FBS12 
          ERRNZ  0-LA.ORDP+18-LA.ORDL 
          SBIT   X1,LA.REFP 
          PL     X1,FBS12    IF NOT REFERENCED IN THIS DO LOOP
          SBIT   X1,LA.EXTP/LA.REFP 
          MI     X1,FBS12    IF KNOWN TO BE EXIT
          SBIT   X1,LA.DEFP/LA.EXTP 
          MI     X1,FBS12    IF LABEL DEFINED IN THIS DO LOOP 
          SA1    T.SYM
          CLAS=  X6,WB,(DLEX) 
          BX3    X3+X6       MERGE LOOP EXIT BIT
          SB7    X2 
          LX2    1
          SB7    B7+X2       CONVERT ORDINAL TO INDEX 
          ERRNZ  3-Z=SYM
          =B7    B7-WA.W+WB.W 
          SA2    X1+B7
          CLAS=  X6,WB,(SLEX) 
          BX6    X2+X6
          SA6    A2 
  
 FBS12    SBIT   X7,LA.ALRNP
          PL     X7,FBS12A   IF NO *ALTERNATE RETURN* TO THIS LABEL 
          MX6    1
          SA6    ALRNF
  
 FBS12A   SBIT   X7,LA.GOTOP/LA.ALRNP 
          PL     X7,FBS12B   IF NO *GOTO* TO THIS LABEL 
          MX6    1
          SA6    GOTOF
  
 FBS12B   =B2    B2+1 
          =B3    B3-1 
          NZ     B3,FBS11    IF NOT FINISHED
  
*         TEST FOR ILLEGAL ENTRY/EXIT CONDITIONS
  
          CLAS=  X1,WB,(DLC)
          BX6    X3+X1       MARK LOOP CLOSED 
          SA6    A3          UPDATE DO LOOP HEADER LABEL *WB* 
          LX6    WB.DLENP-WB.DLEXP
          BX1    -X6*X3 
          BX2    X3 
          HX1    WB.DLEN     MI IFF LOOP HAS ENTRY AND NO EXIT
          HX2    WB.DLEN     MI IFF LOOP HAS EXIT AND NO ENTRY
          PL     X2,FBS13A   IF NO ENTRY
          ANSI   E.DO19      LOOP HAS ENTRY 
  
 FBS13A   PL     X1,FBS14    IF NO ENTRY OR HAS EXIT
          SA2    ALRNF
          PL     X2,FBS13B   IF NO ALTERNATE RETURN TO LOOP 
          WARN   E.DO20 
  
 FBS13B   SA2    GOTOF
          PL     X2,FBS14    IF NO *GOTO* TO THIS LOOP
          FATAL  E.DO07 
  
 FBS14    BX2    -X3*X6 
          HX2    WB.DLEN
          SBIT   X3,WB.DLEXP
          CLAS=  X0,WB,(INDO) 
          MI     X3,FBS14A   IF DO LOOP CONTAINS EXIT 
          CLAS=  X0,WB,(INA)
  
*         WHEN NO EXIT FROM CLOSED DO LOOP, MARK ALL DEFINED LABELS 
*         INACTIVE.  IF OPEN, MARK *INDO*.
  
 FBS14A   SA1    T.SCR
          SA3    T=SCR
          SB3    X3-Z=BLST-1 NUMBER OF LABELS 
          SB2    X1+Z=BLST   STARTING POINT 
  
 FBS15    SA1    B2          FETCH LABEL
          SX3    X1          EXTRACT ORDINAL
          ERRNZ  0-LA.ORDP+18-LA.ORDL 
          SBIT   X1,LA.DEFP 
          PL     X1,FBS16    IF LABEL NOT DEFINED IN CURRENT LOOP 
          SA1    T.SYM
          SB7    X3 
          LX3    1
          SB7    B7+X3       CONVERT ORDINAL TO INDEX 
          ERRNZ  3-Z=SYM
          =B7    B7-WA.W+WB.W 
          SA3    X1+B7
          BX6    X0+X3
          SA6    A3          MARK DEFINED LABEL AS INACTIVE 
  
 FBS16    =B2    B2+1 
          =B3    B3-1 
          NZ     B3,FBS15    IF NOT FINISHED
          PL     X2,FBS18    IF NO POSSIBLE LEGAL ENTRY 
          CALL   LPE         LINK POSSIBLE-ENTRY DO LOOPS 
  
 FBS18    SA2    T=BLST 
          ZR     X2,FBS20    IF THIS IS ONLY BLOCK
  
*         MERGE LABELS INTO OUTER BLOCK 
  
          SA2    T=SCR
          SX2    X2-1 
          SHRINK A2,X2       REMOVE COUNT WORD (LC.)
  
 FBS19    SA1    T.SCR
          SB5    X2-Z=BLST
          ZR     B5,FBS20    IF NO MORE LABELS
          SB5    X2-1 
          SA3    X1+B5       FETCH LABEL
          CLAS=  X0,LA,(DEF)
          BX0    X0*X3
          HX0    LA.DEF 
          LX0    LA.DEFL
          SB2    X0          REF/DEF INDICATOR
          LX3    -LA.ORDP 
          SX6    X3          EXTRACT ORDINAL
          ERRNZ  18-LA.ORDL 
          IX3    X6+X6
          IX3    X3+X6       CONVERT ORDINAL TO INDEX 
          =B7    X3-WA.W+WB.W 
          RJ     ALU         ANALYZE LABEL USAGE (FOR OUTER STRUCTURE)
          SA2    T=SCR
          SX2    X2-1 
          SHRINK A2,X2       REMOVE THE LABEL JUST PROCESSED
          EQ     FBS19
  
*         MOVE BLOCK BACK TO T.BLST 
  
 FBS20    ALLOC  T.BLST,Z=BLST
          SX1    Z=BLST      LENGTH 
          SA2    T.SCR       SOURCE 
          SX3    B7-Z=BLST   DESTINATION
          MOVE   X1,X2,X3 
          SA1    FBSA 
          SX6    Z=BLST+1 
          MX0    -LC.CNTL 
          BX1    X0*X1       CLEAR COUNT
          BX6    X1+X6
          ADDWD  T.BLST      NEW LC. WORD 
  
 FBS25    SHRINK T=SCR,B0 
          EQ     EXIT.
  
 FBSA     BSS    1
 ALRNF    BSS    1
 GOTOF    BSS    1
 PDA      SPACE  4,10 
**        PDA -  PROPOGATE DO LOOP ATTRIBUTES 
* 
*         ENTRY  (X0) = DO ATTRIBUTE BITS TO PROPOGATE
*                (X2) = (T=BLST)
* 
*         EXIT   ALL DO LOOPS CURRENTLY ACTIVE GAIN ATTRIBUTES
* 
*         USES   A1,A3,A7  X0,X1,X2,X3,X7  B2,B3,B7 
  
  
 PDA      SUBR   =           ...ENTRY/EXIT... 
          SA1    T.BLST 
          SB2    X2-1 
  
 PDA1     SA3    X1+B2       FETCH LC. WORD FOR BLOCK 
          LX3    -LC.CNTP 
          SB7    X3          NUMBER OF WORDS IN THIS T.BLST ENTRY 
          ERRNZ  18-LC.CNTL 
          LX3    LC.CNTP-LC.DOP 
          SB3    X3          DO LOOP HEADER LABEL INDEX 
          ERRNZ  18-LC.DOL
          SB2    B2-B7
          ZR     B3,PDA2     IF NOT DO LOOP 
          SA3    T.SYM
          SA3    X3+B3       FETCH *WB* 
          BX7    X3+X0       MERGE IN ATTRIBUTE BITS
          SA7    A3 
  
 PDA2     PL     B2,PDA1     IF MORE BLOCKS 
          EQ     EXIT.
 RBE      SPACE  4,10 
**        RBE  - REMOVE BLOCK ENTRY 
* 
*                CALLED WHEN AN ERROR IS DETECTED IN DO PROCESSING
*                WHICH RENDERS THE DO TERMINAL UNCOMPILABLE.
* 
*         ENTRY  (X6) = MI FOR IMPLIED DO.
*                     = ZR FOR BLOCK IF.
*                     = DO TERMINATOR (TP. FORMAT) FOR PROGRAMMER DO. 
* 
*                (IODOLEN) = LENGTH OF T.BLST PRIOR TO
*                            COMPILING IMPLIED DO.
* 
*         EXIT   ALL DO ENTRIES ON T.BLST PERTAINING TO THAT TERMINATOR 
*                ARE REMOVED.   THE WB.DOIX BIT IS UNSET FOR THE CONTROL
*                INDEX OF EACH DO REMOVED.
* 
*         USES   A1,A2,A3,A6  X0,X1,X2,X3,X6  B2,B3,B7
* 
*         CALLS  ALC, FBS, MVE= 
  
  
 RBE      SUBR   =           ...ENTRY/EXIT... 
          MI     X6,RBE10    IF IMPLIED DO
          NZ     X6,RBE1     IF NOT BLOCK IF
          SA1    IFLEVEL
          SX6    X1-1 
          SA6    A1+         DECREMENT IF LEVEL 
          RJ     FBS         FINISH BLOCK STRUCTURE 
          SA1    T.BLST 
          SA2    T=BLST 
          SB2    X2-1 
          SA3    X1+B2       FETCH COUNT
          SX3    X3 
          ERRNZ  18-LC.CNTL 
          IX2    X2-X3
          SHRINK T=BLST,X2
          EQ     EXIT.
  
 .FIX     SET    --          MRR - REDO THIS TO UTILIZE FBS 
  
 RBE1     HX6    TP.ORD      LEFT JUSTIFY DO TERMINAL LABEL 
          AX6    -TP.ORDL    ISOLATE
          SB3    X6 
          SB3    -B3         PRESERVE TAG OF DO TERMINAL
          SHRINK T=SCR
  
 RBE2     SA2    T.BLST 
          SA3    T=BLST 
          SB2    X3-1 
          SA1    X2+B2       FETCH COUNT WORD 
          LX1    -LC.CNTP 
          SB2    X1          EXTRACT COUNT
          ERRNZ  18-LC.CNTL 
          LX1    LC.CNTP-LC.DOP 
          SX1    X1          EXTRACT DO.N INDEX 
          ERRNZ  18-LC.DOL
          ZR     X1,RBE3     IF BLOCK IF STRUCTURE
          SX0    B2 
          IX0    X3-X0
          SB7    X0+DO.W
          SA1    X2+B7
          AX1    DO.TAGP
          SX1    X1+B3
          ZR     X1,RBE4     IF NOT DO ENTRY MATCH
  
*         IF NOT A DO ENTRY TO DISCARD, SAVE ON T.SCR 
*                (B2) = SIZE OF BLOCK INFORMATION SEGMENT 
  
 RBE3     ALLOC  T.SCR,B2 
          SA1    T.BLST 
          SA2    T=BLST 
          SX0    B2 
          IX2    X1+X2
          IX2    X2-X0       SOURCE 
          SX1    B2          LENGTH 
          SX3    B7-B2       DESTINATION
          MOVE   X1,X2,X3 
  
*         SCRATCH LAST T.BLST ENTRY 
*                (B2) = SIZE OF BLOCK INFORMATION SEGMENT 
  
 RBE4     SA1    T=BLST 
          SX0    B2 
          IX1    X1-X0
          SHRINK A1,X1
          NZ     X6,RBE2     IF NOT FINISHED
  
*         THE BLOCK INFORMATION IS NOW ON T.SCR, IN REVERSE ORDER.
*         MOVE IT BACK TO T.BLST, IN PROPER FORM. 
  
          SA2    T=SCR
          ZR     X2,EXIT.    IF NO BLOCK INFORMATION
          ALLOC  T.BLST,X2
          SB2    X1 
          SB3    X2 
 RBE5     SA1    T.SCR
          =B7    B3-1 
          SA2    B7+X1       FETCH COUNT WORD 
          LX2    -LC.CNTP 
          SB7    X2          EXTRACT COUNT
          ERRNZ  18-LC.CNTL 
          SB3    B3-B7
          SX2    B3+X1       SOURCE 
          SX1    B7          LENGTH 
          SX3    B2          DESTINATION
          SB2    B2+B7       INCREMENT
          MOVE   X1,X2,X3 
          NZ     B3,RBE5     IF NOT FINISHED
          SHRINK T=SCR
          EQ     EXIT.
  
*         LOOP IS AN IMPLIED DO. EACH LEVEL OF THE LOOP 
*         MUST BE DELETED FROM T.BLST.
  
 RBE10    SA3    IODOLEN
          SX3    X3-Z=BLST
  
 RBE12    SA1    T.BLST 
          SA2    T=BLST 
          ZR     X2,EXIT.    IF BLST EMPTY
          SB2    X2-1 
          SA1    X1+B2
          SX1    X1          ISOLATE COUNT
          IX1    X2-X1
          SHRINK T=BLST,X1   ELIMINATE ENTIRE IMPLIED DO
          SX3    X3-Z=BLST
          PL     X3,RBE12    IF ANOTHER LEVEL IN IMPLIED *DO* 
          EQ     EXIT.
  
          LIST   D
          END 
