*DECK     CDDIR 
          IDENT  CDDIR
 CDDIR    SECT   (C$ DIRECTIVE PROCESSING.) 
 EXTS     SPACE  4,10 
*         IN ALLOC
          EXT    ADW
  
*         IN FEC
          EXT    ERT,ERT=OFF,ERT=ON,FEC=BY,FEC.RTN,OIL,STAGE
  
*         IN FERRS
          EXT    E.C$00,E.C$01,E.C$02,E.C$03,E.C$04,E.C$05,E.C$06,E.C$07
          EXT    E.C$08,E.C$09,E.C$10,E.C$11,FILL.,FILL.2 
  
*         IN FTN
          EXT    CO.LOA,CO.LOM,CO.LOO,CO.LOR,CO.LOS 
  
*         IN LEX
          EXT    LDB,SB=LINC,SB=LORD
  
*         IN PAR
          EXT    EMT,PIX,PKX
  
*         IN PEM
          EXT    PDM
  
*         IN PUC
          EXT    LINES,T=C$IF,T=STMT,T.C$IF,WO.CS,WO.DOLG,WO.DOOT,WO.LOA
          EXT    WO.LOM,WO.LOO,WO.LOR,WO.LOS,T.CON
  
*         IN QSKEL/FSKEL
          EXT    V=CDCS,V=CDDOT,V=CDLOO 
          TITLE  C$ COLLATE DIRECTIVE.
**        TRANSLATE C$ COLLATE DIRECTIVE. 
  
  
          HEREIF C$COLLATE
  
          SX6    B4 
          SA6    COLA        PRESERVE (B4)
          CALL   OIL         BREAK SEQUENCE [FOR FUNCTION SELECTION]
          SA1    COLA 
          SB4    X1          RESTORE (B4) 
          SA1    B4 
          SB2    X1-O.LP
          =A1    B4+1 
          NZ     B2,E.C$08   IF NOT *(* 
          SA2    =4LUSER
          SB2    X1-O.VAR 
          NZ     B2,E.C$07   IF NOT C$ PARAMETER
          MX0    TB.TOCL
          BX1    X0*X1       CHARACTER STRING ONLY
          =X6    1
          IX2    X2-X1
          ZR     X2,COL      IF *USER*
          SA2    =5LFIXED 
          IX2    X2-X1
          =X6    0
          ZR     X2,COL      IF *FIXED* 
          LX6    X1 
          SA6    FILL.2 
          EQ     E.C$00      NOT A LEGAL C$ PARAMETER 
  
 COL      SA1    A1+1 
          SB4    B4+2 
          SB2    X1-O.RP
          NZ     B2,E.C$06   IF NOT *)* 
          SA6    WO.CS
          CLAS=  X4,TP,(SHRT),INT 
          LX6    TP.BIASP 
          SX5    0
          BX4    X6+X4
          EMIT   V=CDCS,NONE
          EQ     FEC.RTN
  
 COLA     BSS    1           PRESERVE (B4) ACROSS OIL 
          TITLE  C$ COMDECK DIRECTIVES. 
**        TRANSLATE C$ COMDECK DIRECTIVES.
* 
*         THESE ARE CURRENTLY STUBS.  IMPLEMENTATION WILL BE BY FEATURE 
*         CODE AT A LATER DATE. 
 BEGCOM   SPACE  4,10 
**        TRANSLATE C$ BEGCOM DIRECTIVE.
  
  
          HEREIF C$BEGCOM 
          EQ     FEC.RTN
 ENDCOM   SPACE  4,10 
**        TRANSLATE C$ ENDCOM DIRECTIVE.
  
  
          HEREIF C$ENDCOM 
          EQ     FEC.RTN
          TITLE  C$ DO DIRECTIVE. 
**        TRANSLATE C$ DO DIRECTIVE.
  
  
          HEREIF C$DO 
  
          SX6    FW.DO
          SX7    L.DO 
          RJ     TCP         TRANSLATE C$ PARAMETERS
  
          SA1    DO=LONG
          PL     X1,DO1      IF C$ DO(LONG= ) NOT SPECIFIED 
          BX6    -X1         COMPLEMENT FOR VALUE 
          SA6    A1          CLEAR (TO POSITIVE)
          SA6    WO.DOLG     UPDATE 
  
 DO1      SA1    DO=OT
          PL     X1,FEC.RTN  IF C$ DO(OT= ) NOT SPECIFIED 
          BX6    -X1         COMPLEMENT FOR VALUE 
          SA6    A1          CLEAR (TO POSITIVE)
          SA6    WO.DOOT
          CLAS=  X4,TP,(SHRT),INT 
          LX6    TP.BIASP 
          BX4    X6+X4
          MX5    0
          EMIT   V=CDDOT,NONE 
          EQ     FEC.RTN
  
 FW.DO    BSS 
          DATA   4LLONG 
 DO=LONG  CON    0
          DATA   2LOT 
 DO=OT    CON    0
 L.DO     EQU    *-FW.DO
          TITLE  C$ IF DIRECTIVES.
 IF.      SPACE  4,10 
**        IF. -  DEFINITIONS FOR T.C$IF 
  
  
          DESCRIBE IF.
  
 INA      DEFINE 1           IF GROUP INACTIVE (FEC=BY WHEN ENCOUNTERED)
 PE       DEFINE 1           PROCESSED ELSE (ONLY ONE ALLOWED)
          DEFINE 16 
 LAB      DEFINE 42          IF LABEL (IF PRESENT)
 IF       SPACE  4,10 
**        TRANSLATE C$ IF CONDITIONAL DIRECTIVE.
  
  
          HEREIF C$IF 
          SA1    STAGE
          SX6    FEC=BY 
          IX6    X1-X6
          SA1    B4 
          NZ     X6,IFD1     IF NOT SKIPPING
          SB2    X1-O.LP
          NZ     B2,E.C$08   IF NOT *(* 
          HX1    TB.IOCP
          AX1    -TB.IOCPL   EXTRACT CORRESPONDING *)* ADDRESS
          SB4    X1 
          CLAS=  X6,IF,(INA)
          SA6    IFDA 
          EQ     IFD2        CHECK LABEL, IF ANY
  
 IFD1     SA4    B4 
          SB4    B4+B1
          SX6    X4-O.LP
          NZ     X6,E.C$08   IF INITIAL LPAREN MISSING
          =X6    PM=CXP      *PKX* STORES THIS INTO *PARMODE* 
          CALL   PKX         PARSE CONSTANT EXPRESSION (LOGICAL)
          =B5    B5-M.LOG 
          NZ     B5,E.C$11   IF EXPRESSION NOT LOGICAL
          SA2    B4 
          SB7    X2-O.RP
          NZ     B7,E.C$06   IF MISSING RIGHT PAREN 
          LX5    X6          THE TRUTH VALUE OF THE EXPRESSION
          PL     B2,IFD1A    IF CONSTANT NOT IN A TABLE 
          SA5    T.CON
          SB2    X6 
          SA5    X5+B2       THE TRUTH VALUE OF THE EXPRESSION
  
 IFD1A    MX6    0
          SA6    IFDA        INITIALIZE 
  
*         (X5) .MI. = CONDITION TRUE (CONTINUE COMPILIATION)
  
 IFD2     =A3    B4+1 
          SB4    B4+1 
          BX7    0
          ZR     X3,IFD4     IF *EOS* 
          ERRNZ  O.EOS
          SB2    X3-O.COMMA 
          NZ     B2,IFD3     IF NO COMMA
          SB4    B4+1 
 IFD3     RJ     GDL         GET DIRECTIVE LABEL
 IFD4     SA1    IFDA 
          BX6    X1+X7       FORM IF. ENTRY 
          ADDWD  T.C$IF 
          SBIT   X6,IF.INAP 
          MI     X6,FEC.RTN  IF INACTIVE (CURRENTLY SKIPPING) 
          MI     X5,FEC.RTN  IF TRUE CONDITION
  
  
 IFNO     SA1    STAGE
          SX7    FEC=BY 
          BX6    X1          SAVE (IFDD) = ORIGINAL (STAGE) 
          SA7    A1 
          SA6    IFDB 
          EQ     FEC.RTN
  
 IFDA     BSS    1           T.C$IF ENTRY 
 IFDB     BSS    1           HOLD (STAGE) WHEN SKIP BEGAN 
 ELSE     SPACE  4,10 
**        TRANSLATE C$ ELSE DIRECTIVE.
  
  
          HEREIF C$ELSE 
  
          SA1    T.C$IF 
          SA2    T=C$IF 
          ZR     X2,E.C$01   IF NO C$ IF STACKED
          SB3    X2-1 
          SA3    X1+B3       FETCH CURRENT C$IF ENTRY 
          BX7    0
          SA5    B4+
          SB2    X5-O.COMMA 
          ZR     X5,ELSE1    IF NO LABEL
          ERRNZ  O.EOS
          NZ     B2,E.C$09   IF NO COMMA
          SB4    B4+1 
          RJ     GDL         GET DIRECTIVE LABEL
 ELSE1    MX0    IF.LABL
          LX0    IF.LABL
          BX5    X3*X0
          BX1    X5*X7
          ZR     X1,ELSE2    IF IF OR ELSE HAD NO LABEL 
          IX1    X5-X7
          NZ     X1,E.C$03   IF LABELS DONT MATCH 
 ELSE2    CLAS=  X6,IF,(PE) 
          BX6    X6+X3       MERGE IN PROCESSED ELSE BIT
          SBIT   X3,IF.PEP
          MI     X3,E.C$04   IF ALREADY PROCESSED ELSE
          SA6    A3          UPDATE C$IF ENTRY
          SBIT   X6,IF.INAP 
          MI     X6,FEC.RTN  IF THIS IF GROUP INACTIVE
          SA1    STAGE
          SX6    FEC=BY 
          IX2    X1-X6
          NZ     X2,IFNO     IF NOT CURRENTLY SKIPPING, THEN START
          SA2    IFDB        FETCH PREVIOUS STAGE (BEFORE SKIP) 
          BX6    X2 
          SA6    A1          RESTORE STAGE
          EQ     FEC.RTN
 ENDIF    SPACE  4,10 
**        TRANSLATE C$ ENDIF DIRECTIVE. 
  
  
          HEREIF C$ENDIF
  
          SA1    T.C$IF 
          SA2    T=C$IF 
          ZR     X2,E.C$01   IF NO C$ IF STACKED
          SB3    X2-1 
          SA3    X1+B3       FETCH CURRENT C$IF ENTRY 
          BX7    0
          SA5    B4+
          SB2    X5-O.COMMA 
          ZR     X5,ENDIF1   IF NO LABEL
          ERRNZ  O.EOS
          NZ     B2,E.C$09   IF NO COMMA
          SB4    B4+1 
          RJ     GDL         GET DIRECTIVE LABEL
 ENDIF1   MX0    IF.LABL
          LX0    IF.LABL
          BX5    X3*X0
          BX1    X5*X7
          ZR     X1,ENDIF2   IF IF OR ENDIF HAD NO LABEL
          IX1    X5-X7
          NZ     X1,E.C$03   IF LABELS DONT MATCH 
 ENDIF2   SHRINK A2,B3       REMOVE C$IF ENTRY
          SBIT   X3,IF.INAP 
          MI     X3,FEC.RTN  IF THIS GROUP INACTIVE 
          SA1    STAGE
          SX2    FEC=BY 
          IX3    X1-X2
          NZ     X3,FEC.RTN  IF NOT NOW SKIPPING
          SA2    IFDB        FETCH PREVIOUS STAGE (BEFORE SKIP) 
          BX6    X2 
          SA6    A1          RESTORE STAGE
          EQ     FEC.RTN
          TITLE  C$ LIST DIRECTIVE. 
**        TRANSLATE C$ LIST DIRECTIVE.
  
          HEREIF C$LIST 
  
          SX6    FW.LIST
          SX7    L.LIST 
          RJ     TCP         TRANSLATE C$ PARAMETERS
  
          SA1    LIST=A 
          PL     X1,LIST1    IF C$ LIST(A= ) NOT SPECIFIED
          SA2    CO.LOA 
          BX6    -X1         COMPLEMENT FOR VALUE 
          SA6    A1          CLEAR (TO POSITIVE)
          LX6    -1          POSITION FOR SWITCH
          BX6    X6*X2
          SA6    WO.LOA      UPDATE 
  
 LIST1    SA1    LIST=M 
          PL     X1,LIST2    IF C$ LIST(M= ) NOT SPECIFIED
          SA2    CO.LOM 
          BX6    -X1         COMPLEMENT FOR VALUE 
          SA6    A1          CLEAR (TO POSITIVE)
          LX6    -1          POSITION FOR SWITCH
          BX6    X6*X2
          SA6    WO.LOM      UPDATE 
  
 LIST2    SA1    LIST=O 
          PL     X1,LIST3    IF C$ LIST(O= ) NOT SPECIFIED
          SA2    CO.LOO 
          BX6    -X1         COMPLEMENT FOR VALUE 
          SA6    A1          CLEAR (TO POSITIVE)
          LX6    -1          POSITION FOR SWITCH
          BX6    X6*X2
          SA6    WO.LOO      UPDATE 
          CLAS=  X4,TP,(SHRT),INT 
          BX1    -X1
          LX1    TP.BIASP 
          BX4    X1+X4
          MX5    0
          EMIT   V=CDLOO,NONE 
  
 LIST3    SA1    LIST=R 
          PL     X1,LIST5    IF C$ LIST(R= ) NOT SPECIFIED
          SA2    CO.LOR 
          ZR     X2,LIST5    IF LO=R NOT SELECTED BY CONTROL CARD 
          BX6    -X1         COMPLEMENT FOR VALUE 
          SA6    A1          CLEAR (TO POSITIVE)
          LX6    -1          POSITION FOR SWITCH
          BX6    X6*X2
          SA6    WO.LOR      UPDATE 
          SA2    ERT=ON 
          NZ     X1,LIST4    IF LIST(R=1) 
          SA2    ERT=OFF
 LIST4    BX7    X2 
          SA7    ERT         SET COLLECTION OF REFERENCES APPROPRIATELY 
  
 LIST5    SA1    LIST=S 
          PL     X1,FEC.RTN  IF C$ LIST(S= ) NOT SPECIFIED
          SA2    CO.LOS 
          ZR     X2,FEC.RTN  IF LO=S NOT SELECTED BY CONTROL CARD 
          BX6    -X1         COMPLEMENT FOR VALUE 
          SA6    A1+         CLEAR (TO POSITIVE)
          LX6    -1          POSITION FOR SWITCH
          SA6    WO.LOS      UPDATE 
          NZ     X1,LIST6    IF (S=1) 
  
          SA3    LINES       SOURCE LINE COUNT
          SX7    X3-1 
          NZ     X7,LIST6    IF *C$ LIST(S=0) NOT AT LINE 1 
          SHRINK T=STMT,0 
          SA6    SB=LORD
          SA6    SB=LINC
 LIST6    CALL   LDB         LIST DEFERRED BUFFER 
          EQ     FEC.RTN     EXIT TO FRONT END CONTROLLER 
  
 FW.LIST  BSS    0           ** FWA **
          DATA   1LA
 LIST=A   CON    0
          DATA   1LC         **STUB FOR FUTURE IMPLEMENTATION** 
 LIST=C   CON    0
          DATA   1LM
 LIST=M   CON    0
          DATA   1LO
 LIST=O   CON    0
          DATA   1LR
 LIST=R   CON    0
          DATA   1LS
 LIST=S   CON    0
          DATA   3LALL
          CON    0
 L.LIST   EQU    *-FW.LIST
          TITLE  SUBROUTINES. 
 GDL      SPACE  4,10 
**        GDL -  GET DIRECTIVE LABEL. 
* 
*         ENTRY  (B4) _ C$ DIRECTIVE LABEL
* 
*         EXIT   (X7) = VALUE OF LABEL
* 
*         USES   A1,A7  B2  X0,X1,X7
  
  
 GDL      SUBR               ...ENTRY/EXIT... 
          SA1    B4+
          SB2    X1-O.VAR 
          NZ     B2,E.C$02   IF NOT DIRECTIVE LABEL 
          MX0    TB.TOCL
          HX1    TB.TOC 
          =B4    B4+1 
          BX7    X0*X1       (X7) = LABEL 
          SA7    FILL.2 
          LX7    IF.LABL
          SA1    B4+
          ZR     X1,EXIT.    IF *EOS* 
          ERRNZ  O.EOS
          WARN   E.C$10 
          EQ     EXIT.
 TCP      SPACE  4,10 
**        TCP -  TRANSLATE C$ PARAMETERS. 
* 
*         ENTRY  (B4) _ *(* PRECEDING C$ PARAMETER LIST 
*                (X6) = FWA OF PARAMETER TABLE
*                (X7) = LENGTH OF PARAMETER TABLE 
* 
*         EXIT   (B4) _ CLOSING *)* 
* 
*         CALLS  PIX
* 
*         USES
  
  
 TCPA     BSS    2           SAVE PARAMETER TABLE FWA AND LENGTH
 TCPB     BSS    1           SAVE PARAMETER TABLE ADDRESS 
 TCPC     BSS    1           SAVE FILL. OF C$ DIRECTIVE 
  
 TCP      SUBR               ...ENTRY/EXIT... 
          SA6    TCPA 
          =A7    A6+1 
          SA4    B4 
          SX6    X4-O.LP
          NZ     X6,E.C$08   IF INITIAL LPAREN MISSING
          =B4    B4+1        ADVANCE TO FIRST PARAMETER 
  
 TCP1     SA2    B4          FETCH PARAMETER
          MX0    TB.TOCL
          LX0    TB.TOCL+TB.TOCP
          SB2    X2-O.VAR 
          NZ     B2,E.C$07   IF NOT C$ PARAMETER
          BX6    X0*X2       PARAMETER ONLY 
          SA1    TCPA 
          =A2    A1+1 
          SB6    X1          FWA OF PARAMETER TABLE 
          SB7    X2          LENGTH OF PARAMETER TABLE
          SB7    B7-2        INITIALIZE 
  
 TCP2     MI     B7,TCP3     IF NOT IN PARAMETER TABLE
          SA1    B6+B7
          IX2    X1-X6
          ZR     X2,TCP4     IF MATCH 
          SB7    B7-2        DECREMENT
          EQ     TCP2        LOOP...
  
 TCP3     SA6    FILL.2 
          EQ     E.C$00      NOT A LEGAL C$ PARAMETER 
  
 TCP4     =A2    B4+1 
          =B4    B4+1 
          SB2    X2-O.= 
          ZR     B2,TCP5     IF P=C FORM
          SX6    -B1
          =A6    A1+1        STORE INTO CORRESPONDING VALUE CELL
          EQ     TCP7 
  
 TCP5     SX6    A1 
          SA6    TCPB        SAVE PARAMETER TABLE ENTRY 
          SA1    FILL.
          LX7    X1 
          =A7    A6-TCPB+TCPC 
          =B4    B4+1 
          CALL   PIX         PARSE INTEGER CONSTANT EXPRESSION
          SA1    TCPB 
          =A2    A1-TCPB+TCPC 
          LX7    X2 
          SA1    X1          RELOAD C$ PARAMETER
          SA7    FILL.       RESTORE
          ZR     X6,TCP6     IF VALUE 0 
          SX2    X6-1 
          ZR     X2,TCP6     IF VALUE 1 
          BX6    X1 
          SA6    FILL.2 
          WARN   E.C$05      C$ PARAMETER VALUE MUST BE 0 OR 1
          EQ     TCP10
  
 TCP6     BX6    -X6         COMPLEMENT TO INDICATE APPEARANCE
          =A6    A1+1 
  
 TCP7     SA2    =3LALL 
          IX2    X2-X1
          NZ     X2,TCP10    IF NOT ALL=
          SA1    TCPA 
          =A2    A1+1 
          SB6    X1          FWA OF PARAMETER TABLE 
          SB7    X2-3 
  
 TCP8     MI     B7,TCP10    IF FINISHED
          SA1    B6+B7
          SA6    A1 
          SB7    B7-2 
          EQ     TCP8 
  
 TCP10    SA1    B4 
          =B4    B4+1 
          SB2    X1-O.COMMA 
          ZR     B2,TCP1     IF *,*, CONTINUE PROCESSING
          SB2    X1-O.RP
          NZ     B2,E.C$09   IF NOT *)* 
          SA1    B4+
          ZR     X1,EXIT.    IF *EOS* 
          ERRNZ  O.EOS
          WARN   E.C$10 
          EQ     EXIT.
          SPACE  4,10 
          LIST   D
          END 
